diff --git a/old_library/.gitignore b/old_library/.gitignore new file mode 100644 index 0000000000..1e9d24c887 --- /dev/null +++ b/old_library/.gitignore @@ -0,0 +1,4 @@ +TAGS +build.ninja +.ninja_deps +.ninja_log diff --git a/old_library/.project b/old_library/.project new file mode 100644 index 0000000000..5cb09e4044 --- /dev/null +++ b/old_library/.project @@ -0,0 +1,44 @@ ++ *.lean +- flycheck*.lean +- .#*.lean +- theories/ +- algebra/ +- data/ +- logic/ +- tools/ +- smt/ +- examples/ +- bag.lean +- bv.lean +- complex.lean +- countable.lean +- encodable.lean +- equiv.lean +- data/finset/ +- data/fintype/ +- data/int/ +- data/rat/ +- data/real/ +- data/examples/ +- algebra/category/ +- logic/examples/ +- matrix.lean +- squash.lean +- stream.lean +- old_string.lean +- uprod.lean +- tuple.lean +- old_fin.lean +- pnat.lean +- hf.lean +- data/vector/ +- data/set/ +- interval.lean +- group_power.lean +- ring_power.lean +- group_bigops.lean +- order_bigops.lean +- ring_bigops.lean +- galois_connection.lean +- complete_lattice.lean +- homomorphism.lean \ No newline at end of file diff --git a/old_library/algebra/algebra.md b/old_library/algebra/algebra.md new file mode 100644 index 0000000000..3e18acd484 --- /dev/null +++ b/old_library/algebra/algebra.md @@ -0,0 +1,29 @@ +algebra +======= + +Algebraic structures. + +* [priority](priority.lean) : priority for algebraic operations +* [relation](relation.lean) +* [binary](binary.lean) : binary operations +* [order](order.lean) +* [interval](interval.lean) +* [lattice](lattice.lean) +* [complete lattice](complete_lattice.lean) +* [galois_connection](galois_connection.lean) +* [group](group.lean) +* [group_power](group_power.lean) : nat and int powers +* [group_bigops](group_bigops.lean) : products and sums over lists, finsets and sets +* [ring](ring.lean) +* [ordered_group](ordered_group.lean) +* [ordered_ring](ordered_ring.lean) +* [field](field.lean) +* [ordered_field](ordered_field.lean) +* [module](module.lean) : modules, vector spaces, and linear maps +* [ring_power](ring_power.lean) : power in ring structures +* [ring_bigops](ring_bigops.lean) : products and sums in various structures +* [order_bigops](order_bigops.lean) : min and max over finsets and finite sets +* [bundled](bundled.lean) : bundled versions of the algebraic structures +* [monotone](monotone.lean) : monotone maps between order structures +* [homomorphism](homomorphism.lean) : homomorphisms between algebraic structures +* [category](category/category.md) : category theory (outdated, see HoTT category theory folder) diff --git a/old_library/algebra/binary.lean b/old_library/algebra/binary.lean new file mode 100644 index 0000000000..9678399c05 --- /dev/null +++ b/old_library/algebra/binary.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad + +General properties of binary operations. +-/ +open function + +namespace binary + section + variable {A : Type} + variables (op₁ : A → A → A) (inv : A → A) (one : A) + + local notation a * b := op₁ a b + local notation a ⁻¹ := inv a + + attribute [reducible] + definition commutative := ∀a b, a * b = b * a + attribute [reducible] + definition associative := ∀a b c, (a * b) * c = a * (b * c) + attribute [reducible] + definition left_identity := ∀a, one * a = a + attribute [reducible] + definition right_identity := ∀a, a * one = a + attribute [reducible] + definition left_inverse := ∀a, a⁻¹ * a = one + attribute [reducible] + definition right_inverse := ∀a, a * a⁻¹ = one + attribute [reducible] + definition left_cancelative := ∀a b c, a * b = a * c → b = c + attribute [reducible] + definition right_cancelative := ∀a b c, a * b = c * b → a = c + + attribute [reducible] + definition inv_op_cancel_left := ∀a b, a⁻¹ * (a * b) = b + attribute [reducible] + definition op_inv_cancel_left := ∀a b, a * (a⁻¹ * b) = b + attribute [reducible] + definition inv_op_cancel_right := ∀a b, a * b⁻¹ * b = a + attribute [reducible] + definition op_inv_cancel_right := ∀a b, a * b * b⁻¹ = a + + variable (op₂ : A → A → A) + + local notation a + b := op₂ a b + + attribute [reducible] + definition left_distributive := ∀a b c, a * (b + c) = a * b + a * c + attribute [reducible] + definition right_distributive := ∀a b c, (a + b) * c = a * c + b * c + + attribute [reducible] + definition right_commutative {B : Type} (f : B → A → B) := ∀ b a₁ a₂, f (f b a₁) a₂ = f (f b a₂) a₁ + attribute [reducible] + definition left_commutative {B : Type} (f : A → B → B) := ∀ a₁ a₂ b, f a₁ (f a₂ b) = f a₂ (f a₁ b) + end + + section + variable {A : Type} + variable {f : A → A → A} + variable H_comm : commutative f + variable H_assoc : associative f + local infixl `*` := f + include H_comm + theorem left_comm : left_commutative f := + take a b c, calc + a*(b*c) = (a*b)*c : eq.symm (H_assoc _ _ _) + ... = (b*a)*c : sorry -- by rewrite (H_comm a b) + ... = b*(a*c) : H_assoc _ _ _ + + theorem right_comm : right_commutative f := + take a b c, calc + (a*b)*c = a*(b*c) : H_assoc _ _ _ + ... = a*(c*b) : sorry -- by rewrite (H_comm b c) + ... = (a*c)*b : eq.symm (H_assoc _ _ _) + + theorem comm4 (a b c d : A) : a*b*(c*d) = a*c*(b*d) := + calc + a*b*(c*d) = a*b*c*d : eq.symm (H_assoc _ _ _) + ... = a*c*b*d : sorry -- by rewrite (right_comm H_comm H_assoc a b c) + ... = a*c*(b*d) : H_assoc _ _ _ + end + + section + variable {A : Type} + variable {f : A → A → A} + variable H_assoc : associative f + local infixl `*` := f + theorem assoc4helper (a b c d) : (a*b)*(c*d) = a*((b*c)*d) := + calc + (a*b)*(c*d) = a*(b*(c*d)) : H_assoc _ _ _ + ... = a*((b*c)*d) : sorry -- by rewrite (H_assoc b c d) + end + + attribute [reducible] + definition right_commutative_comp_right + {A B : Type} (f : A → A → A) (g : B → A) (rcomm : right_commutative f) : right_commutative (comp_right f g) := + λ a b₁ b₂, rcomm _ _ _ + + attribute [reducible] + definition left_commutative_compose_left + {A B : Type} (f : A → A → A) (g : B → A) (lcomm : left_commutative f) : left_commutative (comp_left f g) := + λ a b₁ b₂, lcomm _ _ _ +end binary diff --git a/old_library/algebra/bundled.lean b/old_library/algebra/bundled.lean new file mode 100644 index 0000000000..32d2378570 --- /dev/null +++ b/old_library/algebra/bundled.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad + +Bundled structures +-/ +import algebra.group + +structure Semigroup := +(carrier : Type) (struct : semigroup carrier) + +attribute Semigroup.struct [instance] + +structure CommSemigroup := +(carrier : Type) (struct : comm_semigroup carrier) + +attribute CommSemigroup.struct [instance] + +structure Monoid := +(carrier : Type) (struct : monoid carrier) + +attribute Monoid.struct [instance] + +structure CommMonoid := +(carrier : Type) (struct : comm_monoid carrier) + +attribute CommMonoid.struct [instance] + +structure Group := +(carrier : Type) (struct : group carrier) + +attribute Group.struct [instance] + +structure CommGroup := +(carrier : Type) (struct : comm_group carrier) + +attribute CommGroup.struct [instance] + +structure AddSemigroup := +(carrier : Type) (struct : add_semigroup carrier) + +attribute AddSemigroup.struct [instance] + +structure AddCommSemigroup := +(carrier : Type) (struct : add_comm_semigroup carrier) + +attribute AddCommSemigroup.struct [instance] + +structure AddMonoid := +(carrier : Type) (struct : add_monoid carrier) + +attribute AddMonoid.struct [instance] + +structure AddCommMonoid := +(carrier : Type) (struct : add_comm_monoid carrier) + +attribute AddCommMonoid.struct [instance] + +structure AddGroup := +(carrier : Type) (struct : add_group carrier) + +attribute AddGroup.struct [instance] + +structure AddCommGroup := +(carrier : Type) (struct : add_comm_group carrier) + +attribute AddCommGroup.struct [instance] diff --git a/old_library/algebra/category/adjoint.lean b/old_library/algebra/category/adjoint.lean new file mode 100644 index 0000000000..88c7bf067a --- /dev/null +++ b/old_library/algebra/category/adjoint.lean @@ -0,0 +1,19 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Floris van Doorn +-/ + +import .constructions + +open eq eq.ops category functor natural_transformation category.ops prod category.product + +namespace adjoint + + -- definition Hom (C : Category) : Cᵒᵖ ×c C ⇒ type := + -- functor.mk (λ a, hom (pr1 a) (pr2 a)) + -- (λ a b f h, sorry) + -- (λ a, sorry) + -- (λ a b c g f, sorry) + +end adjoint diff --git a/old_library/algebra/category/basic.lean b/old_library/algebra/category/basic.lean new file mode 100644 index 0000000000..d3fcf8c8ca --- /dev/null +++ b/old_library/algebra/category/basic.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Floris van Doorn +-/ +open eq eq.ops + +structure category [class] (ob : Type) : Type := + (hom : ob → ob → Type) + (comp : Π⦃a b c : ob⦄, hom b c → hom a b → hom a c) + (ID : Π (a : ob), hom a a) + (assoc : Π ⦃a b c d : ob⦄ (h : hom c d) (g : hom b c) (f : hom a b), + comp h (comp g f) = comp (comp h g) f) + (id_left : Π ⦃a b : ob⦄ (f : hom a b), comp !ID f = f) + (id_right : Π ⦃a b : ob⦄ (f : hom a b), comp f !ID = f) + +attribute category [multiple_instances] + +namespace category + variables {ob : Type} [C : category ob] + variables {a b c d : ob} + include C + + definition compose := @comp ob _ + + attribute [reducible] + definition id {a : ob} : hom a a := ID a + + infixr `∘` := comp + infixl `⟶`:25 := hom -- input ⟶ using \--> (this is a different arrow than \-> (→)) + + variables {h : hom c d} {g : hom b c} {f : hom a b} {i : hom a a} + + --the following is the only theorem for which "include C" is necessary if C is a variable (why?) + theorem id_compose (a : ob) : (ID a) ∘ id = id := !id_left + + theorem left_id_unique (H : Π{b} {f : hom b a}, i ∘ f = f) : i = id := + calc i = i ∘ id : id_right + ... = id : H + + theorem right_id_unique (H : Π{b} {f : hom a b}, f ∘ i = f) : i = id := + calc i = id ∘ i : id_left + ... = id : H +end category + +inductive Category : Type := mk : Π (ob : Type), category ob → Category + +namespace category + definition Mk {ob} (C) : Category := Category.mk ob C + definition MK (a b c d e f g) : Category := Category.mk a (category.mk b c d e f g) + + -- definition objects [coercion] [reducible] (C : Category) : Type + -- := Category.rec (fun c s, c) C + + -- definition category_instance [instance] [coercion] (C : Category) : category (objects C) + -- := Category.rec (fun c s, s) C + +end category + +open category + +theorem Category.equal (C : Category) : Category.mk C C = C := +Category.rec (λ ob c, rfl) C diff --git a/old_library/algebra/category/category.md b/old_library/algebra/category/category.md new file mode 100644 index 0000000000..78eb39ac63 --- /dev/null +++ b/old_library/algebra/category/category.md @@ -0,0 +1,18 @@ +algebra.category +================ + +Everything in this folder is outdated. See HoTT category folder for a up-to-date version. + +Algebraic structures. + +* [basic](basic.lean) : definition of fully and partially bundled categories +* [morphism](morphism.lean) : isos, retracts, sections, monos, epis +* [functor](functor.lean) : functors, category of (smaller) categories +* [natural_transformation](natural_transformation.lean) +* [constructions](constructions.lean) : constructions of basic examples and constructions of categories: opposite, type, discrete, product, functor, slice and arrow categories + +The following files hardly have any content so far. + +* [limit](limit.lean) : limits and colimits +* [adjoint](adjoint.lean) : adjoint functors +* [yoneda](yoneda.lean) : Yoneda embedding and Yoneda lemma \ No newline at end of file diff --git a/old_library/algebra/category/constructions.lean b/old_library/algebra/category/constructions.lean new file mode 100644 index 0000000000..b4da8ae5e2 --- /dev/null +++ b/old_library/algebra/category/constructions.lean @@ -0,0 +1,386 @@ +-- Copyright (c) 2014 Floris van Doorn. All rights reserved. +-- Released under Apache 2.0 license as described in the file LICENSE. +-- Author: Floris van Doorn + +-- This file contains basic constructions on categories, including common categories + + +import .natural_transformation +import data.unit data.sigma data.prod data.empty data.bool + +open eq eq.ops prod +namespace category + namespace opposite + section + attribute [reducible] + definition opposite {ob : Type} (C : category ob) : category ob := + mk (λa b, hom b a) + (λ a b c f g, g ∘ f) + (λ a, id) + (λ a b c d f g h, symm !assoc) + (λ a b f, !id_right) + (λ a b f, !id_left) + + attribute [reducible] + definition Opposite (C : Category) : Category := Mk (opposite C) + --direct construction: + -- MK C + -- (λa b, hom b a) + -- (λ a b c f g, g ∘ f) + -- (λ a, id) + -- (λ a b c d f g h, symm !assoc) + -- (λ a b f, !id_right) + -- (λ a b f, !id_left) + + infixr `∘op`:60 := @comp _ (opposite _) _ _ _ + + variables {C : Category} {a b c : C} + + theorem compose_op {f : hom a b} {g : hom b c} : f ∘op g = g ∘ f := rfl + + theorem op_op' {ob : Type} (C : category ob) : opposite (opposite C) = C := + category.rec (λ hom comp id assoc idl idr, refl (mk _ _ _ _ _ _)) C + + definition op_op : Opposite (Opposite C) = C := + (@congr_arg _ _ (@opposite C (@opposite C C)) _ (Category.mk C) (op_op' C)) ⬝ !Category.equal + + end + end opposite + + attribute [reducible] + definition type_category : category Type := + mk (λa b, a → b) + (λ a b c, function.comp) + (λ a, _root_.id) + (λ a b c d h g f, symm (function.comp.assoc h g f)) + (λ a b f, function.comp.left_id f) + (λ a b f, function.comp.right_id f) + + attribute [reducible] + definition Type_category : Category := Mk type_category + + section + open decidable unit empty + variables {A : Type} [H : decidable_eq A] + include H + attribute [reducible] + definition set_hom (a b : A) := decidable.rec_on (H a b) (λh, unit) (λh, empty) + attribute [instance] + theorem set_hom_subsingleton (a b : A) : subsingleton (set_hom a b) := rec_subsingleton + attribute [reducible] + definition set_compose {a b c : A} (g : set_hom b c) (f : set_hom a b) : set_hom a c := + decidable.rec_on + (H b c) + (λ Hbc g, decidable.rec_on + (H a b) + (λ Hab f, rec_on_true (trans Hab Hbc) ⋆) + (λh f, empty.rec _ f) f) + (λh (g : empty), empty.rec _ g) g + omit H + definition discrete_category (A : Type) [H : decidable_eq A] : category A := + mk (λa b, set_hom a b) + (λ a b c g f, set_compose g f) + (λ a, decidable.rec_on_true rfl ⋆) + (λ a b c d h g f, @subsingleton.elim (set_hom a d) _ _ _) + (λ a b f, @subsingleton.elim (set_hom a b) _ _ _) + (λ a b f, @subsingleton.elim (set_hom a b) _ _ _) + local attribute discrete_category [reducible] + definition Discrete_category (A : Type) [H : decidable_eq A] := Mk (discrete_category A) + section + local attribute discrete_category [instance] + include H + theorem discrete_category.endomorphism {a b : A} (f : a ⟶ b) : a = b := + decidable.rec_on (H a b) (λh f, h) (λh f, empty.rec _ f) f + + theorem discrete_category.discrete {a b : A} (f : a ⟶ b) + : eq.rec_on (discrete_category.endomorphism f) f = (ID b) := + @subsingleton.elim _ !set_hom_subsingleton _ _ + + definition discrete_category.rec_on {P : Πa b, a ⟶ b → Type} {a b : A} (f : a ⟶ b) + (H : ∀a, P a a id) : P a b f := + cast (dcongr_arg3 P rfl (discrete_category.endomorphism f)⁻¹ + (@subsingleton.elim _ !set_hom_subsingleton _ _))⁻¹ (H a) + end + end + section + open unit bool + definition category_one := discrete_category unit + definition Category_one := Mk category_one + definition category_two := discrete_category bool + definition Category_two := Mk category_two + end + + namespace product + section + open prod + attribute [reducible] + definition prod_category {obC obD : Type} (C : category obC) (D : category obD) + : category (obC × obD) := + mk (λa b, hom (pr1 a) (pr1 b) × hom (pr2 a) (pr2 b)) + (λ a b c g f, (pr1 g ∘ pr1 f , pr2 g ∘ pr2 f) ) + (λ a, (id,id)) + (λ a b c d h g f, pair_eq !assoc !assoc ) + (λ a b f, prod.eq !id_left !id_left ) + (λ a b f, prod.eq !id_right !id_right) + + attribute [reducible] + definition Prod_category (C D : Category) : Category := Mk (prod_category C D) + end + end product + + namespace ops + notation `type`:max := Type_category + postfix `ᵒᵖ`:max := opposite.Opposite + infixr `×c`:30 := product.Prod_category + attribute type_category [instance] + attribute category_one [instance] + attribute category_two [instance] + attribute product.prod_category [instance] + end ops + + open ops + namespace opposite + section + open functor + attribute [reducible] + definition opposite_functor {C D : Category} (F : C ⇒ D) : Cᵒᵖ ⇒ Dᵒᵖ := + @functor.mk (Cᵒᵖ) (Dᵒᵖ) + (λ a, F a) + (λ a b f, F f) + (λ a, respect_id F a) + (λ a b c g f, by apply @respect_comp C D) + end + end opposite + + namespace product + section + open ops functor + attribute [reducible] + definition prod_functor {C C' D D' : Category} (F : C ⇒ D) (G : C' ⇒ D') + : C ×c C' ⇒ D ×c D' := + functor.mk (λ a, pair (F (pr1 a)) (G (pr2 a))) + (λ a b f, pair (F (pr1 f)) (G (pr2 f))) + (λ a, pair_eq !respect_id !respect_id) + (λ a b c g f, pair_eq !respect_comp !respect_comp) + end + end product + + namespace ops + infixr `×f`:30 := product.prod_functor + infixr `ᵒᵖᶠ`:max := opposite.opposite_functor + end ops + + section functor_category + variables (C D : Category) + definition functor_category : category (functor C D) := + mk (λa b, natural_transformation a b) + (λ a b c g f, natural_transformation.compose g f) + (λ a, natural_transformation.id) + (λ a b c d h g f, !natural_transformation.assoc) + (λ a b f, !natural_transformation.id_left) + (λ a b f, !natural_transformation.id_right) + end functor_category + + namespace slice + open sigma function + variables {ob : Type} {C : category ob} {c : ob} + protected definition slice_obs (C : category ob) (c : ob) := Σ(b : ob), hom b c + variables {a b : slice.slice_obs C c} + protected definition to_ob (a : slice.slice_obs C c) : ob := sigma.pr1 a + protected definition to_ob_def (a : slice.slice_obs C c) : slice.to_ob a = sigma.pr1 a := rfl + protected definition ob_hom (a : slice.slice_obs C c) : hom (slice.to_ob a) c := sigma.pr2 a + -- protected theorem slice_obs_equal (H₁ : to_ob a = to_ob b) + -- (H₂ : eq.drec_on H₁ (ob_hom a) = ob_hom b) : a = b := + -- sigma.equal H₁ H₂ + + + protected definition slice_hom (a b : slice.slice_obs C c) : Type := + Σ(g : hom (slice.to_ob a) (slice.to_ob b)), slice.ob_hom b ∘ g = slice.ob_hom a + + protected definition hom_hom (f : slice.slice_hom a b) : hom (slice.to_ob a) (slice.to_ob b) := sigma.pr1 f + protected definition commute (f : slice.slice_hom a b) : slice.ob_hom b ∘ (slice.hom_hom f) = slice.ob_hom a := sigma.pr2 f + -- protected theorem slice_hom_equal (f g : slice_hom a b) (H : hom_hom f = hom_hom g) : f = g := + -- sigma.equal H !proof_irrel + + definition slice_category (C : category ob) (c : ob) : category (slice.slice_obs C c) := + mk (λa b, slice.slice_hom a b) + (λ a b c g f, sigma.mk (slice.hom_hom g ∘ slice.hom_hom f) + (show slice.ob_hom c ∘ (slice.hom_hom g ∘ slice.hom_hom f) = slice.ob_hom a, + proof + calc + slice.ob_hom c ∘ (slice.hom_hom g ∘ slice.hom_hom f) = (slice.ob_hom c ∘ slice.hom_hom g) ∘ slice.hom_hom f : !assoc + ... = slice.ob_hom b ∘ slice.hom_hom f : {slice.commute g} + ... = slice.ob_hom a : {slice.commute f} + qed)) + (λ a, sigma.mk id !id_right) + (λ a b c d h g f, dpair_eq !assoc !proof_irrel) + (λ a b f, sigma.eq !id_left !proof_irrel) + (λ a b f, sigma.eq !id_right !proof_irrel) + -- We use !proof_irrel instead of rfl, to give the unifier an easier time + + -- definition slice_category {ob : Type} (C : category ob) (c : ob) : category (Σ(b : ob), hom b c) + -- := + -- mk (λa b, Σ(g : hom (dpr1 a) (dpr1 b)), dpr2 b ∘ g = dpr2 a) + -- (λ a b c g f, dpair (dpr1 g ∘ dpr1 f) + -- (show dpr2 c ∘ (dpr1 g ∘ dpr1 f) = dpr2 a, + -- proof + -- calc + -- dpr2 c ∘ (dpr1 g ∘ dpr1 f) = (dpr2 c ∘ dpr1 g) ∘ dpr1 f : !assoc + -- ... = dpr2 b ∘ dpr1 f : {dpr2 g} + -- ... = dpr2 a : {dpr2 f} + -- qed)) + -- (λ a, dpair id !id_right) + -- (λ a b c d h g f, dpair_eq !assoc !proof_irrel) + -- (λ a b f, sigma.equal !id_left !proof_irrel) + -- (λ a b f, sigma.equal !id_right !proof_irrel) + -- We use !proof_irrel instead of rfl, to give the unifier an easier time + + attribute [reducible] + definition Slice_category (C : Category) (c : C) := Mk (slice_category C c) + open category.ops + attribute slice_category [instance] + variables {D : Category} + definition forgetful (x : D) : (Slice_category D x) ⇒ D := + functor.mk (λ a, slice.to_ob a) + (λ a b f, slice.hom_hom f) + (λ a, rfl) + (λ a b c g f, rfl) + + definition postcomposition_functor {x y : D} (h : x ⟶ y) + : Slice_category D x ⇒ Slice_category D y := + functor.mk + (λ a, sigma.mk (slice.to_ob a) (h ∘ slice.ob_hom a)) + (λ a b f, + ⟨slice.hom_hom f, + calc + (h ∘ slice.ob_hom b) ∘ slice.hom_hom f = h ∘ (slice.ob_hom b ∘ slice.hom_hom f) : by rewrite assoc + ... = h ∘ slice.ob_hom a : by rewrite slice.commute⟩) + (λ a, rfl) + (λ a b c g f, dpair_eq rfl !proof_irrel) + + -- -- in the following comment I tried to have (A = B) in the type of a == b, but that doesn't solve the problems + -- definition heq2 {A B : Type} (H : A = B) (a : A) (b : B) := a == b + -- definition heq2.intro {A B : Type} {a : A} {b : B} (H : a == b) : heq2 (heq.type_eq H) a b := H + -- definition heq2.elim {A B : Type} {a : A} {b : B} (H : A = B) (H2 : heq2 H a b) : a == b := H2 + -- definition heq2.proof_irrel {A B : Prop} (a : A) (b : B) (H : A = B) : heq2 H a b := + -- hproof_irrel H a b + -- theorem functor.mk_eq2 {C D : Category} {obF obG : C → D} {homF homG idF idG compF compG} + -- (Hob : ∀x, obF x = obG x) + -- (Hmor : ∀(a b : C) (f : a ⟶ b), heq2 (congr_arg (λ x, x a ⟶ x b) (funext Hob)) (homF a b f) (homG a b f)) + -- : functor.mk obF homF idF compF = functor.mk obG homG idG compG := + -- hddcongr_arg4 functor.mk + -- (funext Hob) + -- (hfunext (λ a, hfunext (λ b, hfunext (λ f, !Hmor)))) + -- !proof_irrel + -- !proof_irrel + +-- set_option pp.implicit true +-- set_option pp.coercions true + + -- definition slice_functor : D ⇒ Category_of_categories := + -- functor.mk (λ a, Category.mk (slice_obs D a) (slice_category D a)) + -- (λ a b f, postcomposition_functor f) + -- (λ a, functor.mk_heq + -- (λx, sigma.equal rfl !id_left) + -- (λb c f, sigma.hequal sorry !heq.refl (hproof_irrel sorry _ _))) + -- (λ a b c g f, functor.mk_heq + -- (λx, sigma.equal (sorry ⬝ refl (dpr1 x)) sorry) + -- (λb c f, sorry)) + + --the error message generated here is really confusing: the type of the above refl should be + -- "@dpr1 D (λ (a_1 : D), a_1 ⟶ a) x = @dpr1 D (λ (a_1 : D), a_1 ⟶ c) x", but the second dpr1 is not even well-typed + + end slice + + -- section coslice + -- open sigma + + -- definition coslice {ob : Type} (C : category ob) (c : ob) : category (Σ(b : ob), hom c b) := + -- mk (λa b, Σ(g : hom (dpr1 a) (dpr1 b)), g ∘ dpr2 a = dpr2 b) + -- (λ a b c g f, dpair (dpr1 g ∘ dpr1 f) + -- (show (dpr1 g ∘ dpr1 f) ∘ dpr2 a = dpr2 c, + -- proof + -- calc + -- (dpr1 g ∘ dpr1 f) ∘ dpr2 a = dpr1 g ∘ (dpr1 f ∘ dpr2 a): symm !assoc + -- ... = dpr1 g ∘ dpr2 b : {dpr2 f} + -- ... = dpr2 c : {dpr2 g} + -- qed)) + -- (λ a, dpair id !id_left) + -- (λ a b c d h g f, dpair_eq !assoc !proof_irrel) + -- (λ a b f, sigma.equal !id_left !proof_irrel) + -- (λ a b f, sigma.equal !id_right !proof_irrel) + + -- -- theorem slice_coslice_opp {ob : Type} (C : category ob) (c : ob) : + -- -- coslice C c = opposite (slice (opposite C) c) := + -- -- sorry + -- end coslice + + section arrow + open sigma eq.ops + -- theorem concat_commutative_squares {ob : Type} {C : category ob} {a1 a2 a3 b1 b2 b3 : ob} + -- {f1 : a1 => b1} {f2 : a2 => b2} {f3 : a3 => b3} {g2 : a2 => a3} {g1 : a1 => a2} + -- {h2 : b2 => b3} {h1 : b1 => b2} (H1 : f2 ∘ g1 = h1 ∘ f1) (H2 : f3 ∘ g2 = h2 ∘ f2) + -- : f3 ∘ (g2 ∘ g1) = (h2 ∘ h1) ∘ f1 := + -- calc + -- f3 ∘ (g2 ∘ g1) = (f3 ∘ g2) ∘ g1 : assoc + -- ... = (h2 ∘ f2) ∘ g1 : {H2} + -- ... = h2 ∘ (f2 ∘ g1) : symm assoc + -- ... = h2 ∘ (h1 ∘ f1) : {H1} + -- ... = (h2 ∘ h1) ∘ f1 : assoc + + -- definition arrow {ob : Type} (C : category ob) : category (Σ(a b : ob), hom a b) := + -- mk (λa b, Σ(g : hom (dpr1 a) (dpr1 b)) (h : hom (dpr2' a) (dpr2' b)), + -- dpr3 b ∘ g = h ∘ dpr3 a) + -- (λ a b c g f, dpair (dpr1 g ∘ dpr1 f) (dpair (dpr2' g ∘ dpr2' f) (concat_commutative_squares (dpr3 f) (dpr3 g)))) + -- (λ a, dpair id (dpair id (id_right ⬝ (symm id_left)))) + -- (λ a b c d h g f, dtrip_eq2 assoc assoc !proof_irrel) + -- (λ a b f, trip.equal2 id_left id_left !proof_irrel) + -- (λ a b f, trip.equal2 id_right id_right !proof_irrel) + + -- make these definitions private? + variables {ob : Type} {C : category ob} + protected definition arrow_obs (ob : Type) (C : category ob) := Σ(a b : ob), hom a b + variables {a b : category.arrow_obs ob C} + protected definition src (a : category.arrow_obs ob C) : ob := sigma.pr1 a + protected definition dst (a : category.arrow_obs ob C) : ob := sigma.pr2' a + protected definition to_hom (a : category.arrow_obs ob C) : hom (category.src a) (category.dst a) := sigma.pr3 a + + protected definition arrow_hom (a b : category.arrow_obs ob C) : Type := + Σ (g : hom (category.src a) (category.src b)) (h : hom (category.dst a) (category.dst b)), + category.to_hom b ∘ g = h ∘ category.to_hom a + + protected definition hom_src (m : category.arrow_hom a b) : hom (category.src a) (category.src b) := sigma.pr1 m + protected definition hom_dst (m : category.arrow_hom a b) : hom (category.dst a) (category.dst b) := sigma.pr2' m + protected definition commute (m : category.arrow_hom a b) : + category.to_hom b ∘ (category.hom_src m) = (category.hom_dst m) ∘ category.to_hom a + := sigma.pr3 m + + definition arrow (ob : Type) (C : category ob) : category (category.arrow_obs ob C) := + mk (λa b, category.arrow_hom a b) + (λ a b c g f, sigma.mk (category.hom_src g ∘ category.hom_src f) (sigma.mk (category.hom_dst g ∘ category.hom_dst f) + (show category.to_hom c ∘ (category.hom_src g ∘ category.hom_src f) = (category.hom_dst g ∘ category.hom_dst f) ∘ category.to_hom a, + proof + calc + category.to_hom c ∘ (category.hom_src g ∘ category.hom_src f) = (category.to_hom c ∘ category.hom_src g) ∘ category.hom_src f : by rewrite assoc + ... = (category.hom_dst g ∘ category.to_hom b) ∘ category.hom_src f : by rewrite category.commute + ... = category.hom_dst g ∘ (category.to_hom b ∘ category.hom_src f) : by rewrite assoc + ... = category.hom_dst g ∘ (category.hom_dst f ∘ category.to_hom a) : by rewrite category.commute + ... = (category.hom_dst g ∘ category.hom_dst f) ∘ category.to_hom a : by rewrite assoc + qed) + )) + (λ a, sigma.mk id (sigma.mk id (!id_right ⬝ (symm !id_left)))) + (λ a b c d h g f, ndtrip_eq !assoc !assoc !proof_irrel) + (λ a b f, ndtrip_equal !id_left !id_left !proof_irrel) + (λ a b f, ndtrip_equal !id_right !id_right !proof_irrel) + + end arrow + +end category + + -- definition foo : category (sorry) := + -- mk (λa b, sorry) + -- (λ a b c g f, sorry) + -- (λ a, sorry) + -- (λ a b c d h g f, sorry) + -- (λ a b f, sorry) + -- (λ a b f, sorry) diff --git a/old_library/algebra/category/default.lean b/old_library/algebra/category/default.lean new file mode 100644 index 0000000000..7c35a9c4ed --- /dev/null +++ b/old_library/algebra/category/default.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Floris van Doorn +-/ + +import .morphism .constructions diff --git a/old_library/algebra/category/functor.lean b/old_library/algebra/category/functor.lean new file mode 100644 index 0000000000..f8164838fe --- /dev/null +++ b/old_library/algebra/category/functor.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Floris van Doorn +-/ +import .basic +import logic.cast +open function +open category eq eq.ops heq + +structure functor (C D : Category) : Type := + (object : C → D) + (morphism : Π⦃a b : C⦄, hom a b → hom (object a) (object b)) + (respect_id : Π (a : C), morphism (ID a) = ID (object a)) + (respect_comp : Π ⦃a b c : C⦄ (g : hom b c) (f : hom a b), + morphism (g ∘ f) = morphism g ∘ morphism f) + +infixl `⇒`:25 := functor + +namespace functor + -- attribute object [coercion] + -- attribute morphism [coercion] + attribute respect_id [irreducible] + attribute respect_comp [irreducible] + + variables {A B C D : Category} + + attribute [reducible] + protected definition compose (G : functor B C) (F : functor A B) : functor A C := + functor.mk + (λx, G (F x)) + (λ a b f, G (F f)) + (λ a, proof calc + G (F (ID a)) = G id : {respect_id F a} + --not giving the braces explicitly makes the elaborator compute a couple more seconds + ... = id : respect_id G (F a) qed) + (λ a b c g f, proof calc + G (F (g ∘ f)) = G (F g ∘ F f) : respect_comp F g f + ... = G (F g) ∘ G (F f) : respect_comp G (F g) (F f) qed) + + infixr `∘f`:60 := functor.compose + + protected theorem assoc (H : functor C D) (G : functor B C) (F : functor A B) : + H ∘f (G ∘f F) = (H ∘f G) ∘f F := + rfl + + attribute [reducible] + protected definition id {C : Category} : functor C C := + mk (λa, a) (λ a b f, f) (λ a, rfl) (λ a b c f g, rfl) + attribute [reducible] + protected definition ID (C : Category) : functor C C := @functor.id C + + protected theorem id_left (F : functor C D) : (@functor.id D) ∘f F = F := + functor.rec (λ obF homF idF compF, dcongr_arg4 mk rfl rfl !proof_irrel !proof_irrel) F + protected theorem id_right (F : functor C D) : F ∘f (@functor.id C) = F := + functor.rec (λ obF homF idF compF, dcongr_arg4 mk rfl rfl !proof_irrel !proof_irrel) F + +end functor + +namespace category + open functor + attribute [reducible] + definition category_of_categories : category Category := + mk (λ a b, functor a b) + (λ a b c g f, functor.compose g f) + (λ a, functor.id) + (λ a b c d h g f, !functor.assoc) + (λ a b f, !functor.id_left) + (λ a b f, !functor.id_right) + + attribute [reducible] + definition Category_of_categories := Mk category_of_categories + + namespace ops + notation `Cat`:max := Category_of_categories + attribute category_of_categories [instance] + end ops +end category + +namespace functor + + variables {C D : Category} + + theorem mk_heq {obF obG : C → D} {homF homG idF idG compF compG} (Hob : ∀x, obF x = obG x) + (Hmor : ∀(a b : C) (f : a ⟶ b), homF a b f == homG a b f) + : mk obF homF idF compF = mk obG homG idG compG := + hddcongr_arg4 mk + (funext Hob) + (hfunext (λ a, hfunext (λ b, hfunext (λ f, !Hmor)))) + !proof_irrel + !proof_irrel + + protected theorem hequal {F G : C ⇒ D} : Π (Hob : ∀x, F x = G x) + (Hmor : ∀a b (f : a ⟶ b), F f == G f), F = G := + functor.rec + (λ obF homF idF compF, + functor.rec + (λ obG homG idG compG Hob Hmor, mk_heq Hob Hmor) + G) + F + +-- theorem mk_eq {obF obG : C → D} {homF homG idF idG compF compG} (Hob : ∀x, obF x = obG x) +-- (Hmor : ∀(a b : C) (f : a ⟶ b), cast (congr_arg (λ x, x a ⟶ x b) (funext Hob)) (homF a b f) +-- = homG a b f) +-- : mk obF homF idF compF = mk obG homG idG compG := +-- dcongr_arg4 mk +-- (funext Hob) +-- (funext (λ a, funext (λ b, funext (λ f, sorry ⬝ Hmor a b f)))) +-- -- to fill this sorry use (a generalization of) cast_pull +-- !proof_irrel +-- !proof_irrel + +-- protected theorem equal {F G : C ⇒ D} : Π (Hob : ∀x, F x = G x) +-- (Hmor : ∀a b (f : a ⟶ b), cast (congr_arg (λ x, x a ⟶ x b) (funext Hob)) (F f) = G f), F = G := +-- functor.rec +-- (λ obF homF idF compF, +-- functor.rec +-- (λ obG homG idG compG Hob Hmor, mk_eq Hob Hmor) +-- G) +-- F + + +end functor diff --git a/old_library/algebra/category/limit.lean b/old_library/algebra/category/limit.lean new file mode 100644 index 0000000000..1ac6aea045 --- /dev/null +++ b/old_library/algebra/category/limit.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Floris van Doorn +-/ + +import .natural_transformation +import data.sigma + +open eq eq.ops category functor natural_transformation + +namespace limits +--representable functor + section + variables {I C : Category} {D : I ⇒ C} + + definition constant_diagram (a : C) : I ⇒ C := + mk (λ i, a) + (λ i j u, id) + (λ i, rfl) + (λ i j k v u, symm !id_compose) + + definition cone := Σ(a : C), constant_diagram a ⟹ D + -- definition cone_category : category cone := + -- mk (λa b, sorry) + -- (λ a b c g f, sorry) + -- (λ a, sorry) + -- (λ a b c d h g f, sorry) + -- (λ a b f, sorry) + -- (λ a b f, sorry) + + end +end limits + -- functor.mk (λ a, sorry) + -- (λ a b f, sorry) + -- (λ a, sorry) + -- (λ a b c g f, sorry) diff --git a/old_library/algebra/category/morphism.lean b/old_library/algebra/category/morphism.lean new file mode 100644 index 0000000000..667c7a9f05 --- /dev/null +++ b/old_library/algebra/category/morphism.lean @@ -0,0 +1,286 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Floris van Doorn +-/ + +import .basic algebra.relation algebra.binary + +open eq eq.ops category + +namespace morphism + variables {ob : Type} [C : category ob] include C + variables {a b c : ob} {g : b ⟶ c} {f : a ⟶ b} {h : b ⟶ a} + inductive is_section [class] (f : a ⟶ b) : Type + := mk : ∀{g}, g ∘ f = id → is_section f + inductive is_retraction [class] (f : a ⟶ b) : Type + := mk : ∀{g}, f ∘ g = id → is_retraction f + inductive is_iso [class] (f : a ⟶ b) : Type + := mk : ∀{g}, g ∘ f = id → f ∘ g = id → is_iso f + + attribute is_iso [multiple_instances] + + definition retraction_of (f : a ⟶ b) [H : is_section f] : hom b a := + is_section.rec (λg h, g) H + definition section_of (f : a ⟶ b) [H : is_retraction f] : hom b a := + is_retraction.rec (λg h, g) H + definition inverse (f : a ⟶ b) [H : is_iso f] : hom b a := + is_iso.rec (λg h1 h2, g) H + + postfix `⁻¹` := inverse + + theorem inverse_compose (f : a ⟶ b) [H : is_iso f] : f⁻¹ ∘ f = id := + is_iso.rec (λg h1 h2, h1) H + + theorem compose_inverse (f : a ⟶ b) [H : is_iso f] : f ∘ f⁻¹ = id := + is_iso.rec (λg h1 h2, h2) H + + theorem retraction_compose (f : a ⟶ b) [H : is_section f] : retraction_of f ∘ f = id := + is_section.rec (λg h, h) H + + theorem compose_section (f : a ⟶ b) [H : is_retraction f] : f ∘ section_of f = id := + is_retraction.rec (λg h, h) H + + attribute [instance] + theorem iso_imp_retraction (f : a ⟶ b) [H : is_iso f] : is_section f := + is_section.mk !inverse_compose + + attribute [instance] + theorem iso_imp_section (f : a ⟶ b) [H : is_iso f] : is_retraction f := + is_retraction.mk !compose_inverse + + attribute [instance] + theorem id_is_iso : is_iso (ID a) := + is_iso.mk !id_compose !id_compose + + attribute [instance] + theorem inverse_is_iso (f : a ⟶ b) [H : is_iso f] : is_iso (f⁻¹) := + is_iso.mk !compose_inverse !inverse_compose + + theorem left_inverse_eq_right_inverse {f : a ⟶ b} {g g' : hom b a} + (Hl : g ∘ f = id) (Hr : f ∘ g' = id) : g = g' := + calc + g = g ∘ id : by rewrite id_right + ... = g ∘ f ∘ g' : by rewrite -Hr + ... = (g ∘ f) ∘ g' : by rewrite assoc + ... = id ∘ g' : by rewrite Hl + ... = g' : by rewrite id_left + + theorem retraction_eq_intro [H : is_section f] (H2 : f ∘ h = id) : retraction_of f = h := + left_inverse_eq_right_inverse !retraction_compose H2 + + theorem section_eq_intro [H : is_retraction f] (H2 : h ∘ f = id) : section_of f = h := + symm (left_inverse_eq_right_inverse H2 !compose_section) + + theorem inverse_eq_intro_right [H : is_iso f] (H2 : f ∘ h = id) : f⁻¹ = h := + left_inverse_eq_right_inverse !inverse_compose H2 + + theorem inverse_eq_intro_left [H : is_iso f] (H2 : h ∘ f = id) : f⁻¹ = h := + symm (left_inverse_eq_right_inverse H2 !compose_inverse) + + theorem section_eq_retraction (f : a ⟶ b) [Hl : is_section f] [Hr : is_retraction f] : + retraction_of f = section_of f := + retraction_eq_intro !compose_section + + theorem section_retraction_imp_iso (f : a ⟶ b) [Hl : is_section f] [Hr : is_retraction f] + : is_iso f := + is_iso.mk (subst (section_eq_retraction f) (retraction_compose f)) (compose_section f) + + theorem inverse_unique (H H' : is_iso f) : @inverse _ _ _ _ f H = @inverse _ _ _ _ f H' := + inverse_eq_intro_left !inverse_compose + + theorem inverse_involutive (f : a ⟶ b) [H : is_iso f] : (f⁻¹)⁻¹ = f := + inverse_eq_intro_right !inverse_compose + + theorem retraction_of_id : retraction_of (ID a) = id := + retraction_eq_intro !id_compose + + theorem section_of_id : section_of (ID a) = id := + section_eq_intro !id_compose + + theorem iso_of_id : (ID a)⁻¹ = id := + inverse_eq_intro_left !id_compose + + attribute [instance] + theorem composition_is_section [Hf : is_section f] [Hg : is_section g] + : is_section (g ∘ f) := + is_section.mk + (calc + (retraction_of f ∘ retraction_of g) ∘ g ∘ f + = retraction_of f ∘ retraction_of g ∘ g ∘ f : by rewrite -assoc + ... = retraction_of f ∘ (retraction_of g ∘ g) ∘ f : by rewrite (assoc _ g f) + ... = retraction_of f ∘ id ∘ f : by rewrite retraction_compose + ... = retraction_of f ∘ f : by rewrite id_left + ... = id : by rewrite retraction_compose) + + attribute [instance] + theorem composition_is_retraction [Hf : is_retraction f] [Hg : is_retraction g] + : is_retraction (g ∘ f) := + is_retraction.mk + (calc + (g ∘ f) ∘ section_of f ∘ section_of g + = g ∘ f ∘ section_of f ∘ section_of g : by rewrite -assoc + ... = g ∘ (f ∘ section_of f) ∘ section_of g : by rewrite -assoc + ... = g ∘ id ∘ section_of g : by rewrite compose_section + ... = g ∘ section_of g : by rewrite id_left + ... = id : by rewrite compose_section) + + attribute [instance] + theorem composition_is_inverse [Hf : is_iso f] [Hg : is_iso g] : is_iso (g ∘ f) := + !section_retraction_imp_iso + + structure isomorphic (a b : ob) := + (iso : a ⟶ b) + [is_iso : is_iso iso] + + infix `≅`:50 := morphism.isomorphic + + namespace isomorphic + open relation + attribute is_iso [instance] + + theorem refl (a : ob) : a ≅ a := mk id + theorem symm ⦃a b : ob⦄ (H : a ≅ b) : b ≅ a := mk (inverse (iso H)) + theorem trans ⦃a b c : ob⦄ (H1 : a ≅ b) (H2 : b ≅ c) : a ≅ c := mk (iso H2 ∘ iso H1) + + attribute [instance] + theorem is_equivalence_eq (T : Type) : is_equivalence (isomorphic : ob → ob → Type) := + is_equivalence.mk refl symm trans + end isomorphic + + inductive is_mono [class] (f : a ⟶ b) : Prop := + mk : (∀c (g h : hom c a), f ∘ g = f ∘ h → g = h) → is_mono f + inductive is_epi [class] (f : a ⟶ b) : Prop := + mk : (∀c (g h : hom b c), g ∘ f = h ∘ f → g = h) → is_epi f + + theorem mono_elim [H : is_mono f] {g h : c ⟶ a} (H2 : f ∘ g = f ∘ h) : g = h := + match H with + is_mono.mk H3 := H3 c g h H2 + end + + theorem epi_elim [H : is_epi f] {g h : b ⟶ c} (H2 : g ∘ f = h ∘ f) : g = h := + match H with + is_epi.mk H3 := H3 c g h H2 + end + + attribute [instance] + theorem section_is_mono (f : a ⟶ b) [H : is_section f] : is_mono f := + is_mono.mk + (λ c g h H, calc + g = id ∘ g : by rewrite id_left + ... = (retraction_of f ∘ f) ∘ g : by rewrite -(retraction_compose f) + ... = (retraction_of f ∘ f) ∘ h : by rewrite [-assoc, H, -assoc] + ... = id ∘ h : by rewrite retraction_compose + ... = h : by rewrite id_left) + + attribute [instance] + theorem retraction_is_epi (f : a ⟶ b) [H : is_retraction f] : is_epi f := + is_epi.mk + (λ c g h H, calc + g = g ∘ id : by rewrite id_right + ... = g ∘ f ∘ section_of f : by rewrite -(compose_section f) + ... = h ∘ f ∘ section_of f : by rewrite [assoc, H, -assoc] + ... = h ∘ id : by rewrite compose_section + ... = h : by rewrite id_right) + + --these theorems are now proven automatically using type classes + --should they be instances? + theorem id_is_mono : is_mono (ID a) + theorem id_is_epi : is_epi (ID a) + + attribute [instance] + theorem composition_is_mono [Hf : is_mono f] [Hg : is_mono g] : is_mono (g ∘ f) := + is_mono.mk + (λ d h₁ h₂ H, + have H2 : g ∘ (f ∘ h₁) = g ∘ (f ∘ h₂), + begin + rewrite *assoc, exact H + end, + mono_elim (mono_elim H2)) + + attribute [instance] + theorem composition_is_epi [Hf : is_epi f] [Hg : is_epi g] : is_epi (g ∘ f) := + is_epi.mk + (λ d h₁ h₂ H, + have H2 : (h₁ ∘ g) ∘ f = (h₂ ∘ g) ∘ f, + begin + rewrite -*assoc, exact H + end, + epi_elim (epi_elim H2)) +end morphism +namespace morphism +--rewrite lemmas for inverses, modified from +--https://github.com/JasonGross/HoTT-categories/blob/master/theories/Categories/Category/Morphisms.v + namespace iso + section + variables {ob : Type} [C : category ob] include C + variables {a b c d : ob} + variables (f : b ⟶ a) (r : c ⟶ d) (q : b ⟶ c) (p : a ⟶ b) + variables (g : d ⟶ c) + + variable [Hq : is_iso q] include Hq + theorem compose_pV : q ∘ q⁻¹ = id := !compose_inverse + theorem compose_Vp : q⁻¹ ∘ q = id := !inverse_compose + theorem compose_V_pp : q⁻¹ ∘ (q ∘ p) = p := + calc + q⁻¹ ∘ (q ∘ p) = (q⁻¹ ∘ q) ∘ p : by rewrite assoc + ... = id ∘ p : by rewrite inverse_compose + ... = p : by rewrite id_left + + theorem compose_p_Vp : q ∘ (q⁻¹ ∘ g) = g := + calc + q ∘ (q⁻¹ ∘ g) = (q ∘ q⁻¹) ∘ g : by rewrite assoc + ... = id ∘ g : by rewrite compose_inverse + ... = g : by rewrite id_left + + theorem compose_pp_V : (r ∘ q) ∘ q⁻¹ = r := + calc + (r ∘ q) ∘ q⁻¹ = r ∘ q ∘ q⁻¹ : by rewrite assoc + ... = r ∘ id : by rewrite compose_inverse + ... = r : by rewrite id_right + + theorem compose_pV_p : (f ∘ q⁻¹) ∘ q = f := + calc + (f ∘ q⁻¹) ∘ q = f ∘ q⁻¹ ∘ q : by rewrite assoc + ... = f ∘ id : by rewrite inverse_compose + ... = f : by rewrite id_right + + theorem inv_pp [H' : is_iso p] : (q ∘ p)⁻¹ = p⁻¹ ∘ q⁻¹ := + inverse_eq_intro_left + (show (p⁻¹ ∘ (q⁻¹)) ∘ q ∘ p = id, from + by rewrite [-assoc, compose_V_pp, inverse_compose]) + + theorem inv_Vp [H' : is_iso g] : (q⁻¹ ∘ g)⁻¹ = g⁻¹ ∘ q := inverse_involutive q ▸ inv_pp (q⁻¹) g + theorem inv_pV [H' : is_iso f] : (q ∘ f⁻¹)⁻¹ = f ∘ q⁻¹ := inverse_involutive f ▸ inv_pp q (f⁻¹) + theorem inv_VV [H' : is_iso r] : (q⁻¹ ∘ r⁻¹)⁻¹ = r ∘ q := inverse_involutive r ▸ inv_Vp q (r⁻¹) + end + section + variables {ob : Type} {C : category ob} include C + variables {d c b a : ob} + variables {i : b ⟶ c} {f : b ⟶ a} + {r : c ⟶ d} {q : b ⟶ c} {p : a ⟶ b} + {g : d ⟶ c} {h : c ⟶ b} + {x : b ⟶ d} {z : a ⟶ c} + {y : d ⟶ b} {w : c ⟶ a} + variable [Hq : is_iso q] include Hq + + theorem moveR_Mp (H : y = q⁻¹ ∘ g) : q ∘ y = g := H⁻¹ ▸ compose_p_Vp q g + theorem moveR_pM (H : w = f ∘ q⁻¹) : w ∘ q = f := H⁻¹ ▸ compose_pV_p f q + theorem moveR_Vp (H : z = q ∘ p) : q⁻¹ ∘ z = p := H⁻¹ ▸ compose_V_pp q p + theorem moveR_pV (H : x = r ∘ q) : x ∘ q⁻¹ = r := H⁻¹ ▸ compose_pp_V r q + theorem moveL_Mp (H : q⁻¹ ∘ g = y) : g = q ∘ y := (moveR_Mp (H⁻¹))⁻¹ + theorem moveL_pM (H : f ∘ q⁻¹ = w) : f = w ∘ q := (moveR_pM (H⁻¹))⁻¹ + theorem moveL_Vp (H : q ∘ p = z) : p = q⁻¹ ∘ z := (moveR_Vp (H⁻¹))⁻¹ + theorem moveL_pV (H : r ∘ q = x) : r = x ∘ q⁻¹ := (moveR_pV (H⁻¹))⁻¹ + theorem moveL_1V (H : h ∘ q = id) : h = q⁻¹ := (inverse_eq_intro_left H)⁻¹ + theorem moveL_V1 (H : q ∘ h = id) : h = q⁻¹ := (inverse_eq_intro_right H)⁻¹ + theorem moveL_1M (H : i ∘ q⁻¹ = id) : i = q := moveL_1V H ⬝ inverse_involutive q + theorem moveL_M1 (H : q⁻¹ ∘ i = id) : i = q := moveL_V1 H ⬝ inverse_involutive q + theorem moveR_1M (H : id = i ∘ q⁻¹) : q = i := (moveL_1M (H⁻¹))⁻¹ + theorem moveR_M1 (H : id = q⁻¹ ∘ i) : q = i := (moveL_M1 (H⁻¹))⁻¹ + theorem moveR_1V (H : id = h ∘ q) : q⁻¹ = h := (moveL_1V (H⁻¹))⁻¹ + theorem moveR_V1 (H : id = q ∘ h) : q⁻¹ = h := (moveL_V1 (H⁻¹))⁻¹ + end + end iso + +end morphism diff --git a/old_library/algebra/category/natural_transformation.lean b/old_library/algebra/category/natural_transformation.lean new file mode 100644 index 0000000000..f10aedf512 --- /dev/null +++ b/old_library/algebra/category/natural_transformation.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Floris van Doorn +-/ + +import .functor +open category eq eq.ops functor + +inductive natural_transformation {C D : Category} (F G : C ⇒ D) : Type := +mk : Π (η : Π(a : C), hom (F a) (G a)), (Π{a b : C} (f : hom a b), G f ∘ η a = η b ∘ F f) + → natural_transformation F G + +infixl `⟹`:25 := natural_transformation -- \==> + +namespace natural_transformation + variables {C D : Category} {F G H I : functor C D} + + -- definition natural_map [coercion] (η : F ⟹ G) : Π(a : C), F a ⟶ G a := + -- natural_transformation.rec (λ x y, x) η + + theorem naturality (η : F ⟹ G) : Π⦃a b : C⦄ (f : a ⟶ b), G f ∘ η a = η b ∘ F f := + natural_transformation.rec (λ x y, y) η + + protected definition compose (η : G ⟹ H) (θ : F ⟹ G) : F ⟹ H := + natural_transformation.mk + (λ a, η a ∘ θ a) + (λ a b f, + calc + H f ∘ (η a ∘ θ a) = (H f ∘ η a) ∘ θ a : assoc + ... = (η b ∘ G f) ∘ θ a : naturality η f + ... = η b ∘ (G f ∘ θ a) : assoc + ... = η b ∘ (θ b ∘ F f) : naturality θ f + ... = (η b ∘ θ b) ∘ F f : assoc) +--congr_arg (λx, η b ∘ x) (naturality θ f) -- this needed to be explicit for some reason (on Oct 24) + + infixr `∘n`:60 := natural_transformation.compose + protected theorem assoc (η₃ : H ⟹ I) (η₂ : G ⟹ H) (η₁ : F ⟹ G) : + η₃ ∘n (η₂ ∘n η₁) = (η₃ ∘n η₂) ∘n η₁ := + dcongr_arg2 mk (funext (take x, !assoc)) !proof_irrel + + protected definition id {C D : Category} {F : functor C D} : natural_transformation F F := + mk (λa, id) (λa b f, !id_right ⬝ symm !id_left) + protected definition ID {C D : Category} (F : functor C D) : natural_transformation F F := natural_transformation.id + + protected theorem id_left (η : F ⟹ G) : natural_transformation.compose natural_transformation.id η = η := + natural_transformation.rec (λf H, dcongr_arg2 mk (funext (take x, !id_left)) !proof_irrel) η + + protected theorem id_right (η : F ⟹ G) : natural_transformation.compose η natural_transformation.id = η := + natural_transformation.rec (λf H, dcongr_arg2 mk (funext (take x, !id_right)) !proof_irrel) η +end natural_transformation diff --git a/old_library/algebra/category/yoneda.lean b/old_library/algebra/category/yoneda.lean new file mode 100644 index 0000000000..75f0c7f352 --- /dev/null +++ b/old_library/algebra/category/yoneda.lean @@ -0,0 +1,18 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Floris van Doorn +-/ + +import .constructions + +open eq eq.ops category functor category.ops prod + +namespace yoneda +--representable functor + section + + + + end +end yoneda diff --git a/old_library/algebra/complete_lattice.lean b/old_library/algebra/complete_lattice.lean new file mode 100644 index 0000000000..065970c8cf --- /dev/null +++ b/old_library/algebra/complete_lattice.lean @@ -0,0 +1,435 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Complete lattices + +TODO: define dual complete lattice and simplify proof of dual theorems. +-/ +import algebra.lattice data.set.basic algebra.monotone +open set + +variable {A : Type} + +structure complete_lattice [class] (A : Type) extends lattice A := +(Inf : set A → A) +(Sup : set A → A) +(Inf_le : ∀ {a : A} {s : set A}, a ∈ s → le (Inf s) a) +(le_Inf : ∀ {b : A} {s : set A}, (∀ (a : A), a ∈ s → le b a) → le b (Inf s)) +(le_Sup : ∀ {a : A} {s : set A}, a ∈ s → le a (Sup s)) +(Sup_le : ∀ {b : A} {s : set A} (h : ∀ (a : A), a ∈ s → le a b), le (Sup s) b) + +section + variable [complete_lattice A] + + definition Inf (S : set A) : A := complete_lattice.Inf S + prefix `⨅ `:70 := Inf + + definition Sup (S : set A) : A := complete_lattice.Sup S + prefix `⨆ `:65 := Sup + + theorem Inf_le {a : A} {s : set A} (H : a ∈ s) : (Inf s) ≤ a := complete_lattice.Inf_le H + + theorem le_Inf {b : A} {s : set A} (H : ∀ (a : A), a ∈ s → b ≤ a) : b ≤ Inf s := + complete_lattice.le_Inf H + + theorem le_Sup {a : A} {s : set A} (H : a ∈ s) : a ≤ Sup s := complete_lattice.le_Sup H + + theorem Sup_le {b : A} {s : set A} (H : ∀ (a : A), a ∈ s → a ≤ b) : Sup s ≤ b := + complete_lattice.Sup_le H +end + +-- Minimal complete_lattice definition based just on Inf. +-- We later show that complete_lattice_Inf is a complete_lattice. +structure complete_lattice_Inf [class] (A : Type) extends weak_order A := +(Inf : set A → A) +(Inf_le : ∀ {a : A} {s : set A}, a ∈ s → le (Inf s) a) +(le_Inf : ∀ {b : A} {s : set A}, (∀ (a : A), a ∈ s → le b a) → le b (Inf s)) + +-- Minimal complete_lattice definition based just on Sup. +-- We later show that complete_lattice_Sup is a complete_lattice. +structure complete_lattice_Sup [class] (A : Type) extends weak_order A := +(Sup : set A → A) +(le_Sup : ∀ {a : A} {s : set A}, a ∈ s → le a (Sup s)) +(Sup_le : ∀ {b : A} {s : set A} (h : ∀ (a : A), a ∈ s → le a b), le (Sup s) b) + +namespace complete_lattice_Inf +variable [C : complete_lattice_Inf A] +include C +definition Sup (s : set A) : A := +Inf {b | ∀ a, a ∈ s → a ≤ b} + +local prefix `⨅`:70 := Inf +local prefix `⨆`:65 := Sup + +lemma le_Sup {a : A} {s : set A} : a ∈ s → a ≤ ⨆ s := +suppose a ∈ s, le_Inf + (show ∀ (b : A), (∀ (a : A), a ∈ s → a ≤ b) → a ≤ b, from + take b, assume h, h a `a ∈ s`) + +lemma Sup_le {b : A} {s : set A} (h : ∀ (a : A), a ∈ s → a ≤ b) : ⨆ s ≤ b := +Inf_le h + +definition inf (a b : A) := ⨅ '{a, b} +definition sup (a b : A) := ⨆ '{a, b} + +local infix `⊓` := inf +local infix `⊔` := sup + +lemma inf_le_left (a b : A) : a ⊓ b ≤ a := +Inf_le !mem_insert + +lemma inf_le_right (a b : A) : a ⊓ b ≤ b := +Inf_le (!mem_insert_of_mem !mem_insert) + +lemma le_inf {a b c : A} : c ≤ a → c ≤ b → c ≤ a ⊓ b := +assume h₁ h₂, +le_Inf (take x, suppose x ∈ '{a, b}, + or.elim (eq_or_mem_of_mem_insert this) + (suppose x = a, begin subst x, exact h₁ end) + (suppose x ∈ '{b}, + have x = b, from !eq_of_mem_singleton this, + begin subst x, exact h₂ end)) + +lemma le_sup_left (a b : A) : a ≤ a ⊔ b := +le_Sup !mem_insert + +lemma le_sup_right (a b : A) : b ≤ a ⊔ b := +le_Sup (!mem_insert_of_mem !mem_insert) + +lemma sup_le {a b c : A} : a ≤ c → b ≤ c → a ⊔ b ≤ c := +assume h₁ h₂, +Sup_le (take x, suppose x ∈ '{a, b}, + or.elim (eq_or_mem_of_mem_insert this) + (suppose x = a, by subst x; assumption) + (suppose x ∈ '{b}, + have x = b, from !eq_of_mem_singleton this, + by subst x; assumption)) +end complete_lattice_Inf + +-- Every complete_lattice_Inf is a complete_lattice_Sup +definition complete_lattice_Inf_to_complete_lattice_Sup [C : complete_lattice_Inf A] : + complete_lattice_Sup A := +⦃ complete_lattice_Sup, C ⦄ + +-- Every complete_lattice_Inf is a complete_lattice +attribute [trans_instance] +definition complete_lattice_Inf_to_complete_lattice [C : complete_lattice_Inf A] : + complete_lattice A := +⦃ complete_lattice, C ⦄ + +namespace complete_lattice_Sup +variable [C : complete_lattice_Sup A] +include C +definition Inf (s : set A) : A := +Sup {b | ∀ a, a ∈ s → b ≤ a} + +lemma Inf_le {a : A} {s : set A} : a ∈ s → Inf s ≤ a := +suppose a ∈ s, Sup_le + (show ∀ (b : A), (∀ (a : A), a ∈ s → b ≤ a) → b ≤ a, from + take b, assume h, h a `a ∈ s`) + +lemma le_Inf {b : A} {s : set A} (h : ∀ (a : A), a ∈ s → b ≤ a) : b ≤ Inf s := +le_Sup h + +local prefix `⨅`:70 := Inf +local prefix `⨆`:65 := Sup + +definition inf (a b : A) := ⨅ '{a, b} +definition sup (a b : A) := ⨆ '{a, b} + +local infix `⊓` := inf +local infix `⊔` := sup + +lemma inf_le_left (a b : A) : a ⊓ b ≤ a := +Inf_le !mem_insert + +lemma inf_le_right (a b : A) : a ⊓ b ≤ b := +Inf_le (!mem_insert_of_mem !mem_insert) + +lemma le_inf {a b c : A} : c ≤ a → c ≤ b → c ≤ a ⊓ b := +assume h₁ h₂, +le_Inf (take x, suppose x ∈ '{a, b}, + or.elim (eq_or_mem_of_mem_insert this) + (suppose x = a, begin subst x, exact h₁ end) + (suppose x ∈ '{b}, + have x = b, from !eq_of_mem_singleton this, + begin subst x, exact h₂ end)) + +lemma le_sup_left (a b : A) : a ≤ a ⊔ b := +le_Sup !mem_insert + +lemma le_sup_right (a b : A) : b ≤ a ⊔ b := +le_Sup (!mem_insert_of_mem !mem_insert) + +lemma sup_le {a b c : A} : a ≤ c → b ≤ c → a ⊔ b ≤ c := +assume h₁ h₂, +Sup_le (take x, suppose x ∈ '{a, b}, + or.elim (eq_or_mem_of_mem_insert this) + (assume H : x = a, by subst x; exact h₁) + (suppose x ∈ '{b}, + have x = b, from !eq_of_mem_singleton this, + by subst x; exact h₂)) + +end complete_lattice_Sup + +-- Every complete_lattice_Sup is a complete_lattice_Inf +definition complete_lattice_Sup_to_complete_lattice_Inf [C : complete_lattice_Sup A] : + complete_lattice_Inf A := +⦃ complete_lattice_Inf, C ⦄ + +-- Every complete_lattice_Sup is a complete_lattice +section +attribute [trans_instance] +definition complete_lattice_Sup_to_complete_lattice [C : complete_lattice_Sup A] : + complete_lattice A := +⦃ complete_lattice, C ⦄ +end + +section complete_lattice +variable [C : complete_lattice A] +include C + +variable {f : A → A} +premise (mono : nondecreasing f) + +theorem knaster_tarski : ∃ a, f a = a ∧ ∀ b, f b = b → a ≤ b := +let a := ⨅ {u | f u ≤ u} in +have h₁ : f a = a, from + have ge : f a ≤ a, from + have ∀ b, b ∈ {u | f u ≤ u} → f a ≤ b, from + take b, suppose f b ≤ b, + have a ≤ b, from Inf_le this, + have f a ≤ f b, from mono this, + le.trans `f a ≤ f b` `f b ≤ b`, + le_Inf this, + have le : a ≤ f a, from + have f (f a) ≤ f a, from !mono ge, + have f a ∈ {u | f u ≤ u}, from this, + Inf_le this, + le.antisymm ge le, +have h₂ : ∀ b, f b = b → a ≤ b, from + take b, + suppose f b = b, + have b ∈ {u | f u ≤ u}, from + show f b ≤ b, by rewrite this, + Inf_le this, +exists.intro a (and.intro h₁ h₂) + +theorem knaster_tarski_dual : ∃ a, f a = a ∧ ∀ b, f b = b → b ≤ a := +let a := ⨆ {u | u ≤ f u} in +have h₁ : f a = a, from + have le : a ≤ f a, from + have ∀ b, b ∈ {u | u ≤ f u} → b ≤ f a, from + take b, suppose b ≤ f b, + have b ≤ a, from le_Sup this, + have f b ≤ f a, from mono this, + le.trans `b ≤ f b` `f b ≤ f a`, + Sup_le this, + have ge : f a ≤ a, from + have f a ≤ f (f a), from !mono le, + have f a ∈ {u | u ≤ f u}, from this, + le_Sup this, + le.antisymm ge le, +have h₂ : ∀ b, f b = b → b ≤ a, from + take b, + suppose f b = b, + have b ≤ f b, by rewrite this, + le_Sup this, +exists.intro a (and.intro h₁ h₂) + +/- top and bot -/ + +definition bot : A := ⨅ univ +definition top : A := ⨆ univ +notation `⊥` := bot +notation `⊤` := top + +lemma bot_le (a : A) : ⊥ ≤ a := +Inf_le !mem_univ + +lemma eq_bot {a : A} : (∀ b, a ≤ b) → a = ⊥ := +assume h, +have a ≤ ⊥, from le_Inf (take b bin, h b), +le.antisymm this !bot_le + +lemma le_top (a : A) : a ≤ ⊤ := +le_Sup !mem_univ + +lemma eq_top {a : A} : (∀ b, b ≤ a) → a = ⊤ := +assume h, +have ⊤ ≤ a, from Sup_le (take b bin, h b), +le.antisymm !le_top this + +/- general facts about complete lattices -/ + +lemma Inf_singleton {a : A} : ⨅'{a} = a := +have ⨅'{a} ≤ a, from + Inf_le !mem_insert, +have a ≤ ⨅'{a}, from + le_Inf (take b, suppose b ∈ '{a}, have b = a, from eq_of_mem_singleton this, by rewrite this), +le.antisymm `⨅'{a} ≤ a` `a ≤ ⨅'{a}` + +lemma Sup_singleton {a : A} : ⨆'{a} = a := +have ⨆'{a} ≤ a, from + Sup_le (take b, suppose b ∈ '{a}, have b = a, from eq_of_mem_singleton this, by rewrite this), +have a ≤ ⨆'{a}, from + le_Sup !mem_insert, +le.antisymm `⨆'{a} ≤ a` `a ≤ ⨆'{a}` + +lemma Inf_antimono {s₁ s₂ : set A} : s₁ ⊆ s₂ → ⨅ s₂ ≤ ⨅ s₁ := +suppose s₁ ⊆ s₂, le_Inf (take a : A, suppose a ∈ s₁, Inf_le (mem_of_subset_of_mem `s₁ ⊆ s₂` `a ∈ s₁`)) + +lemma Sup_mono {s₁ s₂ : set A} : s₁ ⊆ s₂ → ⨆ s₁ ≤ ⨆ s₂ := +suppose s₁ ⊆ s₂, Sup_le (take a : A, suppose a ∈ s₁, le_Sup (mem_of_subset_of_mem `s₁ ⊆ s₂` `a ∈ s₁`)) + +lemma Inf_union (s₁ s₂ : set A) : ⨅ (s₁ ∪ s₂) = (⨅s₁) ⊓ (⨅s₂) := +have le₁ : ⨅ (s₁ ∪ s₂) ≤ (⨅s₁) ⊓ (⨅s₂), from + !le_inf + (le_Inf (take a : A, suppose a ∈ s₁, Inf_le (mem_unionl `a ∈ s₁`))) + (le_Inf (take a : A, suppose a ∈ s₂, Inf_le (mem_unionr `a ∈ s₂`))), +have le₂ : (⨅s₁) ⊓ (⨅s₂) ≤ ⨅ (s₁ ∪ s₂), from + le_Inf (take a : A, suppose a ∈ s₁ ∪ s₂, + or.elim this + (suppose a ∈ s₁, + have (⨅s₁) ⊓ (⨅s₂) ≤ ⨅s₁, from !inf_le_left, + have ⨅s₁ ≤ a, from Inf_le `a ∈ s₁`, + le.trans `(⨅s₁) ⊓ (⨅s₂) ≤ ⨅s₁` `⨅s₁ ≤ a`) + (suppose a ∈ s₂, + have (⨅s₁) ⊓ (⨅s₂) ≤ ⨅s₂, from !inf_le_right, + have ⨅s₂ ≤ a, from Inf_le `a ∈ s₂`, + le.trans `(⨅s₁) ⊓ (⨅s₂) ≤ ⨅s₂` `⨅s₂ ≤ a`)), +le.antisymm le₁ le₂ + +lemma Sup_union (s₁ s₂ : set A) : ⨆ (s₁ ∪ s₂) = (⨆s₁) ⊔ (⨆s₂) := +have le₁ : ⨆ (s₁ ∪ s₂) ≤ (⨆s₁) ⊔ (⨆s₂), from + Sup_le (take a : A, suppose a ∈ s₁ ∪ s₂, + or.elim this + (suppose a ∈ s₁, + have a ≤ ⨆s₁, from le_Sup `a ∈ s₁`, + have ⨆s₁ ≤ (⨆s₁) ⊔ (⨆s₂), from !le_sup_left, + le.trans `a ≤ ⨆s₁` `⨆s₁ ≤ (⨆s₁) ⊔ (⨆s₂)`) + (suppose a ∈ s₂, + have a ≤ ⨆s₂, from le_Sup `a ∈ s₂`, + have ⨆s₂ ≤ (⨆s₁) ⊔ (⨆s₂), from !le_sup_right, + le.trans `a ≤ ⨆s₂` `⨆s₂ ≤ (⨆s₁) ⊔ (⨆s₂)`)), +have le₂ : (⨆s₁) ⊔ (⨆s₂) ≤ ⨆ (s₁ ∪ s₂), from + !sup_le + (Sup_le (take a : A, suppose a ∈ s₁, le_Sup (mem_unionl `a ∈ s₁`))) + (Sup_le (take a : A, suppose a ∈ s₂, le_Sup (mem_unionr `a ∈ s₂`))), +le.antisymm le₁ le₂ + +lemma Inf_empty_eq_Sup_univ : ⨅ (∅ : set A) = ⨆ univ := +have le₁ : ⨅ (∅ : set A) ≤ ⨆ univ, from + le_Sup !mem_univ, +have le₂ : ⨆ univ ≤ ⨅ ∅, from + le_Inf (take a : A, suppose a ∈ ∅, absurd this !not_mem_empty), +le.antisymm le₁ le₂ + +lemma Sup_empty_eq_Inf_univ : ⨆ (∅ : set A) = ⨅ univ := +have le₁ : ⨆ (∅ : set A) ≤ ⨅ univ, from + Sup_le (take a, suppose a ∈ ∅, absurd this !not_mem_empty), +have le₂ : ⨅ univ ≤ ⨆ (∅ : set A), from + Inf_le !mem_univ, +le.antisymm le₁ le₂ + +lemma Sup_pair (a b : A) : Sup '{a, b} = sup a b := +by rewrite [insert_eq, Sup_union, *Sup_singleton] + +lemma Inf_pair (a b : A) : Inf '{a, b} = inf a b := +by rewrite [insert_eq, Inf_union, *Inf_singleton] + +end complete_lattice + +/- complete lattice instances -/ + +section +open eq.ops complete_lattice + +attribute [instance] +definition complete_lattice_fun (A B : Type) [complete_lattice B] : + complete_lattice (A → B) := +⦃ complete_lattice, lattice_fun A B, + Inf := λS x, Inf ((λf, f x) ' S), + le_Inf := take f S H x, + le_Inf (take y Hy, obtain g `g ∈ S` `g x = y`, from Hy, `g x = y` ▸ H g `g ∈ S` x), + Inf_le := take f S `f ∈ S` x, + Inf_le (exists.intro f (and.intro `f ∈ S` rfl)), + Sup := λS x, Sup ((λf, f x) ' S), + le_Sup := take f S `f ∈ S` x, + le_Sup (exists.intro f (and.intro `f ∈ S` rfl)), + Sup_le := take f S H x, + Sup_le (take y Hy, obtain g `g ∈ S` `g x = y`, from Hy, `g x = y` ▸ H g `g ∈ S` x) +⦄ + +section +local attribute classical.prop_decidable [instance] -- Prop and set are only in the classical setting a complete lattice + +attribute [instance] +definition complete_lattice_Prop : complete_lattice Prop := +⦃ complete_lattice, lattice_Prop, + Inf := λS, false ∉ S, + le_Inf := take x S H Hx Hf, + H _ Hf Hx, + Inf_le := take x S Hx Hf, + (classical.cases_on x (take x, true.intro) Hf) Hx, + Sup := λS, true ∈ S, + le_Sup := take x S Hx H, + iff_subst (iff.intro (take H, true.intro) (take H', H)) Hx, + Sup_le := take x S H Ht, + H _ Ht true.intro +⦄ + +lemma sInter_eq_Inf_fun {A : Type} (S : set (set A)) : ⋂₀ S = @Inf (A → Prop) _ S := +funext (take x, + calc + (⋂₀ S) x = ∀₀ P ∈ S, P x : rfl + ... = ¬ (∃₀ P ∈ S, P x = false) : + begin + rewrite not_bounded_exists, + apply bounded_forall_congr, + intros, + rewrite eq_false, + rewrite not_not_iff + end + ... = @Inf (A → Prop) _ S x : rfl) + +lemma sUnion_eq_Sup_fun {A : Type} (S : set (set A)) : ⋃₀ S = @Sup (A → Prop) _ S := +funext (take x, + calc + (⋃₀ S) x = ∃₀ P ∈ S, P x : rfl + ... = (∃₀ P ∈ S, P x = true) : + begin + apply bounded_exists_congr, + intros, + rewrite eq_true + end + ... = @Sup (A → Prop) _ S x : rfl) + +attribute [instance] +definition complete_lattice_set (A : Type) : complete_lattice (set A) := +⦃ complete_lattice, + le := subset, + le_refl := @le_refl (A → Prop) _, + le_trans := @le_trans (A → Prop) _, + le_antisymm := @le_antisymm (A → Prop) _, + inf := inter, + sup := union, + inf_le_left := @inf_le_left (A → Prop) _, + inf_le_right := @inf_le_right (A → Prop) _, + le_inf := @le_inf (A → Prop) _, + le_sup_left := @le_sup_left (A → Prop) _, + le_sup_right := @le_sup_right (A → Prop) _, + sup_le := @sup_le (A → Prop) _, + Inf := sInter, + Sup := sUnion, + le_Inf := begin intros X S H, rewrite sInter_eq_Inf_fun, apply (@le_Inf (A → Prop) _), exact H end, + Inf_le := begin intros X S H, rewrite sInter_eq_Inf_fun, apply (@Inf_le (A → Prop) _), exact H end, + le_Sup := begin intros X S H, rewrite sUnion_eq_Sup_fun, apply (@le_Sup (A → Prop) _), exact H end, + Sup_le := begin intros X S H, rewrite sUnion_eq_Sup_fun, apply (@Sup_le (A → Prop) _), exact H end +⦄ + +end + +end diff --git a/old_library/algebra/field.lean b/old_library/algebra/field.lean new file mode 100644 index 0000000000..3cf081a682 --- /dev/null +++ b/old_library/algebra/field.lean @@ -0,0 +1,622 @@ +/- +Copyright (c) 2014 Robert Lewis. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Robert Lewis + +Structures with multiplicative and additive components, including division rings and fields. +The development is modeled after Isabelle's library. +-/ +import algebra.ring +open eq + +variable {A : Type} + +structure division_ring [class] (A : Type) extends ring A, has_inv A, zero_ne_one_class A := + (mul_inv_cancel : ∀{a}, a ≠ zero → mul a (inv a) = one) + (inv_mul_cancel : ∀{a}, a ≠ zero → mul (inv a) a = one) + +section division_ring + variables [s : division_ring A] {a b c : A} + include s + + protected definition algebra.div (a b : A) : A := a * b⁻¹ + + attribute [instance] + definition division_ring_has_div : has_div A := + has_div.mk algebra.div + + attribute [simp] + lemma division.def (a b : A) : a / b = a * b⁻¹ := + rfl + + attribute [simp] + theorem mul_inv_cancel (H : a ≠ 0) : a * a⁻¹ = 1 := + division_ring.mul_inv_cancel H + + attribute [simp] + theorem inv_mul_cancel (H : a ≠ 0) : a⁻¹ * a = 1 := + division_ring.inv_mul_cancel H + + theorem inv_eq_one_div (a : A) : a⁻¹ = 1 / a := eq.symm $ one_mul (a⁻¹) + + theorem div_eq_mul_one_div (a b : A) : a / b = a * (1 / b) := + sorry -- by simp + + attribute [simp] + theorem mul_one_div_cancel (H : a ≠ 0) : a * (1 / a) = 1 := + sorry -- by simp + + attribute [simp] + theorem one_div_mul_cancel (H : a ≠ 0) : (1 / a) * a = 1 := + sorry -- by simp + + attribute [simp] + theorem div_self (H : a ≠ 0) : a / a = 1 := + sorry -- by simp + + attribute [simp] + theorem one_div_one : 1 / 1 = (1:A) := + div_self (ne.symm zero_ne_one) + + theorem mul_div_assoc (a b : A) : (a * b) / c = a * (b / c) := + sorry -- by simp + + theorem one_div_ne_zero (H : a ≠ 0) : 1 / a ≠ 0 := + sorry + /- + assume H2 : 1 / a = 0, + have C1 : 0 = (1:A), from symm (by rewrite [-(mul_one_div_cancel H), H2, mul_zero]), + absurd C1 zero_ne_one + -/ + + attribute [simp] + theorem one_inv_eq : 1⁻¹ = (1:A) := + sorry -- by rewrite [-mul_one, inv_mul_cancel (ne.symm (@zero_ne_one A _))] + + attribute [simp] + theorem div_one (a : A) : a / 1 = a := + sorry -- by simp + + attribute [simp] + theorem zero_div (a : A) : 0 / a = 0 := + sorry -- by simp + + -- note: integral domain has a "mul_ne_zero". A commutative division ring is an integral + -- domain, but let's not define that class for now. + theorem division_ring.mul_ne_zero (Ha : a ≠ 0) (Hb : b ≠ 0) : a * b ≠ 0 := + sorry + /- + assume H : a * b = 0, + have C1 : a = 0, by rewrite [-mul_one, -(mul_one_div_cancel Hb), -mul.assoc, H, zero_mul], + absurd C1 Ha + -/ + + theorem mul_ne_zero_comm (H : a * b ≠ 0) : b * a ≠ 0 := + have H2 : a ≠ 0 ∧ b ≠ 0, from ne_zero_and_ne_zero_of_mul_ne_zero H, + division_ring.mul_ne_zero (and.right H2) (and.left H2) + + theorem eq_one_div_of_mul_eq_one (H : a * b = 1) : b = 1 / a := + sorry + /- + have a ≠ 0, from + suppose a = 0, + have 0 = (1:A), by inst_simp, + absurd this zero_ne_one, + have b = (1 / a) * a * b, by inst_simp, + show b = 1 / a, by inst_simp + -/ + + theorem eq_one_div_of_mul_eq_one_left (H : b * a = 1) : b = 1 / a := + sorry + /- + have a ≠ 0, from + suppose a = 0, + have 0 = (1:A), by inst_simp, + absurd this zero_ne_one, + by inst_simp + -/ + + theorem division_ring.one_div_mul_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) : + (1 / a) * (1 / b) = 1 / (b * a) := + sorry + /- + have (b * a) * ((1 / a) * (1 / b)) = 1, by inst_simp, + eq_one_div_of_mul_eq_one this + -/ + + theorem one_div_neg_one_eq_neg_one : (1:A) / (-1) = -1 := + sorry + /- + have (-1) * (-1) = (1:A), by inst_simp, + symm (eq_one_div_of_mul_eq_one this) + -/ + + theorem division_ring.one_div_neg_eq_neg_one_div (H : a ≠ 0) : 1 / (- a) = - (1 / a) := + have -1 ≠ (0:A), from + (suppose -1 = 0, absurd (symm (calc + 1 = -(-1) : eq.symm $ neg_neg 1 + ... = -0 : sorry -- by rewrite this + ... = (0:A) : neg_zero)) zero_ne_one), + calc + 1 / (- a) = 1 / ((-1) * a) : sorry -- by rewrite neg_eq_neg_one_mul + ... = (1 / a) * (1 / (- 1)) : sorry -- by rewrite (division_ring.one_div_mul_one_div H this) + ... = (1 / a) * (-1) : sorry -- by rewrite one_div_neg_one_eq_neg_one + ... = - (1 / a) : sorry -- by rewrite mul_neg_one_eq_neg + + theorem div_neg_eq_neg_div (b : A) (Ha : a ≠ 0) : b / (- a) = - (b / a) := + calc + b / (- a) = b * (1 / (- a)) : sorry -- by rewrite -inv_eq_one_div + ... = b * -(1 / a) : sorry -- by rewrite (division_ring.one_div_neg_eq_neg_one_div Ha) + ... = -(b * (1 / a)) : sorry -- by rewrite neg_mul_eq_mul_neg + ... = - (b * a⁻¹) : sorry -- by rewrite inv_eq_one_div + + theorem neg_div (a b : A) : (-b) / a = - (b / a) := + sorry -- by rewrite [neg_eq_neg_one_mul, mul_div_assoc, -neg_eq_neg_one_mul] + + theorem division_ring.neg_div_neg_eq (a : A) {b : A} (Hb : b ≠ 0) : (-a) / (-b) = a / b := + sorry -- by rewrite [(div_neg_eq_neg_div _ Hb), neg_div, neg_neg] + + theorem division_ring.one_div_one_div (H : a ≠ 0) : 1 / (1 / a) = a := + symm (eq_one_div_of_mul_eq_one_left (mul_one_div_cancel H)) + + theorem division_ring.eq_of_one_div_eq_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) (H : 1 / a = 1 / b) : + a = b := + sorry -- by rewrite [-(division_ring.one_div_one_div Ha), H, (division_ring.one_div_one_div Hb)] + + attribute [simp] + theorem mul_inv_eq (Ha : a ≠ 0) (Hb : b ≠ 0) : (b * a)⁻¹ = a⁻¹ * b⁻¹ := + sorry + /- + eq.symm (calc + a⁻¹ * b⁻¹ = (1 / a) * (1 / b) : by inst_simp + ... = (1 / (b * a)) : division_ring.one_div_mul_one_div Ha Hb + ... = (b * a)⁻¹ : by simp) + -/ + + theorem mul_div_cancel (a : A) {b : A} (Hb : b ≠ 0) : a * b / b = a := + sorry -- by simp + + theorem div_mul_cancel (a : A) {b : A} (Hb : b ≠ 0) : a / b * b = a := + sorry -- by simp + + theorem div_add_div_same (a b c : A) : a / c + b / c = (a + b) / c := eq.symm $ right_distrib a b (c⁻¹) + + theorem div_sub_div_same (a b c : A) : (a / c) - (b / c) = (a - b) / c := + sorry -- by rewrite [sub_eq_add_neg, -neg_div, div_add_div_same] + + theorem one_div_mul_add_mul_one_div_eq_one_div_add_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) : + (1 / a) * (a + b) * (1 / b) = 1 / a + 1 / b := + sorry + /- + by rewrite [(left_distrib (1 / a)), (one_div_mul_cancel Ha), right_distrib, one_mul, + mul.assoc, (mul_one_div_cancel Hb), mul_one, add.comm] + -/ + theorem one_div_mul_sub_mul_one_div_eq_one_div_add_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) : + (1 / a) * (b - a) * (1 / b) = 1 / a - 1 / b := + sorry + /- + by rewrite [(mul_sub_left_distrib (1 / a)), (one_div_mul_cancel Ha), mul_sub_right_distrib, + one_mul, mul.assoc, (mul_one_div_cancel Hb), mul_one] + -/ + theorem div_eq_one_iff_eq (a : A) {b : A} (Hb : b ≠ 0) : a / b = 1 ↔ a = b := + sorry + /- + iff.intro + (suppose a / b = 1, calc + a = a / b * b : by inst_simp + ... = 1 * b : by rewrite this + ... = b : by simp) + (suppose a = b, by simp) + -/ + + theorem eq_of_div_eq_one (a : A) {b : A} (Hb : b ≠ 0) : a / b = 1 → a = b := + iff.mp $ div_eq_one_iff_eq a Hb + + theorem eq_div_iff_mul_eq (a : A) {b : A} (Hc : c ≠ 0) : a = b / c ↔ a * c = b := + sorry + /- + iff.intro + (suppose a = b / c, by rewrite [this, (!div_mul_cancel Hc)]) + (suppose a * c = b, by rewrite [-(!mul_div_cancel Hc), this]) + -/ + + theorem eq_div_of_mul_eq (a b : A) {c : A} (Hc : c ≠ 0) : a * c = b → a = b / c := + iff.mpr $ eq_div_iff_mul_eq a Hc + + theorem mul_eq_of_eq_div (a b: A) {c : A} (Hc : c ≠ 0) : a = b / c → a * c = b := + iff.mp $ eq_div_iff_mul_eq a Hc + + theorem add_div_eq_mul_add_div (a b : A) {c : A} (Hc : c ≠ 0) : a + b / c = (a * c + b) / c := + sorry + /- + have (a + b / c) * c = a * c + b, by rewrite [right_distrib, (!div_mul_cancel Hc)], + (iff.elim_right (!eq_div_iff_mul_eq Hc)) this + -/ + + theorem mul_mul_div (a : A) {c : A} (Hc : c ≠ 0) : a = a * c * (1 / c) := + sorry -- by simp + + -- There are many similar rules to these last two in the Isabelle library + -- that haven't been ported yet. Do as necessary. +end division_ring + +structure field [class] (A : Type) extends division_ring A, comm_ring A + +section field + variables [s : field A] {a b c d: A} + include s + + theorem field.one_div_mul_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) : (1 / a) * (1 / b) = 1 / (a * b) := + sorry -- 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 := + sorry + /- + have a ≠ 0, from and.left (ne_zero_and_ne_zero_of_mul_ne_zero H), + symm (calc + 1 / b = a * ((1 / a) * (1 / b)) : by inst_simp + ... = a * (1 / (b * a)) : by rewrite (division_ring.one_div_mul_one_div this Hb) + ... = a * (a * b)⁻¹ : by inst_simp) + -/ + + theorem field.div_mul_left (Ha : a ≠ 0) (H : a * b ≠ 0) : b / (a * b) = 1 / a := + let H1 : b * a ≠ 0 := mul_ne_zero_comm H in + sorry -- by rewrite [mul.comm a, (field.div_mul_right Ha H1)] + + theorem mul_div_cancel_left (Ha : a ≠ 0) : a * b / a = b := + sorry -- by rewrite [mul.comm a, (!mul_div_cancel Ha)] + + theorem mul_div_cancel' (Hb : b ≠ 0) : b * (a / b) = a := + sorry -- by rewrite [mul.comm, (!div_mul_cancel Hb)] + + theorem one_div_add_one_div (Ha : a ≠ 0) (Hb : b ≠ 0) : 1 / a + 1 / b = (a + b) / (a * b) := + have a * b ≠ 0, from (division_ring.mul_ne_zero Ha Hb), + sorry -- by rewrite [add.comm, -(field.div_mul_left Ha this), -(field.div_mul_right Hb this), *division.def, -right_distrib] + + theorem field.div_mul_div (a : A) {b : A} (c : A) {d : A} (Hb : b ≠ 0) (Hd : d ≠ 0) : + (a / b) * (c / d) = (a * c) / (b * d) := + sorry -- by inst_simp + + theorem mul_div_mul_left (a : A) {b c : A} (Hb : b ≠ 0) (Hc : c ≠ 0) : + (c * a) / (c * b) = a / b := + sorry -- by rewrite [-(!field.div_mul_div Hc Hb), (div_self Hc), one_mul] + + theorem mul_div_mul_right (a : A) {b c : A} (Hb : b ≠ 0) (Hc : c ≠ 0) : + (a * c) / (b * c) = a / b := + sorry -- by rewrite [(mul.comm a), (mul.comm b), (!mul_div_mul_left Hb Hc)] + + theorem div_mul_eq_mul_div (a b c : A) : (b / c) * a = (b * a) / c := + sorry -- by rewrite [*division.def, mul.assoc, (mul.comm c⁻¹), -mul.assoc] + + theorem field.div_mul_eq_mul_div_comm (a b : A) {c : A} (Hc : c ≠ 0) : + (b / c) * a = b * (a / c) := + sorry + /- + by rewrite [(div_mul_eq_mul_div), -(one_mul c), -(!field.div_mul_div (ne.symm zero_ne_one) Hc), + div_one, one_mul] + -/ + + theorem div_add_div (a : A) {b : A} (c : A) {d : A} (Hb : b ≠ 0) (Hd : d ≠ 0) : + (a / b) + (c / d) = ((a * d) + (b * c)) / (b * d) := + sorry + -- by rewrite [-(!mul_div_mul_right Hb Hd), -(!mul_div_mul_left Hd Hb), div_add_div_same] + + theorem div_sub_div (a : A) {b : A} (c : A) {d : A} (Hb : b ≠ 0) (Hd : d ≠ 0) : + (a / b) - (c / d) = ((a * d) - (b * c)) / (b * d) := + sorry + /- + by rewrite [*sub_eq_add_neg, neg_eq_neg_one_mul, -mul_div_assoc, (!div_add_div Hb Hd), + -mul.assoc, (mul.comm b), mul.assoc, -neg_eq_neg_one_mul] + -/ + + theorem mul_eq_mul_of_div_eq_div (a : A) {b : A} (c : A) {d : A} (Hb : b ≠ 0) + (Hd : d ≠ 0) (H : a / b = c / d) : a * d = c * b := + sorry + /- + by rewrite [-mul_one, mul.assoc, (mul.comm d), -mul.assoc, -(div_self Hb), + -(!field.div_mul_eq_mul_div_comm Hb), H, (div_mul_eq_mul_div), (!div_mul_cancel Hd)] + -/ + + theorem field.one_div_div (Ha : a ≠ 0) (Hb : b ≠ 0) : 1 / (a / b) = b / a := + sorry + /- + have (a / b) * (b / a) = 1, from calc + (a / b) * (b / a) = (a * b) / (b * a) : !field.div_mul_div Hb Ha + ... = (a * b) / (a * b) : by rewrite mul.comm + ... = 1 : div_self (division_ring.mul_ne_zero Ha Hb), + symm (eq_one_div_of_mul_eq_one this) + -/ + + theorem field.div_div_eq_mul_div (a : A) {b c : A} (Hb : b ≠ 0) (Hc : c ≠ 0) : + a / (b / c) = (a * c) / b := + sorry -- by rewrite [div_eq_mul_one_div, (field.one_div_div Hb Hc), -mul_div_assoc] + + theorem field.div_div_eq_div_mul (a : A) {b c : A} (Hb : b ≠ 0) (Hc : c ≠ 0) : + (a / b) / c = a / (b * c) := + sorry -- by rewrite [div_eq_mul_one_div, (!field.div_mul_div Hb Hc), mul_one] + + theorem field.div_div_div_div_eq (a : A) {b c d : A} (Hb : b ≠ 0) (Hc : c ≠ 0) (Hd : d ≠ 0) : + (a / b) / (c / d) = (a * d) / (b * c) := + sorry + /- + by rewrite [(!field.div_div_eq_mul_div Hc Hd), (div_mul_eq_mul_div), + (!field.div_div_eq_div_mul Hb Hc)] + -/ + theorem field.div_mul_eq_div_mul_one_div (a : A) {b c : A} (Hb : b ≠ 0) (Hc : c ≠ 0) : + a / (b * c) = (a / b) * (1 / c) := + sorry -- by rewrite [-!field.div_div_eq_div_mul Hb Hc, -div_eq_mul_one_div] + + theorem eq_of_mul_eq_mul_of_nonzero_left {a b c : A} (H : a ≠ 0) (H2 : a * b = a * c) : b = c := + sorry -- by rewrite [-one_mul b, -div_self H, div_mul_eq_mul_div, H2, mul_div_cancel_left H] + + theorem eq_of_mul_eq_mul_of_nonzero_right {a b c : A} (H : c ≠ 0) (H2 : a * c = b * c) : a = b := + sorry -- by rewrite [-mul_one a, -div_self H, -mul_div_assoc, H2, mul_div_cancel _ H] + +end field + +structure discrete_field [class] (A : Type) extends field A := + (has_decidable_eq : decidable_eq A) + (inv_zero : inv zero = zero) + +attribute discrete_field.has_decidable_eq [instance] + +section discrete_field + variable [s : discrete_field A] + include s + variables {a b c d : A} + + -- many of the theorems in discrete_field are the same as theorems in field or division ring, + -- but with fewer hypotheses since 0⁻¹ = 0 and equality is decidable. + + theorem discrete_field.eq_zero_or_eq_zero_of_mul_eq_zero + (x y : A) (H : x * y = 0) : x = 0 ∨ y = 0 := + sorry + /- + decidable.by_cases + (suppose x = 0, or.inl this) + (suppose x ≠ 0, + or.inr (by rewrite [-one_mul, -(inv_mul_cancel this), mul.assoc, H, mul_zero])) + -/ + + attribute [instance] + definition discrete_field.to_integral_domain : + 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⦄ + + theorem inv_zero : 0⁻¹ = (0:A) := discrete_field.inv_zero A + + theorem one_div_zero : 1 / 0 = (0:A) := + sorry + /- + calc + 1 / 0 = 1 * 0⁻¹ : rfl + ... = 1 * 0 : by rewrite inv_zero + ... = 0 : by rewrite mul_zero + -/ + + theorem div_zero (a : A) : a / 0 = 0 := + sorry -- by rewrite [div_eq_mul_one_div, one_div_zero, mul_zero] + + theorem ne_zero_of_one_div_ne_zero (H : 1 / a ≠ 0) : a ≠ 0 := + assume Ha : a = 0, absurd (symm Ha ▸ one_div_zero) H + + theorem eq_zero_of_one_div_eq_zero (H : 1 / a = 0) : a = 0 := + decidable.by_cases + (assume Ha, Ha) + (assume Ha, false.elim ((one_div_ne_zero Ha) H)) + + variables (a b) + theorem one_div_mul_one_div' : (1 / a) * (1 / b) = 1 / (b * a) := + sorry + /- + decidable.by_cases + (suppose a = 0, + by rewrite [this, div_zero, zero_mul, -(@div_zero A s 1), mul_zero b]) + (assume Ha : a ≠ 0, + decidable.by_cases + (suppose b = 0, + by rewrite [this, div_zero, mul_zero, -(@div_zero A s 1), zero_mul a]) + (suppose b ≠ 0, division_ring.one_div_mul_one_div Ha this)) + -/ + + theorem one_div_neg_eq_neg_one_div : 1 / (- a) = - (1 / a) := + sorry + /- + decidable.by_cases + (suppose a = 0, by rewrite [this, neg_zero, 2 div_zero, neg_zero]) + (suppose a ≠ 0, division_ring.one_div_neg_eq_neg_one_div this) + -/ + + theorem neg_div_neg_eq : (-a) / (-b) = a / b := + sorry + /- + decidable.by_cases + (assume Hb : b = 0, by rewrite [Hb, neg_zero, 2 div_zero]) + (assume Hb : b ≠ 0, !division_ring.neg_div_neg_eq Hb) + -/ + + theorem one_div_one_div : 1 / (1 / a) = a := + sorry + /- + decidable.by_cases + (assume Ha : a = 0, by rewrite [Ha, 2 div_zero]) + (assume Ha : a ≠ 0, division_ring.one_div_one_div Ha) + -/ + + variables {a b} + theorem eq_of_one_div_eq_one_div (H : 1 / a = 1 / b) : a = b := + sorry + /- + decidable.by_cases + (assume Ha : a = 0, + have Hb : b = 0, from eq_zero_of_one_div_eq_zero (by rewrite [-H, Ha, div_zero]), + Hb⁻¹ ▸ Ha) + (assume Ha : a ≠ 0, + have Hb : b ≠ 0, from ne_zero_of_one_div_ne_zero (H ▸ (one_div_ne_zero Ha)), + division_ring.eq_of_one_div_eq_one_div Ha Hb H) + -/ + + variables (a b) + theorem mul_inv' : (b * a)⁻¹ = a⁻¹ * b⁻¹ := + sorry + /- + decidable.by_cases + (assume Ha : a = 0, by rewrite [Ha, mul_zero, 2 inv_zero, zero_mul]) + (assume Ha : a ≠ 0, + decidable.by_cases + (assume Hb : b = 0, by rewrite [Hb, zero_mul, 2 inv_zero, mul_zero]) + (assume Hb : b ≠ 0, mul_inv_eq Ha Hb)) + -/ + +-- the following are specifically for fields + theorem one_div_mul_one_div : (1 / a) * (1 / b) = 1 / (a * b) := + sorry -- by rewrite [one_div_mul_one_div', mul.comm b] + + variable {a} + theorem div_mul_right (Ha : a ≠ 0) : a / (a * b) = 1 / b := + sorry + /- + decidable.by_cases + (assume Hb : b = 0, by rewrite [Hb, mul_zero, 2 div_zero]) + (assume Hb : b ≠ 0, field.div_mul_right Hb (mul_ne_zero Ha Hb)) + -/ + + variables (a) {b} + theorem div_mul_left (Hb : b ≠ 0) : b / (a * b) = 1 / a := + sorry -- by rewrite [mul.comm a, div_mul_right _ Hb] + + variables (a b c) + theorem div_mul_div : (a / b) * (c / d) = (a * c) / (b * d) := + sorry + /- + decidable.by_cases + (assume Hb : b = 0, by rewrite [Hb, div_zero, zero_mul, -(@div_zero A s (a * c)), zero_mul]) + (assume Hb : b ≠ 0, + decidable.by_cases + (assume Hd : d = 0, by rewrite [Hd, div_zero, mul_zero, -(@div_zero A s (a * c)), + mul_zero]) + (assume Hd : d ≠ 0, !field.div_mul_div Hb Hd)) + -/ + + variable {c} + theorem mul_div_mul_left' (Hc : c ≠ 0) : (c * a) / (c * b) = a / b := + sorry + /- + decidable.by_cases + (assume Hb : b = 0, by rewrite [Hb, mul_zero, 2 div_zero]) + (assume Hb : b ≠ 0, !mul_div_mul_left Hb Hc) + -/ + + theorem mul_div_mul_right' (Hc : c ≠ 0) : (a * c) / (b * c) = a / b := + sorry -- by rewrite [(mul.comm a), (mul.comm b), (!mul_div_mul_left' Hc)] + + variables (a b c d) + theorem div_mul_eq_mul_div_comm : (b / c) * a = b * (a / c) := + sorry + /- + decidable.by_cases + (assume Hc : c = 0, by rewrite [Hc, div_zero, zero_mul, -(mul_zero b), -(@div_zero A s a)]) + (assume Hc : c ≠ 0, !field.div_mul_eq_mul_div_comm Hc) + -/ + + theorem one_div_div : 1 / (a / b) = b / a := + sorry + /- + decidable.by_cases + (assume Ha : a = 0, by rewrite [Ha, zero_div, 2 div_zero]) + (assume Ha : a ≠ 0, + decidable.by_cases + (assume Hb : b = 0, by rewrite [Hb, 2 div_zero, zero_div]) + (assume Hb : b ≠ 0, field.one_div_div Ha Hb)) + -/ + + theorem div_div_eq_mul_div : a / (b / c) = (a * c) / b := + sorry -- by rewrite [div_eq_mul_one_div, one_div_div, -mul_div_assoc] + + theorem div_div_eq_div_mul : (a / b) / c = a / (b * c) := + sorry -- by rewrite [div_eq_mul_one_div, div_mul_div, mul_one] + + theorem div_div_div_div_eq : (a / b) / (c / d) = (a * d) / (b * c) := + sorry -- by rewrite [div_div_eq_mul_div, div_mul_eq_mul_div, div_div_eq_div_mul] + + variable {a} + theorem div_helper (H : a ≠ 0) : (1 / (a * b)) * a = 1 / b := + sorry -- by rewrite [div_mul_eq_mul_div, one_mul, !div_mul_right H] + + variable (a) + theorem div_mul_eq_div_mul_one_div : a / (b * c) = (a / b) * (1 / c) := + sorry -- by rewrite [-div_div_eq_div_mul, -div_eq_mul_one_div] + +end discrete_field + +namespace norm_num + +theorem div_add_helper [s : field A] (n d b c val : A) (Hd : d ≠ 0) (H : n + b * d = val) + (H2 : c * d = val) : n / d + b = c := +sorry +/- + begin + apply eq_of_mul_eq_mul_of_nonzero_right Hd, + rewrite [H2, -H, right_distrib, div_mul_cancel _ Hd] + end +-/ + +theorem add_div_helper [s : field A] (n d b c val : A) (Hd : d ≠ 0) (H : d * b + n = val) + (H2 : d * c = val) : b + n / d = c := +sorry +/- + begin + apply eq_of_mul_eq_mul_of_nonzero_left Hd, + rewrite [H2, -H, left_distrib, mul_div_cancel' Hd] + end +-/ +theorem div_mul_helper [s : field A] (n d c v : A) (Hd : d ≠ 0) (H : (n * c) / d = v) : + (n / d) * c = v := +sorry -- by rewrite [-H, field.div_mul_eq_mul_div_comm _ _ Hd, mul_div_assoc] + +theorem mul_div_helper [s : field A] (a n d v : A) (Hd : d ≠ 0) (H : (a * n) / d = v) : + a * (n / d) = v := +sorry -- by rewrite [-H, mul_div_assoc] + +theorem nonzero_of_div_helper [s : field A] (a b : A) (Ha : a ≠ 0) (Hb : b ≠ 0) : a / b ≠ 0 := +sorry +/- + begin + intro Hab, + have Habb : (a / b) * b = 0, by rewrite [Hab, zero_mul], + rewrite [div_mul_cancel _ Hb at Habb], + exact Ha Habb + end +-/ + +theorem div_helper [s : field A] (n d v : A) (Hd : d ≠ 0) (H : v * d = n) : n / d = v := +sorry +/- + begin + apply eq_of_mul_eq_mul_of_nonzero_right Hd, + rewrite (div_mul_cancel _ Hd), + exact eq.symm H + end +-/ + +theorem div_eq_div_helper [s : field A] (a b c d v : A) (H1 : a * d = v) (H2 : c * b = v) + (Hb : b ≠ 0) (Hd : d ≠ 0) : a / b = c / d := +sorry +/- + begin + apply eq_div_of_mul_eq, + exact Hd, + rewrite div_mul_eq_mul_div, + apply eq.symm, + apply eq_div_of_mul_eq, + exact Hb, + rewrite [H1, H2] + end +-/ + +theorem subst_into_div [s : has_div A] (a₁ b₁ a₂ b₂ v : A) (H : a₁ / b₁ = v) (H1 : a₂ = a₁) + (H2 : b₂ = b₁) : a₂ / b₂ = v := +sorry -- by rewrite [H1, H2, H] + +end norm_num diff --git a/old_library/algebra/galois_connection.lean b/old_library/algebra/galois_connection.lean new file mode 100644 index 0000000000..655031dd3e --- /dev/null +++ b/old_library/algebra/galois_connection.lean @@ -0,0 +1,217 @@ +/- +Copyright (c) 2016 Johannes Hölzl. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Johannes Hölzl + +Galois connections - order theoretic adjoints. +-/ +import standard +local attribute classical.prop_decidable [instance] eq.ops algebra set function complete_lattice + +/- Move to set? -/ +definition kern_image {X Y : Type} (f : X → Y) (S : set X) : set Y := {y | ∀x, f x = y → x ∈ S } + +/- Order theoretic definitions -/ + +/- TODO: move to order? -/ +section order +variables {A B : Type} {S : set A} {a a' : A} {b b' : B} {f : A → B} [weak_order A] [weak_order B] + +definition increasing (f : A → A) := ∀⦃a⦄, a ≤ f a +definition decreasing (f : A → A) := ∀⦃a⦄, f a ≤ a + +definition upper_bounds (S : set A) : set A := { x | ∀₀ s ∈ S, s ≤ x } +definition lower_bounds (S : set A) : set A := { x | ∀₀ s ∈ S, x ≤ s } +definition is_least (S : set A) (a : A) := a ∈ S ∧ a ∈ lower_bounds S +definition is_greatest (S : set A) (a : A) := a ∈ S ∧ a ∈ upper_bounds S + +definition monotone (f : A → B) := ∀⦃a b⦄, a ≤ b → f a ≤ f b + +lemma eq_of_is_least_of_is_least (Ha : is_least S a) (Hb : is_least S a') : a = a' := +le.antisymm + begin apply (and.elim_right Ha), apply (and.elim_left Hb) end + begin apply (and.elim_right Hb), apply (and.elim_left Ha) end + +lemma is_least_iff_eq_of_is_least (Ha : is_least S a) : is_least S a' ↔ a = a' := +iff.intro (eq_of_is_least_of_is_least Ha) begin intro H, cases H, apply Ha end + +lemma eq_of_is_greatest_of_is_greatest (Ha : is_greatest S a) (Hb : is_greatest S a') : a = a' := +le.antisymm + begin apply (and.elim_right Hb), apply (and.elim_left Ha) end + begin apply (and.elim_right Ha), apply (and.elim_left Hb) end + +lemma is_greatest_iff_eq_of_is_greatest (Ha : is_greatest S a) : is_greatest S a' ↔ a = a' := +iff.intro (eq_of_is_greatest_of_is_greatest Ha) begin intro H, cases H, apply Ha end + +definition is_lub (S : set A) := is_least (upper_bounds S) +definition is_glb (S : set A) := is_greatest (lower_bounds S) + +lemma eq_of_is_lub_of_is_lub : is_lub S a → is_lub S a' → a = a' := +!eq_of_is_least_of_is_least + +lemma is_lub_iff_eq_of_is_lub : is_lub S a → (is_lub S a' ↔ a = a') := +!is_least_iff_eq_of_is_least + +lemma eq_of_is_glb_of_is_glb : is_glb S a → is_glb S a' → a = a' := +!eq_of_is_greatest_of_is_greatest + +lemma is_glb_iff_eq_of_is_glb : is_glb S a → (is_glb S a' ↔ a = a') := +!is_greatest_iff_eq_of_is_greatest + +lemma mem_upper_bounds_image (Hf : monotone f) (Ha : a ∈ upper_bounds S) : f a ∈ upper_bounds (f ' S) := +bounded_forall_image_of_bounded_forall (take x H, Hf (Ha `x ∈ S`)) + +lemma mem_lower_bounds_image (Hf : monotone f) (Ha : a ∈ lower_bounds S) : f a ∈ lower_bounds (f ' S) := +bounded_forall_image_of_bounded_forall (take x H, Hf (Ha `x ∈ S`)) + +end order + +definition galois_connection {A B : Type} [weak_order A] [weak_order B] (l : A → B) (u : B → A) := + ∀{a b}, l a ≤ b ↔ a ≤ u b + +namespace galois_connection + +section +parameters {A B : Type} [weak_order A] [weak_order B] (l : A → B) (u : B → A) + +lemma monotone_intro (Mu : monotone u) (Ml : monotone l) + (Iul : increasing (u ∘ l)) (Dlu : decreasing (l ∘ u)) : galois_connection l u := +begin + intros a b, + apply iff.intro, + { intro H, apply le.trans, apply Iul, apply Mu, assumption }, + { intro H, apply le.trans, apply Ml, assumption, apply Dlu } +end + +parameter (gc : galois_connection l u) +include gc + +lemma l_le {a : A} {b : B} : a ≤ u b → l a ≤ b := +and.elim_right !gc + +lemma le_u {a : A} {b : B} : l a ≤ b → a ≤ u b := +and.elim_left !gc + +lemma increasing_u_l : increasing (u ∘ l) := +take a, le_u !le.refl + +lemma decreasing_l_u : decreasing (l ∘ u) := +take a, l_le !le.refl + +lemma monotone_u : monotone u := +take a b H, le_u (le.trans !decreasing_l_u H) + +lemma monotone_l : monotone l := +take a b H, l_le (le.trans H !increasing_u_l) + +lemma u_l_u_eq_u : u ∘ l ∘ u = u := +funext (take x, le.antisymm (monotone_u !decreasing_l_u) !increasing_u_l) + +lemma l_u_l_eq_l : l ∘ u ∘ l = l := +funext (take x, le.antisymm !decreasing_l_u (monotone_l !increasing_u_l)) + +lemma u_mem_upper_bounds {S : set A} {b : B} (H : b ∈ upper_bounds (l ' S)) : u b ∈ upper_bounds S := +take c, suppose c ∈ S, le_u (H (!mem_image_of_mem `c ∈ S`)) + +lemma l_mem_lower_bounds {S : set B} {a : A} (H : a ∈ lower_bounds (u ' S)) : l a ∈ lower_bounds S := +take c, suppose c ∈ S, l_le (H (!mem_image_of_mem `c ∈ S`)) + +lemma is_lub_l_image {S : set A} {a : A} (H : is_lub S a) : is_lub (l ' S) (l a) := +and.intro + (mem_upper_bounds_image monotone_l (and.elim_left `is_lub S a`)) + (take b Hb, l_le (and.elim_right `is_lub S a` _ (u_mem_upper_bounds Hb))) + +lemma is_glb_u_image {S : set B} {b : B} (H : is_glb S b) : is_glb (u ' S) (u b) := +and.intro + (mem_lower_bounds_image monotone_u (and.elim_left `is_glb S b`)) + (take a Ha, le_u (and.elim_right `is_glb S b` _ (l_mem_lower_bounds Ha))) + +lemma is_glb_l {a : A} : is_glb { b | a ≤ u b } (l a) := +begin + apply and.intro, + { intro b, apply l_le }, + { intro b H, apply H, apply increasing_u_l } +end + +lemma is_lub_u {b : B} : is_lub { a | l a ≤ b } (u b) := +begin + apply and.intro, + { intro a, apply le_u }, + { intro a H, apply H, apply decreasing_l_u } +end + +end + +/- Constructing Galois connections -/ + +protected lemma id {A : Type} [weak_order A] : @galois_connection A A _ _ id id := +take a b, iff.intro (λx, x) (λx, x) + +protected lemma dual {A B : Type} [woA : weak_order A] [woB : weak_order B] + (l : A → B) (u : B → A) (gc : galois_connection l u) : + @galois_connection B A (weak_order_dual woB) (weak_order_dual woA) u l := +take a b, +begin + apply iff.symm, + rewrite le_dual_eq_le, + rewrite le_dual_eq_le, + exact gc, +end + +protected lemma compose {A B C : Type} [weak_order A] [weak_order B] [weak_order C] + (l1 : A → B) (u1 : B → A) (l2 : B → C) (u2 : C → B) + (gc1 : galois_connection l1 u1) (gc2 : galois_connection l2 u2) : + galois_connection (l2 ∘ l1) (u1 ∘ u2) := +by intros; rewrite gc2; rewrite gc1 + +section + variables {A B : Type} {f : A → B} + + protected lemma image_preimage : galois_connection (image f) (preimage f) := + @image_subset_iff A B f + + protected lemma preimage_kern_image : galois_connection (preimage f) (kern_image f) := + begin + intros X Y, apply iff.intro, all_goals (intro H x Hx), + { intro x' eq, apply H, cases eq, exact Hx }, + { apply H, + esimp [preimage, mem, set_of] at Hx, exact Hx, -- TODO: why is esimp necessary? + exact rfl } + end +end + +end galois_connection + +/- Bounds on complete lattices -/ +/- TODO: move to complete lattices? -/ + +section +variables {A : Type} (S : set A) {a b : A} [complete_lattice A] + +lemma is_lub_sup : is_lub '{a, b} (sup a b) := +and.intro + begin + xrewrite [+bounded_forall_insert_iff, bounded_forall_empty_iff, and_true], + exact (and.intro !le_sup_left !le_sup_right) + end + begin + intro x Hx, + xrewrite [+bounded_forall_insert_iff at Hx, bounded_forall_empty_iff at Hx, and_true at Hx], + apply sup_le, + apply (and.elim_left Hx), + apply (and.elim_right Hx), + end + +lemma is_lub_Sup : is_lub S (⨆S) := +and.intro (take x, le_Sup) (take x, Sup_le) + +lemma is_lub_iff_Sup_eq {a : A} : is_lub S a ↔ (⨆S) = a := +!is_lub_iff_eq_of_is_lub !is_lub_Sup + +lemma is_glb_Inf : is_glb S (⨅S) := +and.intro (take a, Inf_le) (take a, le_Inf) + +lemma is_glb_iff_Inf_eq : is_glb S a ↔ (⨅S) = a := +!is_glb_iff_eq_of_is_glb !is_glb_Inf + +end diff --git a/old_library/algebra/group.lean b/old_library/algebra/group.lean new file mode 100644 index 0000000000..216472bfea --- /dev/null +++ b/old_library/algebra/group.lean @@ -0,0 +1,807 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad, Leonardo de Moura + +Various multiplicative and additive structures. Partially modeled on Isabelle's library. +-/ +import logic.eq data.sigma data.prod +import algebra.binary algebra.priority + +open binary + +variable {A : Type} + +/- semigroup -/ + +/- TODO(Leo): decide whether we keep this annotation or not -/ +-- attribute inv [light 3] +-- attribute neg [light 3] + +structure semigroup [class] (A : Type) extends has_mul A := +(mul_assoc : ∀a b c : A, a * b * c = a * (b * c)) + +-- We add pattern hints to the following lemma because we want it to be used in both directions +-- at inst_simp strategy. +attribute [simp] +theorem mul.assoc [semigroup A] (a b c : A) : a * b * c = a * (b * c) := +semigroup.mul_assoc a b c + +set_option pp.all true +structure comm_semigroup [class] (A : Type) extends semigroup A := +(mul_comm : ∀a b : A, a * b = b * a) + +attribute [simp] +theorem mul.comm [comm_semigroup A] (a b : A) : a * b = b * a := +comm_semigroup.mul_comm a b + +attribute [simp] +theorem mul.left_comm [comm_semigroup A] (a b c : A) : a * (b * c) = b * (a * c) := +binary.left_comm (@mul.comm A _) (@mul.assoc A _) a b c + +theorem mul.right_comm [comm_semigroup A] (a b c : A) : (a * b) * c = (a * c) * b := +sorry -- by simp + +structure left_cancel_semigroup [class] (A : Type) extends semigroup A := +(mul_left_cancel : ∀a b c : A, a * b = a * c → b = c) + +theorem mul.left_cancel [left_cancel_semigroup A] {a b c : A} : a * b = a * c → b = c := +left_cancel_semigroup.mul_left_cancel a b c + +abbreviation eq_of_mul_eq_mul_left' := @mul.left_cancel + +structure right_cancel_semigroup [class] (A : Type) extends semigroup A := +(mul_right_cancel : ∀a b c : A, a * b = c * b → a = c) + +theorem mul.right_cancel [right_cancel_semigroup A] {a b c : A} : a * b = c * b → a = c := +right_cancel_semigroup.mul_right_cancel a b c + +abbreviation eq_of_mul_eq_mul_right' := @mul.right_cancel + +/- additive semigroup -/ + +structure add_semigroup [class] (A : Type) extends has_add A := +(add_assoc : ∀a b c : A, a + b + c = a + (b + c)) + +attribute [simp] +theorem add.assoc [add_semigroup A] (a b c : A) : a + b + c = a + (b + c) := +add_semigroup.add_assoc a b c + +structure add_comm_semigroup [class] (A : Type) extends add_semigroup A := +(add_comm : ∀a b : A, a + b = b + a) + +attribute [simp] +theorem add.comm [add_comm_semigroup A] (a b : A) : a + b = b + a := +add_comm_semigroup.add_comm a b + +attribute [simp] +theorem add.left_comm [add_comm_semigroup A] (a b c : A) : a + (b + c) = b + (a + c) := +binary.left_comm (@add.comm A _) (@add.assoc A _) a b c + +theorem add.right_comm [add_comm_semigroup A] (a b c : A) : (a + b) + c = (a + c) + b := +sorry -- by simp + +structure add_left_cancel_semigroup [class] (A : Type) extends add_semigroup A := +(add_left_cancel : ∀a b c : A, a + b = a + c → b = c) + +theorem add.left_cancel [add_left_cancel_semigroup A] {a b c : A} : a + b = a + c → b = c := +add_left_cancel_semigroup.add_left_cancel a b c + +abbreviation eq_of_add_eq_add_left := @add.left_cancel + +structure add_right_cancel_semigroup [class] (A : Type) extends add_semigroup A := +(add_right_cancel : ∀a b c : A, a + b = c + b → a = c) + +theorem add.right_cancel [add_right_cancel_semigroup A] {a b c : A} : a + b = c + b → a = c := +add_right_cancel_semigroup.add_right_cancel a b c + +abbreviation eq_of_add_eq_add_right := @add.right_cancel + +/- monoid -/ + +structure monoid [class] (A : Type) extends semigroup A, has_one A := +(one_mul : ∀a : A, 1 * a = a) (mul_one : ∀a : A, a * 1 = a) + +attribute [simp] +theorem one_mul [monoid A] (a : A) : 1 * a = a := monoid.one_mul a + +attribute [simp] +theorem mul_one [monoid A] (a : A) : a * 1 = a := monoid.mul_one a + +structure comm_monoid [class] (A : Type) extends monoid A, comm_semigroup A + +/- additive monoid -/ + +structure add_monoid [class] (A : Type) extends add_semigroup A, has_zero A := +(zero_add : ∀a : A, 0 + a = a) (add_zero : ∀a : A, a + 0 = a) + +attribute [simp] +theorem zero_add [add_monoid A] (a : A) : 0 + a = a := add_monoid.zero_add a + +attribute [simp] +theorem add_zero [add_monoid A] (a : A) : a + 0 = a := add_monoid.add_zero a + +structure add_comm_monoid [class] (A : Type) extends add_monoid A, add_comm_semigroup A + +definition add_monoid.to_monoid {A : Type} [add_monoid A] : monoid A := +⦃ monoid, + mul := add_monoid.add, + mul_assoc := add_monoid.add_assoc, + one := add_monoid.zero A, + mul_one := add_monoid.add_zero, + one_mul := add_monoid.zero_add +⦄ + +definition add_comm_monoid.to_comm_monoid {A : Type} [add_comm_monoid A] : comm_monoid A := +⦃ comm_monoid, + add_monoid.to_monoid, + mul_comm := add_comm_monoid.add_comm +⦄ + +section add_comm_monoid + variables [add_comm_monoid A] + + theorem add_comm_three (a b c : A) : a + b + c = c + b + a := + sorry -- by simp + + theorem add.comm4 : ∀ (n m k l : A), n + m + (k + l) = n + k + (m + l) := + sorry -- by simp +end add_comm_monoid + +/- group -/ + +structure group [class] (A : Type) extends monoid A, has_inv A := +(mul_left_inv : ∀a : A, a⁻¹ * a = 1) + +-- Note: with more work, we could derive the axiom one_mul + +section group + variable [group A] + + attribute [simp] + theorem mul.left_inv (a : A) : a⁻¹ * a = 1 := group.mul_left_inv a + + attribute [simp] + theorem inv_mul_cancel_left (a b : A) : a⁻¹ * (a * b) = b := + sorry -- by rewrite [-mul.assoc, mul.left_inv, one_mul] + + attribute [simp] + theorem inv_mul_cancel_right (a b : A) : a * b⁻¹ * b = a := + sorry -- by simp + + theorem inv_eq_of_mul_eq_one {a b : A} (H : a * b = 1) : a⁻¹ = b := + sorry + /- + have a⁻¹ * 1 = b, by inst_simp, + by inst_simp + -/ + + attribute [simp] + theorem one_inv : 1⁻¹ = (1 : A) := + inv_eq_of_mul_eq_one (one_mul 1) + + attribute [simp] + theorem inv_inv (a : A) : (a⁻¹)⁻¹ = a := + inv_eq_of_mul_eq_one (mul.left_inv a) + + variable (A) + theorem left_inverse_inv : function.left_inverse (λ a : A, a⁻¹) (λ a, a⁻¹) := + take a, inv_inv a + variable {A} + + theorem inv.inj {a b : A} (H : a⁻¹ = b⁻¹) : a = b := + sorry + /- + have a = a⁻¹⁻¹, by simp_nohyps, + by inst_simp + -/ + + theorem inv_eq_inv_iff_eq (a b : A) : a⁻¹ = b⁻¹ ↔ a = b := + sorry -- iff.intro (assume H, inv.inj H) (by simp) + + theorem inv_eq_one_iff_eq_one (a : A) : a⁻¹ = 1 ↔ a = 1 := + sorry + /- + have a⁻¹ = 1⁻¹ ↔ a = 1, from inv_eq_inv_iff_eq a 1, + by simp + -/ + + theorem eq_one_of_inv_eq_one (a : A) : a⁻¹ = 1 → a = 1 := + iff.mp (inv_eq_one_iff_eq_one a) + + theorem eq_inv_of_eq_inv {a b : A} (H : a = b⁻¹) : b = a⁻¹ := + sorry -- by simp + + theorem eq_inv_iff_eq_inv (a b : A) : a = b⁻¹ ↔ b = a⁻¹ := + iff.intro eq_inv_of_eq_inv eq_inv_of_eq_inv + + theorem eq_inv_of_mul_eq_one {a b : A} (H : a * b = 1) : a = b⁻¹ := + sorry + /- + have a⁻¹ = b, from inv_eq_of_mul_eq_one H, + by inst_simp + -/ + + attribute [simp] + theorem mul.right_inv (a : A) : a * a⁻¹ = 1 := + sorry + /- + have a = a⁻¹⁻¹, by simp, + by inst_simp + -/ + + attribute [simp] + theorem mul_inv_cancel_left (a b : A) : a * (a⁻¹ * b) = b := + sorry -- by inst_simp + + attribute [simp] + theorem mul_inv_cancel_right (a b : A) : a * b * b⁻¹ = a := + sorry -- by inst_simp + + attribute [simp] + theorem mul_inv (a b : A) : (a * b)⁻¹ = b⁻¹ * a⁻¹ := + sorry -- inv_eq_of_mul_eq_one (by inst_simp) + + theorem eq_of_mul_inv_eq_one {a b : A} (H : a * b⁻¹ = 1) : a = b := + sorry + /- + have a⁻¹ * 1 = a⁻¹, by inst_simp, + by inst_simp + -/ + + theorem eq_mul_inv_of_mul_eq {a b c : A} (H : a * c = b) : a = b * c⁻¹ := + sorry -- by simp + + theorem eq_inv_mul_of_mul_eq {a b c : A} (H : b * a = c) : a = b⁻¹ * c := + sorry -- by simp + + theorem inv_mul_eq_of_eq_mul {a b c : A} (H : b = a * c) : a⁻¹ * b = c := + sorry -- by simp + + theorem mul_inv_eq_of_eq_mul {a b c : A} (H : a = c * b) : a * b⁻¹ = c := + sorry -- by simp + + theorem eq_mul_of_mul_inv_eq {a b c : A} (H : a * c⁻¹ = b) : a = b * c := + sorry -- by simp + + theorem eq_mul_of_inv_mul_eq {a b c : A} (H : b⁻¹ * a = c) : a = b * c := + sorry -- by simp + + theorem mul_eq_of_eq_inv_mul {a b c : A} (H : b = a⁻¹ * c) : a * b = c := + sorry -- by simp + + theorem mul_eq_of_eq_mul_inv {a b c : A} (H : a = c * b⁻¹) : a * b = c := + sorry -- by simp + + theorem mul_eq_iff_eq_inv_mul (a b c : A) : a * b = c ↔ b = a⁻¹ * c := + iff.intro eq_inv_mul_of_mul_eq mul_eq_of_eq_inv_mul + + theorem mul_eq_iff_eq_mul_inv (a b c : A) : a * b = c ↔ a = c * b⁻¹ := + iff.intro eq_mul_inv_of_mul_eq mul_eq_of_eq_mul_inv + + theorem mul_left_cancel {a b c : A} (H : a * b = a * c) : b = c := + sorry + /- + have a⁻¹ * (a * b) = b, by inst_simp, + by inst_simp + -/ + + theorem mul_right_cancel {a b c : A} (H : a * b = c * b) : a = c := + sorry + /- + have a * b * b⁻¹ = a, by inst_simp, + by inst_simp + -/ + + theorem mul_eq_one_of_mul_eq_one {a b : A} (H : b * a = 1) : a * b = 1 := + sorry -- by rewrite [-inv_eq_of_mul_eq_one H, mul.left_inv] + + theorem mul_eq_one_iff_mul_eq_one (a b : A) : a * b = 1 ↔ b * a = 1 := + iff.intro mul_eq_one_of_mul_eq_one mul_eq_one_of_mul_eq_one + + definition conj_by (g a : A) := g * a * g⁻¹ + definition is_conjugate (a b : A) := ∃ x, conj_by x b = a + + local infixl ` ~ ` := is_conjugate + local infixr ` ∘c `:55 := conj_by + + local attribute conj_by [reducible] + + attribute [simp] + lemma conj_compose (f g a : A) : f ∘c g ∘c a = f*g ∘c a := + sorry -- by inst_simp + + attribute [simp] + lemma conj_id (a : A) : 1 ∘c a = a := + sorry -- by inst_simp + + attribute [simp] + lemma conj_one (g : A) : g ∘c 1 = 1 := + sorry -- by inst_simp + + attribute [simp] + lemma conj_inv_cancel (g : A) : ∀ a, g⁻¹ ∘c g ∘c a = a := + sorry -- by inst_simp + + attribute [simp] + lemma conj_inv (g : A) : ∀ a, (g ∘c a)⁻¹ = g ∘c a⁻¹ := + sorry -- by inst_simp + + lemma is_conj.refl (a : A) : a ~ a := exists.intro 1 (conj_id a) + + lemma is_conj.symm (a b : A) : a ~ b → b ~ a := + sorry + /- + assume Pab, obtain x (Pconj : x ∘c b = a), from Pab, + have Pxinv : x⁻¹ ∘c x ∘c b = x⁻¹ ∘c a, by simp, + exists.intro x⁻¹ (by simp) + -/ + + lemma is_conj.trans (a b c : A) : a ~ b → b ~ c → a ~ c := + sorry + /- + assume Pab, assume Pbc, + obtain x (Px : x ∘c b = a), from Pab, + obtain y (Py : y ∘c c = b), from Pbc, + exists.intro (x*y) (by inst_simp) + -/ + +end group + +attribute [instance] +definition group.to_left_cancel_semigroup [s : group A] : + left_cancel_semigroup A := +⦃ left_cancel_semigroup, s, + mul_left_cancel := @mul_left_cancel A s ⦄ + +attribute [instance] +definition group.to_right_cancel_semigroup [s : group A] : + right_cancel_semigroup A := +⦃ right_cancel_semigroup, s, + mul_right_cancel := @mul_right_cancel A s ⦄ + +structure comm_group [class] (A : Type) extends group A, comm_monoid A + +/- additive group -/ + +structure add_group [class] (A : Type) extends add_monoid A, has_neg A := +(add_left_inv : ∀a : A, -a + a = 0) + +definition add_group.to_group {A : Type} [add_group A] : group A := +⦃ group, add_monoid.to_monoid, + mul_left_inv := add_group.add_left_inv ⦄ + + +section add_group + variables [s : add_group A] + include s + + attribute [simp] + theorem add.left_inv (a : A) : -a + a = 0 := add_group.add_left_inv a + + attribute [simp] + theorem neg_add_cancel_left (a b : A) : -a + (a + b) = b := + calc -a + (a + b) = (-a + a) + b : sorry -- by rewrite add.assoc + ... = b : sorry -- by simp + + attribute [simp] + theorem neg_add_cancel_right (a b : A) : a + -b + b = a := + sorry -- by simp + + theorem neg_eq_of_add_eq_zero {a b : A} (H : a + b = 0) : -a = b := + sorry + /- + have -a + 0 = b, by inst_simp, + by inst_simp + -/ + + attribute [simp] + theorem neg_zero : -0 = (0 : A) := neg_eq_of_add_eq_zero (zero_add 0) + + attribute [simp] + theorem neg_neg (a : A) : -(-a) = a := neg_eq_of_add_eq_zero (add.left_inv a) + + variable (A) + theorem left_inverse_neg : function.left_inverse (λ a : A, - a) (λ a, - a) := + take a, neg_neg a + variable {A} + + theorem eq_neg_of_add_eq_zero {a b : A} (H : a + b = 0) : a = -b := + have -a = b, from neg_eq_of_add_eq_zero H, + sorry -- by inst_simp + + theorem neg.inj {a b : A} (H : -a = -b) : a = b := + sorry + /- + have a = -(-a), by simp_nohyps, + by inst_simp + -/ + + theorem neg_eq_neg_iff_eq (a b : A) : -a = -b ↔ a = b := + sorry -- iff.intro (assume H, neg.inj H) (by simp) + + theorem eq_of_neg_eq_neg {a b : A} : -a = -b → a = b := + iff.mp (neg_eq_neg_iff_eq a b) + + theorem neg_eq_zero_iff_eq_zero (a : A) : -a = 0 ↔ a = 0 := + have -a = -0 ↔ a = 0, from neg_eq_neg_iff_eq a 0, + sorry -- by simp + + theorem eq_zero_of_neg_eq_zero {a : A} : -a = 0 → a = 0 := + iff.mp (neg_eq_zero_iff_eq_zero a) + + theorem eq_neg_of_eq_neg {a b : A} (H : a = -b) : b = -a := + sorry -- by simp + + theorem eq_neg_iff_eq_neg (a b : A) : a = -b ↔ b = -a := + iff.intro eq_neg_of_eq_neg eq_neg_of_eq_neg + + attribute [simp] + theorem add.right_inv (a : A) : a + -a = 0 := + sorry + /- + have a = -(-a), by simp, + by inst_simp + -/ + + attribute [simp] + theorem add_neg_cancel_left (a b : A) : a + (-a + b) = b := + sorry -- by inst_simp + + attribute [simp] + theorem add_neg_cancel_right (a b : A) : a + b + -b = a := + sorry -- by simp + + attribute [simp] + theorem neg_add_rev (a b : A) : -(a + b) = -b + -a := + sorry -- neg_eq_of_add_eq_zero (by simp) + + -- TODO: delete these in favor of sub rules? + theorem eq_add_neg_of_add_eq {a b c : A} (H : a + c = b) : a = b + -c := + sorry -- by simp + + theorem eq_neg_add_of_add_eq {a b c : A} (H : b + a = c) : a = -b + c := + sorry -- by simp + + theorem neg_add_eq_of_eq_add {a b c : A} (H : b = a + c) : -a + b = c := + sorry -- by simp + + theorem add_neg_eq_of_eq_add {a b c : A} (H : a = c + b) : a + -b = c := + sorry -- by simp + + theorem eq_add_of_add_neg_eq {a b c : A} (H : a + -c = b) : a = b + c := + sorry -- by simp + + theorem eq_add_of_neg_add_eq {a b c : A} (H : -b + a = c) : a = b + c := + sorry -- by simp + + theorem add_eq_of_eq_neg_add {a b c : A} (H : b = -a + c) : a + b = c := + sorry -- by simp + + theorem add_eq_of_eq_add_neg {a b c : A} (H : a = c + -b) : a + b = c := + sorry -- by simp + + theorem add_eq_iff_eq_neg_add (a b c : A) : a + b = c ↔ b = -a + c := + iff.intro eq_neg_add_of_add_eq add_eq_of_eq_neg_add + + theorem add_eq_iff_eq_add_neg (a b c : A) : a + b = c ↔ a = c + -b := + iff.intro eq_add_neg_of_add_eq add_eq_of_eq_add_neg + + theorem add_left_cancel {a b c : A} (H : a + b = a + c) : b = c := + sorry + /- + have -a + (a + b) = b, by inst_simp, + by inst_simp + -/ + + theorem add_right_cancel {a b c : A} (H : a + b = c + b) : a = c := + sorry + /- + have a + b + -b = a, by inst_simp, + by inst_simp + -/ + + attribute [instance] + definition add_group.to_left_cancel_semigroup : add_left_cancel_semigroup A := + ⦃ add_left_cancel_semigroup, s, + add_left_cancel := @add_left_cancel A s ⦄ + + attribute [instance] + definition add_group.to_add_right_cancel_semigroup : + add_right_cancel_semigroup A := + ⦃ add_right_cancel_semigroup, s, + add_right_cancel := @add_right_cancel A s ⦄ + + theorem add_neg_eq_neg_add_rev {a b : A} : a + -b = -(b + -a) := + sorry -- by simp + + theorem ne_add_of_ne_zero_right (a : A) {b : A} (H : b ≠ 0) : a ≠ b + a := + sorry + /- + begin + intro Heq, + apply H, + rewrite [-zero_add a at Heq{1}], + let Heq' := eq_of_add_eq_add_right Heq, + apply eq.symm Heq' + end + -/ + + theorem ne_add_of_ne_zero_left (a : A) {b : A} (H : b ≠ 0) : a ≠ a + b := + sorry + /- + begin + intro Heq, + apply H, + rewrite [-add_zero a at Heq{1}], + let Heq' := eq_of_add_eq_add_left Heq, + apply eq.symm Heq' + end + -/ + + /- sub -/ + + -- TODO: derive corresponding facts for div in a field + attribute [reducible] + protected definition algebra.sub (a b : A) : A := a + -b + + attribute [instance] + definition add_group_has_sub : has_sub A := + has_sub.mk algebra.sub + + attribute [simp] + theorem sub_eq_add_neg (a b : A) : a - b = a + -b := rfl + + theorem sub_self (a : A) : a - a = 0 := add.right_inv a + + theorem sub_add_cancel (a b : A) : a - b + b = a := neg_add_cancel_right a b + + theorem add_sub_cancel (a b : A) : a + b - b = a := add_neg_cancel_right a b + + theorem add_sub_assoc (a b c : A) : a + b - c = a + (b - c) := + sorry -- by rewrite [sub_eq_add_neg, add.assoc, -sub_eq_add_neg] + + theorem eq_of_sub_eq_zero {a b : A} (H : a - b = 0) : a = b := + sorry + /- + have -a + 0 = -a, by inst_simp, + by inst_simp + -/ + + theorem eq_iff_sub_eq_zero (a b : A) : a = b ↔ a - b = 0 := + iff.intro (assume H, eq.subst H (sub_self _)) (assume H, eq_of_sub_eq_zero H) + + theorem zero_sub (a : A) : 0 - a = -a := zero_add (-a) + + theorem sub_zero (a : A) : a - 0 = a := + sorry -- by simp + + theorem sub_ne_zero_of_ne {a b : A} (H : a ≠ b) : a - b ≠ 0 := + sorry + /- + begin + intro Hab, + apply H, + apply eq_of_sub_eq_zero Hab + end + -/ + + theorem sub_neg_eq_add (a b : A) : a - (-b) = a + b := + sorry -- by simp + + theorem neg_sub (a b : A) : -(a - b) = b - a := + sorry -- neg_eq_of_add_eq_zero (by inst_simp) + + theorem add_sub (a b c : A) : a + (b - c) = a + b - c := + sorry -- by simp + + theorem sub_add_eq_sub_sub_swap (a b c : A) : a - (b + c) = a - c - b := + sorry -- by inst_simp + + theorem sub_eq_iff_eq_add (a b c : A) : a - b = c ↔ a = c + b := + iff.intro (assume H, eq_add_of_add_neg_eq H) (assume H, add_neg_eq_of_eq_add H) + + theorem eq_sub_iff_add_eq (a b c : A) : a = b - c ↔ a + c = b := + iff.intro (assume H, add_eq_of_eq_add_neg H) (assume H, eq_add_neg_of_add_eq H) + + theorem eq_iff_eq_of_sub_eq_sub {a b c d : A} (H : a - b = c - d) : a = b ↔ c = d := + calc + a = b ↔ a - b = 0 : eq_iff_sub_eq_zero a b + ... = (c - d = 0) : sorry -- by rewrite H + ... ↔ c = d : iff.symm (eq_iff_sub_eq_zero c d) + + theorem eq_sub_of_add_eq {a b c : A} (H : a + c = b) : a = b - c := + sorry -- by simp + + theorem sub_eq_of_eq_add {a b c : A} (H : a = c + b) : a - b = c := + sorry -- by simp + + theorem eq_add_of_sub_eq {a b c : A} (H : a - c = b) : a = b + c := + sorry -- by simp + + theorem add_eq_of_eq_sub {a b c : A} (H : a = c - b) : a + b = c := + sorry -- by simp + + theorem left_inverse_sub_add_left (c : A) : function.left_inverse (λ x, x - c) (λ x, x + c) := + take x, add_sub_cancel x c + + theorem left_inverse_add_left_sub (c : A) : function.left_inverse (λ x, x + c) (λ x, x - c) := + take x, sub_add_cancel x c + + theorem left_inverse_add_right_neg_add (c : A) : + function.left_inverse (λ x, c + x) (λ x, - c + x) := + take x, add_neg_cancel_left c x + + theorem left_inverse_neg_add_add_right (c : A) : + function.left_inverse (λ x, - c + x) (λ x, c + x) := + take x, neg_add_cancel_left c x +end add_group + +structure add_comm_group [class] (A : Type) extends add_group A, add_comm_monoid A + +section add_comm_group + variable [s : add_comm_group A] + include s + + theorem sub_add_eq_sub_sub (a b c : A) : a - (b + c) = a - b - c := + sorry -- by simp + + theorem neg_add_eq_sub (a b : A) : -a + b = b - a := + sorry -- by simp + + theorem neg_add (a b : A) : -(a + b) = -a + -b := + sorry -- by simp + + theorem sub_add_eq_add_sub (a b c : A) : a - b + c = a + c - b := + sorry -- by simp + + theorem sub_sub (a b c : A) : a - b - c = a - (b + c) := + sorry -- by simp + + theorem add_sub_add_left_eq_sub (a b c : A) : (c + a) - (c + b) = a - b := + sorry -- by simp + + theorem eq_sub_of_add_eq' {a b c : A} (H : c + a = b) : a = b - c := + sorry -- by simp + + theorem sub_eq_of_eq_add' {a b c : A} (H : a = b + c) : a - b = c := + sorry -- by simp + + theorem eq_add_of_sub_eq' {a b c : A} (H : a - b = c) : a = b + c := + sorry -- by simp + + theorem add_eq_of_eq_sub' {a b c : A} (H : b = c - a) : a + b = c := + sorry -- by simp + + theorem sub_sub_self (a b : A) : a - (a - b) = b := + sorry -- by simp + + theorem add_sub_comm (a b c d : A) : a + b - (c + d) = (a - c) + (b - d) := + sorry -- by simp + + theorem sub_eq_sub_add_sub (a b c : A) : a - b = c - b + (a - c) := + sorry -- by simp + + theorem neg_neg_sub_neg (a b : A) : - (-a - -b) = a - b := + sorry -- by simp + +end add_comm_group + +definition group_of_add_group (A : Type) [G : add_group A] : group A := +⦃group, + mul := has_add.add, + mul_assoc := add.assoc, + one := has_zero.zero A, + one_mul := zero_add, + mul_one := add_zero, + inv := has_neg.neg, + mul_left_inv := add.left_inv⦄ + +namespace norm_num +reveal add.assoc + +definition add1 [has_add A] [has_one A] (a : A) : A := add a one + +local attribute add1 bit0 bit1 [reducible] + +theorem add_comm_four [add_comm_semigroup A] (a b : A) : a + a + (b + b) = (a + b) + (a + b) := +sorry -- by simp + +theorem add_comm_middle [add_comm_semigroup A] (a b c : A) : a + b + c = a + c + b := +sorry -- by simp + +theorem bit0_add_bit0 [add_comm_semigroup A] (a b : A) : bit0 a + bit0 b = bit0 (a + b) := +sorry -- by simp + +theorem bit0_add_bit0_helper [add_comm_semigroup A] (a b t : A) (H : a + b = t) : + bit0 a + bit0 b = bit0 t := +sorry -- by rewrite -H; simp + +theorem bit1_add_bit0 [add_comm_semigroup A] [has_one A] (a b : A) : + bit1 a + bit0 b = bit1 (a + b) := +sorry -- by simp + +theorem bit1_add_bit0_helper [add_comm_semigroup A] [has_one A] (a b t : A) + (H : a + b = t) : bit1 a + bit0 b = bit1 t := +sorry -- by rewrite -H; simp + +theorem bit0_add_bit1 [add_comm_semigroup A] [has_one A] (a b : A) : + bit0 a + bit1 b = bit1 (a + b) := +sorry -- by simp + +theorem bit0_add_bit1_helper [add_comm_semigroup A] [has_one A] (a b t : A) + (H : a + b = t) : bit0 a + bit1 b = bit1 t := +sorry -- by rewrite -H; simp + +theorem bit1_add_bit1 [add_comm_semigroup A] [has_one A] (a b : A) : + bit1 a + bit1 b = bit0 (add1 (a + b)) := +sorry -- by simp + +theorem bit1_add_bit1_helper [add_comm_semigroup A] [has_one A] (a b t s: A) + (H : (a + b) = t) (H2 : add1 t = s) : bit1 a + bit1 b = bit0 s := +sorry -- by inst_simp + +theorem bin_add_zero [add_monoid A] (a : A) : a + zero = a := +sorry -- by simp + +theorem bin_zero_add [add_monoid A] (a : A) : zero + a = a := +sorry -- by simp + +theorem one_add_bit0 [add_comm_semigroup A] [has_one A] (a : A) : one + bit0 a = bit1 a := +sorry -- by simp + +theorem bit0_add_one [has_add A] [has_one A] (a : A) : bit0 a + one = bit1 a := +rfl + +theorem bit1_add_one [has_add A] [has_one A] (a : A) : bit1 a + one = add1 (bit1 a) := +rfl + +theorem bit1_add_one_helper [has_add A] [has_one A] (a t : A) (H : add1 (bit1 a) = t) : + bit1 a + one = t := +sorry -- by inst_simp + +theorem one_add_bit1 [add_comm_semigroup A] [has_one A] (a : A) : one + bit1 a = add1 (bit1 a) := +sorry -- by simp + +theorem one_add_bit1_helper [add_comm_semigroup A] [has_one A] (a t : A) + (H : add1 (bit1 a) = t) : one + bit1 a = t := +sorry -- by inst_simp + +theorem add1_bit0 [has_add A] [has_one A] (a : A) : add1 (bit0 a) = bit1 a := +rfl + +theorem add1_bit1 [add_comm_semigroup A] [has_one A] (a : A) : + add1 (bit1 a) = bit0 (add1 a) := +sorry -- by simp + +theorem add1_bit1_helper [add_comm_semigroup A] [has_one A] (a t : A) (H : add1 a = t) : + add1 (bit1 a) = bit0 t := +sorry -- by inst_simp + +theorem add1_one [has_add A] [has_one A] : add1 (one : A) = bit0 one := +rfl + +theorem add1_zero [add_monoid A] [has_one A] : add1 (zero : A) = one := +sorry -- by simp + +theorem one_add_one [has_add A] [has_one A] : (one : A) + one = bit0 one := +rfl + +theorem subst_into_sum [has_add A] (l r tl tr t : A) (prl : l = tl) (prr : r = tr) + (prt : tl + tr = t) : l + r = t := +sorry -- by simp + +theorem neg_zero_helper [add_group A] (a : A) (H : a = 0) : - a = 0 := +sorry -- by simp + +end norm_num + +attribute [simp] + zero_add add_zero one_mul mul_one + +attribute [simp] + neg_neg sub_eq_add_neg + +attribute [simp] + add.assoc add.comm add.left_comm + mul.left_comm mul.comm mul.assoc diff --git a/old_library/algebra/group_bigops.lean b/old_library/algebra/group_bigops.lean new file mode 100644 index 0000000000..d03a52f1e5 --- /dev/null +++ b/old_library/algebra/group_bigops.lean @@ -0,0 +1,553 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad + +Finite products on a monoid, and finite sums on an additive monoid. There are three versions: + + Prodl, Suml : products and sums over lists + Prod, Sum (in namespace finset) : products and sums over finsets + Prod, Sum (in namespace set) : products and sums over finite sets + +We also define internal functions Prodl_semigroup and Prod_semigroup that can be used to define +operations over commutative semigroups where there is no unit. We put them into their own namespaces +so that they won't be very prominent. They can be used to define Min and Max in the number systems, +or Inter for finsets. + +We have to be careful with dependencies. This theory imports files from finset and list, which +import basic files from nat. +-/ +import .group .group_power data.list.basic data.list.perm data.finset.basic data.set.finite +open function binary quot subtype list + +variables {A B : Type} +variable [deceqA : decidable_eq A] + +definition mulf [sgB : semigroup B] (f : A → B) : B → A → B := +λ b a, b * f a + +/- +-- list versions. +-/ + +/- Prodl_semigroup: product indexed by a list, with a default for the empty list -/ + +namespace Prodl_semigroup + variable [semigroup B] + + definition Prodl_semigroup (dflt : B) : ∀ (l : list A) (f : A → B), B + | [] f := dflt + | (a :: l) f := list.foldl (mulf f) (f a) l + + theorem Prodl_semigroup_nil (dflt : B) (f : A → B) : Prodl_semigroup dflt nil f = dflt := rfl + + theorem Prodl_semigroup_cons (dflt : B) (f : A → B) (a : A) (l : list A) : + Prodl_semigroup dflt (a::l) f = list.foldl (mulf f) (f a) l := rfl + + theorem Prodl_semigroup_singleton (dflt : B) (f : A → B) (a : A) : + Prodl_semigroup dflt [a] f = f a := rfl + + theorem Prodl_semigroup_cons_cons (dflt : B) (f : A → B) (a₁ a₂ : A) (l : list A) : + Prodl_semigroup dflt (a₁::a₂::l) f = f a₁ * Prodl_semigroup dflt (a₂::l) f := + begin + rewrite [↑Prodl_semigroup, foldl_cons, ↑mulf at {2}], + generalize (f a₂), + induction l with a l ih, + {intro x, exact rfl}, + intro x, + rewrite [*foldl_cons, ↑mulf at {2,3}, mul.assoc, ih] + end + + theorem Prodl_semigroup_binary (dflt : B) (f : A → B) (a₁ a₂ : A) : + Prodl_semigroup dflt [a₁, a₂] f = f a₁ * f a₂ := rfl + + section deceqA + include deceqA + + theorem Prodl_semigroup_insert_of_mem (dflt : B) (f : A → B) {a : A} {l : list A} : a ∈ l → + Prodl_semigroup dflt (insert a l) f = Prodl_semigroup dflt l f := + assume ainl, by rewrite [insert_eq_of_mem ainl] + + theorem Prodl_semigroup_insert_insert_of_not_mem (dflt : B) (f : A → B) + {a₁ a₂ : A} {l : list A} (h₁ : a₂ ∉ l) (h₂ : a₁ ∉ insert a₂ l) : + Prodl_semigroup dflt (insert a₁ (insert a₂ l)) f = + f a₁ * Prodl_semigroup dflt (insert a₂ l) f := + by rewrite [insert_eq_of_not_mem h₂, insert_eq_of_not_mem h₁, Prodl_semigroup_cons_cons] + end deceqA +end Prodl_semigroup + +/- Prodl: product indexed by a list -/ + +section monoid + variable [monoid B] + + definition Prodl (l : list A) (f : A → B) : B := + list.foldl (mulf f) 1 l + + -- ∏ x ← l, f x + notation `∏` binders `←` l `, ` r:(scoped f, Prodl l f) := r + + private theorem foldl_const (f : A → B) : + ∀ (l : list A) (b : B), foldl (mulf f) b l = b * foldl (mulf f) 1 l + | [] b := by rewrite [*foldl_nil, mul_one] + | (a::l) b := by rewrite [*foldl_cons, foldl_const, {foldl _ (mulf f 1 a) _}foldl_const, ↑mulf, + one_mul, mul.assoc] + + theorem Prodl_nil (f : A → B) : Prodl [] f = 1 := rfl + + theorem Prodl_cons (f : A → B) (a : A) (l : list A) : Prodl (a::l) f = f a * Prodl l f := + by rewrite [↑Prodl, foldl_cons, foldl_const, ↑mulf, one_mul] + + theorem Prodl_append : + ∀ (l₁ l₂ : list A) (f : A → B), Prodl (l₁++l₂) f = Prodl l₁ f * Prodl l₂ f + | [] l₂ f := by rewrite [append_nil_left, Prodl_nil, one_mul] + | (a::l) l₂ f := by rewrite [append_cons, *Prodl_cons, Prodl_append, mul.assoc] + + section deceqA + include deceqA + + theorem Prodl_insert_of_mem (f : A → B) {a : A} {l : list A} : a ∈ l → + Prodl (insert a l) f = Prodl l f := + assume ainl, by rewrite [insert_eq_of_mem ainl] + + theorem Prodl_insert_of_not_mem (f : A → B) {a : A} {l : list A} : + a ∉ l → Prodl (insert a l) f = f a * Prodl l f := + assume nainl, by rewrite [insert_eq_of_not_mem nainl, Prodl_cons] + + theorem Prodl_union {l₁ l₂ : list A} (f : A → B) (d : disjoint l₁ l₂) : + Prodl (union l₁ l₂) f = Prodl l₁ f * Prodl l₂ f := + by rewrite [union_eq_append d, Prodl_append] + end deceqA + + theorem Prodl_one : ∀(l : list A), Prodl l (λ x, 1) = (1:B) + | [] := rfl + | (a::l) := by rewrite [Prodl_cons, Prodl_one, mul_one] + + lemma Prodl_singleton (a : A) (f : A → B) : Prodl [a] f = f a := + !one_mul + + lemma Prodl_map {f : A → B} : + ∀ {l : list A}, Prodl l f = Prodl (map f l) id + | nil := by rewrite [map_nil] + | (a::l) := begin rewrite [map_cons, Prodl_cons f, Prodl_cons id (f a), Prodl_map] end + + open nat + lemma Prodl_eq_pow_of_const {f : A → B} : + ∀ {l : list A} b, (∀ a, a ∈ l → f a = b) → Prodl l f = b ^ length l + | nil := take b, assume Pconst, by rewrite [length_nil, {b^0}pow_zero] + | (a::l) := take b, assume Pconst, + have Pconstl : ∀ a', a' ∈ l → f a' = b, + from take a' Pa'in, Pconst a' (mem_cons_of_mem a Pa'in), + by rewrite [Prodl_cons f, Pconst a !mem_cons, Prodl_eq_pow_of_const b Pconstl, length_cons, + add_one, pow_succ b] +end monoid + +section comm_monoid + variable [comm_monoid B] + + theorem Prodl_mul (l : list A) (f g : A → B) : Prodl l (λx, f x * g x) = Prodl l f * Prodl l g := + list.induction_on l + (by rewrite [*Prodl_nil, mul_one]) + (take a l, + assume IH, + by rewrite [*Prodl_cons, IH, *mul.assoc, mul.left_comm (Prodl l f)]) +end comm_monoid + +/- Suml: sum indexed by a list -/ + +section add_monoid + variable [add_monoid B] + local attribute add_monoid.to_monoid [trans_instance] + + definition Suml (l : list A) (f : A → B) : B := Prodl l f + + -- ∑ x ← l, f x + notation `∑` binders `←` l `, ` r:(scoped f, Suml l f) := r + + theorem Suml_nil (f : A → B) : Suml [] f = 0 := Prodl_nil f + theorem Suml_cons (f : A → B) (a : A) (l : list A) : Suml (a::l) f = f a + Suml l f := + Prodl_cons f a l + theorem Suml_append (l₁ l₂ : list A) (f : A → B) : Suml (l₁++l₂) f = Suml l₁ f + Suml l₂ f := + Prodl_append l₁ l₂ f + + section deceqA + include deceqA + theorem Suml_insert_of_mem (f : A → B) {a : A} {l : list A} (H : a ∈ l) : + Suml (insert a l) f = Suml l f := Prodl_insert_of_mem f H + theorem Suml_insert_of_not_mem (f : A → B) {a : A} {l : list A} (H : a ∉ l) : + Suml (insert a l) f = f a + Suml l f := Prodl_insert_of_not_mem f H + theorem Suml_union {l₁ l₂ : list A} (f : A → B) (d : disjoint l₁ l₂) : + Suml (union l₁ l₂) f = Suml l₁ f + Suml l₂ f := Prodl_union f d + end deceqA + + theorem Suml_zero (l : list A) : Suml l (λ x, 0) = (0:B) := Prodl_one l + theorem Suml_singleton (a : A) (f : A → B) : Suml [a] f = f a := Prodl_singleton a f +end add_monoid + +section add_comm_monoid + variable [acmB : add_comm_monoid B] + include acmB + local attribute add_comm_monoid.to_comm_monoid [trans_instance] + + theorem Suml_add (l : list A) (f g : A → B) : Suml l (λx, f x + g x) = Suml l f + Suml l g := + Prodl_mul l f g +end add_comm_monoid + +/- +-- finset versions +-/ + +/- Prod_semigroup : product indexed by a finset, with a default for the empty finset -/ + +namespace finset + variable [comm_semigroup B] + + theorem mulf_rcomm (f : A → B) : right_commutative (mulf f) := + right_commutative_comp_right (@has_mul.mul B _) f (@mul.right_comm B _) + + namespace Prod_semigroup + open Prodl_semigroup + + private theorem Prodl_semigroup_eq_Prodl_semigroup_of_perm + (dflt : B) (f : A → B) {l₁ l₂ : list A} (p : perm l₁ l₂) : + Prodl_semigroup dflt l₁ f = Prodl_semigroup dflt l₂ f := + perm.induction_on p + rfl -- nil nil + (take x l₁ l₂ p ih, + by rewrite [*Prodl_semigroup_cons, perm.foldl_eq_of_perm (mulf_rcomm f) p]) + (take x y l, + begin rewrite [*Prodl_semigroup_cons, *foldl_cons, ↑mulf, mul.comm] end) + (take l₁ l₂ l₃ p₁ p₂ ih₁ ih₂, eq.trans ih₁ ih₂) + + definition Prod_semigroup (dflt : B) (s : finset A) (f : A → B) : B := + quot.lift_on s + (λ l, Prodl_semigroup dflt (elt_of l) f) + (λ l₁ l₂ p, Prodl_semigroup_eq_Prodl_semigroup_of_perm dflt f p) + + theorem Prod_semigroup_empty (dflt : B) (f : A → B) : Prod_semigroup dflt ∅ f = dflt := rfl + + section deceqA + include deceqA + + theorem Prod_semigroup_singleton (dflt : B) (f : A → B) (a : A) : + Prod_semigroup dflt '{a} f = f a := rfl + + theorem Prod_semigroup_insert_insert (dflt : B) (f : A → B) {a₁ a₂ : A} {s : finset A} : + a₂ ∉ s → a₁ ∉ insert a₂ s → + Prod_semigroup dflt (insert a₁ (insert a₂ s)) f = + f a₁ * Prod_semigroup dflt (insert a₂ s) f := + quot.induction_on s + (take l h₁ h₂, Prodl_semigroup_insert_insert_of_not_mem dflt f h₁ h₂) + + theorem Prod_semigroup_insert (dflt : B) (f : A → B) {a : A} {s : finset A} (anins : a ∉ s) + (sne : s ≠ ∅) : + Prod_semigroup dflt (insert a s) f = f a * Prod_semigroup dflt s f := + obtain a' (a's : a' ∈ s), from exists_mem_of_ne_empty sne, + have H : s = insert a' (erase a' s), from eq.symm (insert_erase a's), + begin + rewrite [H, Prod_semigroup_insert_insert dflt f !not_mem_erase (eq.subst H anins)] + end + end deceqA + end Prod_semigroup +end finset + +/- Prod: product indexed by a finset -/ + +namespace finset + variable [comm_monoid B] + + theorem Prodl_eq_Prodl_of_perm (f : A → B) {l₁ l₂ : list A} : + perm l₁ l₂ → Prodl l₁ f = Prodl l₂ f := + λ p, perm.foldl_eq_of_perm (mulf_rcomm f) p 1 + + definition Prod (s : finset A) (f : A → B) : B := + quot.lift_on s + (λ l, Prodl (elt_of l) f) + (λ l₁ l₂ p, Prodl_eq_Prodl_of_perm f p) + + -- ∏ x ∈ s, f x + notation `∏` binders `∈` s `, ` r:(scoped f, Prod s f) := r + + theorem Prod_empty (f : A → B) : Prod ∅ f = 1 := + Prodl_nil f + + theorem Prod_mul (s : finset A) (f g : A → B) : Prod s (λx, f x * g x) = Prod s f * Prod s g := + quot.induction_on s (take u, !Prodl_mul) + + theorem Prod_one (s : finset A) : Prod s (λ x, 1) = (1:B) := + quot.induction_on s (take u, !Prodl_one) + + section deceqA + include deceqA + + theorem Prod_insert_of_mem (f : A → B) {a : A} {s : finset A} : + a ∈ s → Prod (insert a s) f = Prod s f := + quot.induction_on s + (λ l ainl, Prodl_insert_of_mem f ainl) + + theorem Prod_insert_of_not_mem (f : A → B) {a : A} {s : finset A} : + a ∉ s → Prod (insert a s) f = f a * Prod s f := + quot.induction_on s + (λ l nainl, Prodl_insert_of_not_mem f nainl) + + theorem Prod_union (f : A → B) {s₁ s₂ : finset A} (disj : s₁ ∩ s₂ = ∅) : + Prod (s₁ ∪ s₂) f = Prod s₁ f * Prod s₂ f := + have H1 : disjoint s₁ s₂ → Prod (s₁ ∪ s₂) f = Prod s₁ f * Prod s₂ f, from + quot.induction_on₂ s₁ s₂ + (λ l₁ l₂ d, Prodl_union f d), + H1 (disjoint_of_inter_eq_empty disj) + + theorem Prod_ext {s : finset A} {f g : A → B} : + (∀{x}, x ∈ s → f x = g x) → Prod s f = Prod s g := + finset.induction_on s + (assume H, rfl) + (take x s', assume H1 : x ∉ s', + assume IH : (∀ {x : A}, x ∈ s' → f x = g x) → Prod s' f = Prod s' g, + assume H2 : ∀{y}, y ∈ insert x s' → f y = g y, + have H3 : ∀y, y ∈ s' → f y = g y, from + take y, assume H', H2 (mem_insert_of_mem _ H'), + have H4 : f x = g x, from H2 !mem_insert, + by rewrite [Prod_insert_of_not_mem f H1, Prod_insert_of_not_mem g H1, IH H3, H4]) + + theorem Prod_singleton (a : A) (f : A → B) : Prod '{a} f = f a := + have a ∉ ∅, from not_mem_empty a, + by rewrite [Prod_insert_of_not_mem f this, Prod_empty, mul_one] + + theorem Prod_image {C : Type} [deceqC : decidable_eq C] {s : finset A} (f : C → B) {g : A → C} + (H : set.inj_on g (to_set s)) : + (∏ j ∈ image g s, f j) = (∏ i ∈ s, f (g i)) := + begin + induction s with a s anins ih, + {rewrite [*Prod_empty]}, + have injg : set.inj_on g (to_set s), + from set.inj_on_of_inj_on_of_subset H (λ x, mem_insert_of_mem a), + have g a ∉ g ' s, from + suppose g a ∈ g ' s, + obtain b [(bs : b ∈ s) (gbeq : g b = g a)], from exists_of_mem_image this, + have aias : set.mem a (to_set (insert a s)), + by rewrite to_set_insert; apply set.mem_insert a s, + have bias : set.mem b (to_set (insert a s)), + by rewrite to_set_insert; apply set.mem_insert_of_mem; exact bs, + have b = a, from H bias aias gbeq, + show false, from anins (eq.subst this bs), + rewrite [image_insert, Prod_insert_of_not_mem _ this, Prod_insert_of_not_mem _ anins, ih injg] + end + + theorem Prod_eq_of_bij_on {C : Type} [deceqC : decidable_eq C] {s : finset A} {t : finset C} + (f : C → B) {g : A → C} (H : set.bij_on g (to_set s) (to_set t)) : + (∏ j ∈ t, f j) = (∏ i ∈ s, f (g i)) := + have g ' s = t, + by apply eq_of_to_set_eq_to_set; rewrite to_set_image; exact set.image_eq_of_bij_on H, + using this, by rewrite [-this, Prod_image f (and.left (and.right H))] + end deceqA +end finset + +/- Sum: sum indexed by a finset -/ + +namespace finset + variable [add_comm_monoid B] + local attribute add_comm_monoid.to_comm_monoid [trans_instance] + + definition Sum (s : finset A) (f : A → B) : B := Prod s f + + -- ∑ x ∈ s, f x + notation `∑` binders `∈` s `, ` r:(scoped f, Sum s f) := r + + theorem Sum_empty (f : A → B) : Sum ∅ f = 0 := Prod_empty f + theorem Sum_add (s : finset A) (f g : A → B) : + Sum s (λx, f x + g x) = Sum s f + Sum s g := Prod_mul s f g + theorem Sum_zero (s : finset A) : Sum s (λ x, 0) = (0:B) := Prod_one s + + section deceqA + include deceqA + theorem Sum_insert_of_mem (f : A → B) {a : A} {s : finset A} (H : a ∈ s) : + Sum (insert a s) f = Sum s f := Prod_insert_of_mem f H + theorem Sum_insert_of_not_mem (f : A → B) {a : A} {s : finset A} (H : a ∉ s) : + Sum (insert a s) f = f a + Sum s f := Prod_insert_of_not_mem f H + theorem Sum_union (f : A → B) {s₁ s₂ : finset A} (disj : s₁ ∩ s₂ = ∅) : + Sum (s₁ ∪ s₂) f = Sum s₁ f + Sum s₂ f := Prod_union f disj + theorem Sum_ext {s : finset A} {f g : A → B} (H : ∀x, x ∈ s → f x = g x) : + Sum s f = Sum s g := Prod_ext H + theorem Sum_singleton (a : A) (f : A → B) : Sum '{a} f = f a := Prod_singleton a f + + theorem Sum_image {C : Type} [deceqC : decidable_eq C] {s : finset A} (f : C → B) {g : A → C} + (H : set.inj_on g (to_set s)) : + (∑ j ∈ image g s, f j) = (∑ i ∈ s, f (g i)) := Prod_image f H + theorem Sum_eq_of_bij_on {C : Type} [deceqC : decidable_eq C] {s : finset A} {t : finset C} + (f : C → B) {g : A → C} (H : set.bij_on g (to_set s) (to_set t)) : + (∑ j ∈ t, f j) = (∑ i ∈ s, f (g i)) := Prod_eq_of_bij_on f H + end deceqA +end finset + +/- +-- set versions +-/ + +namespace set +local attribute classical.prop_decidable [instance] + +/- Prod: product indexed by a set -/ + +section Prod + variable [comm_monoid B] + + noncomputable definition Prod (s : set A) (f : A → B) : B := finset.Prod (to_finset s) f + + -- ∏ x ∈ s, f x + notation `∏` binders `∈` s `, ` r:(scoped f, Prod s f) := r + + theorem Prod_empty (f : A → B) : Prod ∅ f = 1 := + by rewrite [↑Prod, to_finset_empty] + + theorem Prod_of_not_finite {s : set A} (nfins : ¬ finite s) (f : A → B) : Prod s f = 1 := + by rewrite [↑Prod, to_finset_of_not_finite nfins] + + theorem Prod_mul (s : set A) (f g : A → B) : Prod s (λx, f x * g x) = Prod s f * Prod s g := + by rewrite [↑Prod, finset.Prod_mul] + + theorem Prod_one (s : set A) : Prod s (λ x, 1) = (1:B) := + by rewrite [↑Prod, finset.Prod_one] + + theorem Prod_insert_of_mem (f : A → B) {a : A} {s : set A} (H : a ∈ s) : + Prod (insert a s) f = Prod s f := + by_cases + (suppose finite s, + have (#finset a ∈ set.to_finset s), by rewrite mem_to_finset_eq; apply H, + by rewrite [↑Prod, to_finset_insert, finset.Prod_insert_of_mem f this]) + (assume nfs : ¬ finite s, + have ¬ finite (insert a s), from assume H, nfs (finite_of_finite_insert H), + by rewrite [Prod_of_not_finite nfs, Prod_of_not_finite this]) + + theorem Prod_insert_of_not_mem (f : A → B) {a : A} {s : set A} [finite s] (H : a ∉ s) : + Prod (insert a s) f = f a * Prod s f := + have (#finset a ∉ set.to_finset s), by rewrite mem_to_finset_eq; apply H, + by rewrite [↑Prod, to_finset_insert, finset.Prod_insert_of_not_mem f this] + + theorem Prod_union (f : A → B) {s₁ s₂ : set A} [finite s₁] [finite s₂] + (disj : s₁ ∩ s₂ = ∅) : + Prod (s₁ ∪ s₂) f = Prod s₁ f * Prod s₂ f := + begin + rewrite [↑Prod, to_finset_union], + apply finset.Prod_union, + apply finset.eq_of_to_set_eq_to_set, + rewrite [finset.to_set_inter, *to_set_to_finset, finset.to_set_empty, disj] + end + + theorem Prod_ext {s : set A} {f g : A → B} (H : ∀{x}, x ∈ s → f x = g x) : Prod s f = Prod s g := + by_cases + (suppose finite s, + by esimp [Prod]; apply finset.Prod_ext; intro x; rewrite [mem_to_finset_eq]; apply H) + (assume nfs : ¬ finite s, + by rewrite [*Prod_of_not_finite nfs]) + + theorem Prod_singleton (a : A) (f : A → B) : Prod '{a} f = f a := + by rewrite [↑Prod, to_finset_insert, to_finset_empty, finset.Prod_singleton] + + theorem Prod_image {C : Type} {s : set A} [fins : finite s] (f : C → B) {g : A → C} + (H : inj_on g s) : + (∏ j ∈ image g s, f j) = (∏ i ∈ s, f (g i)) := + begin + have H' : inj_on g (finset.to_set (set.to_finset s)), by rewrite to_set_to_finset; exact H, + rewrite [↑Prod, to_finset_image g s, finset.Prod_image f H'] + end + + theorem Prod_eq_of_bij_on {C : Type} {s : set A} {t : set C} (f : C → B) + {g : A → C} (H : bij_on g s t) : + (∏ j ∈ t, f j) = (∏ i ∈ s, f (g i)) := + by_cases + (suppose finite s, + have g ' s = t, from image_eq_of_bij_on H, + using this, by rewrite [-this, Prod_image f (and.left (and.right H))]) + (assume nfins : ¬ finite s, + have nfint : ¬ finite t, from + suppose finite t, + have finite s, from finite_of_bij_on' H, + show false, from nfins this, + by rewrite [Prod_of_not_finite nfins, Prod_of_not_finite nfint]) +end Prod + +/- Sum: sum indexed by a set -/ + +section Sum + variable [add_comm_monoid B] + local attribute add_comm_monoid.to_comm_monoid [trans_instance] + + noncomputable definition Sum (s : set A) (f : A → B) : B := Prod s f + + proposition Sum_def (s : set A) (f : A → B) : Sum s f = finset.Sum (to_finset s) f := rfl + + -- ∑ x ∈ s, f x + notation `∑` binders `∈` s `, ` r:(scoped f, Sum s f) := r + + theorem Sum_empty (f : A → B) : Sum ∅ f = 0 := Prod_empty f + theorem Sum_of_not_finite {s : set A} (nfins : ¬ finite s) (f : A → B) : Sum s f = 0 := + Prod_of_not_finite nfins f + theorem Sum_add (s : set A) (f g : A → B) : + Sum s (λx, f x + g x) = Sum s f + Sum s g := Prod_mul s f g + theorem Sum_zero (s : set A) : Sum s (λ x, 0) = (0:B) := Prod_one s + + theorem Sum_insert_of_mem (f : A → B) {a : A} {s : set A} (H : a ∈ s) : + Sum (insert a s) f = Sum s f := Prod_insert_of_mem f H + theorem Sum_insert_of_not_mem (f : A → B) {a : A} {s : set A} [finite s] (H : a ∉ s) : + Sum (insert a s) f = f a + Sum s f := Prod_insert_of_not_mem f H + theorem Sum_union (f : A → B) {s₁ s₂ : set A} [finite s₁] [finite s₂] + (disj : s₁ ∩ s₂ = ∅) : + Sum (s₁ ∪ s₂) f = Sum s₁ f + Sum s₂ f := Prod_union f disj + theorem Sum_ext {s : set A} {f g : A → B} (H : ∀x, x ∈ s → f x = g x) : + Sum s f = Sum s g := Prod_ext H + + theorem Sum_singleton (a : A) (f : A → B) : Sum '{a} f = f a := + Prod_singleton a f + + theorem Sum_image {C : Type} {s : set A} [fins : finite s] (f : C → B) {g : A → C} + (H : inj_on g s) : + (∑ j ∈ image g s, f j) = (∑ i ∈ s, f (g i)) := Prod_image f H + theorem Sum_eq_of_bij_on {C : Type} {s : set A} {t : set C} (f : C → B) {g : A → C} + (H : bij_on g s t) : + (∑ j ∈ t, f j) = (∑ i ∈ s, f (g i)) := Prod_eq_of_bij_on f H +end Sum + +/- Prod_semigroup : product indexed by a set, with a default for the empty set -/ + +namespace Prod_semigroup + variable [comm_semigroup B] + + noncomputable definition Prod_semigroup (dflt : B) (s : set A) (f : A → B) : B := + finset.Prod_semigroup.Prod_semigroup dflt (to_finset s) f + + theorem Prod_semigroup_empty (dflt : B) (f : A → B) : Prod_semigroup dflt ∅ f = dflt := + by rewrite [↑Prod_semigroup, to_finset_empty] + + theorem Prod_semigroup_of_not_finite (dflt : B) {s : set A} (nfins : ¬ finite s) (f : A → B) : + Prod_semigroup dflt s f = dflt := + by rewrite [↑Prod_semigroup, to_finset_of_not_finite nfins] + + theorem Prod_semigroup_singleton (dflt : B) (f : A → B) (a : A) : + Prod_semigroup dflt ('{a}) f = f a := + by rewrite [↑Prod_semigroup, to_finset_insert, to_finset_empty, + finset.Prod_semigroup.Prod_semigroup_singleton dflt f a] + + theorem Prod_semigroup_insert_insert (dflt : B) (f : A → B) {a₁ a₂ : A} {s : set A} + [h : finite s] : + a₂ ∉ s → a₁ ∉ insert a₂ s → + Prod_semigroup dflt (insert a₁ (insert a₂ s)) f = + f a₁ * Prod_semigroup dflt (insert a₂ s) f := + begin + rewrite [↑Prod_semigroup, -+mem_to_finset_eq, +to_finset_insert], + intro h1 h2, + apply finset.Prod_semigroup.Prod_semigroup_insert_insert dflt f h1 h2 + end + + theorem Prod_semigroup_insert (dflt : B) (f : A → B) {a : A} {s : set A} [h : finite s] : + a ∉ s → s ≠ ∅ → Prod_semigroup dflt (insert a s) f = f a * Prod_semigroup dflt s f := + begin + rewrite [↑Prod_semigroup, -mem_to_finset_eq, +to_finset_insert, -finset.to_set_empty], + intro h1 h2, + apply finset.Prod_semigroup.Prod_semigroup_insert dflt f h1, + intro h3, revert h2, rewrite [-h3, to_set_to_finset], + intro h4, exact (h4 rfl) + end + +end Prod_semigroup + +end set diff --git a/old_library/algebra/group_power.lean b/old_library/algebra/group_power.lean new file mode 100644 index 0000000000..df414e4320 --- /dev/null +++ b/old_library/algebra/group_power.lean @@ -0,0 +1,264 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +The power operation on monoids and groups. We separate this from group, because it depends on +nat, which in turn depends on other parts of algebra. + +We have "pow a n" for natural number powers, and "gpow a i" for integer powers. The notation +a^n is used for the first, but users can locally redefine it to gpow when needed. + +Note: power adopts the convention that 0^0=1. +-/ +import data.nat.basic data.int.basic + +variables {A : Type} + +structure has_pow_nat [class] (A : Type) := +(pow_nat : A → nat → A) + +definition pow_nat {A : Type} [s : has_pow_nat A] : A → nat → A := +has_pow_nat.pow_nat + +infix ` ^ ` := pow_nat + +structure has_pow_int [class] (A : Type) := +(pow_int : A → int → A) + +definition pow_int {A : Type} [s : has_pow_int A] : A → int → A := +has_pow_int.pow_int + + /- monoid -/ +section monoid +open nat + +variable [s : monoid A] +include s + +definition monoid.pow (a : A) : ℕ → A +| 0 := 1 +| (n+1) := a * monoid.pow n + +attribute [instance] +definition monoid_has_pow_nat : has_pow_nat A := +has_pow_nat.mk monoid.pow + +theorem pow_zero (a : A) : a^0 = 1 := rfl +theorem pow_succ (a : A) (n : ℕ) : a^(succ n) = a * a^n := rfl + +theorem pow_one (a : A) : a^1 = a := !mul_one +theorem pow_two (a : A) : a^2 = a * a := +calc + a^2 = a * (a * 1) : rfl + ... = a * a : mul_one +theorem pow_three (a : A) : a^3 = a * (a * a) := +calc + a^3 = a * (a * (a * 1)) : rfl + ... = a * (a * a) : mul_one +theorem pow_four (a : A) : a^4 = a * (a * (a * a)) := +calc + a^4 = a * a^3 : rfl + ... = a * (a * (a * a)) : pow_three + +theorem pow_succ' (a : A) : ∀n, a^(succ n) = a^n * a +| 0 := by rewrite [pow_succ, *pow_zero, one_mul, mul_one] +| (succ n) := by rewrite [pow_succ, pow_succ' at {1}, pow_succ, mul.assoc] + +theorem one_pow : ∀ n : ℕ, 1^n = (1:A) +| 0 := rfl +| (succ n) := by rewrite [pow_succ, one_mul, one_pow] + +theorem pow_add (a : A) (m n : ℕ) : a^(m + n) = a^m * a^n := +begin + induction n with n ih, + {krewrite [nat.add_zero, pow_zero, mul_one]}, + rewrite [add_succ, *pow_succ', ih, mul.assoc] +end + +theorem pow_mul (a : A) (m : ℕ) : ∀ n, a^(m * n) = (a^m)^n +| 0 := by rewrite [nat.mul_zero, pow_zero] +| (succ n) := by rewrite [nat.mul_succ, pow_add, pow_succ', pow_mul] + +theorem pow_comm (a : A) (m n : ℕ) : a^m * a^n = a^n * a^m := +by rewrite [-*pow_add, add.comm] + +end monoid + +/- commutative monoid -/ + +section comm_monoid +open nat +variable [s : comm_monoid A] +include s + +theorem mul_pow (a b : A) : ∀ n, (a * b)^n = a^n * b^n +| 0 := by rewrite [*pow_zero, mul_one] +| (succ n) := by rewrite [*pow_succ', mul_pow, *mul.assoc, mul.left_comm a] + +end comm_monoid + +section group +variable [s : group A] +include s + +section nat +open nat +theorem inv_pow (a : A) : ∀n, (a⁻¹)^n = (a^n)⁻¹ +| 0 := by rewrite [*pow_zero, one_inv] +| (succ n) := by rewrite [pow_succ, pow_succ', inv_pow, mul_inv] + +theorem pow_sub (a : A) {m n : ℕ} (H : m ≥ n) : a^(m - n) = a^m * (a^n)⁻¹ := +have H1 : m - n + n = m, from nat.sub_add_cancel H, +have H2 : a^(m - n) * a^n = a^m, by rewrite [-pow_add, H1], +eq_mul_inv_of_mul_eq H2 + +theorem pow_inv_comm (a : A) : ∀m n, (a⁻¹)^m * a^n = a^n * (a⁻¹)^m +| 0 n := by rewrite [*pow_zero, one_mul, mul_one] +| m 0 := by rewrite [*pow_zero, one_mul, mul_one] +| (succ m) (succ n) := by rewrite [pow_succ' at {1}, pow_succ at {1}, pow_succ', pow_succ, + *mul.assoc, inv_mul_cancel_left, mul_inv_cancel_left, pow_inv_comm] + +end nat + +open int + +definition gpow (a : A) : ℤ → A +| (of_nat n) := a^n +| -[1+n] := (a^(nat.succ n))⁻¹ + +open nat + +private lemma gpow_add_aux (a : A) (m n : nat) : + gpow a ((of_nat m) + -[1+n]) = gpow a (of_nat m) * gpow a (-[1+n]) := +or.elim (nat.lt_or_ge m (nat.succ n)) + (assume H : (m < nat.succ n), + have H1 : (#nat nat.succ n - m > nat.zero), from nat.sub_pos_of_lt H, + calc + gpow a ((of_nat m) + -[1+n]) = gpow a (sub_nat_nat m (nat.succ n)) : rfl + ... = gpow a (-[1+ nat.pred (nat.sub (nat.succ n) m)]) : {sub_nat_nat_of_lt H} + ... = (a ^ (nat.succ (nat.pred (nat.sub (nat.succ n) m))))⁻¹ : rfl + ... = (a ^ (nat.succ n) * (a ^ m)⁻¹)⁻¹ : + by krewrite [succ_pred_of_pos H1, pow_sub a (nat.le_of_lt H)] + ... = a ^ m * (a ^ (nat.succ n))⁻¹ : + by rewrite [mul_inv, inv_inv] + ... = gpow a (of_nat m) * gpow a (-[1+n]) : rfl) + (assume H : (m ≥ nat.succ n), + calc + gpow a ((of_nat m) + -[1+n]) = gpow a (sub_nat_nat m (nat.succ n)) : rfl + ... = gpow a (#nat m - nat.succ n) : {sub_nat_nat_of_ge H} + ... = a ^ m * (a ^ (nat.succ n))⁻¹ : pow_sub a H + ... = gpow a (of_nat m) * gpow a (-[1+n]) : rfl) + +theorem gpow_add (a : A) : ∀i j : int, gpow a (i + j) = gpow a i * gpow a j +| (of_nat m) (of_nat n) := !pow_add +| (of_nat m) -[1+n] := !gpow_add_aux +| -[1+m] (of_nat n) := by rewrite [add.comm, gpow_add_aux, ↑gpow, -*inv_pow, pow_inv_comm] +| -[1+m] -[1+n] := + calc + gpow a (-[1+m] + -[1+n]) = (a^(#nat nat.succ m + nat.succ n))⁻¹ : rfl + ... = (a^(nat.succ m))⁻¹ * (a^(nat.succ n))⁻¹ : by rewrite [pow_add, pow_comm, mul_inv] + ... = gpow a (-[1+m]) * gpow a (-[1+n]) : rfl + +theorem gpow_comm (a : A) (i j : ℤ) : gpow a i * gpow a j = gpow a j * gpow a i := +by rewrite [-*gpow_add, add.comm] +end group + +section ordered_ring +open nat +variable [s : linear_ordered_ring A] +include s + +theorem pow_pos {a : A} (H : a > 0) (n : ℕ) : a ^ n > 0 := + begin + induction n, + krewrite pow_zero, + apply zero_lt_one, + rewrite pow_succ', + apply mul_pos, + apply v_0, apply H + end + +theorem pow_ge_one_of_ge_one {a : A} (H : a ≥ 1) (n : ℕ) : a ^ n ≥ 1 := + begin + induction n, + krewrite pow_zero, + apply le.refl, + rewrite [pow_succ', -mul_one 1], + apply mul_le_mul v_0 H zero_le_one, + apply le_of_lt, + apply pow_pos, + apply gt_of_ge_of_gt H zero_lt_one + end + +theorem pow_two_add (n : ℕ) : (2:A)^n + 2^n = 2^(succ n) := + by rewrite [pow_succ', -one_add_one_eq_two, left_distrib, *mul_one] + +end ordered_ring + +/- additive monoid -/ + +section add_monoid +variable [s : add_monoid A] +include s +local attribute add_monoid.to_monoid [trans_instance] +open nat + +definition nmul : ℕ → A → A := λ n a, a^n + +infix [priority algebra.prio] `⬝` := nmul + +theorem zero_nmul (a : A) : (0:ℕ) ⬝ a = 0 := pow_zero a +theorem succ_nmul (n : ℕ) (a : A) : nmul (succ n) a = a + (nmul n a) := pow_succ a n + +theorem succ_nmul' (n : ℕ) (a : A) : succ n ⬝ a = nmul n a + a := pow_succ' a n + +theorem nmul_zero (n : ℕ) : n ⬝ 0 = (0:A) := one_pow n + +theorem one_nmul (a : A) : 1 ⬝ a = a := pow_one a + +theorem add_nmul (m n : ℕ) (a : A) : (m + n) ⬝ a = (m ⬝ a) + (n ⬝ a) := pow_add a m n + +theorem mul_nmul (m n : ℕ) (a : A) : (m * n) ⬝ a = m ⬝ (n ⬝ a) := eq.subst (mul.comm n m) (pow_mul a n m) + +theorem nmul_comm (m n : ℕ) (a : A) : (m ⬝ a) + (n ⬝ a) = (n ⬝ a) + (m ⬝ a) := pow_comm a m n + +end add_monoid + +/- additive commutative monoid -/ + +section add_comm_monoid +open nat +variable [s : add_comm_monoid A] +include s +local attribute add_comm_monoid.to_comm_monoid [trans_instance] + +theorem nmul_add (n : ℕ) (a b : A) : n ⬝ (a + b) = (n ⬝ a) + (n ⬝ b) := mul_pow a b n + +end add_comm_monoid + +section add_group +variable [s : add_group A] +include s +local attribute add_group.to_group [trans_instance] + +section nat +open nat +theorem nmul_neg (n : ℕ) (a : A) : n ⬝ (-a) = -(n ⬝ a) := inv_pow a n + +theorem sub_nmul {m n : ℕ} (a : A) (H : m ≥ n) : (m - n) ⬝ a = (m ⬝ a) + -(n ⬝ a) := pow_sub a H + +theorem nmul_neg_comm (m n : ℕ) (a : A) : (m ⬝ (-a)) + (n ⬝ a) = (n ⬝ a) + (m ⬝ (-a)) := pow_inv_comm a m n + +end nat + +open int + +definition imul : ℤ → A → A := λ i a, gpow a i + +theorem add_imul (i j : ℤ) (a : A) : imul (i + j) a = imul i a + imul j a := + gpow_add a i j + +theorem imul_comm (i j : ℤ) (a : A) : imul i a + imul j a = imul j a + imul i a := gpow_comm a i j + +end add_group diff --git a/old_library/algebra/homomorphism.lean b/old_library/algebra/homomorphism.lean new file mode 100644 index 0000000000..d26d9d6cd2 --- /dev/null +++ b/old_library/algebra/homomorphism.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2016 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad + +Homomorphisms between structures: + + is_add_hom : structures with has_add + is_mul_hom : structures with has_mul + is_module_hom : structures with has_add, has_smul + is_ring_hom : structures with has_add, has_mul + +If you are working with a one particular kind of homomorphism, e.g. multiplicative, we recommend + + local abbreviation is_hom := @is_mul_hom + +These are all tentatively declared as type classes. The theorems which infer id and compose +as instances are *not*, however, declared as instances: the first is rarely useful and the +second makes class inference loop. + +Type class inference is useful here because usually a hypothesis like is_hom f is in the context. +If you need an instance that the system does not infer, simply put it in the context, e.g. + + assert is_hom f, from ..., + ... +-/ +import algebra.module data.set +open function set + +variables {A B C : Type} + +/- additive structures -/ + +definition add_ker [has_zero B] (f : A → B) : set A := {a | f a = 0} + +proposition add_ker_eq [has_zero B] (f : A → B) : add_ker f = f '- '{0} := +ext (take x, iff.intro + (assume H, mem_preimage (mem_singleton_of_eq H)) + (assume H, eq_of_mem_singleton (mem_of_mem_preimage H))) + +structure is_add_hom [class] [has_add A] [has_add B] (f : A → B) : Prop := +(hom_add : ∀ a₁ a₂, f (a₁ + a₂) = f a₁ + f a₂) + +proposition hom_add [has_add A] [has_add B] (f : A → B) [H : is_add_hom f] (a₁ a₂ : A) : + f (a₁ + a₂) = f a₁ + f a₂ := is_add_hom.hom_add _ _ f a₁ a₂ + +proposition is_add_hom_id [has_add A] : is_add_hom (@id A) := +is_add_hom.mk (take a₁ a₂, rfl) + +proposition is_add_hom_comp [has_add A] [has_add B] [has_add C] + {f : B → C} {g : A → B} [is_add_hom f] [is_add_hom g] : is_add_hom (f ∘ g) := +is_add_hom.mk (take a₁ a₂, by esimp; rewrite *hom_add) + +section add_group_A_B + variables [add_group A] [add_group B] + + proposition hom_zero (f : A → B) [is_add_hom f] : + f (0 : A) = 0 := + have f 0 + f 0 = f 0 + 0, by rewrite [-hom_add f, +add_zero], + eq_of_add_eq_add_left this + + proposition hom_neg (f : A → B) [is_add_hom f] (a : A) : + f (- a) = - f a := + have f (- a) + f a = 0, by rewrite [-hom_add f, add.left_inv, hom_zero], + eq_neg_of_add_eq_zero this + + proposition hom_sub (f : A → B) [is_add_hom f] (a₁ a₂ : A) : + f (a₁ - a₂) = f a₁ - f a₂ := + by rewrite [*sub_eq_add_neg, *hom_add, hom_neg] + + proposition injective_hom_add [add_group B] {f : A → B} [is_add_hom f] + (H : ∀ x, f x = 0 → x = 0) : + injective f := + take x₁ x₂, + suppose f x₁ = f x₂, + have f (x₁ - x₂) = 0, by rewrite [hom_sub, this, sub_self], + have x₁ - x₂ = 0, from H _ this, + eq_of_sub_eq_zero this + + proposition eq_zero_of_injective_hom [add_group B] {f : A → B} [is_add_hom f] + (injf : injective f) {a : A} (fa0 : f a = 0) : + a = 0 := + have f a = f 0, by rewrite [fa0, hom_zero], + show a = 0, from injf this +end add_group_A_B + +/- multiplicative structures -/ + +definition mul_ker [has_one B] (f : A → B) : set A := {a | f a = 1} + +proposition mul_ker_eq [has_one B] (f : A → B) : mul_ker f = f '- '{1} := +ext (take x, iff.intro + (assume H, mem_preimage (mem_singleton_of_eq H)) + (assume H, eq_of_mem_singleton (mem_of_mem_preimage H))) + +structure is_mul_hom [class] [has_mul A] [has_mul B] (f : A → B) : Prop := +(hom_mul : ∀ a₁ a₂, f (a₁ * a₂) = f a₁ * f a₂) + +proposition hom_mul [has_mul A] [has_mul B] (f : A → B) [H : is_mul_hom f] (a₁ a₂ : A) : + f (a₁ * a₂) = f a₁ * f a₂ := is_mul_hom.hom_mul _ _ f a₁ a₂ + +proposition is_mul_hom_id [has_mul A] : is_mul_hom (@id A) := +is_mul_hom.mk (take a₁ a₂, rfl) + +proposition is_mul_hom_comp [has_mul A] [has_mul B] [has_mul C] + {f : B → C} {g : A → B} [is_mul_hom f] [is_mul_hom g] : is_mul_hom (f ∘ g) := +is_mul_hom.mk (take a₁ a₂, by esimp; rewrite *hom_mul) + +section group_A_B + variables [group A] [group B] + + proposition hom_one (f : A → B) [is_mul_hom f] : + f (1 : A) = 1 := + have f 1 * f 1 = f 1 * 1, by rewrite [-hom_mul f, *mul_one], + eq_of_mul_eq_mul_left' this + + proposition hom_inv (f : A → B) [is_mul_hom f] (a : A) : + f (a⁻¹) = (f a)⁻¹ := + have f (a⁻¹) * f a = 1, by rewrite [-hom_mul f, mul.left_inv, hom_one], + eq_inv_of_mul_eq_one this + + proposition injective_hom_mul [group B] {f : A → B} [is_mul_hom f] + (H : ∀ x, f x = 1 → x = 1) : + injective f := + take x₁ x₂, + suppose f x₁ = f x₂, + have f (x₁ * x₂⁻¹) = 1, by rewrite [hom_mul, hom_inv, this, mul.right_inv], + have x₁ * x₂⁻¹ = 1, from H _ this, + eq_of_mul_inv_eq_one this + + proposition eq_one_of_injective_hom [group B] {f : A → B} [is_mul_hom f] + (injf : injective f) {a : A} (fa1 : f a = 1) : + a = 1 := + have f a = f 1, by rewrite [fa1, hom_one], + show a = 1, from injf this +end group_A_B + +/- modules -/ + +structure is_module_hom [class] (R : Type) {M₁ M₂ : Type} + [has_scalar R M₁] [has_scalar R M₂] [has_add M₁] [has_add M₂] + (f : M₁ → M₂) extends is_add_hom f := +(hom_smul : ∀ r : R, ∀ a : M₁, f (r • a) = r • f a) + +section module_hom + variables {R : Type} {M₁ M₂ M₃ : Type} + variables [has_scalar R M₁] [has_scalar R M₂] [has_scalar R M₃] + variables [has_add M₁] [has_add M₂] [has_add M₃] + variables (g : M₂ → M₃) (f : M₁ → M₂) [is_module_hom R g] [is_module_hom R f] + + proposition hom_smul (r : R) (a : M₁) : f (r • a) = r • f a := + is_module_hom.hom_smul _ _ _ _ f r a + + proposition is_module_hom_id : is_module_hom R (@id M₁) := + is_module_hom.mk (λ a₁ a₂, rfl) (λ r a, rfl) + + proposition is_module_hom_comp : is_module_hom R (g ∘ f) := + is_module_hom.mk + (take a₁ a₂, by esimp; rewrite *hom_add) + (take r a, by esimp; rewrite [hom_smul f, hom_smul g]) + + proposition hom_smul_add_smul (a b : R) (u v : M₁) : f (a • u + b • v) = a • f u + b • f v := + by rewrite [hom_add, +hom_smul f] +end module_hom + +/- rings -/ + +structure is_ring_hom [class] {R₁ R₂ : Type} [has_mul R₁] [has_mul R₂] [has_add R₁] [has_add R₂] + (f : R₁ → R₂) extends is_add_hom f, is_mul_hom f + +section semiring + variables {R₁ R₂ R₃ : Type} [semiring R₁] [semiring R₂] [semiring R₃] + variables (g : R₂ → R₃) (f : R₁ → R₂) [is_ring_hom g] [is_ring_hom f] + + proposition is_ring_hom_id : is_ring_hom (@id R₁) := + is_ring_hom.mk (λ a₁ a₂, rfl) (λ a₁ a₂, rfl) + + proposition is_ring_hom_comp : is_ring_hom (g ∘ f) := + is_ring_hom.mk + (take a₁ a₂, by esimp; rewrite *hom_add) + (take r a, by esimp; rewrite [hom_mul f, hom_mul g]) + + proposition hom_mul_add_mul (a b c d : R₁) : f (a * b + c * d) = f a * f b + f c * f d := + by rewrite [hom_add, +hom_mul] +end semiring diff --git a/old_library/algebra/interval.lean b/old_library/algebra/interval.lean new file mode 100644 index 0000000000..82372f13cf --- /dev/null +++ b/old_library/algebra/interval.lean @@ -0,0 +1,187 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Notation for intervals and some properties. + +The mnemonic: o = open, c = closed, i = infinity. For example, Ioi a b is '(a, ∞). +-/ +import .order data.set +open set + +namespace interval + +section order_pair +variables {A : Type} [order_pair A] + +definition Ioo (a b : A) : set A := {x | a < x ∧ x < b} +definition Ioc (a b : A) : set A := {x | a < x ∧ x ≤ b} +definition Ico (a b : A) : set A := {x | a ≤ x ∧ x < b} +definition Icc (a b : A) : set A := {x | a ≤ x ∧ x ≤ b} +definition Ioi (a : A) : set A := {x | a < x} +definition Ici (a : A) : set A := {x | a ≤ x} +definition Iio (b : A) : set A := {x | x < b} +definition Iic (b : A) : set A := {x | x ≤ b} + +notation `'(` a `, ` b `)` := Ioo a b +notation `'(` a `, ` b `]` := Ioc a b +notation `'[` a `, ` b `)` := Ico a b +notation `'[` a `, ` b `]` := Icc a b +notation `'(` a `, ` `∞` `)` := Ioi a +notation `'[` a `, ` `∞` `)` := Ici a +notation `'(` `-∞` `, ` b `)` := Iio b +notation `'(` `-∞` `, ` b `]` := Iic b + +variables a b : A + +proposition Ioi_inter_Iio : '(a, ∞) ∩ '(-∞, b) = '(a, b) := rfl +proposition Ici_inter_Iio : '[a, ∞) ∩ '(-∞, b) = '[a, b) := rfl +proposition Ioi_inter_Iic : '(a, ∞) ∩ '(-∞, b] = '(a, b] := rfl +proposition Ioc_inter_Iic : '[a, ∞) ∩ '(-∞, b] = '[a, b] := rfl + +proposition Icc_self : '[a, a] = '{a} := +set.ext (take x, iff.intro + (suppose x ∈ '[a, a], + have x = a, from le.antisymm (and.right this) (and.left this), + show x ∈ '{a}, from mem_singleton_of_eq this) + (suppose x ∈ '{a}, + have x = a, from eq_of_mem_singleton this, + show a ≤ x ∧ x ≤ a, from and.intro (eq.subst this !le.refl) (eq.subst this !le.refl))) + +proposition Icc_eq_empty {a b : A} (H : b < a) : '[a, b] = ∅ := +eq_empty_of_forall_not_mem + (take x, suppose x ∈ '[a, b], + have a ≤ b, from le.trans (and.left this) (and.right this), + not_le_of_gt H this) + +end order_pair + +section strong_order_pair + +variables {A : Type} [linear_strong_order_pair A] + +proposition compl_Ici (a : A) : -'[a, ∞) = '(-∞, a) := +ext (take x, iff.intro + (assume H, lt_of_not_ge H) + (assume H, not_le_of_gt H)) + +proposition compl_Iic (a : A) : -'(-∞, a] = '(a, ∞) := +ext (take x, iff.intro + (assume H, lt_of_not_ge H) + (assume H, not_le_of_gt H)) + +proposition compl_Ioi (a : A) : -'(a, ∞) = '(-∞, a] := +ext (take x, iff.intro + (assume H, le_of_not_gt H) + (assume H, not_lt_of_ge H)) + +proposition compl_Iio (a : A) : -'(-∞, a) = '[a, ∞) := +ext (take x, iff.intro + (assume H, le_of_not_gt H) + (assume H, not_lt_of_ge H)) + +proposition Icc_eq_Icc_union_Ioc {a b c : A} (H1 : a ≤ b) (H2 : b ≤ c) : + '[a, c] = '[a, b] ∪ '(b, c] := +set.ext (take x, iff.intro + (assume H3 : x ∈ '[a, c], + or.elim (le_or_gt x b) + (suppose x ≤ b, + or.inl (and.intro (and.left H3) this)) + (suppose x > b, + or.inr (and.intro this (and.right H3)))) + (suppose x ∈ '[a, b] ∪ '(b, c], + or.elim this + (suppose x ∈ '[a, b], + and.intro (and.left this) (le.trans (and.right this) H2)) + (suppose x ∈ '(b, c], + and.intro (le_of_lt (lt_of_le_of_lt H1 (and.left this))) (and.right this)))) + +proposition singleton_union_Ioc {a b : A} (H : a ≤ b) : '{a} ∪ '(a, b] = '[a,b] := +by rewrite [-Icc_self, Icc_eq_Icc_union_Ioc !le.refl H] + +end strong_order_pair + +/- intervals of natural numbers -/ + +namespace nat +open nat eq.ops + variables m n : ℕ + + proposition Ioc_eq_Icc_succ : '(m, n] = '[succ m, n] := rfl + + proposition Ioo_eq_Ico_succ : '(m, n) = '[succ m, n) := rfl + + proposition Ico_succ_eq_Icc : '[m, succ n) = '[m, n] := + set.ext (take x, iff.intro + (assume H, and.intro (and.left H) (le_of_lt_succ (and.right H))) + (assume H, and.intro (and.left H) (lt_succ_of_le (and.right H)))) + + proposition Ioo_succ_eq_Ioc : '(m, succ n) = '(m, n] := + set.ext (take x, iff.intro + (assume H, and.intro (and.left H) (le_of_lt_succ (and.right H))) + (assume H, and.intro (and.left H) (lt_succ_of_le (and.right H)))) + + proposition Ici_zero : '[(0 : nat), ∞) = univ := + eq_univ_of_forall (take x, zero_le x) + + proposition Icc_zero (n : ℕ) : '[0, n] = '(-∞, n] := + have '[0, n] = '[0, ∞) ∩ '(-∞, n], from rfl, + by rewrite [this, Ici_zero, univ_inter] + + proposition bij_on_add_Icc_zero (m n : ℕ) : bij_on (add m) ('[0, n]) ('[m, m+n]) := + have mapsto : ∀₀ i ∈ '[0, n], m + i ∈ '[m, m+n], from + (take i, assume imem, + have H1 : m ≤ m + i, from !le_add_right, + have H2 : m + i ≤ m + n, from add_le_add_left (and.right imem) m, + show m + i ∈ '[m, m+n], from and.intro H1 H2), + have injon : inj_on (add m) ('[0, n]), from + (take i j, assume Hi Hj H, !eq_of_add_eq_add_left H), + have surjon : surj_on (add m) ('[0, n]) ('[m, m+n]), from + (take j, assume Hj : j ∈ '[m, m+n], + obtain lej jle, from Hj, + let i := j - m in + have ile : i ≤ n, from calc + j - m ≤ m + n - m : nat.sub_le_sub_right jle m + ... = n : nat.add_sub_cancel_left, + have iadd : m + i = j, by rewrite add.comm; apply nat.sub_add_cancel lej, + exists.intro i (and.intro (and.intro !zero_le ile) iadd)), + bij_on.mk mapsto injon surjon +end nat + +section nat -- put the instances in the intervals namespace +open nat eq.ops + variables m n : ℕ + + attribute [instance] + proposition nat.Iic_finite (n : ℕ) : finite '(-∞, n] := + nat.induction_on n + (have '(-∞, 0] ⊆ '{0}, from λ x H, mem_singleton_of_eq (le.antisymm H !zero_le), + finite_subset this) + (take n, assume ih : finite '(-∞, n], + have '(-∞, succ n] ⊆ '(-∞, n] ∪ '{succ n}, + by intro x H; rewrite [mem_union_iff, mem_singleton_iff]; apply le_or_eq_succ_of_le_succ H, + finite_subset this) + + attribute [instance] + proposition nat.Iio_finite (n : ℕ) : finite '(-∞, n) := + have '(-∞, n) ⊆ '(-∞, n], from λ x, le_of_lt, + finite_subset this + + attribute [instance] + proposition nat.Icc_finite (m n : ℕ) : finite ('[m, n]) := + have '[m, n] ⊆ '(-∞, n], from λ x H, and.right H, + finite_subset this + + attribute [instance] + proposition nat.Ico_finite (m n : ℕ) : finite ('[m, n)) := + have '[m, n) ⊆ '(-∞, n), from λ x H, and.right H, + finite_subset this + + attribute [instance] + proposition nat.Ioc_finite (m n : ℕ) : finite '(m, n] := + have '(m, n] ⊆ '(-∞, n], from λ x H, and.right H, + finite_subset this +end nat + +end interval diff --git a/old_library/algebra/lattice.lean b/old_library/algebra/lattice.lean new file mode 100644 index 0000000000..d825d696a8 --- /dev/null +++ b/old_library/algebra/lattice.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad +-/ +import .order + +variable {A : Type} + +/- lattices (we could split this to upper- and lower-semilattices, if needed) -/ + +structure lattice [class] (A : Type) extends weak_order A := +(inf : A → A → A) +(sup : A → A → A) +(inf_le_left : ∀ a b, le (inf a b) a) +(inf_le_right : ∀ a b, le (inf a b) b) +(le_inf : ∀a b c, le c a → le c b → le c (inf a b)) +(le_sup_left : ∀ a b, le a (sup a b)) +(le_sup_right : ∀ a b, le b (sup a b)) +(sup_le : ∀ a b c, le a c → le b c → le (sup a b) c) + +definition inf := @lattice.inf +definition sup := @lattice.sup +infix ` ⊓ `:70 := inf +infix ` ⊔ `:65 := sup + +section + variable [s : lattice A] + include s + + theorem inf_le_left (a b : A) : a ⊓ b ≤ a := lattice.inf_le_left a b + + theorem inf_le_right (a b : A) : a ⊓ b ≤ b := lattice.inf_le_right a b + + theorem le_inf {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) : c ≤ a ⊓ b := lattice.le_inf a b c H₁ H₂ + + theorem le_sup_left (a b : A) : a ≤ a ⊔ b := lattice.le_sup_left a b + + theorem le_sup_right (a b : A) : b ≤ a ⊔ b := lattice.le_sup_right a b + + theorem sup_le {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) : a ⊔ b ≤ c := lattice.sup_le a b c H₁ H₂ + + /- inf -/ + + theorem eq_inf {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) (H₃ : ∀{d}, d ≤ a → d ≤ b → d ≤ c) : + c = a ⊓ b := + le.antisymm (le_inf H₁ H₂) (H₃ (inf_le_left a b) (inf_le_right a b)) + + theorem inf.comm (a b : A) : a ⊓ b = b ⊓ a := + eq_inf (inf_le_right a b) (inf_le_left a b) (λ c H₁ H₂, le_inf H₂ H₁) + + theorem inf.assoc (a b c : A) : (a ⊓ b) ⊓ c = a ⊓ (b ⊓ c) := + sorry + /- + begin + apply eq_inf, + { apply le.trans, apply inf_le_left, apply inf_le_left }, + { apply le_inf, apply le.trans, apply inf_le_left, apply inf_le_right, apply inf_le_right }, + { intros [d, H₁, H₂], apply le_inf, apply le_inf H₁, apply le.trans H₂, apply inf_le_left, + apply le.trans H₂, apply inf_le_right } + end + -/ + + theorem inf.left_comm (a b c : A) : a ⊓ (b ⊓ c) = b ⊓ (a ⊓ c) := + binary.left_comm (@inf.comm A s) (@inf.assoc A s) a b c + + theorem inf.right_comm (a b c : A) : (a ⊓ b) ⊓ c = (a ⊓ c) ⊓ b := + binary.right_comm (@inf.comm A s) (@inf.assoc A s) a b c + + theorem inf_self (a : A) : a ⊓ a = a := + sorry -- by apply eq.symm; apply eq_inf (le.refl a) !le.refl; intros; assumption + + theorem inf_eq_left {a b : A} (H : a ≤ b) : a ⊓ b = a := + sorry -- by apply eq.symm; apply eq_inf !le.refl H; intros; assumption + + theorem inf_eq_right {a b : A} (H : b ≤ a) : a ⊓ b = b := + eq.subst (inf.comm b a) (inf_eq_left H) + + /- sup -/ + + theorem eq_sup {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) (H₃ : ∀{d}, a ≤ d → b ≤ d → c ≤ d) : + c = a ⊔ b := + le.antisymm (H₃ (le_sup_left a b) (le_sup_right a b)) (sup_le H₁ H₂) + + theorem sup.comm (a b : A) : a ⊔ b = b ⊔ a := + eq_sup (le_sup_right a b) (le_sup_left a b) (λ c H₁ H₂, sup_le H₂ H₁) + + theorem sup.assoc (a b c : A) : (a ⊔ b) ⊔ c = a ⊔ (b ⊔ c) := + sorry + /- + begin + apply eq_sup, + { apply le.trans, apply le_sup_left a b, apply le_sup_left }, + { apply sup_le, apply le.trans, apply le_sup_right a b, apply le_sup_left, apply le_sup_right }, + { intros [d, H₁, H₂], apply sup_le, apply sup_le H₁, apply le.trans !le_sup_left H₂, + apply le.trans !le_sup_right H₂} + end + -/ + + theorem sup.left_comm (a b c : A) : a ⊔ (b ⊔ c) = b ⊔ (a ⊔ c) := + binary.left_comm (@sup.comm A s) (@sup.assoc A s) a b c + + theorem sup.right_comm (a b c : A) : (a ⊔ b) ⊔ c = (a ⊔ c) ⊔ b := + binary.right_comm (@sup.comm A s) (@sup.assoc A s) a b c + + theorem sup_self (a : A) : a ⊔ a = a := + sorry -- by apply eq.symm; apply eq_sup (le.refl a) !le.refl; intros; assumption + + theorem sup_eq_left {a b : A} (H : b ≤ a) : a ⊔ b = a := + sorry -- by apply eq.symm; apply eq_sup !le.refl H; intros; assumption + + theorem sup_eq_right {a b : A} (H : a ≤ b) : a ⊔ b = b := + eq.subst (sup.comm b a) (sup_eq_left H) +end + +/- lattice instances -/ + +attribute [instance] +definition lattice_Prop : lattice Prop := +⦃ lattice, weak_order_Prop, + inf := and, + le_inf := take a b c Ha Hb Hc, and.intro (Ha Hc) (Hb Hc), + inf_le_left := @and.elim_left, + inf_le_right := @and.elim_right, + sup := or, + sup_le := @or.rec, + le_sup_left := @or.intro_left, + le_sup_right := @or.intro_right +⦄ + +attribute [instance] +definition lattice_fun (A B : Type) [lattice B] : lattice (A → B) := +⦃ lattice, weak_order_fun A B, + inf := λf g x, inf (f x) (g x), + le_inf := take f g h Hf Hg x, le_inf (Hf x) (Hg x), + inf_le_left := take f g x, inf_le_left (f x) (g x), + inf_le_right := take f g x, inf_le_right (f x) (g x), + sup := λf g x, sup (f x) (g x), + sup_le := take f g h Hf Hg x, sup_le (Hf x) (Hg x), + le_sup_left := take f g x, le_sup_left (f x) (g x), + le_sup_right := take t g x, le_sup_right (t x) (g x) +⦄ + +/- + Should we add a trans-instance from total orders to lattices? + If we added we should add it with lower priority: + Prop is added as a lattice, but in the classical case it is a total order! +-/ diff --git a/old_library/algebra/module.lean b/old_library/algebra/module.lean new file mode 100644 index 0000000000..8113066233 --- /dev/null +++ b/old_library/algebra/module.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2015 Nathaniel Thomas. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Nathaniel Thomas, Jeremy Avigad + +Modules and vector spaces over a ring. + +(We use "left_module," which is more precise, because "module" is a keyword.) +-/ +import algebra.field + +structure has_scalar [class] (F V : Type) := +(smul : F → V → V) + +infixl ` • `:73 := has_scalar.smul + +/- modules over a ring -/ + +structure left_module [class] (R M : Type) [ringR : ring R] + extends has_scalar R M, add_comm_group M := +(smul_left_distrib : ∀ (r : R) (x y : M), smul r (add x y) = (add (smul r x) (smul r y))) +(smul_right_distrib : ∀ (r s : R) (x : M), smul (ring.add r s) x = (add (smul r x) (smul s x))) +(mul_smul : ∀ r s x, smul (mul r s) x = smul r (smul s x)) +(one_smul : ∀ x, smul one x = x) + +section left_module + variables {R M : Type} + variable [ringR : ring R] + variable [moduleRM : left_module R M] + include ringR moduleRM + + -- Note: the anonymous include does not work in the propositions below. + + proposition smul_left_distrib (a : R) (u v : M) : a • (u + v) = a • u + a • v := + left_module.smul_left_distrib ringR a u v + + proposition smul_right_distrib (a b : R) (u : M) : (a + b) • u = a • u + b • u := + left_module.smul_right_distrib ringR a b u + + proposition mul_smul (a : R) (b : R) (u : M) : (a * b) • u = a • (b • u) := + left_module.mul_smul ringR a b u + + proposition one_smul (u : M) : (1 : R) • u = u := left_module.one_smul ringR u + + proposition zero_smul (u : M) : (0 : R) • u = 0 := + sorry + /- + have (0 : R) • u + 0 • u = 0 • u + 0, by rewrite [-smul_right_distrib, *add_zero], + !add.left_cancel this + -/ + + proposition smul_zero (a : R) : a • (0 : M) = 0 := + sorry + /- + have a • (0:M) + a • 0 = a • 0 + 0, by rewrite [-smul_left_distrib, *add_zero], + !add.left_cancel this + -/ + + proposition neg_smul (a : R) (u : M) : (-a) • u = - (a • u) := + sorry -- eq_neg_of_add_eq_zero (by rewrite [-smul_right_distrib, add.left_inv, zero_smul]) + + proposition neg_one_smul (u : M) : -(1 : R) • u = -u := + sorry -- by rewrite [neg_smul, one_smul] + + proposition smul_neg (a : R) (u : M) : a • (-u) = -(a • u) := + sorry -- by rewrite [-neg_one_smul, -mul_smul, mul_neg_one_eq_neg, neg_smul] + + proposition smul_sub_left_distrib (a : R) (u v : M) : a • (u - v) = a • u - a • v := + sorry -- by rewrite [sub_eq_add_neg, smul_left_distrib, smul_neg] + + proposition sub_smul_right_distrib (a b : R) (v : M) : (a - b) • v = a • v - b • v := + sorry -- by rewrite [sub_eq_add_neg, smul_right_distrib, neg_smul] +end left_module + +/- vector spaces -/ + +structure vector_space [class] (F V : Type) [fieldF : field F] + extends left_module F V diff --git a/old_library/algebra/monotone.lean b/old_library/algebra/monotone.lean new file mode 100644 index 0000000000..7281abfb8c --- /dev/null +++ b/old_library/algebra/monotone.lean @@ -0,0 +1,477 @@ +/- +Copyright (c) 2016 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Weak and strict order preserving maps. + +TODO: we will probably eventually want versions restricted to smaller domains, +"nondecreasing_on" etc. Maybe we can do this with subtypes. +-/ +import .order +open eq function + +variables {A B C : Type} + +section + variables [weak_order A] [weak_order B] [weak_order C] + + definition nondecreasing (f : A → B) : Prop := ∀ ⦃a₁ a₂⦄, a₁ ≤ a₂ → f a₁ ≤ f a₂ + + definition nonincreasing (f : A → B) : Prop := ∀ ⦃a₁ a₂⦄, a₁ ≤ a₂ → f a₁ ≥ f a₂ + + theorem nondecreasing_id : nondecreasing (@id A) := take a₁ a₂, assume H, H + + theorem nondecreasing_comp_nondec_nondec {g : B → C} {f : A → B} + (Hg : nondecreasing g) (Hf : nondecreasing f) : nondecreasing (g ∘ f) := + take a₁ a₂, assume H, Hg (Hf H) + + theorem nondecreasing_comp_noninc_noninc {g : B → C} {f : A → B} + (Hg : nonincreasing g) (Hf : nonincreasing f) : nondecreasing (g ∘ f) := + take a₁ a₂, assume H, Hg (Hf H) + + theorem nonincreasing_comp_noninc_nondec {g : B → C} {f : A → B} + (Hg : nonincreasing g) (Hf : nondecreasing f) : nonincreasing (g ∘ f) := + take a₁ a₂, assume H, Hg (Hf H) + + theorem nonincreasing_comp_nondec_noninc {g : B → C} {f : A → B} + (Hg : nondecreasing g) (Hf : nonincreasing f) : nonincreasing (g ∘ f) := + take a₁ a₂, assume H, Hg (Hf H) +end + +section + variables [strict_order A] [strict_order B] [strict_order C] + + definition strictly_increasing (f : A → B) : Prop := + ∀ ⦃a₁ a₂⦄, a₁ < a₂ → f a₁ < f a₂ + + definition strictly_decreasing (f : A → B) : Prop := + ∀ ⦃a₁ a₂⦄, a₁ < a₂ → f a₁ > f a₂ + + theorem strictly_increasing_id : strictly_increasing (@id A) := take a₁ a₂, assume H, H + + theorem strictly_increasing_comp_inc_inc {g : B → C} {f : A → B} + (Hg : strictly_increasing g) (Hf : strictly_increasing f) : strictly_increasing (g ∘ f) := + take a₁ a₂, assume H, Hg (Hf H) + + theorem strictly_increasing_comp_dec_dec {g : B → C} {f : A → B} + (Hg : strictly_decreasing g) (Hf : strictly_decreasing f) : strictly_increasing (g ∘ f) := + take a₁ a₂, assume H, Hg (Hf H) + + theorem strictly_decreasing_comp_inc_dec {g : B → C} {f : A → B} + (Hg : strictly_increasing g) (Hf : strictly_decreasing f) : strictly_decreasing (g ∘ f) := + take a₁ a₂, assume H, Hg (Hf H) + + theorem strictly_decreasing_comp_dec_inc {g : B → C} {f : A → B} + (Hg : strictly_decreasing g) (Hf : strictly_increasing f) : strictly_decreasing (g ∘ f) := + take a₁ a₂, assume H, Hg (Hf H) +end + +section + variables [strong_order_pair A] [strong_order_pair B] + + theorem nondecreasing_of_strictly_increasing {f : A → B} (H : strictly_increasing f) : + nondecreasing f := + take a₁ a₂, suppose a₁ ≤ a₂, + show f a₁ ≤ f a₂, from or.elim (lt_or_eq_of_le this) + (suppose a₁ < a₂, le_of_lt (H this)) + (suppose a₁ = a₂, le_of_eq (congr_arg f this)) + + theorem nonincreasing_of_strictly_decreasing {f : A → B} (H : strictly_decreasing f) : + nonincreasing f := + take a₁ a₂, suppose a₁ ≤ a₂, + show f a₁ ≥ f a₂, from or.elim (lt_or_eq_of_le this) + (suppose a₁ < a₂, le_of_lt (H this)) + (suppose a₁ = a₂, le_of_eq (congr_arg f (symm this))) +end + +section + variables [linear_strong_order_pair A] [linear_strong_order_pair B] [linear_strong_order_pair C] + + theorem lt_of_strictly_increasing {f : A → B} {a₁ a₂ : A} (H : strictly_increasing f) + (H' : f a₁ < f a₂) : a₁ < a₂ := + lt_of_not_ge (suppose a₂ ≤ a₁, + have f a₂ ≤ f a₁, from nondecreasing_of_strictly_increasing H this, + show false, from not_le_of_gt H' this) + + theorem lt_iff_of_strictly_increasing {f : A → B} (a₁ a₂ : A) (H : strictly_increasing f) : + f a₁ < f a₂ ↔ a₁ < a₂ := + iff.intro (lt_of_strictly_increasing H) (@H a₁ a₂) + + theorem le_of_strictly_increasing {f : A → B} {a₁ a₂ : A} (H : strictly_increasing f) + (H' : f a₁ ≤ f a₂) : a₁ ≤ a₂ := + le_of_not_gt (suppose a₂ < a₁, not_le_of_gt (H this) H') + + theorem le_iff_of_strictly_increasing {f : A → B} (a₁ a₂ : A) (H : strictly_increasing f) : + f a₁ ≤ f a₂ ↔ a₁ ≤ a₂ := + iff.intro (le_of_strictly_increasing H) (λ H', nondecreasing_of_strictly_increasing H H') + + theorem lt_of_strictly_decreasing {f : A → B} {a₁ a₂ : A} (H : strictly_decreasing f) + (H' : f a₁ > f a₂) : a₁ < a₂ := + lt_of_not_ge (suppose a₂ ≤ a₁, + have f a₂ ≥ f a₁, from nonincreasing_of_strictly_decreasing H this, + show false, from not_le_of_gt H' this) + + theorem gt_iff_of_strictly_decreasing {f : A → B} (a₁ a₂ : A) (H : strictly_decreasing f) : + f a₁ > f a₂ ↔ a₁ < a₂ := + iff.intro (lt_of_strictly_decreasing H) (@H a₁ a₂) + + theorem le_of_strictly_decreasing {f : A → B} {a₁ a₂ : A} (H : strictly_decreasing f) + (H' : f a₁ ≥ f a₂) : a₁ ≤ a₂ := + le_of_not_gt (suppose a₂ < a₁, not_le_of_gt (H this) H') + + theorem ge_iff_of_strictly_decreasing {f : A → B} (a₁ a₂ : A) (H : strictly_decreasing f) : + f a₁ ≥ f a₂ ↔ a₁ ≤ a₂ := + iff.intro (le_of_strictly_decreasing H) (λ H', nonincreasing_of_strictly_decreasing H H') + + theorem strictly_increasing_of_left_inverse {g : B → A} {f : A → B} (H : left_inverse g f) + (H' : strictly_increasing g) : strictly_increasing f := + sorry + /- + take a₁ a₂, suppose a₁ < a₂, + have g (f a₁) < g (f a₂), by rewrite *H; apply this, + lt_of_strictly_increasing H' this + -/ + + theorem strictly_decreasing_of_left_inverse {g : B → A} {f : A → B} (H : left_inverse g f) + (H' : strictly_decreasing g) : strictly_decreasing f := + sorry + /- + take b₁ b₂, suppose b₁ < b₂, + have g (f b₁) < g (f b₂), by rewrite *H; apply this, + lt_of_strictly_decreasing H' this + -/ + + theorem nondecreasing_of_left_inverse {g : B → A} {f : A → B} (H : left_inverse g f) + (H' : strictly_increasing g) : nondecreasing f := + sorry + /- + take a₁ a₂, suppose a₁ ≤ a₂, + have g (f a₁) ≤ g (f a₂), by rewrite *H; apply this, + le_of_strictly_increasing H' this + -/ + + theorem nonincreasing_of_left_inverse {g : B → A} {f : A → B} (H : left_inverse g f) + (H' : strictly_decreasing g) : nonincreasing f := + sorry + /- + take b₁ b₂, suppose b₁ ≤ b₂, + have g (f b₁) ≤ g (f b₂), by rewrite *H; apply this, + le_of_strictly_decreasing H' this + -/ +end + +/- composition rules for strict orders -/ + +section + variables [strict_order A] [strict_order B] [strict_order C] + + theorem strictly_increasing_of_strictly_increasing_comp_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_increasing h) (H₃ : strictly_increasing (g ∘ f)) : + strictly_increasing f := + sorry + /- + take a₁ a₂, suppose a₁ < a₂, + have h (g (f a₁)) < h (g (f a₂)), from H₂ (H₃ this), + show f a₁ < f a₂, by rewrite *H₁ at this; apply this + -/ + + theorem strictly_decreasing_of_strictly_increasing_comp_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_decreasing h) (H₃ : strictly_increasing (g ∘ f)) : + strictly_decreasing f := + sorry + /- + take a₁ a₂, suppose a₁ < a₂, + have h (g (f a₁)) > h (g (f a₂)), from H₂ (H₃ this), + show f a₁ > f a₂, by rewrite *H₁ at this; apply this + -/ + + theorem strictly_decreasing_of_strictly_decreasing_comp_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_increasing h) (H₃ : strictly_decreasing (g ∘ f)) : + strictly_decreasing f := + sorry + /- + take a₁ a₂, suppose a₁ < a₂, + have h (g (f a₁)) > h (g (f a₂)), from H₂ (H₃ this), + show f a₁ > f a₂, by rewrite *H₁ at this; apply this + -/ + + theorem strictly_increasing_of_strictly_decreasing_comp_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_decreasing h) (H₃ : strictly_decreasing (g ∘ f)) : + strictly_increasing f := + sorry + /- + take a₁ a₂, suppose a₁ < a₂, + have h (g (f a₁)) < h (g (f a₂)), from H₂ (H₃ this), + show f a₁ < f a₂, by rewrite *H₁ at this; apply this + -/ + + theorem strictly_increasing_of_strictly_decreasing_comp_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_decreasing h) (H₃ : strictly_decreasing (g ∘ f)) : + strictly_increasing g := + sorry + /- + take a₁ a₂, suppose a₁ < a₂, + have g (f (h a₁)) < g (f (h a₂)), from H₃ (H₂ this), + show g a₁ < g a₂, by rewrite *H₁ at this; apply this + -/ + + theorem strictly_decreasing_of_strictly_decreasing_comp_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_increasing h) (H₃ : strictly_decreasing (g ∘ f)) : + strictly_decreasing g := + sorry + /- + take a₁ a₂, suppose a₁ < a₂, + have g (f (h a₁)) > g (f (h a₂)), from H₃ (H₂ this), + show g a₁ > g a₂, by rewrite *H₁ at this; apply this + -/ + + theorem strictly_increasing_of_strictly_increasing_comp_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_increasing h) (H₃ : strictly_increasing (g ∘ f)) : + strictly_increasing g := + sorry + /- + take a₁ a₂, suppose a₁ < a₂, + have g (f (h a₁)) < g (f (h a₂)), from H₃ (H₂ this), + show g a₁ < g a₂, by rewrite *H₁ at this; apply this + -/ + + theorem strictly_decreasing_of_strictly_increasing_comp_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_decreasing h) (H₃ : strictly_increasing (g ∘ f)) : + strictly_decreasing g := + sorry + /- + take a₁ a₂, suppose a₁ < a₂, + have g (f (h a₁)) > g (f (h a₂)), from H₃ (H₂ this), + show g a₁ > g a₂, by rewrite *H₁ at this; apply this + -/ +end + +section + variables [strict_order A] [linear_strong_order_pair B] [linear_strong_order_pair C] + + theorem strictly_increasing_comp_iff_strictly_increasing_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_increasing h) : + strictly_increasing (g ∘ f) ↔ strictly_increasing f := + have H₃ : strictly_increasing g, from strictly_increasing_of_left_inverse H₁ H₂, + iff.intro + (strictly_increasing_of_strictly_increasing_comp_right H₁ H₂) + (strictly_increasing_comp_inc_inc H₃) + + theorem strictly_increasing_comp_iff_strictly_decreasing_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_decreasing h) : + strictly_increasing (g ∘ f) ↔ strictly_decreasing f := + have H₃ : strictly_decreasing g, from strictly_decreasing_of_left_inverse H₁ H₂, + iff.intro + (strictly_decreasing_of_strictly_increasing_comp_right H₁ H₂) + (strictly_increasing_comp_dec_dec H₃) + + theorem strictly_decreasing_comp_iff_strictly_decreasing_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_increasing h) : + strictly_decreasing (g ∘ f) ↔ strictly_decreasing f := + have H₃ : strictly_increasing g, from strictly_increasing_of_left_inverse H₁ H₂, + iff.intro + (strictly_decreasing_of_strictly_decreasing_comp_right H₁ H₂) + (strictly_decreasing_comp_inc_dec H₃) + + theorem strictly_decreasing_comp_iff_strictly_increasing_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_decreasing h) : + strictly_decreasing (g ∘ f) ↔ strictly_increasing f := + have H₃ : strictly_decreasing g, from strictly_decreasing_of_left_inverse H₁ H₂, + iff.intro + (strictly_increasing_of_strictly_decreasing_comp_right H₁ H₂) + (strictly_decreasing_comp_dec_inc H₃) +end + +section + variables [linear_strong_order_pair A] [linear_strong_order_pair B] [strict_order C] + + theorem strictly_increasing_comp_iff_strinctly_increasing_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_increasing f) : + strictly_increasing (g ∘ f) ↔ strictly_increasing g := + have H₃ : strictly_increasing h, from strictly_increasing_of_left_inverse H₁ H₂, + iff.intro + (strictly_increasing_of_strictly_increasing_comp_left H₁ H₃) + (λ H, strictly_increasing_comp_inc_inc H H₂) + + theorem strictly_increasing_comp_iff_strictly_decreasing_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_decreasing f) : + strictly_increasing (g ∘ f) ↔ strictly_decreasing g := + have H₃ : strictly_decreasing h, from strictly_decreasing_of_left_inverse H₁ H₂, + iff.intro + (strictly_decreasing_of_strictly_increasing_comp_left H₁ H₃) + (λ H, strictly_increasing_comp_dec_dec H H₂) + + theorem strictly_decreasing_comp_iff_strictly_increasing_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_decreasing f) : + strictly_decreasing (g ∘ f) ↔ strictly_increasing g := + have H₃ : strictly_decreasing h, from strictly_decreasing_of_left_inverse H₁ H₂, + iff.intro + (strictly_increasing_of_strictly_decreasing_comp_left H₁ H₃) + (λ H, strictly_decreasing_comp_inc_dec H H₂) + + theorem strictly_decreasing_comp_iff_strictly_decreasing_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_increasing f) : + strictly_decreasing (g ∘ f) ↔ strictly_decreasing g := + have H₃ : strictly_increasing h, from strictly_increasing_of_left_inverse H₁ H₂, + iff.intro + (strictly_decreasing_of_strictly_decreasing_comp_left H₁ H₃) + (λ H, strictly_decreasing_comp_dec_inc H H₂) +end + +/- composition rules for weak orders -/ + +section + variables [weak_order A] [weak_order B] [weak_order C] + + theorem nondecreasing_of_nondecreasing_comp_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : nondecreasing h) (H₃ : nondecreasing (g ∘ f)) : + nondecreasing f := + sorry + /- + take a₁ a₂, suppose a₁ ≤ a₂, + have h (g (f a₁)) ≤ h (g (f a₂)), from H₂ (H₃ this), + show f a₁ ≤ f a₂, by rewrite *H₁ at this; apply this + -/ + + theorem nonincreasing_of_nondecreasing_comp_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : nonincreasing h) (H₃ : nondecreasing (g ∘ f)) : + nonincreasing f := + sorry + /- + take a₁ a₂, suppose a₁ ≤ a₂, + have h (g (f a₁)) ≥ h (g (f a₂)), from H₂ (H₃ this), + show f a₁ ≥ f a₂, by rewrite *H₁ at this; apply this + -/ + + theorem nonincreasing_of_nonincreasing_comp_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : nondecreasing h) (H₃ : nonincreasing (g ∘ f)) : + nonincreasing f := + sorry + /- + take a₁ a₂, suppose a₁ ≤ a₂, + have h (g (f a₁)) ≥ h (g (f a₂)), from H₂ (H₃ this), + show f a₁ ≥ f a₂, by rewrite *H₁ at this; apply this + -/ + + theorem nondecreasing_of_nonincreasing_comp_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : nonincreasing h) (H₃ : nonincreasing (g ∘ f)) : + nondecreasing f := + sorry + /- + take a₁ a₂, suppose a₁ ≤ a₂, + have h (g (f a₁)) ≤ h (g (f a₂)), from H₂ (H₃ this), + show f a₁ ≤ f a₂, by rewrite *H₁ at this; apply this + -/ + + theorem nondecreasing_of_nondecreasing_comp_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : nondecreasing h) (H₃ : nondecreasing (g ∘ f)) : + nondecreasing g := + sorry + /- + take a₁ a₂, suppose a₁ ≤ a₂, + have g (f (h a₁)) ≤ g (f (h a₂)), from H₃ (H₂ this), + show g a₁ ≤ g a₂, by rewrite *H₁ at this; apply this + -/ + + theorem nonincreasing_of_nondecreasing_comp_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : nonincreasing h) (H₃ : nondecreasing (g ∘ f)) : + nonincreasing g := + sorry + /- + take a₁ a₂, suppose a₁ ≤ a₂, + have g (f (h a₁)) ≥ g (f (h a₂)), from H₃ (H₂ this), + show g a₁ ≥ g a₂, by rewrite *H₁ at this; apply this + -/ + + theorem nondecreasing_of_nonincreasing_comp_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : nonincreasing h) (H₃ : nonincreasing (g ∘ f)) : + nondecreasing g := + sorry + /- + take a₁ a₂, suppose a₁ ≤ a₂, + have g (f (h a₁)) ≤ g (f (h a₂)), from H₃ (H₂ this), + show g a₁ ≤ g a₂, by rewrite *H₁ at this; apply this + -/ + theorem nonincreasing_of_nonincreasing_comp_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : nondecreasing h) (H₃ : nonincreasing (g ∘ f)) : + nonincreasing g := + sorry + /- + take a₁ a₂, suppose a₁ ≤ a₂, + have g (f (h a₁)) ≥ g (f (h a₂)), from H₃ (H₂ this), + show g a₁ ≥ g a₂, by rewrite *H₁ at this; apply this + -/ +end + +section + variables [weak_order A] [linear_strong_order_pair B] [linear_strong_order_pair C] + + theorem nondecreasing_comp_iff_nondecreasing_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_increasing h) : + nondecreasing (g ∘ f) ↔ nondecreasing f := + have H₃ : nondecreasing g, from nondecreasing_of_left_inverse H₁ H₂, + iff.intro + (nondecreasing_of_nondecreasing_comp_right H₁ (nondecreasing_of_strictly_increasing H₂)) + (nondecreasing_comp_nondec_nondec H₃) + + theorem nondecreasing_comp_iff_nonincreasing_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_decreasing h) : + nondecreasing (g ∘ f) ↔ nonincreasing f := + have H₃ : nonincreasing g, from nonincreasing_of_left_inverse H₁ H₂, + iff.intro + (nonincreasing_of_nondecreasing_comp_right H₁ (nonincreasing_of_strictly_decreasing H₂)) + (nondecreasing_comp_noninc_noninc H₃) + + theorem nonincreasing_comp_iff_nonincreasing_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_increasing h) : + nonincreasing (g ∘ f) ↔ nonincreasing f := + have H₃ : nondecreasing g, from nondecreasing_of_left_inverse H₁ H₂, + iff.intro + (nonincreasing_of_nonincreasing_comp_right H₁ (nondecreasing_of_strictly_increasing H₂)) + (nonincreasing_comp_nondec_noninc H₃) + + theorem nonincreasing_comp_iff_nondecreasing_right {g : B → C} {f : A → B} {h : C → B} + (H₁ : left_inverse h g) (H₂ : strictly_decreasing h) : + nonincreasing (g ∘ f) ↔ nondecreasing f := + have H₃ : nonincreasing g, from nonincreasing_of_left_inverse H₁ H₂, + iff.intro + (nondecreasing_of_nonincreasing_comp_right H₁ (nonincreasing_of_strictly_decreasing H₂)) + (nonincreasing_comp_noninc_nondec H₃) +end + +section + variables [linear_strong_order_pair A] [linear_strong_order_pair B] [weak_order C] + + theorem nondecreasing_comp_iff_nondecreasing_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_increasing f) : + nondecreasing (g ∘ f) ↔ nondecreasing g := + have H₃ : nondecreasing h, from nondecreasing_of_left_inverse H₁ H₂, + iff.intro + (nondecreasing_of_nondecreasing_comp_left H₁ H₃) + (λ H, nondecreasing_comp_nondec_nondec H (nondecreasing_of_strictly_increasing H₂)) + + theorem nondecreasing_comp_iff_nonincreasing_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_decreasing f) : + nondecreasing (g ∘ f) ↔ nonincreasing g := + have H₃ : nonincreasing h, from nonincreasing_of_left_inverse H₁ H₂, + iff.intro + (nonincreasing_of_nondecreasing_comp_left H₁ H₃) + (λ H, nondecreasing_comp_noninc_noninc H (nonincreasing_of_strictly_decreasing H₂)) + + theorem nonincreasing_comp_iff_nondecreasing_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_decreasing f) : + nonincreasing (g ∘ f) ↔ nondecreasing g := + have H₃ : nonincreasing h, from nonincreasing_of_left_inverse H₁ H₂, + iff.intro + (nondecreasing_of_nonincreasing_comp_left H₁ H₃) + (λ H, nonincreasing_comp_nondec_noninc H (nonincreasing_of_strictly_decreasing H₂)) + + theorem nonincreasing_comp_iff_nonincreasing_left {g : B → C} {f : A → B} {h : B → A} + (H₁ : left_inverse f h) (H₂ : strictly_increasing f) : + nonincreasing (g ∘ f) ↔ nonincreasing g := + have H₃ : nondecreasing h, from nondecreasing_of_left_inverse H₁ H₂, + iff.intro + (nonincreasing_of_nonincreasing_comp_left H₁ H₃) + (λ H, nonincreasing_comp_noninc_nondec H (nondecreasing_of_strictly_increasing H₂)) +end diff --git a/old_library/algebra/order.lean b/old_library/algebra/order.lean new file mode 100644 index 0000000000..399aa491d6 --- /dev/null +++ b/old_library/algebra/order.lean @@ -0,0 +1,523 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Weak orders "≤", strict orders "<", and structures that include both. +-/ +import logic.eq logic.connectives algebra.binary algebra.priority +open eq function + +variables {A : Type} + +/- weak orders -/ + +structure weak_order [class] (A : Type) extends has_le A := +(le_refl : ∀a, le a a) +(le_trans : ∀a b c, le a b → le b c → le a c) +(le_antisymm : ∀a b, le a b → le b a → a = b) + +section + variables [weak_order A] + + attribute [refl] + theorem le.refl (a : A) : a ≤ a := weak_order.le_refl a + + theorem le_of_eq {a b : A} (H : a = b) : a ≤ b := H ▸ le.refl a + + attribute [trans] + theorem le.trans {a b c : A} : a ≤ b → b ≤ c → a ≤ c := weak_order.le_trans a b c + + attribute [trans] + theorem ge.trans {a b c : A} (H1 : a ≥ b) (H2: b ≥ c) : a ≥ c := le.trans H2 H1 + + theorem le.antisymm {a b : A} : a ≤ b → b ≤ a → a = b := weak_order.le_antisymm a b + + -- Alternate syntax. (Abbreviations do not migrate well.) + theorem eq_of_le_of_ge {a b : A} : a ≤ b → b ≤ a → a = b := le.antisymm +end + +structure linear_weak_order [class] (A : Type) extends weak_order A := +(le_total : ∀a b, le a b ∨ le b a) + +section + variables [linear_weak_order A] + + theorem le.total (a b : A) : a ≤ b ∨ b ≤ a := linear_weak_order.le_total a b + + theorem le_of_not_ge {a b : A} (H : ¬ a ≥ b) : a ≤ b := or.resolve_left (le.total b a) H +end + +/- strict orders -/ + +structure strict_order [class] (A : Type) extends has_lt A := +(lt_irrefl : ∀a, ¬ lt a a) +(lt_trans : ∀a b c, lt a b → lt b c → lt a c) + +section + variable [strict_order A] + + theorem lt.irrefl (a : A) : ¬ a < a := strict_order.lt_irrefl a + theorem not_lt_self (a : A) : ¬ a < a := lt.irrefl a -- alternate syntax + + theorem lt_self_iff_false (a : A) : a < a ↔ false := + iff_false_intro (lt.irrefl a) + + attribute [trans] + theorem lt.trans {a b c : A} : a < b → b < c → a < c := strict_order.lt_trans a b c + + attribute [trans] + theorem gt.trans {a b c : A} (H1 : a > b) (H2: b > c) : a > c := lt.trans H2 H1 + + theorem ne_of_lt {a b : A} (lt_ab : a < b) : a ≠ b := + assume eq_ab : a = b, + show false, from lt.irrefl b (eq_ab ▸ lt_ab) + + theorem ne_of_gt {a b : A} (gt_ab : a > b) : a ≠ b := + ne.symm (ne_of_lt gt_ab) + + theorem lt.asymm {a b : A} (H : a < b) : ¬ b < a := + assume H1 : b < a, lt.irrefl _ (lt.trans H H1) + + theorem not_lt_of_gt {a b : A} (H : a > b) : ¬ a < b := lt.asymm H -- alternate syntax +end + +/- well-founded orders -/ + +structure wf_strict_order [class] (A : Type) extends strict_order A := +(wf_rec : ∀P : A → Type, (∀x, (∀y, lt y x → P y) → P x) → ∀x, P x) + +definition wf.rec_on {A : Type} [s : wf_strict_order A] {P : A → Type} + (x : A) (H : ∀x, (∀y, wf_strict_order.lt y x → P y) → P x) : P x := +wf_strict_order.wf_rec P H x + +theorem wf.ind_on.{u v} {A : Type.{u}} [s : wf_strict_order.{u 0} A] {P : A → Prop} + (x : A) (H : ∀x, (∀y, wf_strict_order.lt y x → P y) → P x) : P x := +wf.rec_on x H + +/- structures with a weak and a strict order -/ + +structure order_pair [class] (A : Type) extends weak_order A, has_lt A := +(le_of_lt : ∀ a b, lt a b → le a b) +(lt_of_lt_of_le : ∀ a b c, lt a b → le b c → lt a c) +(lt_of_le_of_lt : ∀ a b c, le a b → lt b c → lt a c) +(lt_irrefl : ∀ a, ¬ lt a a) + +section + variable [s : order_pair A] + variables {a b c : A} + include s + + theorem le_of_lt : a < b → a ≤ b := order_pair.le_of_lt a b + + attribute [trans] + theorem lt_of_lt_of_le : a < b → b ≤ c → a < c := order_pair.lt_of_lt_of_le a b c + + attribute [trans] + theorem lt_of_le_of_lt : a ≤ b → b < c → a < c := order_pair.lt_of_le_of_lt a b c + + private theorem lt_irrefl (s' : order_pair A) (a : A) : ¬ a < a := order_pair.lt_irrefl a + + private theorem lt_trans (s' : order_pair A) (a b c: A) (lt_ab : a < b) (lt_bc : b < c) : a < c := + lt_of_lt_of_le lt_ab (le_of_lt lt_bc) + + attribute [instance] + definition order_pair.to_strict_order : strict_order A := + ⦃ strict_order, s, lt_irrefl := lt_irrefl s, lt_trans := lt_trans s ⦄ + + attribute [trans] + theorem gt_of_gt_of_ge (H1 : a > b) (H2 : b ≥ c) : a > c := lt_of_le_of_lt H2 H1 + + attribute [trans] + theorem gt_of_ge_of_gt (H1 : a ≥ b) (H2 : b > c) : a > c := lt_of_lt_of_le H2 H1 + + theorem not_le_of_gt (H : a > b) : ¬ a ≤ b := + assume H1 : a ≤ b, + lt.irrefl _ (lt_of_lt_of_le H H1) + + theorem not_lt_of_ge (H : a ≥ b) : ¬ a < b := + assume H1 : a < b, + lt.irrefl _ (lt_of_le_of_lt H H1) +end + +structure strong_order_pair [class] (A : Type) extends weak_order A, has_lt A := +(le_iff_lt_or_eq : ∀a b, le a b ↔ lt a b ∨ a = b) +(lt_irrefl : ∀ a, ¬ lt a a) + +section strong_order_pair + variable [strong_order_pair A] + + theorem le_iff_lt_or_eq {a b : A} : a ≤ b ↔ a < b ∨ a = b := + strong_order_pair.le_iff_lt_or_eq a b + + theorem lt_or_eq_of_le {a b : A} (le_ab : a ≤ b) : a < b ∨ a = b := + iff.mp le_iff_lt_or_eq le_ab + + theorem le_of_lt_or_eq {a b : A} (lt_or_eq : a < b ∨ a = b) : a ≤ b := + iff.mpr le_iff_lt_or_eq lt_or_eq + + private theorem lt_irrefl' (a : A) : ¬ a < a := + strong_order_pair.lt_irrefl a + + private theorem le_of_lt' (a b : A) : a < b → a ≤ b := + take Hlt, le_of_lt_or_eq (or.inl Hlt) + + private theorem lt_iff_le_and_ne {a b : A} : a < b ↔ (a ≤ b ∧ a ≠ b) := + iff.intro + (take Hlt, and.intro (le_of_lt_or_eq (or.inl Hlt)) (take Hab, absurd (Hab ▸ Hlt) (lt_irrefl' b))) + (take Hand, + have Hor : a < b ∨ a = b, from lt_or_eq_of_le (and.left Hand), + or_resolve_left Hor (and.right Hand)) + + theorem lt_of_le_of_ne {a b : A} : a ≤ b → a ≠ b → a < b := + take H1 H2, iff.mpr lt_iff_le_and_ne (and.intro H1 H2) + + private theorem ne_of_lt' {a b : A} (H : a < b) : a ≠ b := + and.right ((iff.mp lt_iff_le_and_ne) H) + + private theorem lt_of_lt_of_le' (a b c : A) : a < b → b ≤ c → a < c := + assume lt_ab : a < b, + assume le_bc : b ≤ c, + have le_ac : a ≤ c, from le.trans (le_of_lt' _ _ lt_ab) le_bc, + have ne_ac : a ≠ c, from + assume eq_ac : a = c, + have le_ba : b ≤ a, from symm eq_ac ▸ le_bc, + have eq_ab : a = b, from le.antisymm (le_of_lt' _ _ lt_ab) le_ba, + show false, from ne_of_lt' lt_ab eq_ab, + show a < c, from iff.mpr (lt_iff_le_and_ne) (and.intro le_ac ne_ac) + + theorem lt_of_le_of_lt' (a b c : A) : a ≤ b → b < c → a < c := + assume le_ab : a ≤ b, + assume lt_bc : b < c, + have le_ac : a ≤ c, from le.trans le_ab (le_of_lt' _ _ lt_bc), + have ne_ac : a ≠ c, from + assume eq_ac : a = c, + have le_cb : c ≤ b, from eq_ac ▸ le_ab, + have eq_bc : b = c, from le.antisymm (le_of_lt' _ _ lt_bc) le_cb, + show false, from ne_of_lt' lt_bc eq_bc, + show a < c, from iff.mpr (lt_iff_le_and_ne) (and.intro le_ac ne_ac) +end strong_order_pair + +attribute [instance] +definition strong_order_pair.to_order_pair + [s : strong_order_pair A] : order_pair A := +⦃ order_pair, s, + lt_irrefl := lt_irrefl', + le_of_lt := le_of_lt', + lt_of_le_of_lt := lt_of_le_of_lt', + lt_of_lt_of_le := lt_of_lt_of_le' ⦄ + +/- linear orders -/ + +structure linear_order_pair [class] (A : Type) extends order_pair A, linear_weak_order A + +structure linear_strong_order_pair [class] (A : Type) extends strong_order_pair A, + linear_weak_order A + +attribute [instance] +definition linear_strong_order_pair.to_linear_order_pair + [s : linear_strong_order_pair A] : linear_order_pair A := +⦃ linear_order_pair, s, strong_order_pair.to_order_pair ⦄ + +section + variable [linear_strong_order_pair A] + variables (a b c : A) + + theorem lt.trichotomy : a < b ∨ a = b ∨ b < a := + or.elim (le.total a b) + (assume H : a ≤ b, + or.elim (iff.mp le_iff_lt_or_eq H) (assume H1, or.inl H1) (assume H1, or.inr (or.inl H1))) + (assume H : b ≤ a, + or.elim (iff.mp le_iff_lt_or_eq H) + (assume H1, or.inr (or.inr H1)) + (assume H1, or.inr (or.inl (symm H1)))) + + theorem lt.by_cases {a b : A} {P : Prop} + (H1 : a < b → P) (H2 : a = b → P) (H3 : b < a → P) : P := + or.elim (lt.trichotomy a b) + (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 b)) (assume H', le_of_lt H') + + theorem lt_of_not_ge {a b : A} (H : ¬ a ≥ b) : a < b := + lt.by_cases + (assume H', absurd (le_of_lt H') H) + (assume H', absurd (H' ▸ le.refl b) H) + (assume H', H') + + theorem lt_or_ge : a < b ∨ a ≥ b := + lt.by_cases + (assume H1 : a < b, or.inl H1) + (assume H1 : a = b, or.inr (H1 ▸ le.refl a)) + (assume H1 : a > b, or.inr (le_of_lt H1)) + + theorem le_or_gt : a ≤ b ∨ a > b := + or.swap (lt_or_ge b a) + + theorem lt_or_gt_of_ne {a b : A} (H : a ≠ b) : a < b ∨ a > b := + lt.by_cases (assume H1, or.inl H1) (assume H1, absurd H1 H) (assume H1, or.inr H1) +end + +open decidable + +structure decidable_linear_order [class] (A : Type) extends linear_strong_order_pair A := +(decidable_lt : decidable_rel lt) + +section + variable [s : decidable_linear_order A] + variables {a b c d : A} + include s + open decidable + + attribute [instance] + definition decidable_lt : decidable (a < b) := + @decidable_linear_order.decidable_lt _ _ _ _ + + attribute [instance] + definition decidable_le : decidable (a ≤ b) := + by_cases + (assume H : a < b, tt (le_of_lt H)) + (assume H : ¬ a < b, + have H1 : b ≤ a, from le_of_not_gt H, + by_cases + (assume H2 : b < a, ff (not_le_of_gt H2)) + (assume H2 : ¬ b < a, tt (le_of_not_gt H2))) + + attribute [instance] + definition has_decidable_eq : decidable (a = b) := + by_cases + (assume H : a ≤ b, + by_cases + (assume H1 : b ≤ a, tt (le.antisymm H H1)) + (assume H1 : ¬ b ≤ a, ff (assume H2 : a = b, H1 (H2 ▸ le.refl a)))) + (assume H : ¬ a ≤ b, + (ff (assume H1 : a = b, H (H1 ▸ le.refl a)))) + + theorem eq_or_lt_of_not_lt {a b : A} (H : ¬ a < b) : a = b ∨ b < a := + if Heq : a = b then or.inl Heq else or.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 := + sorry + /- + begin + cases eq_or_lt_of_not_lt (not_lt_of_ge H), + exact or.inl a_1⁻¹, + exact or.inr a_1 + end + -/ + + -- testing equality first may result in more definitional equalities + definition lt.cases {B : Type} (a b : A) (t_lt t_eq t_gt : B) : B := + if a = b then t_eq else (if a < b then t_lt else t_gt) + + theorem lt.cases_of_eq {B : Type} {a b : A} {t_lt t_eq t_gt : B} (H : a = b) : + lt.cases a b t_lt t_eq t_gt = t_eq := if_pos H + + theorem lt.cases_of_lt {B : Type} {a b : A} {t_lt t_eq t_gt : B} (H : a < b) : + lt.cases a b t_lt t_eq t_gt = t_lt := + trans (if_neg (ne_of_lt H)) (if_pos H) + + theorem lt.cases_of_gt {B : Type} {a b : A} {t_lt t_eq t_gt : B} (H : a > b) : + lt.cases a b t_lt t_eq t_gt = t_gt := + trans (if_neg (ne.symm (ne_of_lt H))) (if_neg (lt.asymm H)) + + definition min (a b : A) : A := if a ≤ b then a else b + definition max (a b : A) : A := if a ≤ b then b else a + + /- these show min and max form a lattice -/ + + theorem min_le_left (a b : A) : min a b ≤ a := + sorry + /- + by_cases + (assume H : a ≤ b, by rewrite [↑min, if_pos H]) + (assume H : ¬ a ≤ b, by rewrite [↑min, if_neg H]; apply le_of_lt (lt_of_not_ge H)) + -/ + + theorem min_le_right (a b : A) : min a b ≤ b := + sorry + /- + by_cases + (assume H : a ≤ b, by rewrite [↑min, if_pos H]; apply H) + (assume H : ¬ a ≤ b, by rewrite [↑min, if_neg H]) + -/ + + theorem le_min {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) : c ≤ min a b := + sorry + /- + by_cases + (assume H : a ≤ b, by rewrite [↑min, if_pos H]; apply H₁) + (assume H : ¬ a ≤ b, by rewrite [↑min, if_neg H]; apply H₂) + -/ + + theorem le_max_left (a b : A) : a ≤ max a b := + sorry + /- + by_cases + (assume H : a ≤ b, by rewrite [↑max, if_pos H]; apply H) + (assume H : ¬ a ≤ b, by rewrite [↑max, if_neg H]) + -/ + + theorem le_max_right (a b : A) : b ≤ max a b := + sorry + /- + by_cases + (assume H : a ≤ b, by rewrite [↑max, if_pos H]) + (assume H : ¬ a ≤ b, by rewrite [↑max, if_neg H]; apply le_of_lt (lt_of_not_ge H)) + -/ + + theorem max_le {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) : max a b ≤ c := + sorry + /- + by_cases + (assume H : a ≤ b, by rewrite [↑max, if_pos H]; apply H₂) + (assume H : ¬ a ≤ b, by rewrite [↑max, if_neg H]; apply H₁) + -/ + + theorem le_max_left_iff_true (a b : A) : a ≤ max a b ↔ true := + iff_true_intro (le_max_left a b) + + theorem le_max_right_iff_true (a b : A) : b ≤ max a b ↔ true := + iff_true_intro (le_max_right a b) + + /- these are also proved for lattices, but with inf and sup in place of min and max -/ + + theorem eq_min {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) (H₃ : ∀{d}, d ≤ a → d ≤ b → d ≤ c) : + c = min a b := + le.antisymm (le_min H₁ H₂) (H₃ (min_le_left a b) (min_le_right a b)) + + theorem min.comm (a b : A) : min a b = min b a := + eq_min (min_le_right a b) (min_le_left a b) (λ c H₁ H₂, le_min H₂ H₁) + + theorem min.assoc (a b c : A) : min (min a b) c = min a (min b c) := + sorry + /- + begin + apply eq_min, + { apply le.trans, apply min_le_left, apply min_le_left }, + { apply le_min, apply le.trans, apply min_le_left, apply min_le_right, apply min_le_right }, + { intros [d, H₁, H₂], apply le_min, apply le_min H₁, apply le.trans H₂, apply min_le_left, + apply le.trans H₂, apply min_le_right } + end + -/ + + theorem min.left_comm (a b c : A) : min a (min b c) = min b (min a c) := + binary.left_comm (@min.comm A s) (@min.assoc A s) a b c + + theorem min.right_comm (a b c : A) : min (min a b) c = min (min a c) b := + binary.right_comm (@min.comm A s) (@min.assoc A s) a b c + + theorem min_self (a : A) : min a a = a := + sorry -- by apply eq.symm; apply eq_min (le.refl a) !le.refl; intros; assumption + + theorem min_eq_left {a b : A} (H : a ≤ b) : min a b = a := + sorry -- by apply eq.symm; apply eq_min !le.refl H; intros; assumption + + theorem min_eq_right {a b : A} (H : b ≤ a) : min a b = b := + eq.subst (min.comm b a) (min_eq_left H) + + theorem eq_max {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) (H₃ : ∀{d}, a ≤ d → b ≤ d → c ≤ d) : + c = max a b := + le.antisymm (H₃ (le_max_left a b) (le_max_right a b)) (max_le H₁ H₂) + + theorem max.comm (a b : A) : max a b = max b a := + eq_max (le_max_right a b) (le_max_left a b) (λ c H₁ H₂, max_le H₂ H₁) + + theorem max.assoc (a b c : A) : max (max a b) c = max a (max b c) := + sorry + /- + begin + apply eq_max, + { apply le.trans, apply le_max_left a b, apply le_max_left }, + { apply max_le, apply le.trans, apply le_max_right a b, apply le_max_left, apply le_max_right }, + { intros [d, H₁, H₂], apply max_le, apply max_le H₁, apply le.trans !le_max_left H₂, + apply le.trans !le_max_right H₂} + end + -/ + + theorem max.left_comm (a b c : A) : max a (max b c) = max b (max a c) := + binary.left_comm (@max.comm A s) (@max.assoc A s) a b c + + theorem max.right_comm (a b c : A) : max (max a b) c = max (max a c) b := + binary.right_comm (@max.comm A s) (@max.assoc A s) a b c + + theorem max_self (a : A) : max a a = a := + sorry -- by apply eq.symm; apply eq_max (le.refl a) !le.refl; intros; assumption + + theorem max_eq_left {a b : A} (H : b ≤ a) : max a b = a := + sorry -- by apply eq.symm; apply eq_max !le.refl H; intros; assumption + + theorem max_eq_right {a b : A} (H : a ≤ b) : max a b = b := + eq.subst (max.comm b a) (max_eq_left H) + + /- these rely on lt_of_lt -/ + + theorem min_eq_left_of_lt {a b : A} (H : a < b) : min a b = a := + min_eq_left (le_of_lt H) + + theorem min_eq_right_of_lt {a b : A} (H : b < a) : min a b = b := + min_eq_right (le_of_lt H) + + theorem max_eq_left_of_lt {a b : A} (H : b < a) : max a b = a := + max_eq_left (le_of_lt H) + + theorem max_eq_right_of_lt {a b : A} (H : a < b) : max a b = b := + max_eq_right (le_of_lt H) + + /- these use the fact that it is a linear ordering -/ + + theorem lt_min {a b c : A} (H₁ : a < b) (H₂ : a < c) : a < min b c := + sorry + /- + or.elim !le_or_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 := + sorry + /- + or.elim !le_or_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 + +/- order instances -/ + +attribute [instance] +definition weak_order_Prop : weak_order Prop := +⦃ weak_order, + le := λx y, x → y, + le_refl := λx, id, + le_trans := λa b c H1 H2 x, H2 (H1 x), + le_antisymm := λf g H1 H2, propext (and.intro H1 H2) +⦄ + +attribute [instance] +definition weak_order_fun (A B : Type) [weak_order B] : weak_order (A → B) := +⦃ weak_order, + le := λx y, ∀b, x b ≤ y b, + le_refl := λf b, le.refl (f b), + le_trans := λf g h H1 H2 b, le.trans (H1 b) (H2 b), + le_antisymm := λf g H1 H2, funext (λb, le.antisymm (H1 b) (H2 b)) +⦄ + +definition weak_order_dual {A : Type} (wo : weak_order A) : weak_order A := +⦃ weak_order, + le := λx y, y ≤ x, + le_refl := le.refl, + le_trans := sorry, -- take a b c `b ≤ a` `c ≤ b`, le.trans `c ≤ b` `b ≤ a`, + le_antisymm := sorry ⦄ -- take a b `b ≤ a` `a ≤ b`, le.antisymm `a ≤ b` `b ≤ a` ⦄ + +lemma le_dual_eq_le {A : Type} (wo : weak_order A) (a b : A) : + @le _ (@weak_order.to_has_le _ (weak_order_dual wo)) a b = + @le _ (@weak_order.to_has_le _ wo) b a := +rfl + +-- what to do with the strict variants? diff --git a/old_library/algebra/order_bigops.lean b/old_library/algebra/order_bigops.lean new file mode 100644 index 0000000000..4579411102 --- /dev/null +++ b/old_library/algebra/order_bigops.lean @@ -0,0 +1,477 @@ +/- +Copyright (c) 2016 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad + +Min and max over finite sets. + +To support constructive theories, we start with the class +decidable_linear_ordered_cancel_comm_monoid, because: +(1) We need a decidable linear order to have min and max +(2) We need a default element for min and max over the empty set, and max empty = 0 is the + right choice for nat. +(3) All our number classes are instances. +We can define variants of Min and Max if needed. +-/ +import .group_bigops .ordered_ring + +variables {A B : Type} + +section + variable [decidable_linear_order A] + + definition max_comm_semigroup : comm_semigroup A := + ⦃ comm_semigroup, + mul := max, + mul_assoc := max.assoc, + mul_comm := max.comm + ⦄ + + definition min_comm_semigroup : comm_semigroup A := + ⦃ comm_semigroup, + mul := min, + mul_assoc := min.assoc, + mul_comm := min.comm + ⦄ +end + +/- finset versions -/ + +namespace finset + +section deceq_A +variable [decidable_eq A] + +section decidable_linear_ordered_cancel_comm_monoid_B + variable [decidable_linear_ordered_cancel_comm_monoid B] + + section max_comm_semigroup + local attribute max_comm_semigroup [instance] + open Prod_semigroup + + definition Max (s : finset A) (f : A → B) : B := Prod_semigroup 0 s f + notation `Max` binders `∈` s `, ` r:(scoped f, Max s f) := r + + proposition Max_empty (f : A → B) : (Max x ∈ ∅, f x) = 0 := !Prod_semigroup_empty + + proposition Max_singleton (f : A → B) (a : A) : (Max x ∈ '{a}, f x) = f a := + !Prod_semigroup_singleton + + proposition Max_insert_insert (f : A → B) {a₁ a₂ : A} {s : finset A} : + a₂ ∉ s → a₁ ∉ insert a₂ s → + (Max x ∈ insert a₁ (insert a₂ s), f x) = max (f a₁) (Max x ∈ insert a₂ s, f x) := + !Prod_semigroup_insert_insert + + proposition Max_insert (f : A → B) {a : A} {s : finset A} (anins : a ∉ s) (sne : s ≠ ∅) : + (Max x ∈ insert a s, f x) = max (f a) (Max x ∈ s, f x) := + !Prod_semigroup_insert anins sne + end max_comm_semigroup + + proposition Max_pair (f : A → B) (a₁ a₂ : A) : (Max x ∈ '{a₁, a₂}, f x) = max (f a₁) (f a₂) := + decidable.by_cases + (suppose a₁ = a₂, by rewrite [this, pair_eq_singleton, max_self] ) + (suppose a₁ ≠ a₂, + have a₁ ∉ '{a₂}, by rewrite [mem_singleton_iff]; apply this, + using this, by rewrite [Max_insert f this !singleton_ne_empty]) + + proposition le_Max (f : A → B) {a : A} {s : finset A} (H : a ∈ s) : f a ≤ Max x ∈ s, f x := + begin + induction s with a' s' a'nins' ih, + {exact false.elim (not_mem_empty a H)}, + cases (decidable.em (s' = ∅)) with s'empty s'nempty, + {rewrite [s'empty at *, Max_singleton, eq_of_mem_singleton H]}, + rewrite [Max_insert f a'nins' s'nempty], + cases (eq_or_mem_of_mem_insert H) with aeqa' ains', + {rewrite aeqa', apply le_max_left}, + apply le.trans (ih ains') !le_max_right + end + + proposition Max_le (f : A → B) {s : finset A} {b : B} (sne : s ≠ ∅) (H : ∀ a, a ∈ s → f a ≤ b) : + (Max x ∈ s, f x) ≤ b := + begin + induction s with a' s' a'nins' ih, + {exact absurd rfl sne}, + cases (decidable.em (s' = ∅)) with s'empty s'nempty, + {rewrite [s'empty, Max_singleton], exact H a' !mem_insert}, + rewrite [Max_insert f a'nins' s'nempty], + apply max_le (H a' !mem_insert), + apply ih s'nempty, + intro a H', + exact H a (mem_insert_of_mem a' H') + end + + proposition Max_add_right (f : A → B) {s : finset A} (b : B) (sne : s ≠ ∅) : + (Max x ∈ s, f x + b) = (Max x ∈ s, f x) + b := + begin + induction s with a' s' a'nins' ih, + {exact absurd rfl sne}, + cases (decidable.em (s' = ∅)) with s'empty s'ne, + {rewrite [s'empty, Max_singleton]}, + rewrite [*Max_insert _ a'nins' s'ne, ih s'ne, max_add_add_right] + end + + proposition Max_add_left (f : A → B) {s : finset A} (b : B) (sne : s ≠ ∅) : + (Max x ∈ s, b + f x) = b + (Max x ∈ s, f x) := + begin + induction s with a' s' a'nins' ih, + {exact absurd rfl sne}, + cases (decidable.em (s' = ∅)) with s'empty s'ne, + {rewrite [s'empty, Max_singleton]}, + rewrite [*Max_insert _ a'nins' s'ne, ih s'ne, max_add_add_left] + end + + section min_comm_semigroup + local attribute min_comm_semigroup [instance] + open Prod_semigroup + + definition Min (s : finset A) (f : A → B) : B := Prod_semigroup 0 s f + notation `Min` binders `∈` s `, ` r:(scoped f, Min s f) := r + + proposition Min_empty (f : A → B) : (Min x ∈ ∅, f x) = 0 := !Prod_semigroup_empty + + proposition Min_singleton (f : A → B) (a : A) : (Min x ∈ '{a}, f x) = f a := + !Prod_semigroup_singleton + + proposition Min_insert_insert (f : A → B) {a₁ a₂ : A} {s : finset A} : + a₂ ∉ s → a₁ ∉ insert a₂ s → + (Min x ∈ insert a₁ (insert a₂ s), f x) = min (f a₁) (Min x ∈ insert a₂ s, f x) := + !Prod_semigroup_insert_insert + + proposition Min_insert (f : A → B) {a : A} {s : finset A} (anins : a ∉ s) (sne : s ≠ ∅) : + (Min x ∈ insert a s, f x) = min (f a) (Min x ∈ s, f x) := + !Prod_semigroup_insert anins sne + end min_comm_semigroup + + proposition Min_pair (f : A → B) (a₁ a₂ : A) : (Min x ∈ '{a₁, a₂}, f x) = min (f a₁) (f a₂) := + decidable.by_cases + (suppose a₁ = a₂, by rewrite [this, pair_eq_singleton, min_self] ) + (suppose a₁ ≠ a₂, + have a₁ ∉ '{a₂}, by rewrite [mem_singleton_iff]; apply this, + using this, by rewrite [Min_insert f this !singleton_ne_empty]) + + proposition Min_le (f : A → B) {a : A} {s : finset A} (H : a ∈ s) : (Min x ∈ s, f x) ≤ f a := + begin + induction s with a' s' a'nins' ih, + {exact false.elim (not_mem_empty a H)}, + cases (decidable.em (s' = ∅)) with s'empty s'nempty, + {rewrite [s'empty at *, Min_singleton, eq_of_mem_singleton H]}, + rewrite [Min_insert f a'nins' s'nempty], + cases (eq_or_mem_of_mem_insert H) with aeqa' ains', + {rewrite aeqa', apply min_le_left}, + apply le.trans !min_le_right (ih ains') + end + + proposition le_Min (f : A → B) {s : finset A} {b : B} (sne : s ≠ ∅) (H : ∀ a, a ∈ s → b ≤ f a) : + b ≤ Min x ∈ s, f x := + begin + induction s with a' s' a'nins' ih, + {exact absurd rfl sne}, + cases (decidable.em (s' = ∅)) with s'empty s'nempty, + {rewrite [s'empty, Min_singleton], exact H a' !mem_insert}, + rewrite [Min_insert f a'nins' s'nempty], + apply le_min (H a' !mem_insert), + apply ih s'nempty, + intro a H', + exact H a (mem_insert_of_mem a' H') + end + + proposition Min_add_right (f : A → B) {s : finset A} (b : B) (sne : s ≠ ∅) : + (Min x ∈ s, f x + b) = (Min x ∈ s, f x) + b := + begin + induction s with a' s' a'nins' ih, + {exact absurd rfl sne}, + cases (decidable.em (s' = ∅)) with s'empty s'ne, + {rewrite [s'empty, Min_singleton]}, + rewrite [*Min_insert _ a'nins' s'ne, ih s'ne, min_add_add_right] + end + + proposition Min_add_left (f : A → B) {s : finset A} (b : B) (sne : s ≠ ∅) : + (Min x ∈ s, b + f x) = b + (Min x ∈ s, f x) := + begin + induction s with a' s' a'nins' ih, + {exact absurd rfl sne}, + cases (decidable.em (s' = ∅)) with s'empty s'ne, + {rewrite [s'empty, Min_singleton]}, + rewrite [*Min_insert _ a'nins' s'ne, ih s'ne, min_add_add_left] + end +end decidable_linear_ordered_cancel_comm_monoid_B + +section decidable_linear_ordered_comm_group_B + variable [decidable_linear_ordered_comm_group B] + + proposition Max_neg (f : A → B) (s : finset A) : (Max x ∈ s, - f x) = - Min x ∈ s, f x := + begin + cases (decidable.em (s = ∅)) with se sne, + {rewrite [se, Max_empty, Min_empty, neg_zero]}, + apply eq_of_le_of_ge, + {apply !Max_le sne, + intro a ains, + apply neg_le_neg, + apply !Min_le ains}, + apply neg_le_of_neg_le, + apply !le_Min sne, + intro a ains, + apply neg_le_of_neg_le, + apply !le_Max ains + end + + proposition Min_neg (f : A → B) (s : finset A) : (Min x ∈ s, - f x) = - Max x ∈ s, f x := + begin + cases (decidable.em (s = ∅)) with se sne, + {rewrite [se, Max_empty, Min_empty, neg_zero]}, + apply eq_of_le_of_ge, + {apply le_neg_of_le_neg, + apply !Max_le sne, + intro a ains, + apply le_neg_of_le_neg, + apply !Min_le ains}, + apply !le_Min sne, + intro a ains, + apply neg_le_neg, + apply !le_Max ains + end + + proposition Max_eq_neg_Min_neg (f : A → B) (s : finset A) : + (Max x ∈ s, f x) = - Min x ∈ s, - f x := + by rewrite [Min_neg, neg_neg] + + proposition Min_eq_neg_Max_neg (f : A → B) (s : finset A) : + (Min x ∈ s, f x) = - Max x ∈ s, - f x := + by rewrite [Max_neg, neg_neg] + +end decidable_linear_ordered_comm_group_B + +end deceq_A + +/- Min and Max *of* a finset -/ + +section decidable_linear_ordered_semiring_A + variable [decidable_linear_ordered_semiring A] + + definition Max₀ (s : finset A) : A := Max x ∈ s, x + definition Min₀ (s : finset A) : A := Min x ∈ s, x + + proposition Max₀_empty : Max₀ ∅ = (0 : A) := !Max_empty + + proposition Max₀_singleton (a : A) : Max₀ '{a} = a := !Max_singleton + + proposition Max₀_insert_insert {a₁ a₂ : A} {s : finset A} (H₁ : a₂ ∉ s) (H₂ : a₁ ∉ insert a₂ s) : + Max₀ (insert a₁ (insert a₂ s)) = max a₁ (Max₀ (insert a₂ s)) := + !Max_insert_insert H₁ H₂ + + proposition Max₀_insert {s : finset A} {a : A} (anins : a ∉ s) (sne : s ≠ ∅) : + Max₀ (insert a s) = max a (Max₀ s) := !Max_insert anins sne + + proposition Max₀_pair (a₁ a₂ : A) : Max₀ '{a₁, a₂} = max a₁ a₂ := !Max_pair + + proposition le_Max₀ {a : A} {s : finset A} (H : a ∈ s) : a ≤ Max₀ s := !le_Max H + + proposition Max₀_le {s : finset A} {a : A} (sne : s ≠ ∅) (H : ∀ x, x ∈ s → x ≤ a) : + Max₀ s ≤ a := !Max_le sne H + + proposition Min₀_empty : Min₀ ∅ = (0 : A) := !Min_empty + + proposition Min₀_singleton (a : A) : Min₀ '{a} = a := !Min_singleton + + proposition Min₀_insert_insert {a₁ a₂ : A} {s : finset A} (H₁ : a₂ ∉ s) (H₂ : a₁ ∉ insert a₂ s) : + Min₀ (insert a₁ (insert a₂ s)) = min a₁ (Min₀ (insert a₂ s)) := + !Min_insert_insert H₁ H₂ + + proposition Min₀_insert {s : finset A} {a : A} (anins : a ∉ s) (sne : s ≠ ∅) : + Min₀ (insert a s) = min a (Min₀ s) := !Min_insert anins sne + + proposition Min₀_pair (a₁ a₂ : A) : Min₀ '{a₁, a₂} = min a₁ a₂ := !Min_pair + + proposition Min₀_le {a : A} {s : finset A} (H : a ∈ s) : Min₀ s ≤ a := !Min_le H + + proposition le_Min₀ {s : finset A} {a : A} (sne : s ≠ ∅) (H : ∀ x, x ∈ s → a ≤ x) : + a ≤ Min₀ s := !le_Min sne H +end decidable_linear_ordered_semiring_A + +end finset + +/- finite set versions -/ + +namespace set +local attribute classical.prop_decidable [instance] + +section decidable_linear_ordered_cancel_comm_monoid_B + variable [decidable_linear_ordered_cancel_comm_monoid B] + + noncomputable definition Max (s : set A) (f : A → B) : B := finset.Max (to_finset s) f + notation `Max` binders `∈` s `, ` r:(scoped f, Max s f) := r + + noncomputable definition Min (s : set A) (f : A → B) : B := finset.Min (to_finset s) f + notation `Min` binders `∈` s `, ` r:(scoped f, Min s f) := r + + proposition Max_empty (f : A → B) : (Max x ∈ ∅, f x) = 0 := + by rewrite [↑set.Max, to_finset_empty, finset.Max_empty] + + proposition Max_singleton (f : A → B) (a : A) : (Max x ∈ '{a}, f x) = f a := + by rewrite [↑set.Max, to_finset_insert, to_finset_empty, finset.Max_singleton] + + proposition Max_insert_insert (f : A → B) {a₁ a₂ : A} {s : set A} [h : finite s] : + a₂ ∉ s → a₁ ∉ insert a₂ s → + (Max x ∈ insert a₁ (insert a₂ s), f x) = max (f a₁) (Max x ∈ insert a₂ s, f x) := + begin + rewrite [↑set.Max, -+mem_to_finset_eq, +to_finset_insert], + apply finset.Max_insert_insert + end + + proposition Max_insert (f : A → B) {a : A} {s : set A} [h : finite s] (anins : a ∉ s) + (sne : s ≠ ∅) : + (Max x ∈ insert a s, f x) = max (f a) (Max x ∈ s, f x) := + begin + revert anins sne, + rewrite [↑set.Max, -+mem_to_finset_eq, +to_finset_insert], + intro h1 h2, + apply finset.Max_insert f h1 (λ h', h2 (eq_empty_of_to_finset_eq_empty h')), + end + + proposition Max_pair (f : A → B) (a₁ a₂ : A) : (Max x ∈ '{a₁, a₂}, f x) = max (f a₁) (f a₂) := + by rewrite [↑set.Max, +to_finset_insert, +to_finset_empty, finset.Max_pair] + + proposition le_Max (f : A → B) {a : A} {s : set A} [fins : finite s] (H : a ∈ s) : + f a ≤ Max x ∈ s, f x := + by rewrite [-+mem_to_finset_eq at H, ↑set.Max]; exact finset.le_Max f H + + proposition Max_le (f : A → B) {s : set A} [fins : finite s] {b : B} (sne : s ≠ ∅) + (H : ∀ a, a ∈ s → f a ≤ b) : + (Max x ∈ s, f x) ≤ b := + begin + rewrite [↑set.Max], + apply finset.Max_le f (λ H', sne (eq_empty_of_to_finset_eq_empty H')), + intro a H', apply H a, rewrite mem_to_finset_eq at H', exact H' + end + + proposition Max_add_right (f : A → B) {s : set A} [fins : finite s] (b : B) (sne : s ≠ ∅) : + (Max x ∈ s, f x + b) = (Max x ∈ s, f x) + b := + begin + rewrite [↑set.Max], + apply finset.Max_add_right f b (λ h, sne (eq_empty_of_to_finset_eq_empty h)) + end + + proposition Max_add_left (f : A → B) {s : set A} [fins : finite s] (b : B) (sne : s ≠ ∅) : + (Max x ∈ s, b + f x) = b + (Max x ∈ s, f x) := + begin + rewrite [↑set.Max], + apply finset.Max_add_left f b (λ h, sne (eq_empty_of_to_finset_eq_empty h)) + end + + proposition Min_empty (f : A → B) : (Min x ∈ ∅, f x) = 0 := + by rewrite [↑set.Min, to_finset_empty, finset.Min_empty] + + proposition Min_singleton (f : A → B) (a : A) : (Min x ∈ '{a}, f x) = f a := + by rewrite [↑set.Min, to_finset_insert, to_finset_empty, finset.Min_singleton] + + proposition Min_insert_insert (f : A → B) {a₁ a₂ : A} {s : set A} [h : finite s] : + a₂ ∉ s → a₁ ∉ insert a₂ s → + (Min x ∈ insert a₁ (insert a₂ s), f x) = min (f a₁) (Min x ∈ insert a₂ s, f x) := + begin + rewrite [↑set.Min, -+mem_to_finset_eq, +to_finset_insert], + apply finset.Min_insert_insert + end + + proposition Min_insert (f : A → B) {a : A} {s : set A} [h : finite s] (anins : a ∉ s) + (sne : s ≠ ∅) : + (Min x ∈ insert a s, f x) = min (f a) (Min x ∈ s, f x) := + begin + revert anins sne, + rewrite [↑set.Min, -+mem_to_finset_eq, +to_finset_insert], + intro h1 h2, + apply finset.Min_insert f h1 (λ h', h2 (eq_empty_of_to_finset_eq_empty h')), + end + + proposition Min_pair (f : A → B) (a₁ a₂ : A) : (Min x ∈ '{a₁, a₂}, f x) = min (f a₁) (f a₂) := + by rewrite [↑set.Min, +to_finset_insert, +to_finset_empty, finset.Min_pair] + + proposition Min_le (f : A → B) {a : A} {s : set A} [fins : finite s] (H : a ∈ s) : + (Min x ∈ s, f x) ≤ f a := + by rewrite [-+mem_to_finset_eq at H, ↑set.Min]; exact finset.Min_le f H + + proposition le_Min (f : A → B) {s : set A} [fins : finite s] {b : B} (sne : s ≠ ∅) + (H : ∀ a, a ∈ s → b ≤ f a) : + b ≤ Min x ∈ s, f x := + begin + rewrite [↑set.Min], + apply finset.le_Min f (λ H', sne (eq_empty_of_to_finset_eq_empty H')), + intro a H', apply H a, rewrite mem_to_finset_eq at H', exact H' + end + + proposition Min_add_right (f : A → B) {s : set A} [fins : finite s] (b : B) (sne : s ≠ ∅) : + (Min x ∈ s, f x + b) = (Min x ∈ s, f x) + b := + begin + rewrite [↑set.Min], + apply finset.Min_add_right f b (λ h, sne (eq_empty_of_to_finset_eq_empty h)) + end + + proposition Min_add_left (f : A → B) {s : set A} [fins : finite s] (b : B) (sne : s ≠ ∅) : + (Min x ∈ s, b + f x) = b + (Min x ∈ s, f x) := + begin + rewrite [↑set.Min], + apply finset.Min_add_left f b (λ h, sne (eq_empty_of_to_finset_eq_empty h)) + end +end decidable_linear_ordered_cancel_comm_monoid_B + +section decidable_linear_ordered_comm_group_B + variable [decidable_linear_ordered_comm_group B] + + proposition Max_neg (f : A → B) (s : set A) : (Max x ∈ s, - f x) = - Min x ∈ s, f x := + by rewrite [↑set.Max, finset.Max_neg] + + proposition Min_neg (f : A → B) (s : set A) : (Min x ∈ s, - f x) = - Max x ∈ s, f x := + by rewrite [↑set.Min, finset.Min_neg] + + proposition Max_eq_neg_Min_neg (f : A → B) (s : set A) : (Max x ∈ s, f x) = - Min x ∈ s, - f x := + by rewrite [↑set.Max, ↑set.Min, finset.Max_eq_neg_Min_neg] + + proposition Min_eq_neg_Max_neg (f : A → B) (s : set A) : (Min x ∈ s, f x) = - Max x ∈ s, - f x := + by rewrite [↑set.Max, ↑set.Min, finset.Min_eq_neg_Max_neg] +end decidable_linear_ordered_comm_group_B + +section decidable_linear_ordered_semiring_A + variable [decidable_linear_ordered_semiring A] + + noncomputable definition Max₀ (s : set A) : A := Max x ∈ s, x + noncomputable definition Min₀ (s : set A) : A := Min x ∈ s, x + + proposition Max₀_empty : Max₀ ∅ = (0 : A) := !Max_empty + + proposition Max₀_singleton (a : A) : Max₀ '{a} = a := !Max_singleton + + proposition Max₀_insert_insert {a₁ a₂ : A} {s : set A} [fins : finite s] (H₁ : a₂ ∉ s) + (H₂ : a₁ ∉ insert a₂ s) : + Max₀ (insert a₁ (insert a₂ s)) = max a₁ (Max₀ (insert a₂ s)) := + !Max_insert_insert H₁ H₂ + + proposition Max₀_insert {s : set A} [fins : finite s] {a : A} (anins : a ∉ s) (sne : s ≠ ∅) : + Max₀ (insert a s) = max a (Max₀ s) := !Max_insert anins sne + + proposition Max₀_pair (a₁ a₂ : A) : Max₀ '{a₁, a₂} = max a₁ a₂ := !Max_pair + + proposition le_Max₀ {a : A} {s : set A} [fins : finite s] (H : a ∈ s) : a ≤ Max₀ s := !le_Max H + + proposition Max₀_le {s : set A} [fins : finite s] {a : A} (sne : s ≠ ∅) (H : ∀ x, x ∈ s → x ≤ a) : + Max₀ s ≤ a := !Max_le sne H + + proposition Min₀_empty : Min₀ ∅ = (0 : A) := !Min_empty + + proposition Min₀_singleton (a : A) : Min₀ '{a} = a := !Min_singleton + + proposition Min₀_insert_insert {a₁ a₂ : A} {s : set A} [fins : finite s] (H₁ : a₂ ∉ s) + (H₂ : a₁ ∉ insert a₂ s) : + Min₀ (insert a₁ (insert a₂ s)) = min a₁ (Min₀ (insert a₂ s)) := + !Min_insert_insert H₁ H₂ + + proposition Min₀_insert {s : set A} [fins : finite s] {a : A} (anins : a ∉ s) (sne : s ≠ ∅) : + Min₀ (insert a s) = min a (Min₀ s) := !Min_insert anins sne + + proposition Min₀_pair (a₁ a₂ : A) : Min₀ '{a₁, a₂} = min a₁ a₂ := !Min_pair + + proposition Min₀_le {a : A} {s : set A} [fins : finite s] (H : a ∈ s) : Min₀ s ≤ a := !Min_le H + + proposition le_Min₀ {s : set A} [fins : finite s] {a : A} (sne : s ≠ ∅) (H : ∀ x, x ∈ s → a ≤ x) : + a ≤ Min₀ s := !le_Min sne H +end decidable_linear_ordered_semiring_A + +end set diff --git a/old_library/algebra/ordered_field.lean b/old_library/algebra/ordered_field.lean new file mode 100644 index 0000000000..96eb8de4ad --- /dev/null +++ b/old_library/algebra/ordered_field.lean @@ -0,0 +1,672 @@ +/- +Copyright (c) 2014 Robert Lewis. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Robert Lewis +-/ +import algebra.ordered_ring algebra.field +open eq + +structure linear_ordered_field [class] (A : Type) extends linear_ordered_ring A, field A + +section linear_ordered_field + + variable {A : Type} + variables [s : linear_ordered_field A] {a b c d : A} + include s + + -- helpers for following + theorem mul_zero_lt_mul_inv_of_pos (H : 0 < a) : a * 0 < a * (1 / a) := + sorry + /- + calc + a * 0 = 0 : by rewrite mul_zero + ... < 1 : !zero_lt_one + ... = a * a⁻¹ : eq.symm (mul_inv_cancel (ne.symm (ne_of_lt H))) + ... = a * (1 / a) : by rewrite inv_eq_one_div + -/ + theorem mul_zero_lt_mul_inv_of_neg (H : a < 0) : a * 0 < a * (1 / a) := + sorry + /- + calc + a * 0 = 0 : by rewrite mul_zero + ... < 1 : !zero_lt_one + ... = a * a⁻¹ : eq.symm (mul_inv_cancel (ne_of_lt H)) + ... = a * (1 / a) : by rewrite inv_eq_one_div + -/ + + theorem one_div_pos_of_pos (H : 0 < a) : 0 < 1 / a := + lt_of_mul_lt_mul_left (mul_zero_lt_mul_inv_of_pos H) (le_of_lt H) + + theorem one_div_neg_of_neg (H : a < 0) : 1 / a < 0 := + gt_of_mul_lt_mul_neg_left (mul_zero_lt_mul_inv_of_neg H) (le_of_lt H) + + + theorem le_mul_of_ge_one_right (Hb : b ≥ 0) (H : a ≥ 1) : b ≤ b * a := + mul_one _ ▸ (mul_le_mul_of_nonneg_left H Hb) + + theorem lt_mul_of_gt_one_right (Hb : b > 0) (H : a > 1) : b < b * a := + mul_one _ ▸ (mul_lt_mul_of_pos_left H Hb) + + theorem one_le_div_iff_le (a : A) {b : A} (Hb : b > 0) : 1 ≤ a / b ↔ b ≤ a := + have Hb' : b ≠ 0, from ne.symm (ne_of_lt Hb), + iff.intro + (assume H : 1 ≤ a / b, + calc + b = b : rfl + ... ≤ b * (a / b) : le_mul_of_ge_one_right (le_of_lt Hb) H + ... = a : mul_div_cancel' Hb') + (assume H : b ≤ a, + have Hbinv : 1 / b > 0, from one_div_pos_of_pos Hb, calc + 1 = b * (1 / b) : eq.symm (mul_one_div_cancel Hb') + ... ≤ a * (1 / b) : mul_le_mul_of_nonneg_right H (le_of_lt Hbinv) + ... = a / b : eq.symm $ div_eq_mul_one_div a b) + + theorem le_of_one_le_div (Hb : b > 0) (H : 1 ≤ a / b) : b ≤ a := + iff.mp (one_le_div_iff_le a Hb) H + + theorem one_le_div_of_le (Hb : b > 0) (H : b ≤ a) : 1 ≤ a / b := + iff.mpr (one_le_div_iff_le a Hb) H + + theorem one_lt_div_iff_lt (a : A) {b : A} (Hb : b > 0) : 1 < a / b ↔ b < a := + have Hb' : b ≠ 0, from ne.symm (ne_of_lt Hb), + iff.intro + (assume H : 1 < a / b, + calc + b < b * (a / b) : lt_mul_of_gt_one_right Hb H + ... = a : mul_div_cancel' Hb') + (assume H : b < a, + have Hbinv : 1 / b > 0, from one_div_pos_of_pos Hb, calc + 1 = b * (1 / b) : eq.symm (mul_one_div_cancel Hb') + ... < a * (1 / b) : mul_lt_mul_of_pos_right H Hbinv + ... = a / b : eq.symm $ div_eq_mul_one_div a b) + + theorem lt_of_one_lt_div (Hb : b > 0) (H : 1 < a / b) : b < a := + iff.mp (one_lt_div_iff_lt a Hb) H + + theorem one_lt_div_of_lt (Hb : b > 0) (H : b < a) : 1 < a / b := + iff.mpr (one_lt_div_iff_lt a Hb) H + + theorem exists_lt (a : A) : ∃ x, x < a := + have H : a - 1 < a, from add_lt_of_le_of_neg (le.refl _) zero_gt_neg_one, + exists.intro _ H + + theorem exists_gt (a : A) : ∃ x, x > a := + have H : a + 1 > a, from lt_add_of_le_of_pos (le.refl _) zero_lt_one, + exists.intro _ H + + -- the following theorems amount to four iffs, for <, ≤, ≥, >. + + theorem mul_le_of_le_div (Hc : 0 < c) (H : a ≤ b / c) : a * c ≤ b := + div_mul_cancel b (ne.symm (ne_of_lt Hc)) ▸ mul_le_mul_of_nonneg_right H (le_of_lt Hc) + + theorem le_div_of_mul_le (Hc : 0 < c) (H : a * c ≤ b) : a ≤ b / c := + calc + a = a * c * (1 / c) : mul_mul_div a (ne.symm (ne_of_lt Hc)) + ... ≤ b * (1 / c) : mul_le_mul_of_nonneg_right H (le_of_lt (one_div_pos_of_pos Hc)) + ... = b / c : eq.symm $ div_eq_mul_one_div b c + + theorem mul_lt_of_lt_div (Hc : 0 < c) (H : a < b / c) : a * c < b := + div_mul_cancel b (ne.symm (ne_of_lt Hc)) ▸ mul_lt_mul_of_pos_right H Hc + + theorem lt_div_of_mul_lt (Hc : 0 < c) (H : a * c < b) : a < b / c := + calc + a = a * c * (1 / c) : mul_mul_div a (ne.symm (ne_of_lt Hc)) + ... < b * (1 / c) : mul_lt_mul_of_pos_right H (one_div_pos_of_pos Hc) + ... = b / c : eq.symm $ div_eq_mul_one_div b c + + theorem mul_le_of_div_le_of_neg (Hc : c < 0) (H : b / c ≤ a) : a * c ≤ b := + div_mul_cancel b (ne_of_lt Hc) ▸ mul_le_mul_of_nonpos_right H (le_of_lt Hc) + + theorem div_le_of_mul_le_of_neg (Hc : c < 0) (H : a * c ≤ b) : b / c ≤ a := + calc + a = a * c * (1 / c) : mul_mul_div a (ne_of_lt Hc) + ... ≥ b * (1 / c) : mul_le_mul_of_nonpos_right H (le_of_lt (one_div_neg_of_neg Hc)) + ... = b / c : eq.symm $ div_eq_mul_one_div b c + + theorem mul_lt_of_gt_div_of_neg (Hc : c < 0) (H : a > b / c) : a * c < b := + div_mul_cancel b (ne_of_lt Hc) ▸ mul_lt_mul_of_neg_right H Hc + + theorem div_lt_of_mul_lt_of_pos (Hc : c > 0) (H : b < a * c) : b / c < a := + calc + a = a * c * (1 / c) : mul_mul_div a (ne_of_gt Hc) + ... > b * (1 / c) : mul_lt_mul_of_pos_right H (one_div_pos_of_pos Hc) + ... = b / c : eq.symm $ div_eq_mul_one_div b c + + theorem div_lt_of_mul_gt_of_neg (Hc : c < 0) (H : a * c < b) : b / c < a := + calc + a = a * c * (1 / c) : mul_mul_div a (ne_of_lt Hc) + ... > b * (1 / c) : mul_lt_mul_of_neg_right H (one_div_neg_of_neg Hc) + ... = b / c : eq.symm $ div_eq_mul_one_div b c + + theorem div_le_of_le_mul (Hb : b > 0) (H : a ≤ b * c) : a / b ≤ c := + calc + a / b = a * (1 / b) : div_eq_mul_one_div a b + ... ≤ (b * c) * (1 / b) : mul_le_mul_of_nonneg_right H (le_of_lt (one_div_pos_of_pos Hb)) + ... = (b * c) / b : eq.symm $ div_eq_mul_one_div (b * c) b + ... = c : mul_div_cancel_left (ne.symm (ne_of_lt Hb)) + + theorem le_mul_of_div_le (Hc : c > 0) (H : a / c ≤ b) : a ≤ b * c := + sorry + /- + calc + a = a / c * c : by rewrite (!div_mul_cancel (ne.symm (ne_of_lt Hc))) + ... ≤ b * c : mul_le_mul_of_nonneg_right H (le_of_lt Hc) + -/ + + -- following these in the isabelle file, there are 8 biconditionals for the above with - signs + -- skipping for now + + theorem mul_sub_mul_div_mul_neg (Hc : c ≠ 0) (Hd : d ≠ 0) (H : a / c < b / d) : + (a * d - b * c) / (c * d) < 0 := + sorry + /- + have H1 : a / c - b / d < 0, from calc + a / c - b / d < b / d - b / d : sub_lt_sub_right H _ + ... = 0 : !sub_self, + calc + 0 > a / c - b / d : H1 + ... = (a * d - c * b) / (c * d) : !div_sub_div Hc Hd + ... = (a * d - b * c) / (c * d) : by rewrite (mul.comm b c) + -/ + theorem mul_sub_mul_div_mul_nonpos (Hc : c ≠ 0) (Hd : d ≠ 0) (H : a / c ≤ b / d) : + (a * d - b * c) / (c * d) ≤ 0 := + sorry + /- + have H1 : a / c - b / d ≤ 0, from calc + a / c - b / d ≤ b / d - b / d : sub_le_sub_right H _ + ... = 0 : !sub_self, + calc + 0 ≥ a / c - b / d : H1 + ... = (a * d - c * b) / (c * d) : !div_sub_div Hc Hd + ... = (a * d - b * c) / (c * d) : by rewrite (mul.comm b c) + -/ + + theorem div_lt_div_of_mul_sub_mul_div_neg (Hc : c ≠ 0) (Hd : d ≠ 0) + (H : (a * d - b * c) / (c * d) < 0) : a / c < b / d := + sorry + /- + have H1 : (a * d - c * b) / (c * d) < 0, by rewrite [mul.comm c b]; exact H, + have H2 : a / c - b / d < 0, by rewrite [!div_sub_div Hc Hd]; exact H1, + have H3 : a / c - b / d + b / d < 0 + b / d, from add_lt_add_right H2 _, + begin rewrite [zero_add at H3, sub_eq_add_neg at H3, neg_add_cancel_right at H3], exact H3 end + -/ + + theorem div_le_div_of_mul_sub_mul_div_nonpos (Hc : c ≠ 0) (Hd : d ≠ 0) + (H : (a * d - b * c) / (c * d) ≤ 0) : a / c ≤ b / d := + sorry + /- + have H1 : (a * d - c * b) / (c * d) ≤ 0, by rewrite [mul.comm c b]; exact H, + have H2 : a / c - b / d ≤ 0, by rewrite [!div_sub_div Hc Hd]; exact H1, + have H3 : a / c - b / d + b / d ≤ 0 + b / d, from add_le_add_right H2 _, + begin rewrite [zero_add at H3, sub_eq_add_neg at H3, neg_add_cancel_right at H3], exact H3 end + -/ + + theorem div_pos_of_pos_of_pos (Ha : 0 < a) (Hb : 0 < b) : 0 < a / b := + sorry + /- + begin + rewrite div_eq_mul_one_div, + apply mul_pos, + exact Ha, + apply one_div_pos_of_pos, + exact Hb + end + -/ + + theorem div_nonneg_of_nonneg_of_pos (Ha : 0 ≤ a) (Hb : 0 < b) : 0 ≤ a / b := + sorry + /- + begin + rewrite div_eq_mul_one_div, + apply mul_nonneg, + exact Ha, + apply le_of_lt, + apply one_div_pos_of_pos, + exact Hb + end + -/ + + theorem div_neg_of_neg_of_pos (Ha : a < 0) (Hb : 0 < b) : a / b < 0:= + sorry + /- + begin + rewrite div_eq_mul_one_div, + apply mul_neg_of_neg_of_pos, + exact Ha, + apply one_div_pos_of_pos, + exact Hb + end + -/ + + theorem div_nonpos_of_nonpos_of_pos (Ha : a ≤ 0) (Hb : 0 < b) : a / b ≤ 0 := + sorry + /- + begin + rewrite div_eq_mul_one_div, + apply mul_nonpos_of_nonpos_of_nonneg, + exact Ha, + apply le_of_lt, + apply one_div_pos_of_pos, + exact Hb + end + -/ + + theorem div_neg_of_pos_of_neg (Ha : 0 < a) (Hb : b < 0) : a / b < 0 := + sorry + /- + begin + rewrite div_eq_mul_one_div, + apply mul_neg_of_pos_of_neg, + exact Ha, + apply one_div_neg_of_neg, + exact Hb + end + -/ + + theorem div_nonpos_of_nonneg_of_neg (Ha : 0 ≤ a) (Hb : b < 0) : a / b ≤ 0 := + sorry + /- + begin + rewrite div_eq_mul_one_div, + apply mul_nonpos_of_nonneg_of_nonpos, + exact Ha, + apply le_of_lt, + apply one_div_neg_of_neg, + exact Hb + end + -/ + + theorem div_pos_of_neg_of_neg (Ha : a < 0) (Hb : b < 0) : 0 < a / b := + sorry + /- + begin + rewrite div_eq_mul_one_div, + apply mul_pos_of_neg_of_neg, + exact Ha, + apply one_div_neg_of_neg, + exact Hb + end + -/ + + theorem div_nonneg_of_nonpos_of_neg (Ha : a ≤ 0) (Hb : b < 0) : 0 ≤ a / b := + sorry + /- + begin + rewrite div_eq_mul_one_div, + apply mul_nonneg_of_nonpos_of_nonpos, + exact Ha, + apply le_of_lt, + apply one_div_neg_of_neg, + exact Hb + end + -/ + + theorem div_lt_div_of_lt_of_pos (H : a < b) (Hc : 0 < c) : a / c < b / c := + sorry + /- + begin + rewrite [{a/c}div_eq_mul_one_div, {b/c}div_eq_mul_one_div], + exact mul_lt_mul_of_pos_right H (one_div_pos_of_pos Hc) + end + -/ + + theorem div_le_div_of_le_of_pos (H : a ≤ b) (Hc : 0 < c) : a / c ≤ b / c := + sorry + /- + begin + rewrite [{a/c}div_eq_mul_one_div, {b/c}div_eq_mul_one_div], + exact mul_le_mul_of_nonneg_right H (le_of_lt (one_div_pos_of_pos Hc)) + end + -/ + + theorem div_lt_div_of_lt_of_neg (H : b < a) (Hc : c < 0) : a / c < b / c := + sorry + /- + begin + rewrite [{a/c}div_eq_mul_one_div, {b/c}div_eq_mul_one_div], + exact mul_lt_mul_of_neg_right H (one_div_neg_of_neg Hc) + end + -/ + + theorem div_le_div_of_le_of_neg (H : b ≤ a) (Hc : c < 0) : a / c ≤ b / c := + sorry + /- + begin + rewrite [{a/c}div_eq_mul_one_div, {b/c}div_eq_mul_one_div], + exact mul_le_mul_of_nonpos_right H (le_of_lt (one_div_neg_of_neg Hc)) + end + -/ + + theorem two_pos : (1 : A) + 1 > 0 := + add_pos zero_lt_one zero_lt_one + + theorem one_add_one_ne_zero : 1 + 1 ≠ (0:A) := + ne.symm (ne_of_lt two_pos) + + theorem two_ne_zero : 2 ≠ (0:A) := + sorry -- by unfold bit0; apply one_add_one_ne_zero + + theorem add_halves (a : A) : a / 2 + a / 2 = a := + sorry + /- + calc + a / 2 + a / 2 = (a + a) / 2 : by rewrite div_add_div_same + ... = (a * 1 + a * 1) / 2 : by rewrite mul_one + ... = (a * (1 + 1)) / 2 : by rewrite left_distrib + ... = (a * 2) / 2 : by rewrite one_add_one_eq_two + ... = a : by rewrite [@mul_div_cancel A _ _ _ two_ne_zero] + -/ + + theorem sub_self_div_two (a : A) : a - a / 2 = a / 2 := + sorry -- by rewrite [-{a}add_halves at {1}, add_sub_cancel] + + theorem add_midpoint {a b : A} (H : a < b) : a + (b - a) / 2 < b := + sorry + /- + begin + rewrite [-div_sub_div_same, sub_eq_add_neg, {b / 2 + _}add.comm, -add.assoc, -sub_eq_add_neg], + apply add_lt_of_lt_sub_right, + rewrite *sub_self_div_two, + apply div_lt_div_of_lt_of_pos H two_pos + end + -/ + + theorem div_two_sub_self (a : A) : a / 2 - a = - (a / 2) := + sorry -- by rewrite [-{a}add_halves at {2}, sub_add_eq_sub_sub, sub_self, zero_sub] + + theorem add_self_div_two (a : A) : (a + a) / 2 = a := + sorry + /- + symm (iff.mpr (!eq_div_iff_mul_eq (ne_of_gt (add_pos zero_lt_one zero_lt_one))) + (by krewrite [left_distrib, *mul_one])) + -/ + + theorem two_gt_one : (2:A) > 1 := + calc (2:A) = 1+1 : one_add_one_eq_two + ... > 1+0 : add_lt_add_left zero_lt_one _ + ... = 1 : add_zero 1 + + theorem two_ge_one : (2:A) ≥ 1 := + le_of_lt two_gt_one + + theorem four_pos : (4 : A) > 0 := add_pos two_pos two_pos + + theorem mul_le_mul_of_mul_div_le (H : a * (b / c) ≤ d) (Hc : c > 0) : b * a ≤ d * c := + sorry + /- + begin + rewrite [-mul_div_assoc at H, mul.comm b], + apply le_mul_of_div_le Hc H + end + -/ + + theorem div_two_lt_of_pos (H : a > 0) : a / (1 + 1) < a := + have Ha : a / (1 + 1) > 0, from div_pos_of_pos_of_pos H (add_pos zero_lt_one zero_lt_one), + calc + a / (1 + 1) < a / (1 + 1) + a / (1 + 1) : lt_add_of_pos_left Ha + ... = a : add_halves a + + theorem div_mul_le_div_mul_of_div_le_div_pos {e : A} (Hb : b ≠ 0) (Hd : d ≠ 0) (H : a / b ≤ c / d) + (He : e > 0) : a / (b * e) ≤ c / (d * e) := + sorry + /- + begin + rewrite [!field.div_mul_eq_div_mul_one_div Hb (ne_of_gt He), + !field.div_mul_eq_div_mul_one_div Hd (ne_of_gt He)], + apply mul_le_mul_of_nonneg_right H, + apply le_of_lt, + apply one_div_pos_of_pos He + end + -/ + + theorem exists_add_lt_and_pos_of_lt (H : b < a) : ∃ c : A, b + c < a ∧ c > 0 := + sorry + /- + exists.intro ((a - b) / (1 + 1)) + (and.intro (have H2 : a + a > (b + b) + (a - b), from calc + a + a > b + a : add_lt_add_right H _ + ... = b + a + b - b : by rewrite add_sub_cancel + ... = b + b + a - b : by rewrite add.right_comm + ... = (b + b) + (a - b) : by rewrite add_sub, + have H3 : (a + a) / 2 > ((b + b) + (a - b)) / 2, + from div_lt_div_of_lt_of_pos H2 two_pos, + by rewrite [one_add_one_eq_two, sub_eq_add_neg, add_self_div_two at H3, -div_add_div_same at H3, add_self_div_two at H3]; + exact H3) + (div_pos_of_pos_of_pos (iff.mpr !sub_pos_iff_lt H) two_pos)) + -/ + + theorem ge_of_forall_ge_sub {a b : A} (H : ∀ ε : A, ε > 0 → a ≥ b - ε) : a ≥ b := + sorry + /- + begin + apply le_of_not_gt, + intro Hb, + cases exists_add_lt_and_pos_of_lt Hb with [c, Hc], + let Hc' := H c (and.right Hc), + apply (not_le_of_gt (and.left Hc)) (iff.mpr !le_add_iff_sub_right_le Hc') + end + -/ + +end linear_ordered_field + +structure discrete_linear_ordered_field [class] (A : Type) extends linear_ordered_field A, + decidable_linear_ordered_comm_ring A := + (inv_zero : inv zero = zero) + +section discrete_linear_ordered_field + + variable {A : Type} + variables [s : discrete_linear_ordered_field A] {a b c : A} + include s + + definition dec_eq_of_dec_lt : ∀ x y : A, decidable (x = y) := + take x y, + decidable.by_cases + (assume H : x < y, decidable.ff (ne_of_lt H)) + (assume H : ¬ x < y, + decidable.by_cases + (assume H' : y < x, decidable.ff (ne.symm (ne_of_lt H'))) + (assume H' : ¬ y < x, + decidable.tt (le.antisymm (le_of_not_gt H') (le_of_not_gt H)))) + + attribute [instance] + definition discrete_linear_ordered_field.to_discrete_field : discrete_field A := + ⦃ discrete_field, s, has_decidable_eq := dec_eq_of_dec_lt⦄ + + theorem pos_of_one_div_pos (H : 0 < 1 / a) : 0 < a := + have H1 : 0 < 1 / (1 / a), from one_div_pos_of_pos H, + have H2 : 1 / a ≠ 0, from + (assume H3 : 1 / a = 0, + have H4 : 1 / (1 / a) = 0, from symm H3 ▸ div_zero 1, + absurd H4 (ne.symm (ne_of_lt H1))), + (division_ring.one_div_one_div (ne_zero_of_one_div_ne_zero H2)) ▸ H1 + + theorem neg_of_one_div_neg (H : 1 / a < 0) : a < 0 := + have H1 : 0 < - (1 / a), from neg_pos_of_neg H, + have Ha : a ≠ 0, from ne_zero_of_one_div_ne_zero (ne_of_lt H), + have H2 : 0 < 1 / (-a), from symm (division_ring.one_div_neg_eq_neg_one_div Ha) ▸ H1, + have H3 : 0 < -a, from pos_of_one_div_pos H2, + neg_of_neg_pos H3 + + theorem le_of_one_div_le_one_div (H : 0 < a) (Hl : 1 / a ≤ 1 / b) : b ≤ a := + have Hb : 0 < b, from pos_of_one_div_pos (calc + 0 < 1 / a : one_div_pos_of_pos H + ... ≤ 1 / b : Hl), + have H' : 1 ≤ a / b, from (calc + 1 = a / a : eq.symm (div_self (ne.symm (ne_of_lt H))) + ... = a * (1 / a) : div_eq_mul_one_div a a + ... ≤ a * (1 / b) : mul_le_mul_of_nonneg_left Hl (le_of_lt H) + ... = a / b : eq.symm $ div_eq_mul_one_div a b + ), le_of_one_le_div Hb H' + + theorem le_of_one_div_le_one_div_of_neg (H : b < 0) (Hl : 1 / a ≤ 1 / b) : b ≤ a := + sorry + /- + have Ha : a ≠ 0, from ne_of_lt (neg_of_one_div_neg (calc + 1 / a ≤ 1 / b : Hl + ... < 0 : one_div_neg_of_neg H)), + have H' : -b > 0, from neg_pos_of_neg H, + have Hl' : - (1 / b) ≤ - (1 / a), from neg_le_neg Hl, + have Hl'' : 1 / - b ≤ 1 / - a, from calc + 1 / -b = - (1 / b) : by rewrite [division_ring.one_div_neg_eq_neg_one_div (ne_of_lt H)] + ... ≤ - (1 / a) : Hl' + ... = 1 / -a : by rewrite [division_ring.one_div_neg_eq_neg_one_div Ha], + le_of_neg_le_neg (le_of_one_div_le_one_div H' Hl'') + -/ + + theorem lt_of_one_div_lt_one_div (H : 0 < a) (Hl : 1 / a < 1 / b) : b < a := + have Hb : 0 < b, from pos_of_one_div_pos (calc + 0 < 1 / a : one_div_pos_of_pos H + ... < 1 / b : Hl), + have H : 1 < a / b, from (calc + 1 = a / a : eq.symm (div_self (ne.symm (ne_of_lt H))) + ... = a * (1 / a) : div_eq_mul_one_div a a + ... < a * (1 / b) : mul_lt_mul_of_pos_left Hl H + ... = a / b : eq.symm $ div_eq_mul_one_div a b), + lt_of_one_lt_div Hb H + + theorem lt_of_one_div_lt_one_div_of_neg (H : b < 0) (Hl : 1 / a < 1 / b) : b < a := + have H1 : b ≤ a, from le_of_one_div_le_one_div_of_neg H (le_of_lt Hl), + have Hn : b ≠ a, from + (assume Hn' : b = a, + have Hl' : 1 / a = 1 / b, from Hn' ▸ refl _, + absurd Hl' (ne_of_lt Hl)), + lt_of_le_of_ne H1 Hn + + theorem one_div_lt_one_div_of_lt (Ha : 0 < a) (H : a < b) : 1 / b < 1 / a := + lt_of_not_ge + (assume H', + absurd H (not_lt_of_ge (le_of_one_div_le_one_div Ha H'))) + + theorem one_div_le_one_div_of_le (Ha : 0 < a) (H : a ≤ b) : 1 / b ≤ 1 / a := + le_of_not_gt + (assume H', + absurd H (not_le_of_gt (lt_of_one_div_lt_one_div Ha H'))) + + theorem one_div_lt_one_div_of_lt_of_neg (Hb : b < 0) (H : a < b) : 1 / b < 1 / a := + lt_of_not_ge + (assume H', + absurd H (not_lt_of_ge (le_of_one_div_le_one_div_of_neg Hb H'))) + + theorem one_div_le_one_div_of_le_of_neg (Hb : b < 0) (H : a ≤ b) : 1 / b ≤ 1 / a := + le_of_not_gt + (assume H', + absurd H (not_le_of_gt (lt_of_one_div_lt_one_div_of_neg Hb H'))) + + theorem one_div_le_of_one_div_le_of_pos (Ha : a > 0) (H : 1 / a ≤ b) : 1 / b ≤ a := + sorry + /- + begin + rewrite -(one_div_one_div a), + apply one_div_le_one_div_of_le, + apply one_div_pos_of_pos, + repeat assumption + end + -/ + + theorem one_div_le_of_one_div_le_of_neg (Ha : b < 0) (H : 1 / a ≤ b) : 1 / b ≤ a := + sorry + /- + begin + rewrite -(one_div_one_div a), + apply one_div_le_one_div_of_le_of_neg, + repeat assumption + end + -/ + + theorem one_lt_one_div (H1 : 0 < a) (H2 : a < 1) : 1 < 1 / a := + one_div_one ▸ one_div_lt_one_div_of_lt H1 H2 + + theorem one_le_one_div (H1 : 0 < a) (H2 : a ≤ 1) : 1 ≤ 1 / a := + one_div_one ▸ one_div_le_one_div_of_le H1 H2 + + theorem one_div_lt_neg_one (H1 : a < 0) (H2 : -1 < a) : 1 / a < -1 := + one_div_neg_one_eq_neg_one ▸ one_div_lt_one_div_of_lt_of_neg H1 H2 + + theorem one_div_le_neg_one (H1 : a < 0) (H2 : -1 ≤ a) : 1 / a ≤ -1 := + one_div_neg_one_eq_neg_one ▸ one_div_le_one_div_of_le_of_neg H1 H2 + + theorem div_lt_div_of_pos_of_lt_of_pos (Hb : 0 < b) (H : b < a) (Hc : 0 < c) : c / a < c / b := + sorry + /- + begin + apply iff.mp !sub_neg_iff_lt, + rewrite [div_eq_mul_one_div, {c / b}div_eq_mul_one_div, -mul_sub_left_distrib], + apply mul_neg_of_pos_of_neg, + exact Hc, + apply iff.mpr !sub_neg_iff_lt, + apply one_div_lt_one_div_of_lt, + repeat assumption + end + -/ + + theorem div_mul_le_div_mul_of_div_le_div_pos' {d e : A} (H : a / b ≤ c / d) + (He : e > 0) : a / (b * e) ≤ c / (d * e) := + sorry + /- + begin + rewrite [2 div_mul_eq_div_mul_one_div], + apply mul_le_mul_of_nonneg_right H, + apply le_of_lt, + apply one_div_pos_of_pos He + end + -/ + + theorem abs_div (a b : A) : abs (a / b) = abs a / abs b := + sorry + /- + decidable.by_cases + (suppose b = 0, by rewrite [this, abs_zero, *div_zero, abs_zero]) + (suppose b ≠ 0, + have abs b ≠ 0, from assume H, this (eq_zero_of_abs_eq_zero H), + eq_div_of_mul_eq _ _ this + (show abs (a / b) * abs b = abs a, by rewrite [-abs_mul, div_mul_cancel _ `b ≠ 0`])) + -/ + + theorem abs_one_div (a : A) : abs (1 / a) = 1 / abs a := + sorry -- by rewrite [abs_div, abs_of_nonneg (zero_le_one : 1 ≥ (0 : A))] + + theorem sign_eq_div_abs (a : A) : sign a = a / (abs a) := + sorry + /- + decidable.by_cases + (suppose a = 0, by subst a; rewrite [zero_div, sign_zero]) + (suppose a ≠ 0, + have abs a ≠ 0, from assume H, this (eq_zero_of_abs_eq_zero H), + !eq_div_of_mul_eq this !eq_sign_mul_abs⁻¹) + -/ + + theorem add_quarters (a : A) : a / 4 + a / 4 = a / 2 := + sorry + /- + have H4 : (4 : A) = 2 * 2, by norm_num, + calc + a / 4 + a / 4 = (a + a) / (2 * 2) : by rewrite [-H4, div_add_div_same] + ... = (a * 1 + a * 1) / (2 * 2) : by rewrite mul_one + ... = (a * (1 + 1)) / (2 * 2) : by rewrite left_distrib + ... = (a * 2) / (2 * 2) : rfl + ... = ((a * 2) / 2) / 2 : by rewrite -div_div_eq_div_mul + ... = a / 2 : by rewrite (mul_div_cancel a two_ne_zero) + -/ + + lemma div_two_add_div_four_lt {a : A} (H : a > 0) : a / 2 + a / 4 < a := + sorry + /- + begin + replace (4 : A) with (2 : A) + 2, + have Hne : (2 + 2 : A) ≠ 0, from ne_of_gt four_pos, + krewrite (div_add_div _ _ two_ne_zero Hne), + have Hnum : (2 + 2 + 2) / (2 * (2 + 2)) = (3 : A) / 4, by norm_num, + rewrite [{2 * a}mul.comm, -left_distrib, mul_div_assoc, -mul_one a at {2}], krewrite Hnum, + apply mul_lt_mul_of_pos_left, + apply div_lt_of_mul_lt_of_pos, + apply four_pos, + rewrite one_mul, + replace (3 : A) with (2 : A) + 1, + replace (4 : A) with (2 : A) + 2, + apply add_lt_add_left, + apply two_gt_one, + exact H + end + -/ +end discrete_linear_ordered_field diff --git a/old_library/algebra/ordered_group.lean b/old_library/algebra/ordered_group.lean new file mode 100644 index 0000000000..1997c68553 --- /dev/null +++ b/old_library/algebra/ordered_group.lean @@ -0,0 +1,1025 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad + +Partially ordered additive groups, modeled on Isabelle's library. These classes can be refined +if necessary. +-/ +import algebra.group algebra.order algebra.monotone +open eq + +variables {A B : Type} + +/- partially ordered monoids, such as the natural numbers -/ + +structure ordered_cancel_comm_monoid [class] (A : Type) extends add_comm_monoid A, + add_left_cancel_semigroup A, add_right_cancel_semigroup A, order_pair A := +(add_le_add_left : ∀a b, le a b → ∀c, le (add c a) (add c b)) +(le_of_add_le_add_left : ∀a b c, le (add a b) (add a c) → le b c) +(add_lt_add_left : ∀a b, lt a b → ∀c, lt (add c a) (add c b)) +(lt_of_add_lt_add_left : ∀a b c, lt (add a b) (add a c) → lt b c) + +section + variables [ordered_cancel_comm_monoid A] + variables {a b c d e : A} + + theorem add_lt_add_left (H : a < b) (c : A) : c + a < c + b := + ordered_cancel_comm_monoid.add_lt_add_left a b H c + + theorem add_lt_add_right (H : a < b) (c : A) : a + c < b + c := + sorry + /- + begin + rewrite [add.comm, {b + _}add.comm], + exact (add_lt_add_left H c) + end + -/ + + theorem add_le_add_left (H : a ≤ b) (c : A) : c + a ≤ c + b := + ordered_cancel_comm_monoid.add_le_add_left a b H c + + theorem add_le_add_right (H : a ≤ b) (c : A) : a + c ≤ b + c := + (add.comm c a) ▸ (add.comm c b) ▸ (add_le_add_left H c) + + theorem add_le_add (Hab : a ≤ b) (Hcd : c ≤ d) : a + c ≤ b + d := + le.trans (add_le_add_right Hab c) (add_le_add_left Hcd b) + + theorem le_add_of_nonneg_right (H : b ≥ 0) : a ≤ a + b := + sorry + /- + begin + have H1 : a + b ≥ a + 0, from add_le_add_left H a, + rewrite add_zero at H1, + exact H1 + end + -/ + + theorem le_add_of_nonneg_left (H : b ≥ 0) : a ≤ b + a := + sorry + /- + begin + have H1 : 0 + a ≤ b + a, from add_le_add_right H a, + rewrite zero_add at H1, + exact H1 + end + -/ + + theorem add_lt_add (Hab : a < b) (Hcd : c < d) : a + c < b + d := + lt.trans (add_lt_add_right Hab c) (add_lt_add_left Hcd b) + + theorem add_lt_add_of_le_of_lt (Hab : a ≤ b) (Hcd : c < d) : a + c < b + d := + lt_of_le_of_lt (add_le_add_right Hab c) (add_lt_add_left Hcd b) + + theorem add_lt_add_of_lt_of_le (Hab : a < b) (Hcd : c ≤ d) : a + c < b + d := + lt_of_lt_of_le (add_lt_add_right Hab c) (add_le_add_left Hcd b) + + theorem lt_add_of_pos_right (H : b > 0) : a < a + b := add_zero a ▸ add_lt_add_left H a + + theorem lt_add_of_pos_left (H : b > 0) : a < b + a := zero_add a ▸ add_lt_add_right H a + + -- here we start using le_of_add_le_add_left. + theorem le_of_add_le_add_left (H : a + b ≤ a + c) : b ≤ c := + ordered_cancel_comm_monoid.le_of_add_le_add_left a b c H + + theorem le_of_add_le_add_right (H : a + b ≤ c + b) : a ≤ c := + sorry -- le_of_add_le_add_left (show b + a ≤ b + c, begin rewrite [add.comm, {b + _}add.comm], exact H end) + + theorem lt_of_add_lt_add_left (H : a + b < a + c) : b < c := + ordered_cancel_comm_monoid.lt_of_add_lt_add_left a b c H + + theorem lt_of_add_lt_add_right (H : a + b < c + b) : a < c := + lt_of_add_lt_add_left ((add.comm a b) ▸ (add.comm c b) ▸ H) + + theorem add_le_add_left_iff (a b c : A) : a + b ≤ a + c ↔ b ≤ c := + iff.intro le_of_add_le_add_left (assume H, add_le_add_left H _) + + theorem add_le_add_right_iff (a b c : A) : a + b ≤ c + b ↔ a ≤ c := + iff.intro le_of_add_le_add_right (assume H, add_le_add_right H _) + + theorem add_lt_add_left_iff (a b c : A) : a + b < a + c ↔ b < c := + iff.intro lt_of_add_lt_add_left (assume H, add_lt_add_left H _) + + theorem add_lt_add_right_iff (a b c : A) : a + b < c + b ↔ a < c := + iff.intro lt_of_add_lt_add_right (assume H, add_lt_add_right H _) + + -- here we start using properties of zero. + theorem add_nonneg (Ha : 0 ≤ a) (Hb : 0 ≤ b) : 0 ≤ a + b := + zero_add 0 ▸ (add_le_add Ha Hb) + + theorem add_pos (Ha : 0 < a) (Hb : 0 < b) : 0 < a + b := + zero_add 0 ▸ (add_lt_add Ha Hb) + + theorem add_pos_of_pos_of_nonneg (Ha : 0 < a) (Hb : 0 ≤ b) : 0 < a + b := + zero_add 0 ▸ (add_lt_add_of_lt_of_le Ha Hb) + + theorem add_pos_of_nonneg_of_pos (Ha : 0 ≤ a) (Hb : 0 < b) : 0 < a + b := + zero_add 0 ▸ (add_lt_add_of_le_of_lt Ha Hb) + + theorem add_nonpos (Ha : a ≤ 0) (Hb : b ≤ 0) : a + b ≤ 0 := + zero_add 0 ▸ (add_le_add Ha Hb) + + theorem add_neg (Ha : a < 0) (Hb : b < 0) : a + b < 0 := + zero_add 0 ▸ (add_lt_add Ha Hb) + + theorem add_neg_of_neg_of_nonpos (Ha : a < 0) (Hb : b ≤ 0) : a + b < 0 := + zero_add 0 ▸ (add_lt_add_of_lt_of_le Ha Hb) + + theorem add_neg_of_nonpos_of_neg (Ha : a ≤ 0) (Hb : b < 0) : a + b < 0 := + zero_add 0 ▸ (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 + (Ha : 0 ≤ a) (Hb : 0 ≤ b) : a + b = 0 ↔ a = 0 ∧ b = 0 := + sorry + /- + iff.intro + (assume Hab : a + b = 0, + have Ha' : a ≤ 0, from + calc + a = a + 0 : by rewrite add_zero + ... ≤ a + b : add_le_add_left Hb _ + ... = 0 : Hab, + have Haz : a = 0, from le.antisymm Ha' Ha, + have Hb' : b ≤ 0, from + calc + b = 0 + b : by rewrite zero_add + ... ≤ a + b : by exact add_le_add_right Ha _ + ... = 0 : Hab, + have Hbz : b = 0, from le.antisymm Hb' Hb, + and.intro Haz Hbz) + (assume Hab : a = 0 ∧ b = 0, + obtain Ha' Hb', from Hab, + by rewrite [Ha', Hb', add_zero]) + -/ + + theorem le_add_of_nonneg_of_le (Ha : 0 ≤ a) (Hbc : b ≤ c) : b ≤ a + c := + zero_add b ▸ add_le_add Ha Hbc + + theorem le_add_of_le_of_nonneg (Hbc : b ≤ c) (Ha : 0 ≤ a) : b ≤ c + a := + add_zero b ▸ add_le_add Hbc Ha + + theorem lt_add_of_pos_of_le (Ha : 0 < a) (Hbc : b ≤ c) : b < a + c := + zero_add b ▸ add_lt_add_of_lt_of_le Ha Hbc + + theorem lt_add_of_le_of_pos (Hbc : b ≤ c) (Ha : 0 < a) : b < c + a := + add_zero b ▸ add_lt_add_of_le_of_lt Hbc Ha + + theorem add_le_of_nonpos_of_le (Ha : a ≤ 0) (Hbc : b ≤ c) : a + b ≤ c := + zero_add c ▸ add_le_add Ha Hbc + + theorem add_le_of_le_of_nonpos (Hbc : b ≤ c) (Ha : a ≤ 0) : b + a ≤ c := + add_zero c ▸ add_le_add Hbc Ha + + theorem add_lt_of_neg_of_le (Ha : a < 0) (Hbc : b ≤ c) : a + b < c := + zero_add c ▸ add_lt_add_of_lt_of_le Ha Hbc + + theorem add_lt_of_le_of_neg (Hbc : b ≤ c) (Ha : a < 0) : b + a < c := + add_zero c ▸ add_lt_add_of_le_of_lt Hbc Ha + + theorem lt_add_of_nonneg_of_lt (Ha : 0 ≤ a) (Hbc : b < c) : b < a + c := + zero_add b ▸ add_lt_add_of_le_of_lt Ha Hbc + + theorem lt_add_of_lt_of_nonneg (Hbc : b < c) (Ha : 0 ≤ a) : b < c + a := + add_zero b ▸ add_lt_add_of_lt_of_le Hbc Ha + + theorem lt_add_of_pos_of_lt (Ha : 0 < a) (Hbc : b < c) : b < a + c := + zero_add b ▸ add_lt_add Ha Hbc + + theorem lt_add_of_lt_of_pos (Hbc : b < c) (Ha : 0 < a) : b < c + a := + add_zero b ▸ add_lt_add Hbc Ha + + theorem add_lt_of_nonpos_of_lt (Ha : a ≤ 0) (Hbc : b < c) : a + b < c := + zero_add c ▸ add_lt_add_of_le_of_lt Ha Hbc + + theorem add_lt_of_lt_of_nonpos (Hbc : b < c) (Ha : a ≤ 0) : b + a < c := + add_zero c ▸ add_lt_add_of_lt_of_le Hbc Ha + + theorem add_lt_of_neg_of_lt (Ha : a < 0) (Hbc : b < c) : a + b < c := + zero_add c ▸ add_lt_add Ha Hbc + + theorem add_lt_of_lt_of_neg (Hbc : b < c) (Ha : a < 0) : b + a < c := + add_zero c ▸ add_lt_add Hbc Ha + + theorem strictly_increasing_add_left (c : A) : strictly_increasing (λ x, x + c) := + take x₁ x₂, assume H, add_lt_add_right H c + + theorem strictly_increasing_add_right (c : A) : strictly_increasing (λ x, c + x) := + take x₁ x₂, assume H, add_lt_add_left H c + + theorem nondecreasing_add_left (c : A) : nondecreasing (λ x, x + c) := + take x₁ x₂, assume H, add_le_add_right H c + + theorem nondecreasing_add_right (c : A) : nondecreasing (λ x, c + x) := + take x₁ x₂, assume H, add_le_add_left H c +end + +/- ordered cancelative commutative monoids with a decidable linear order -/ + +structure decidable_linear_ordered_cancel_comm_monoid [class] (A : Type) + extends ordered_cancel_comm_monoid A, decidable_linear_order A + +section + variables [decidable_linear_ordered_cancel_comm_monoid A] + variables {a b c d e : A} + + theorem min_add_add_left : min (a + b) (a + c) = a + min b c := + sorry + /- + eq.symm (eq_min + (show a + min b c ≤ a + b, from add_le_add_left !min_le_left _) + (show a + min b c ≤ a + c, from add_le_add_left !min_le_right _) + (take d, + assume H₁ : d ≤ a + b, + assume H₂ : d ≤ a + c, + decidable.by_cases + (suppose b ≤ c, using this, by rewrite [min_eq_left this]; apply H₁) + (suppose ¬ b ≤ c, using this, + by rewrite [min_eq_right (le_of_lt (lt_of_not_ge this))]; apply H₂))) + -/ + + theorem min_add_add_right : min (a + c) (b + c) = min a b + c := + sorry -- by rewrite [add.comm a c, add.comm b c, add.comm _ c]; apply min_add_add_left + + theorem max_add_add_left : max (a + b) (a + c) = a + max b c := + sorry + /- + eq.symm (eq_max + (add_le_add_left !le_max_left _) + (add_le_add_left !le_max_right _) + (take d, + assume H₁ : a + b ≤ d, + assume H₂ : a + c ≤ d, + decidable.by_cases + (suppose b ≤ c, using this, by rewrite [max_eq_right this]; apply H₂) + (suppose ¬ b ≤ c, using this, + by rewrite [max_eq_left (le_of_lt (lt_of_not_ge this))]; apply H₁))) + -/ + + theorem max_add_add_right : max (a + c) (b + c) = max a b + c := + sorry -- by rewrite [add.comm a c, add.comm b c, add.comm _ c]; apply max_add_add_left +end + +/- partially ordered groups -/ + +structure ordered_comm_group [class] (A : Type) extends add_comm_group A, order_pair A := +(add_le_add_left : ∀a b, le a b → ∀c, le (add c a) (add c b)) +(add_lt_add_left : ∀a b, lt a b → ∀ c, lt (add c a) (add c b)) + +theorem ordered_comm_group.le_of_add_le_add_left [ordered_comm_group A] {a b c : A} + (H : a + b ≤ a + c) : b ≤ c := +have H' : -a + (a + b) ≤ -a + (a + c), from ordered_comm_group.add_le_add_left _ _ H _, +sorry -- by rewrite *neg_add_cancel_left at H'; exact H' + +theorem ordered_comm_group.lt_of_add_lt_add_left [ordered_comm_group A] {a b c : A} + (H : a + b < a + c) : b < c := +have H' : -a + (a + b) < -a + (a + c), from ordered_comm_group.add_lt_add_left _ _ H _, +sorry -- by rewrite *neg_add_cancel_left at H'; exact H' + +attribute [instance] +definition ordered_comm_group.to_ordered_cancel_comm_monoid [s : ordered_comm_group A] : ordered_cancel_comm_monoid A := +⦃ ordered_cancel_comm_monoid, s, + add_left_cancel := @add.left_cancel A _, + add_right_cancel := @add.right_cancel A _, + le_of_add_le_add_left := @ordered_comm_group.le_of_add_le_add_left A _, + lt_of_add_lt_add_left := @ordered_comm_group.lt_of_add_lt_add_left A _⦄ + +section + variables [ordered_comm_group A] (a b c d e : A) + + theorem neg_le_neg {a b : A} (H : a ≤ b) : -b ≤ -a := + have H1 : 0 ≤ -a + b, from add.left_inv a ▸ add_le_add_left H (-a), + add_neg_cancel_right (-a) b ▸ zero_add (-b) ▸ add_le_add_right H1 (-b) + + theorem le_of_neg_le_neg {a b : A} (H : -b ≤ -a) : a ≤ b := + neg_neg a ▸ neg_neg b ▸ neg_le_neg H + + theorem neg_le_neg_iff_le : -a ≤ -b ↔ b ≤ a := + iff.intro le_of_neg_le_neg neg_le_neg + + theorem nonneg_of_neg_nonpos {a : A} (H : -a ≤ 0) : 0 ≤ a := + le_of_neg_le_neg (symm neg_zero ▸ H) + + theorem neg_nonpos_of_nonneg {a : A} (H : 0 ≤ a) : -a ≤ 0 := + neg_zero ▸ neg_le_neg H + + theorem neg_nonpos_iff_nonneg : -a ≤ 0 ↔ 0 ≤ a := + iff.intro nonneg_of_neg_nonpos neg_nonpos_of_nonneg + + theorem nonpos_of_neg_nonneg {a : A} (H : 0 ≤ -a) : a ≤ 0 := + le_of_neg_le_neg (symm neg_zero ▸ H) + + theorem neg_nonneg_of_nonpos {a : A} (H : a ≤ 0) : 0 ≤ -a := + neg_zero ▸ neg_le_neg H + + theorem neg_nonneg_iff_nonpos : 0 ≤ -a ↔ a ≤ 0 := + iff.intro nonpos_of_neg_nonneg neg_nonneg_of_nonpos + + theorem neg_lt_neg {a b : A} (H : a < b) : -b < -a := + have H1 : 0 < -a + b, from add.left_inv a ▸ add_lt_add_left H (-a), + add_neg_cancel_right (-a) b ▸ zero_add (-b) ▸ add_lt_add_right H1 (-b) + + theorem lt_of_neg_lt_neg {a b : A} (H : -b < -a) : a < b := + neg_neg a ▸ neg_neg b ▸ neg_lt_neg H + + theorem neg_lt_neg_iff_lt : -a < -b ↔ b < a := + iff.intro lt_of_neg_lt_neg neg_lt_neg + + theorem pos_of_neg_neg {a : A} (H : -a < 0) : 0 < a := + lt_of_neg_lt_neg (symm neg_zero ▸ H) + + theorem neg_neg_of_pos {a : A} (H : 0 < a) : -a < 0 := + neg_zero ▸ neg_lt_neg H + + theorem neg_neg_iff_pos : -a < 0 ↔ 0 < a := + iff.intro pos_of_neg_neg neg_neg_of_pos + + theorem neg_of_neg_pos {a : A} (H : 0 < -a) : a < 0 := + lt_of_neg_lt_neg (symm neg_zero ▸ H) + + theorem neg_pos_of_neg {a : A} (H : a < 0) : 0 < -a := + neg_zero ▸ neg_lt_neg H + + theorem neg_pos_iff_neg : 0 < -a ↔ a < 0 := + iff.intro neg_of_neg_pos neg_pos_of_neg + + theorem le_neg_iff_le_neg : a ≤ -b ↔ b ≤ -a := neg_neg a ▸ neg_le_neg_iff_le (-a) b + + theorem le_neg_of_le_neg {a b : A} : a ≤ -b → b ≤ -a := iff.mp (le_neg_iff_le_neg a b) + + theorem neg_le_iff_neg_le : -a ≤ b ↔ -b ≤ a := neg_neg b ▸ neg_le_neg_iff_le a (-b) + + theorem neg_le_of_neg_le {a b : A} : -a ≤ b → -b ≤ a := iff.mp (neg_le_iff_neg_le a b) + + theorem lt_neg_iff_lt_neg : a < -b ↔ b < -a := neg_neg a ▸ neg_lt_neg_iff_lt (-a) b + + theorem lt_neg_of_lt_neg {a b : A} : a < -b → b < -a := iff.mp (lt_neg_iff_lt_neg a b) + + theorem neg_lt_iff_neg_lt : -a < b ↔ -b < a := neg_neg b ▸ neg_lt_neg_iff_lt a (-b) + + theorem neg_lt_of_neg_lt {a b : A} : -a < b → -b < a := iff.mp (neg_lt_iff_neg_lt a b) + + theorem sub_nonneg_iff_le : 0 ≤ a - b ↔ b ≤ a := sub_self b ▸ add_le_add_right_iff b (-b) a + + theorem sub_nonneg_of_le {a b : A} : b ≤ a → 0 ≤ a - b := iff.mpr (sub_nonneg_iff_le a b) + + theorem le_of_sub_nonneg {a b : A} : 0 ≤ a - b → b ≤ a := iff.mp (sub_nonneg_iff_le a b) + + theorem sub_nonpos_iff_le : a - b ≤ 0 ↔ a ≤ b := sub_self b ▸ add_le_add_right_iff a (-b) b + + theorem sub_nonpos_of_le {a b : A} : a ≤ b → a - b ≤ 0 := iff.mpr (sub_nonpos_iff_le a b) + + theorem le_of_sub_nonpos {a b : A} : a - b ≤ 0 → a ≤ b := iff.mp (sub_nonpos_iff_le a b) + + theorem sub_pos_iff_lt : 0 < a - b ↔ b < a := sub_self b ▸ add_lt_add_right_iff b (-b) a + + theorem sub_pos_of_lt {a b : A} : b < a → 0 < a - b := iff.mpr (sub_pos_iff_lt a b) + + theorem lt_of_sub_pos {a b : A} : 0 < a - b → b < a := iff.mp (sub_pos_iff_lt a b) + + theorem sub_neg_iff_lt : a - b < 0 ↔ a < b := sub_self b ▸ add_lt_add_right_iff a (-b) b + + theorem sub_neg_of_lt {a b : A} : a < b → a - b < 0 := iff.mpr (sub_neg_iff_lt a b) + + theorem lt_of_sub_neg {a b : A} : a - b < 0 → a < b := iff.mp (sub_neg_iff_lt a b) + + theorem add_le_iff_le_neg_add : a + b ≤ c ↔ b ≤ -a + c := + have H: a + b ≤ c ↔ -a + (a + b) ≤ -a + c, from iff.symm (add_le_add_left_iff (-a) (a + b) c), + neg_add_cancel_left a b ▸ H + + theorem add_le_of_le_neg_add {a b c : A} : b ≤ -a + c → a + b ≤ c := + iff.mpr (add_le_iff_le_neg_add a b c) + + theorem le_neg_add_of_add_le {a b c : A} : a + b ≤ c → b ≤ -a + c := + iff.mp (add_le_iff_le_neg_add a b c) + + theorem add_le_iff_le_sub_left : a + b ≤ c ↔ b ≤ c - a := + sorry -- by rewrite [sub_eq_add_neg, {c+_}add.comm]; apply add_le_iff_le_neg_add + + theorem add_le_of_le_sub_left {a b c : A} : b ≤ c - a → a + b ≤ c := + iff.mpr (add_le_iff_le_sub_left a b c) + + theorem le_sub_left_of_add_le {a b c : A} : a + b ≤ c → b ≤ c - a := + iff.mp (add_le_iff_le_sub_left a b c) + + theorem add_le_iff_le_sub_right : a + b ≤ c ↔ a ≤ c - b := + have H: a + b ≤ c ↔ a + b - b ≤ c - b, from iff.symm (add_le_add_right_iff (a + b) (-b) c), + add_neg_cancel_right a b ▸ H + + theorem add_le_of_le_sub_right {a b c : A} : a ≤ c - b → a + b ≤ c := + iff.mpr (add_le_iff_le_sub_right a b c) + + theorem le_sub_right_of_add_le {a b c : A} : a + b ≤ c → a ≤ c - b := + iff.mp (add_le_iff_le_sub_right a b c) + + theorem le_add_iff_neg_add_le : a ≤ b + c ↔ -b + a ≤ c := + have H: a ≤ b + c ↔ -b + a ≤ -b + (b + c), from iff.symm (add_le_add_left_iff (-b) a (b + c)), + sorry -- by rewrite neg_add_cancel_left at H; exact H + + theorem le_add_of_neg_add_le {a b c : A} : -b + a ≤ c → a ≤ b + c := + iff.mpr (le_add_iff_neg_add_le a b c) + + theorem neg_add_le_of_le_add {a b c : A} : a ≤ b + c → -b + a ≤ c := + iff.mp (le_add_iff_neg_add_le a b c) + + theorem le_add_iff_sub_left_le : a ≤ b + c ↔ a - b ≤ c := + sorry -- by rewrite [sub_eq_add_neg, {a+_}add.comm]; apply le_add_iff_neg_add_le + + theorem le_add_of_sub_left_le {a b c : A} : a - b ≤ c → a ≤ b + c := + iff.mpr (le_add_iff_sub_left_le a b c) + + theorem sub_left_le_of_le_add {a b c : A} : a ≤ b + c → a - b ≤ c := + iff.mp (le_add_iff_sub_left_le a b c) + + theorem le_add_iff_sub_right_le : a ≤ b + c ↔ a - c ≤ b := + have H: a ≤ b + c ↔ a - c ≤ b + c - c, from iff.symm (add_le_add_right_iff a (-c) (b + c)), + sorry -- by rewrite [sub_eq_add_neg (b+c) c at H, add_neg_cancel_right at H]; exact H + + theorem le_add_of_sub_right_le {a b c : A} : a - c ≤ b → a ≤ b + c := + iff.mpr $ le_add_iff_sub_right_le a b c + + theorem sub_right_le_of_le_add {a b c : A} : a ≤ b + c → a - c ≤ b := + iff.mp $ le_add_iff_sub_right_le a b c + + theorem le_add_iff_neg_add_le_left : a ≤ b + c ↔ -b + a ≤ c := + have H: a ≤ b + c ↔ -b + a ≤ -b + (b + c), from iff.symm $ add_le_add_left_iff (-b) a (b + c), + sorry -- by rewrite neg_add_cancel_left at H; exact H + + theorem le_add_of_neg_add_le_left {a b c : A} : -b + a ≤ c → a ≤ b + c := + iff.mpr $ le_add_iff_neg_add_le_left a b c + + theorem neg_add_le_left_of_le_add {a b c : A} : a ≤ b + c → -b + a ≤ c := + iff.mp $ le_add_iff_neg_add_le_left a b c + + theorem le_add_iff_neg_add_le_right : a ≤ b + c ↔ -c + a ≤ b := + sorry -- by rewrite add.comm; apply le_add_iff_neg_add_le_left + + theorem le_add_of_neg_add_le_right {a b c : A} : -c + a ≤ b → a ≤ b + c := + iff.mpr $ le_add_iff_neg_add_le_right a b c + + theorem neg_add_le_right_of_le_add {a b c : A} : a ≤ b + c → -c + a ≤ b := + iff.mp $ le_add_iff_neg_add_le_right a b c + + theorem le_add_iff_neg_le_sub_left : c ≤ a + b ↔ -a ≤ b - c := + have H : c ≤ a + b ↔ -a + c ≤ b, from le_add_iff_neg_add_le c a b, + have H' : -a + c ≤ b ↔ -a ≤ b - c, from add_le_iff_le_sub_right (-a) c b, + iff.trans H H' + + theorem le_add_of_neg_le_sub_left {a b c : A} : -a ≤ b - c → c ≤ a + b := + iff.mpr $ le_add_iff_neg_le_sub_left a b c + + theorem neg_le_sub_left_of_le_add {a b c : A} : c ≤ a + b → -a ≤ b - c := + iff.mp $ le_add_iff_neg_le_sub_left a b c + + theorem le_add_iff_neg_le_sub_right : c ≤ a + b ↔ -b ≤ a - c := + sorry -- by rewrite add.comm; apply le_add_iff_neg_le_sub_left + + theorem le_add_of_neg_le_sub_right {a b c : A} : -b ≤ a - c → c ≤ a + b := + iff.mpr $ le_add_iff_neg_le_sub_right a b c + + theorem neg_le_sub_right_of_le_add {a b c : A} : c ≤ a + b → -b ≤ a - c := + iff.mp $ le_add_iff_neg_le_sub_right a b c + + theorem add_lt_iff_lt_neg_add_left : a + b < c ↔ b < -a + c := + have H: a + b < c ↔ -a + (a + b) < -a + c, from iff.symm $ add_lt_add_left_iff (-a) (a + b) c, + sorry -- begin rewrite neg_add_cancel_left at H, exact H end + + theorem add_lt_of_lt_neg_add_left {a b c : A} : b < -a + c → a + b < c := + iff.mpr $ add_lt_iff_lt_neg_add_left a b c + + theorem lt_neg_add_left_of_add_lt {a b c : A} : a + b < c → b < -a + c := + iff.mp $ add_lt_iff_lt_neg_add_left a b c + + theorem add_lt_iff_lt_neg_add_right : a + b < c ↔ a < -b + c := + sorry -- by rewrite add.comm; apply add_lt_iff_lt_neg_add_left + + theorem add_lt_of_lt_neg_add_right {a b c : A} : a < -b + c → a + b < c := + iff.mpr $ add_lt_iff_lt_neg_add_right a b c + + theorem lt_neg_add_right_of_add_lt {a b c : A} : a + b < c → a < -b + c := + iff.mp $ add_lt_iff_lt_neg_add_right a b c + + theorem add_lt_iff_lt_sub_left : a + b < c ↔ b < c - a := + sorry + /- + begin + rewrite [sub_eq_add_neg, {c+_}add.comm], + apply add_lt_iff_lt_neg_add_left + end + -/ + + theorem add_lt_of_lt_sub_left {a b c : A} : b < c - a → a + b < c := + iff.mpr $ add_lt_iff_lt_sub_left a b c + + theorem lt_sub_left_of_add_lt {a b c : A} : a + b < c → b < c - a := + iff.mp $ add_lt_iff_lt_sub_left a b c + + theorem add_lt_iff_lt_sub_right : a + b < c ↔ a < c - b := + sorry + /- + have H: a + b < c ↔ a + b - b < c - b, from iff.symm (!add_lt_add_right_iff), + by rewrite [sub_eq_add_neg at H, add_neg_cancel_right at H]; exact H + -/ + + theorem add_lt_of_lt_sub_right {a b c : A} : a < c - b → a + b < c := + iff.mpr $ add_lt_iff_lt_sub_right a b c + + theorem lt_sub_right_of_add_lt {a b c : A} : a + b < c → a < c - b := + iff.mp $ add_lt_iff_lt_sub_right a b c + + theorem lt_add_iff_neg_add_lt_left : a < b + c ↔ -b + a < c := + sorry + /- + have H: a < b + c ↔ -b + a < -b + (b + c), from iff.symm (!add_lt_add_left_iff), + by rewrite neg_add_cancel_left at H; exact H + -/ + + theorem lt_add_of_neg_add_lt_left {a b c : A} : -b + a < c → a < b + c := + iff.mpr $ lt_add_iff_neg_add_lt_left a b c + + theorem neg_add_lt_left_of_lt_add {a b c : A} : a < b + c → -b + a < c := + iff.mp $ lt_add_iff_neg_add_lt_left a b c + + theorem lt_add_iff_neg_add_lt_right : a < b + c ↔ -c + a < b := + sorry -- by rewrite add.comm; apply lt_add_iff_neg_add_lt_left + + theorem lt_add_of_neg_add_lt_right {a b c : A} : -c + a < b → a < b + c := + iff.mpr $ lt_add_iff_neg_add_lt_right a b c + + theorem neg_add_lt_right_of_lt_add {a b c : A} : a < b + c → -c + a < b := + iff.mp $ lt_add_iff_neg_add_lt_right a b c + + theorem lt_add_iff_sub_lt_left : a < b + c ↔ a - b < c := + sorry -- by rewrite [sub_eq_add_neg, {a + _}add.comm]; apply lt_add_iff_neg_add_lt_left + + theorem lt_add_of_sub_lt_left {a b c : A} : a - b < c → a < b + c := + iff.mpr $ lt_add_iff_sub_lt_left a b c + + theorem sub_lt_left_of_lt_add {a b c : A} : a < b + c → a - b < c := + iff.mp $ lt_add_iff_sub_lt_left a b c + + theorem lt_add_iff_sub_lt_right : a < b + c ↔ a - c < b := + sorry -- by rewrite add.comm; apply lt_add_iff_sub_lt_left + + theorem lt_add_of_sub_lt_right {a b c : A} : a - c < b → a < b + c := + iff.mpr $ lt_add_iff_sub_lt_right a b c + + theorem sub_lt_right_of_lt_add {a b c : A} : a < b + c → a - c < b := + iff.mp $ lt_add_iff_sub_lt_right a b c + + theorem sub_lt_of_sub_lt {a b c : A} : a - b < c → a - c < b := + sorry + /- + begin + intro H, + apply sub_lt_left_of_lt_add, + apply lt_add_of_sub_lt_right H + end + -/ + + theorem sub_le_of_sub_le {a b c : A} : a - b ≤ c → a - c ≤ b := + sorry + /- + begin + intro H, + apply sub_left_le_of_le_add, + apply le_add_of_sub_right_le H + end + -/ + + -- TODO: the Isabelle library has varations on a + b ≤ b ↔ a ≤ 0 + theorem le_iff_le_of_sub_eq_sub {a b c d : A} (H : a - b = c - d) : a ≤ b ↔ c ≤ d := + calc + a ≤ b ↔ a - b ≤ 0 : iff.symm (sub_nonpos_iff_le a b) + ... = (c - d ≤ 0) : sorry -- by rewrite H + ... ↔ c ≤ d : sub_nonpos_iff_le c d + + theorem lt_iff_lt_of_sub_eq_sub {a b c d : A} (H : a - b = c - d) : a < b ↔ c < d := + calc + a < b ↔ a - b < 0 : iff.symm (sub_neg_iff_lt a b) + ... = (c - d < 0) : sorry -- by rewrite H + ... ↔ c < d : sub_neg_iff_lt c d + + theorem sub_le_sub_left {a b : A} (H : a ≤ b) (c : A) : c - b ≤ c - a := + add_le_add_left (neg_le_neg H) c + + theorem sub_le_sub_right {a b : A} (H : a ≤ b) (c : A) : a - c ≤ b - c := add_le_add_right H (-c) + + theorem sub_le_sub {a b c d : A} (Hab : a ≤ b) (Hcd : c ≤ d) : a - d ≤ b - c := + add_le_add Hab (neg_le_neg Hcd) + + theorem sub_lt_sub_left {a b : A} (H : a < b) (c : A) : c - b < c - a := + add_lt_add_left (neg_lt_neg H) c + + theorem sub_lt_sub_right {a b : A} (H : a < b) (c : A) : a - c < b - c := add_lt_add_right H (-c) + + theorem sub_lt_sub {a b c d : A} (Hab : a < b) (Hcd : c < d) : a - d < b - c := + add_lt_add Hab (neg_lt_neg Hcd) + + theorem sub_lt_sub_of_le_of_lt {a b c d : A} (Hab : a ≤ b) (Hcd : c < d) : a - d < b - c := + add_lt_add_of_le_of_lt Hab (neg_lt_neg Hcd) + + theorem sub_lt_sub_of_lt_of_le {a b c d : A} (Hab : a < b) (Hcd : c ≤ d) : a - d < b - c := + add_lt_add_of_lt_of_le Hab (neg_le_neg Hcd) + + theorem sub_le_self (a : A) {b : A} (H : b ≥ 0) : a - b ≤ a := + sorry + /- + calc + a - b = a + -b : rfl + ... ≤ a + 0 : add_le_add_left (neg_nonpos_of_nonneg H) _ + ... = a : by rewrite add_zero + -/ + + theorem sub_lt_self (a : A) {b : A} (H : b > 0) : a - b < a := + calc + a - b = a + -b : rfl + ... < a + 0 : add_lt_add_left (neg_neg_of_pos H) _ + ... = a : sorry -- by rewrite add_zero + + theorem add_le_add_three {a b c d e f : A} (H1 : a ≤ d) (H2 : b ≤ e) (H3 : c ≤ f) : + a + b + c ≤ d + e + f := + sorry + /- + begin + apply le.trans, + apply add_le_add, + apply add_le_add, + repeat assumption, + apply le.refl + end + -/ + + theorem sub_le_of_nonneg {b : A} (H : b ≥ 0) : a - b ≤ a := + add_le_of_le_of_nonpos (le.refl a) (neg_nonpos_of_nonneg H) + + theorem sub_lt_of_pos {b : A} (H : b > 0) : a - b < a := + add_lt_of_le_of_neg (le.refl a) (neg_neg_of_pos H) + + theorem neg_add_neg_le_neg_of_pos {a : A} (H : a > 0) : -a + -a ≤ -a := + neg_add a a ▸ neg_le_neg (le_add_of_nonneg_left (le_of_lt H)) + + variable (A) + theorem strictly_decreasing_neg : strictly_decreasing (λ x : A, -x) := + @neg_lt_neg A _ + + variable {A} + + section + variable [strict_order B] + + theorem strictly_decreasing_neg_of_strictly_increasing {f : B → A} + (H : strictly_increasing f) : strictly_decreasing (λ x, - f x) := + strictly_decreasing_comp_dec_inc (strictly_decreasing_neg A) H + + theorem strictly_increasing_neg_of_strictly_decreasing {f : B → A} + (H : strictly_decreasing f) : strictly_increasing (λ x, - f x) := + strictly_increasing_comp_dec_dec (strictly_decreasing_neg A) H + + theorem strictly_decreasing_of_strictly_increasing_neg {f : B → A} + (H : strictly_increasing (λ x, - f x)) : strictly_decreasing f := + strictly_decreasing_of_strictly_increasing_comp_right (left_inverse_neg A) + (strictly_decreasing_neg A) H + + theorem strictly_increasing_of_strictly_decreasing_neg {f : B → A} + (H : strictly_decreasing (λ x, - f x)) : strictly_increasing f := + strictly_increasing_of_strictly_decreasing_comp_right (left_inverse_neg A) + (strictly_decreasing_neg A) H + + theorem strictly_decreasing_neg_iff {f : B → A} : + strictly_decreasing (λ x, - f x) ↔ strictly_increasing f := + iff.intro strictly_increasing_of_strictly_decreasing_neg + strictly_decreasing_neg_of_strictly_increasing + + theorem strictly_increasing_neg_iff {f : B → A} : + strictly_increasing (λ x, - f x) ↔ strictly_decreasing f := + iff.intro strictly_decreasing_of_strictly_increasing_neg + strictly_increasing_neg_of_strictly_decreasing + + theorem strictly_decreasing_neg_of_strictly_increasing' {f : A → B} + (H : strictly_increasing f) : strictly_decreasing (λ x, f (-x)) := + strictly_decreasing_comp_inc_dec H (strictly_decreasing_neg A) + + theorem strictly_increasing_neg_of_strictly_decreasing' {f : A → B} + (H : strictly_decreasing f) : strictly_increasing (λ x, f (-x)) := + strictly_increasing_comp_dec_dec H (strictly_decreasing_neg A) + + theorem strictly_decreasing_of_strictly_increasing_neg' {f : A → B} + (H : strictly_increasing (λ x, f (-x))) : strictly_decreasing f := + strictly_decreasing_of_strictly_increasing_comp_left (left_inverse_neg A) + (strictly_decreasing_neg A) H + + theorem strictly_increasing_of_strictly_decreasing_neg' {f : A → B} + (H : strictly_decreasing (λ x, f (-x))) : strictly_increasing f := + strictly_increasing_of_strictly_decreasing_comp_left (left_inverse_neg A) + (strictly_decreasing_neg A) H + + theorem strictly_decreasing_neg_iff' {f : A → B} : + strictly_decreasing (λ x, f (-x)) ↔ strictly_increasing f := + iff.intro strictly_increasing_of_strictly_decreasing_neg' + strictly_decreasing_neg_of_strictly_increasing' + + theorem strictly_increasing_neg_iff' {f : A → B} : + strictly_increasing (λ x, f (-x)) ↔ strictly_decreasing f := + iff.intro strictly_decreasing_of_strictly_increasing_neg' + strictly_increasing_neg_of_strictly_decreasing' + end + + section + variable [weak_order B] + + theorem nondecreasing_of_neg_nonincreasing {f : B → A} (H : nonincreasing (λ x, -f x)) : + nondecreasing f := + take a₁ a₂, suppose a₁ ≤ a₂, le_of_neg_le_neg (H this) + + theorem nonincreasing_neg {f : B → A} (H : nondecreasing f) : nonincreasing (λ x, -f x) := + take a₁ a₂, suppose a₁ ≤ a₂, neg_le_neg (H this) + + theorem nonincreasing_neg_iff (f : B → A) : nonincreasing (λ x, - f x) ↔ nondecreasing f := + iff.intro nondecreasing_of_neg_nonincreasing nonincreasing_neg + + theorem nonincreasing_of_neg_nondecreasing {f : B → A} (H : nondecreasing (λ x, -f x)) : + nonincreasing f := + take a₁ a₂, suppose a₁ ≤ a₂, le_of_neg_le_neg (H this) + + theorem nondecreasing_neg {f : B → A} (H : nonincreasing f) : nondecreasing (λ x, -f x) := + take a₁ a₂, suppose a₁ ≤ a₂, neg_le_neg (H this) + + theorem nondecreasing_neg_iff (f : B → A) : nondecreasing (λ x, - f x) ↔ nonincreasing f := + iff.intro nonincreasing_of_neg_nondecreasing nondecreasing_neg + + theorem nondecreasing_of_neg_nonincreasing' {f : A → B} (H : nonincreasing (λ x, f (-x))) : + nondecreasing f := + take a₁ a₂, suppose a₁ ≤ a₂, + have f(-(-a₁)) ≤ f(-(-a₂)), from H (neg_le_neg this), + sorry -- by rewrite *neg_neg at this; exact this + + theorem nonincreasing_neg' {f : A → B} (H : nondecreasing f) : nonincreasing (λ x, f (-x)) := + take a₁ a₂, suppose a₁ ≤ a₂, H (neg_le_neg this) + + theorem nonincreasing_neg_iff' (f : A → B) : nonincreasing (λ x, f (- x)) ↔ nondecreasing f := + iff.intro nondecreasing_of_neg_nonincreasing' nonincreasing_neg' + + theorem nonincreasing_of_neg_nondecreasing' {f : A → B} (H : nondecreasing (λ x, f (-x))) : + nonincreasing f := + take a₁ a₂, suppose a₁ ≤ a₂, + have f(-(-a₁)) ≥ f(-(-a₂)), from H (neg_le_neg this), + sorry -- by rewrite *neg_neg at this; exact this + + theorem nondecreasing_neg' {f : A → B} (H : nonincreasing f) : nondecreasing (λ x, f (-x)) := + take a₁ a₂, suppose a₁ ≤ a₂, H (neg_le_neg this) + + theorem nondecreasing_neg_iff' (f : A → B) : nondecreasing (λ x, f (- x)) ↔ nonincreasing f := + iff.intro nonincreasing_of_neg_nondecreasing' nondecreasing_neg' + end +end + +/- linear ordered group with decidable order -/ + +structure decidable_linear_ordered_comm_group [class] (A : Type) + extends add_comm_group A, decidable_linear_order A := + (add_le_add_left : ∀ a b, le a b → ∀ c, le (add c a) (add c b)) + (add_lt_add_left : ∀ a b, lt a b → ∀ c, lt (add c a) (add c b)) + +definition decidable_linear_ordered_comm_group.to_ordered_comm_group + [instance] + (A : Type) [s : decidable_linear_ordered_comm_group A] : ordered_comm_group A := +⦃ ordered_comm_group, s, + le_of_lt := @le_of_lt A _, + lt_of_le_of_lt := @lt_of_le_of_lt A _, + lt_of_lt_of_le := @lt_of_lt_of_le A _ ⦄ + +definition decidable_linear_ordered_comm_group.to_decidable_linear_ordered_cancel_comm_monoid + [instance] (A : Type) [s : decidable_linear_ordered_comm_group A] : + decidable_linear_ordered_cancel_comm_monoid A := +⦃ decidable_linear_ordered_cancel_comm_monoid, s, + @ordered_comm_group.to_ordered_cancel_comm_monoid A _ ⦄ + +section + variables [s : decidable_linear_ordered_comm_group A] + variables {a b c d e : A} + include s + + theorem max_neg_neg : max (-a) (-b) = - min a b := + eq.symm (eq_max + (show -a ≤ -(min a b), from neg_le_neg $ min_le_left a b) + (show -b ≤ -(min a b), from neg_le_neg $ min_le_right a b) + (take d, + assume H₁ : -a ≤ d, + assume H₂ : -b ≤ d, + have H : -d ≤ min a b, + from le_min (iff.mp (neg_le_iff_neg_le a d) H₁) (iff.mp (neg_le_iff_neg_le b d) H₂), + show -(min a b) ≤ d, from iff.mp (neg_le_iff_neg_le d (min a b)) H)) + + theorem min_eq_neg_max_neg_neg : min a b = - max (-a) (-b) := + sorry -- by rewrite [max_neg_neg, neg_neg] + + theorem min_neg_neg : min (-a) (-b) = - max a b := + sorry -- by rewrite [min_eq_neg_max_neg_neg, *neg_neg] + + theorem max_eq_neg_min_neg_neg : max a b = - min (-a) (-b) := + sorry -- by rewrite [min_neg_neg, neg_neg] + + /- absolute value -/ + variables {a b c} + + definition abs (a : A) : A := max a (-a) + + theorem abs_of_nonneg (H : a ≥ 0) : abs a = a := + have H' : -a ≤ a, from le.trans (neg_nonpos_of_nonneg H) H, + max_eq_left H' + + theorem abs_of_pos (H : a > 0) : abs a = a := + abs_of_nonneg (le_of_lt H) + + theorem abs_of_nonpos (H : a ≤ 0) : abs a = -a := + have H' : a ≤ -a, from le.trans H (neg_nonneg_of_nonpos H), + max_eq_right H' + + theorem abs_of_neg (H : a < 0) : abs a = -a := abs_of_nonpos (le_of_lt H) + + theorem abs_zero : abs 0 = (0:A) := abs_of_nonneg (le.refl _) + + theorem abs_neg (a : A) : abs (-a) = abs a := + sorry -- by rewrite [↑abs, max.comm, neg_neg] + + theorem abs_pos_of_pos (H : a > 0) : abs a > 0 := + sorry -- by rewrite (abs_of_pos H); exact H + + theorem abs_pos_of_neg (H : a < 0) : abs a > 0 := + abs_neg a ▸ abs_pos_of_pos (neg_pos_of_neg H) + + theorem abs_sub (a b : A) : abs (a - b) = abs (b - a) := + sorry -- by rewrite [-neg_sub, abs_neg] + + theorem ne_zero_of_abs_ne_zero {a : A} (H : abs a ≠ 0) : a ≠ 0 := + assume Ha, H (symm Ha ▸ abs_zero) + + /- these assume a linear order -/ + + theorem eq_zero_of_neg_eq (H : -a = a) : a = 0 := + lt.by_cases + (assume H1 : a < 0, + have H2: a > 0, from H ▸ neg_pos_of_neg H1, + absurd H1 (lt.asymm H2)) + (assume H1 : a = 0, H1) + (assume H1 : a > 0, + have H2: a < 0, from H ▸ neg_neg_of_pos H1, + absurd H1 (lt.asymm H2)) + + theorem abs_nonneg (a : A) : abs a ≥ 0 := + sorry + /- + or.elim (le.total 0 a) + (assume H : 0 ≤ a, by rewrite (abs_of_nonneg H); exact H) + (assume H : a ≤ 0, + calc + 0 ≤ -a : neg_nonneg_of_nonpos H + ... = abs a : eq.symm (abs_of_nonpos H)) + -/ + + theorem abs_abs (a : A) : abs (abs a) = abs a := abs_of_nonneg $ abs_nonneg a + + theorem le_abs_self (a : A) : a ≤ abs a := + or.elim (le.total 0 a) + (assume H : 0 ≤ a, abs_of_nonneg H ▸ le.refl (abs a)) + (assume H : a ≤ 0, le.trans H $ abs_nonneg a) + + theorem neg_le_abs_self (a : A) : -a ≤ abs a := + abs_neg a ▸ le_abs_self (-a) + + theorem eq_zero_of_abs_eq_zero (H : abs a = 0) : a = 0 := + have H1 : a ≤ 0, from H ▸ le_abs_self a, + have H2 : -a ≤ 0, from H ▸ abs_neg a ▸ le_abs_self (-a), + le.antisymm H1 (nonneg_of_neg_nonpos H2) + + theorem abs_eq_zero_iff_eq_zero (a : A) : abs a = 0 ↔ a = 0 := + iff.intro eq_zero_of_abs_eq_zero (assume H, trans (congr_arg abs H) abs_zero) + + theorem eq_of_abs_sub_eq_zero {a b : A} (H : abs (a - b) = 0) : a = b := + have a - b = 0, from eq_zero_of_abs_eq_zero H, + show a = b, from eq_of_sub_eq_zero this + + theorem abs_pos_of_ne_zero (H : a ≠ 0) : abs a > 0 := + or.elim (lt_or_gt_of_ne H) abs_pos_of_neg abs_pos_of_pos + + theorem abs.by_cases {P : A → Prop} {a : A} (H1 : P a) (H2 : P (-a)) : P (abs a) := + or.elim (le.total 0 a) + (assume H : 0 ≤ a, symm (abs_of_nonneg H) ▸ H1) + (assume H : a ≤ 0, symm (abs_of_nonpos H) ▸ H2) + + theorem abs_le_of_le_of_neg_le (H1 : a ≤ b) (H2 : -a ≤ b) : abs a ≤ b := + abs.by_cases H1 H2 + + theorem abs_lt_of_lt_of_neg_lt (H1 : a < b) (H2 : -a < b) : abs a < b := + abs.by_cases H1 H2 + + -- the triangle inequality + section + private lemma aux1 {a b : A} (H1 : a + b ≥ 0) (H2 : a ≥ 0) : abs (a + b) ≤ abs a + abs b := + sorry + /- + decidable.by_cases + (assume H3 : b ≥ 0, + calc + abs (a + b) ≤ abs (a + b) : !le.refl + ... = a + b : by rewrite (abs_of_nonneg H1) + ... = abs a + b : by rewrite (abs_of_nonneg H2) + ... = abs a + abs b : by rewrite (abs_of_nonneg H3)) + (assume H3 : ¬ b ≥ 0, + have H4 : b ≤ 0, from le_of_lt (lt_of_not_ge H3), + calc + abs (a + b) = a + b : by rewrite (abs_of_nonneg H1) + ... = abs a + b : by rewrite (abs_of_nonneg H2) + ... ≤ abs a + 0 : add_le_add_left H4 _ + ... ≤ abs a + -b : add_le_add_left (neg_nonneg_of_nonpos H4) _ + ... = abs a + abs b : by rewrite (abs_of_nonpos H4)) + -/ + + private lemma aux2 {a b : A} (H1 : a + b ≥ 0) : abs (a + b) ≤ abs a + abs b := + sorry + /- + or.elim (le.total b 0) + (assume H2 : b ≤ 0, + have H3 : ¬ a < 0, from + assume H4 : a < 0, + have H5 : a + b < 0, from !add_zero ▸ add_lt_add_of_lt_of_le H4 H2, + not_lt_of_ge H1 H5, + aux1 H1 (le_of_not_gt H3)) + (assume H2 : 0 ≤ b, + begin + have H3 : abs (b + a) ≤ abs b + abs a, + begin + rewrite add.comm at H1, + exact aux1 H1 H2 + end, + rewrite [add.comm, {abs a + _}add.comm], + exact H3 + end) + -/ + + theorem abs_add_le_abs_add_abs (a b : A) : abs (a + b) ≤ abs a + abs b := + sorry + /- + or.elim (le.total 0 (a + b)) + (assume H2 : 0 ≤ a + b, aux2 H2) + (assume H2 : a + b ≤ 0, + have H3 : -a + -b = -(a + b), by rewrite neg_add, + have H4 : -(a + b) ≥ 0, from iff.mpr (neg_nonneg_iff_nonpos (a+b)) H2, + have H5 : -a + -b ≥ 0, begin rewrite -H3 at H4, exact H4 end, + calc + abs (a + b) = abs (-a + -b) : by rewrite [-abs_neg, neg_add] + ... ≤ abs (-a) + abs (-b) : aux2 H5 + ... = abs a + abs b : by rewrite *abs_neg) + -/ + + theorem abs_sub_abs_le_abs_sub (a b : A) : abs a - abs b ≤ abs (a - b) := + sorry + /- + have H1 : abs a - abs b + abs b ≤ abs (a - b) + abs b, from + calc + abs a - abs b + abs b = abs a : by rewrite sub_add_cancel + ... = abs (a - b + b) : by rewrite sub_add_cancel + ... ≤ abs (a - b) + abs b : !abs_add_le_abs_add_abs, + le_of_add_le_add_right H1 + -/ + + theorem abs_sub_le (a b c : A) : abs (a - c) ≤ abs (a - b) + abs (b - c) := + sorry + /- + calc + abs (a - c) = abs (a - b + (b - c)) : by rewrite [*sub_eq_add_neg, add.assoc, neg_add_cancel_left] + ... ≤ abs (a - b) + abs (b - c) : !abs_add_le_abs_add_abs + -/ + + theorem abs_add_three (a b c : A) : abs (a + b + c) ≤ abs a + abs b + abs c := + sorry + /- + begin + apply le.trans, + apply abs_add_le_abs_add_abs, + apply le.trans, + apply add_le_add_right, + apply abs_add_le_abs_add_abs, + apply le.refl + end + -/ + + theorem dist_bdd_within_interval {a b lb ub : A} (H : lb < ub) (Hal : lb ≤ a) (Hau : a ≤ ub) + (Hbl : lb ≤ b) (Hbu : b ≤ ub) : abs (a - b) ≤ ub - lb := + sorry + /- + begin + cases (decidable.em (b ≤ a)) with [Hba, Hba], + rewrite (abs_of_nonneg (iff.mpr !sub_nonneg_iff_le Hba)), + apply sub_le_sub, + apply Hau, + apply Hbl, + rewrite [abs_of_neg (iff.mpr !sub_neg_iff_lt (lt_of_not_ge Hba)), neg_sub], + apply sub_le_sub, + apply Hbu, + apply Hal + end + -/ + end +end diff --git a/old_library/algebra/ordered_ring.lean b/old_library/algebra/ordered_ring.lean new file mode 100644 index 0000000000..761d3c4cb7 --- /dev/null +++ b/old_library/algebra/ordered_ring.lean @@ -0,0 +1,875 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad + +Here an "ordered_ring" is partially ordered ring, which is ordered with respect to both a weak +order and an associated strict order. Our numeric structures (int, rat, and real) will be instances +of "linear_ordered_comm_ring". This development is modeled after Isabelle's library. +-/ +import algebra.ordered_group algebra.ring +open eq + +variable {A : Type} + +private definition absurd_a_lt_a {B : Type} {a : A} [s : strict_order A] (H : a < a) : B := +absurd H (lt.irrefl a) + +/- semiring structures -/ + +structure ordered_semiring [class] (A : Type) + extends semiring A, ordered_cancel_comm_monoid A := +(mul_le_mul_of_nonneg_left: ∀a b c, le a b → le zero c → le (mul c a) (mul c b)) +(mul_le_mul_of_nonneg_right: ∀a b c, le a b → le zero c → le (mul a c) (mul b c)) +(mul_lt_mul_of_pos_left: ∀a b c, lt a b → lt zero c → lt (mul c a) (mul c b)) +(mul_lt_mul_of_pos_right: ∀a b c, lt a b → lt zero c → lt (mul a c) (mul b c)) + +section + variable [s : ordered_semiring A] + variables (a b c d e : A) + include s + + theorem mul_le_mul_of_nonneg_left {a b c : A} (Hab : a ≤ b) (Hc : 0 ≤ c) : c * a ≤ c * b := + ordered_semiring.mul_le_mul_of_nonneg_left a b c Hab Hc + + theorem mul_le_mul_of_nonneg_right {a b c : A} (Hab : a ≤ b) (Hc : 0 ≤ c) : a * c ≤ b * c := + ordered_semiring.mul_le_mul_of_nonneg_right a b c Hab Hc + + -- TODO: there are four variations, depending on which variables we assume to be nonneg + theorem mul_le_mul {a b c d : A} (Hac : a ≤ c) (Hbd : b ≤ d) (nn_b : 0 ≤ b) (nn_c : 0 ≤ c) : + a * b ≤ c * d := + calc + a * b ≤ c * b : mul_le_mul_of_nonneg_right Hac nn_b + ... ≤ c * d : mul_le_mul_of_nonneg_left Hbd nn_c + + theorem mul_nonneg {a b : A} (Ha : a ≥ 0) (Hb : b ≥ 0) : a * b ≥ 0 := + sorry + /- + begin + have H : 0 * b ≤ a * b, from mul_le_mul_of_nonneg_right Ha Hb, + rewrite zero_mul at H, + exact H + end + -/ + + theorem mul_nonpos_of_nonneg_of_nonpos {a b : A} (Ha : a ≥ 0) (Hb : b ≤ 0) : a * b ≤ 0 := + sorry + /- + begin + have H : a * b ≤ a * 0, from mul_le_mul_of_nonneg_left Hb Ha, + rewrite mul_zero at H, + exact H + end + -/ + + theorem mul_nonpos_of_nonpos_of_nonneg {a b : A} (Ha : a ≤ 0) (Hb : b ≥ 0) : a * b ≤ 0 := + sorry + /- + begin + have H : a * b ≤ 0 * b, from mul_le_mul_of_nonneg_right Ha Hb, + rewrite zero_mul at H, + exact H + end + -/ + + theorem mul_lt_mul_of_pos_left {a b c : A} (Hab : a < b) (Hc : 0 < c) : c * a < c * b := + ordered_semiring.mul_lt_mul_of_pos_left a b c Hab Hc + + theorem mul_lt_mul_of_pos_right {a b c : A} (Hab : a < b) (Hc : 0 < c) : a * c < b * c := + ordered_semiring.mul_lt_mul_of_pos_right a b c Hab Hc + + -- TODO: once again, there are variations + theorem mul_lt_mul {a b c d : A} (Hac : a < c) (Hbd : b ≤ d) (pos_b : 0 < b) (nn_c : 0 ≤ c) : + a * b < c * d := + calc + a * b < c * b : mul_lt_mul_of_pos_right Hac pos_b + ... ≤ c * d : mul_le_mul_of_nonneg_left Hbd nn_c + + theorem mul_lt_mul' {a b c d : A} (H1 : a < c) (H2 : b < d) (H3 : b ≥ 0) (H4 : c > 0) : + a * b < c * d := + calc + a * b ≤ c * b : mul_le_mul_of_nonneg_right (le_of_lt H1) H3 + ... < c * d : mul_lt_mul_of_pos_left H2 H4 + + theorem mul_pos {a b : A} (Ha : a > 0) (Hb : b > 0) : a * b > 0 := + sorry + /- + begin + have H : 0 * b < a * b, from mul_lt_mul_of_pos_right Ha Hb, + rewrite zero_mul at H, + exact H + end + -/ + + theorem mul_neg_of_pos_of_neg {a b : A} (Ha : a > 0) (Hb : b < 0) : a * b < 0 := + sorry + /- + begin + have H : a * b < a * 0, from mul_lt_mul_of_pos_left Hb Ha, + rewrite mul_zero at H, + exact H + end + -/ + + theorem mul_neg_of_neg_of_pos {a b : A} (Ha : a < 0) (Hb : b > 0) : a * b < 0 := + sorry + /- + begin + have H : a * b < 0 * b, from mul_lt_mul_of_pos_right Ha Hb, + rewrite zero_mul at H, + exact H + end + -/ + + theorem mul_self_lt_mul_self {a b : A} (H1 : 0 ≤ a) (H2 : a < b) : a * a < b * b := + mul_lt_mul' H2 H2 H1 (lt_of_le_of_lt H1 H2) +end + +structure linear_ordered_semiring [class] (A : Type) + extends ordered_semiring A, linear_strong_order_pair A := +(zero_lt_one : lt zero one) + +section + variable [s : linear_ordered_semiring A] + variables {a b c : A} + include s + + theorem zero_lt_one : 0 < (1:A) := linear_ordered_semiring.zero_lt_one A + + theorem lt_of_mul_lt_mul_left (H : c * a < c * b) (Hc : c ≥ 0) : a < b := + lt_of_not_ge + (assume H1 : b ≤ a, + have H2 : c * b ≤ c * a, from mul_le_mul_of_nonneg_left H1 Hc, + not_lt_of_ge H2 H) + + theorem lt_of_mul_lt_mul_right (H : a * c < b * c) (Hc : c ≥ 0) : a < b := + lt_of_not_ge + (assume H1 : b ≤ a, + have H2 : b * c ≤ a * c, from mul_le_mul_of_nonneg_right H1 Hc, + not_lt_of_ge H2 H) + + theorem le_of_mul_le_mul_left (H : c * a ≤ c * b) (Hc : c > 0) : a ≤ b := + le_of_not_gt + (assume H1 : b < a, + have H2 : c * b < c * a, from mul_lt_mul_of_pos_left H1 Hc, + not_le_of_gt H2 H) + + theorem le_of_mul_le_mul_right (H : a * c ≤ b * c) (Hc : c > 0) : a ≤ b := + le_of_not_gt + (assume H1 : b < a, + have H2 : b * c < a * c, from mul_lt_mul_of_pos_right H1 Hc, + not_le_of_gt H2 H) + + theorem le_iff_mul_le_mul_left (a b : A) {c : A} (H : c > 0) : a ≤ b ↔ c * a ≤ c * b := + iff.intro + (assume H', mul_le_mul_of_nonneg_left H' (le_of_lt H)) + (assume H', le_of_mul_le_mul_left H' H) + + theorem le_iff_mul_le_mul_right (a b : A) {c : A} (H : c > 0) : a ≤ b ↔ a * c ≤ b * c := + iff.intro + (assume H', mul_le_mul_of_nonneg_right H' (le_of_lt H)) + (assume H', le_of_mul_le_mul_right H' H) + + theorem pos_of_mul_pos_left (H : 0 < a * b) (H1 : 0 ≤ a) : 0 < b := + lt_of_not_ge + (assume H2 : b ≤ 0, + have H3 : a * b ≤ 0, from mul_nonpos_of_nonneg_of_nonpos H1 H2, + not_lt_of_ge H3 H) + + theorem pos_of_mul_pos_right (H : 0 < a * b) (H1 : 0 ≤ b) : 0 < a := + lt_of_not_ge + (assume H2 : a ≤ 0, + have H3 : a * b ≤ 0, from mul_nonpos_of_nonpos_of_nonneg H2 H1, + not_lt_of_ge H3 H) + + theorem nonneg_of_mul_nonneg_left (H : 0 ≤ a * b) (H1 : 0 < a) : 0 ≤ b := + le_of_not_gt + (assume H2 : b < 0, + not_le_of_gt (mul_neg_of_pos_of_neg H1 H2) H) + + theorem nonneg_of_mul_nonneg_right (H : 0 ≤ a * b) (H1 : 0 < b) : 0 ≤ a := + le_of_not_gt + (assume H2 : a < 0, + not_le_of_gt (mul_neg_of_neg_of_pos H2 H1) H) + + theorem neg_of_mul_neg_left (H : a * b < 0) (H1 : 0 ≤ a) : b < 0 := + lt_of_not_ge + (assume H2 : b ≥ 0, + not_lt_of_ge (mul_nonneg H1 H2) H) + + theorem neg_of_mul_neg_right (H : a * b < 0) (H1 : 0 ≤ b) : a < 0 := + lt_of_not_ge + (assume H2 : a ≥ 0, + not_lt_of_ge (mul_nonneg H2 H1) H) + + theorem nonpos_of_mul_nonpos_left (H : a * b ≤ 0) (H1 : 0 < a) : b ≤ 0 := + le_of_not_gt + (assume H2 : b > 0, + not_le_of_gt (mul_pos H1 H2) H) + + theorem nonpos_of_mul_nonpos_right (H : a * b ≤ 0) (H1 : 0 < b) : a ≤ 0 := + le_of_not_gt + (assume H2 : a > 0, + not_le_of_gt (mul_pos H2 H1) H) +end + +structure decidable_linear_ordered_semiring [class] (A : Type) + extends linear_ordered_semiring A, decidable_linear_ordered_cancel_comm_monoid A + +/- ring structures -/ + +structure ordered_ring [class] (A : Type) + extends ring A, ordered_comm_group A, zero_ne_one_class A := +(mul_nonneg : ∀a b, le zero a → le zero b → le zero (mul a b)) +(mul_pos : ∀a b, lt zero a → lt zero b → lt zero (mul a b)) + +theorem ordered_ring.mul_le_mul_of_nonneg_left [s : ordered_ring A] {a b c : A} + (Hab : a ≤ b) (Hc : 0 ≤ c) : c * a ≤ c * b := +have H1 : 0 ≤ b - a, from iff.elim_right (sub_nonneg_iff_le b a) Hab, +have H2 : 0 ≤ c * (b - a), from ordered_ring.mul_nonneg c (b - a) Hc H1, +sorry +/- +begin + rewrite mul_sub_left_distrib at H2, + exact (iff.mp !sub_nonneg_iff_le H2) +end +-/ + +theorem ordered_ring.mul_le_mul_of_nonneg_right [s : ordered_ring A] {a b c : A} + (Hab : a ≤ b) (Hc : 0 ≤ c) : a * c ≤ b * c := +have H1 : 0 ≤ b - a, from iff.elim_right (sub_nonneg_iff_le b a) Hab, +have H2 : 0 ≤ (b - a) * c, from ordered_ring.mul_nonneg (b - a) c H1 Hc, +sorry +/- +begin + rewrite mul_sub_right_distrib at H2, + exact (iff.mp !sub_nonneg_iff_le H2) +end +-/ + +theorem ordered_ring.mul_lt_mul_of_pos_left [s : ordered_ring A] {a b c : A} + (Hab : a < b) (Hc : 0 < c) : c * a < c * b := +have H1 : 0 < b - a, from iff.elim_right (sub_pos_iff_lt b a) Hab, +have H2 : 0 < c * (b - a), from ordered_ring.mul_pos c (b - a) Hc H1, +sorry +/- +begin + rewrite mul_sub_left_distrib at H2, + exact (iff.mp !sub_pos_iff_lt H2) +end +-/ + +theorem ordered_ring.mul_lt_mul_of_pos_right [s : ordered_ring A] {a b c : A} + (Hab : a < b) (Hc : 0 < c) : a * c < b * c := +have H1 : 0 < b - a, from iff.elim_right (sub_pos_iff_lt b a) Hab, +have H2 : 0 < (b - a) * c, from ordered_ring.mul_pos (b - a) c H1 Hc, +sorry +/- +begin + rewrite mul_sub_right_distrib at H2, + exact (iff.mp !sub_pos_iff_lt H2) +end +-/ + +attribute [instance] +definition ordered_ring.to_ordered_semiring + [s : ordered_ring A] : + ordered_semiring A := +⦃ ordered_semiring, s, + mul_zero := mul_zero, + zero_mul := zero_mul, + add_left_cancel := @add.left_cancel A _, + add_right_cancel := @add.right_cancel A _, + le_of_add_le_add_left := @le_of_add_le_add_left A _, + mul_le_mul_of_nonneg_left := @ordered_ring.mul_le_mul_of_nonneg_left A _, + mul_le_mul_of_nonneg_right := @ordered_ring.mul_le_mul_of_nonneg_right A _, + mul_lt_mul_of_pos_left := @ordered_ring.mul_lt_mul_of_pos_left A _, + mul_lt_mul_of_pos_right := @ordered_ring.mul_lt_mul_of_pos_right A _, + lt_of_add_lt_add_left := @lt_of_add_lt_add_left A _⦄ + +section + variable [s : ordered_ring A] + variables {a b c : A} + include s + + theorem mul_le_mul_of_nonpos_left (H : b ≤ a) (Hc : c ≤ 0) : c * a ≤ c * b := + sorry + /- + have Hc' : -c ≥ 0, from iff.mpr !neg_nonneg_iff_nonpos Hc, + have H1 : -c * b ≤ -c * a, from mul_le_mul_of_nonneg_left H Hc', + have H2 : -(c * b) ≤ -(c * a), + begin + rewrite [-*neg_mul_eq_neg_mul at H1], + exact H1 + end, + iff.mp !neg_le_neg_iff_le H2 + -/ + + theorem mul_le_mul_of_nonpos_right (H : b ≤ a) (Hc : c ≤ 0) : a * c ≤ b * c := + sorry + /- + have Hc' : -c ≥ 0, from iff.mpr !neg_nonneg_iff_nonpos Hc, + have H1 : b * -c ≤ a * -c, from mul_le_mul_of_nonneg_right H Hc', + have H2 : -(b * c) ≤ -(a * c), + begin + rewrite [-*neg_mul_eq_mul_neg at H1], + exact H1 + end, + iff.mp !neg_le_neg_iff_le H2 + -/ + + theorem mul_nonneg_of_nonpos_of_nonpos (Ha : a ≤ 0) (Hb : b ≤ 0) : 0 ≤ a * b := + sorry + /- + begin + have H : 0 * b ≤ a * b, from mul_le_mul_of_nonpos_right Ha Hb, + rewrite zero_mul at H, + exact H + end + -/ + + theorem mul_lt_mul_of_neg_left (H : b < a) (Hc : c < 0) : c * a < c * b := + sorry + /- + have Hc' : -c > 0, from iff.mpr !neg_pos_iff_neg Hc, + have H1 : -c * b < -c * a, from mul_lt_mul_of_pos_left H Hc', + have H2 : -(c * b) < -(c * a), + begin + rewrite [-*neg_mul_eq_neg_mul at H1], + exact H1 + end, + iff.mp !neg_lt_neg_iff_lt H2 + -/ + + theorem mul_lt_mul_of_neg_right (H : b < a) (Hc : c < 0) : a * c < b * c := + sorry + /- + have Hc' : -c > 0, from iff.mpr !neg_pos_iff_neg Hc, + have H1 : b * -c < a * -c, from mul_lt_mul_of_pos_right H Hc', + have H2 : -(b * c) < -(a * c), + begin + rewrite [-*neg_mul_eq_mul_neg at H1], + exact H1 + end, + iff.mp !neg_lt_neg_iff_lt H2 + -/ + + theorem mul_pos_of_neg_of_neg (Ha : a < 0) (Hb : b < 0) : 0 < a * b := + sorry + /- + begin + have H : 0 * b < a * b, from mul_lt_mul_of_neg_right Ha Hb, + rewrite zero_mul at H, + exact H + end + -/ + +end + +-- TODO: we can eliminate mul_pos_of_pos, but now it is not worth the effort to redeclare the +-- class instance +structure linear_ordered_ring [class] (A : Type) + extends ordered_ring A, linear_strong_order_pair A := + (zero_lt_one : lt zero one) + +attribute [instance] +definition linear_ordered_ring.to_linear_ordered_semiring + [s : linear_ordered_ring A] : + linear_ordered_semiring A := +⦃ linear_ordered_semiring, s, + mul_zero := mul_zero, + zero_mul := zero_mul, + add_left_cancel := @add.left_cancel A _, + add_right_cancel := @add.right_cancel A _, + le_of_add_le_add_left := @le_of_add_le_add_left A _, + mul_le_mul_of_nonneg_left := @mul_le_mul_of_nonneg_left A _, + mul_le_mul_of_nonneg_right := @mul_le_mul_of_nonneg_right A _, + mul_lt_mul_of_pos_left := @mul_lt_mul_of_pos_left A _, + mul_lt_mul_of_pos_right := @mul_lt_mul_of_pos_right A _, + le_total := linear_ordered_ring.le_total, + lt_of_add_lt_add_left := @lt_of_add_lt_add_left A _ ⦄ + +structure linear_ordered_comm_ring [class] (A : Type) extends linear_ordered_ring A, comm_monoid A + +theorem linear_ordered_comm_ring.eq_zero_or_eq_zero_of_mul_eq_zero [s : linear_ordered_comm_ring A] + {a b : A} (H : a * b = 0) : a = 0 ∨ b = 0 := +sorry +/- +lt.by_cases + (assume Ha : 0 < a, + lt.by_cases + (assume Hb : 0 < b, + begin + have H1 : 0 < a * b, from mul_pos Ha Hb, + rewrite H at H1, + apply absurd_a_lt_a H1 + end) + (assume Hb : 0 = b, or.inr (Hb⁻¹)) + (assume Hb : 0 > b, + begin + have H1 : 0 > a * b, from mul_neg_of_pos_of_neg Ha Hb, + rewrite H at H1, + apply absurd_a_lt_a H1 + end)) + (assume Ha : 0 = a, or.inl (Ha⁻¹)) + (assume Ha : 0 > a, + lt.by_cases + (assume Hb : 0 < b, + begin + have H1 : 0 > a * b, from mul_neg_of_neg_of_pos Ha Hb, + rewrite H at H1, + apply absurd_a_lt_a H1 + end) + (assume Hb : 0 = b, or.inr (Hb⁻¹)) + (assume Hb : 0 > b, + begin + have H1 : 0 < a * b, from mul_pos_of_neg_of_neg Ha Hb, + rewrite H at H1, + apply absurd_a_lt_a H1 + end)) +-/ + +-- Linearity implies no zero divisors. Doesn't need commutativity. +attribute [instance] +definition linear_ordered_comm_ring.to_integral_domain + [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 ⦄ + +section + variable [s : linear_ordered_ring A] + variables (a b c : A) + include s + + theorem mul_self_nonneg : a * a ≥ 0 := + or.elim (le.total 0 a) + (assume H : a ≥ 0, mul_nonneg H H) + (assume H : a ≤ 0, mul_nonneg_of_nonpos_of_nonpos H H) + + theorem zero_le_one : 0 ≤ (1:A) := + have H : 1 * 1 ≥ 0, from mul_self_nonneg (1:A), + sorry + /- + begin + rewrite one_mul at H, + assumption + end + -/ + + theorem pos_and_pos_or_neg_and_neg_of_mul_pos {a b : A} (Hab : a * b > 0) : + (a > 0 ∧ b > 0) ∨ (a < 0 ∧ b < 0) := + sorry + /- + lt.by_cases + (assume Ha : 0 < a, + lt.by_cases + (assume Hb : 0 < b, or.inl (and.intro Ha Hb)) + (assume Hb : 0 = b, + begin + rewrite [-Hb at Hab, mul_zero at Hab], + apply absurd_a_lt_a Hab + end) + (assume Hb : b < 0, + absurd Hab (lt.asymm (mul_neg_of_pos_of_neg Ha Hb)))) + (assume Ha : 0 = a, + begin + rewrite [-Ha at Hab, zero_mul at Hab], + apply absurd_a_lt_a Hab + end) + (assume Ha : a < 0, + lt.by_cases + (assume Hb : 0 < b, + absurd Hab (lt.asymm (mul_neg_of_neg_of_pos Ha Hb))) + (assume Hb : 0 = b, + begin + rewrite [-Hb at Hab, mul_zero at Hab], + apply absurd_a_lt_a Hab + end) + (assume Hb : b < 0, or.inr (and.intro Ha Hb))) + -/ + + theorem gt_of_mul_lt_mul_neg_left {a b c : A} (H : c * a < c * b) (Hc : c ≤ 0) : a > b := + sorry + /- + have nhc : -c ≥ 0, from neg_nonneg_of_nonpos Hc, + have H2 : -(c * b) < -(c * a), from iff.mpr (neg_lt_neg_iff_lt _ _) H, + have H3 : (-c) * b < (-c) * a, from calc + (-c) * b = - (c * b) : by rewrite neg_mul_eq_neg_mul + ... < -(c * a) : H2 + ... = (-c) * a : by rewrite neg_mul_eq_neg_mul, + lt_of_mul_lt_mul_left H3 nhc + -/ + + theorem zero_gt_neg_one : -1 < (0:A) := + neg_zero ▸ (neg_lt_neg zero_lt_one) + + theorem le_of_mul_le_of_ge_one {a b c : A} (H : a * c ≤ b) (Hb : b ≥ 0) (Hc : c ≥ 1) : a ≤ b := + sorry + /- + have H' : a * c ≤ b * c, from calc + a * c ≤ b : H + ... = b * 1 : by rewrite mul_one + ... ≤ b * c : mul_le_mul_of_nonneg_left Hc Hb, + le_of_mul_le_mul_right H' (lt_of_lt_of_le zero_lt_one Hc) + -/ + + theorem nonneg_le_nonneg_of_squares_le {a b : A} (Ha : a ≥ 0) (Hb : b ≥ 0) (H : a * a ≤ b * b) : + a ≤ b := + sorry + /- + begin + apply le_of_not_gt, + intro Hab, + note Hposa := lt_of_le_of_lt Hb Hab, + note H' := calc + b * b ≤ a * b : mul_le_mul_of_nonneg_right (le_of_lt Hab) Hb + ... < a * a : mul_lt_mul_of_pos_left Hab Hposa, + apply (not_le_of_gt H') H + end + -/ + +end + +/- TODO: Isabelle's library has all kinds of cancelation rules for the simplifier. + Search on mult_le_cancel_right1 in Rings.thy. -/ + +structure decidable_linear_ordered_comm_ring [class] (A : Type) extends linear_ordered_comm_ring A, + decidable_linear_ordered_comm_group A + +definition decidable_linear_ordered_comm_ring.to_decidable_linear_ordered_semiring + [instance] [s : decidable_linear_ordered_comm_ring A] : + decidable_linear_ordered_semiring A := +⦃decidable_linear_ordered_semiring, s, @linear_ordered_ring.to_linear_ordered_semiring A _⦄ + +section + variable [s : decidable_linear_ordered_comm_ring A] + variables {a b c : A} + include s + + definition sign (a : A) : A := lt.cases a 0 (-1) 0 1 + + theorem sign_of_neg (H : a < 0) : sign a = -1 := lt.cases_of_lt H + + theorem sign_zero : sign 0 = (0:A) := lt.cases_of_eq rfl + + theorem sign_of_pos (H : a > 0) : sign a = 1 := lt.cases_of_gt H + + theorem sign_one : sign 1 = (1:A) := sign_of_pos zero_lt_one + + theorem sign_neg_one : sign (-1) = -(1:A) := sign_of_neg (neg_neg_of_pos zero_lt_one) + + theorem sign_sign (a : A) : sign (sign a) = sign a := + sorry + /- + lt.by_cases + (assume H : a > 0, + calc + sign (sign a) = sign 1 : by rewrite (sign_of_pos H) + ... = 1 : by rewrite sign_one + ... = sign a : by rewrite (sign_of_pos H)) + (assume H : 0 = a, + calc + sign (sign a) = sign (sign 0) : by rewrite H + ... = sign 0 : by rewrite sign_zero at {1} + ... = sign a : by rewrite -H) + (assume H : a < 0, + calc + sign (sign a) = sign (-1) : by rewrite (sign_of_neg H) + ... = -1 : by rewrite sign_neg_one + ... = sign a : by rewrite (sign_of_neg H)) + -/ + + theorem pos_of_sign_eq_one (H : sign a = 1) : a > 0 := + sorry + /- + lt.by_cases + (assume H1 : 0 < a, H1) + (assume H1 : 0 = a, + begin + rewrite [-H1 at H, sign_zero at H], + apply absurd H zero_ne_one + end) + (assume H1 : 0 > a, + have H2 : -1 = 1, from (sign_of_neg H1)⁻¹ ⬝ H, + absurd ((eq_zero_of_neg_eq H2)⁻¹) zero_ne_one) + -/ + + theorem eq_zero_of_sign_eq_zero (H : sign a = 0) : a = 0 := + sorry + /- + lt.by_cases + (assume H1 : 0 < a, + absurd (H⁻¹ ⬝ sign_of_pos H1) zero_ne_one) + (assume H1 : 0 = a, H1⁻¹) + (assume H1 : 0 > a, + have H2 : 0 = -1, from H⁻¹ ⬝ sign_of_neg H1, + have H3 : 1 = 0, from eq_neg_of_eq_neg H2 ⬝ neg_zero, + absurd (H3⁻¹) zero_ne_one) + -/ + + theorem neg_of_sign_eq_neg_one (H : sign a = -1) : a < 0 := + sorry + /- + lt.by_cases + (assume H1 : 0 < a, + have H2 : -1 = 1, from H⁻¹ ⬝ (sign_of_pos H1), + absurd ((eq_zero_of_neg_eq H2)⁻¹) zero_ne_one) + (assume H1 : 0 = a, + have H2 : (0:A) = -1, + begin + rewrite [-H1 at H, sign_zero at H], + exact H + end, + have H3 : 1 = 0, from eq_neg_of_eq_neg H2 ⬝ neg_zero, + absurd (H3⁻¹) zero_ne_one) + (assume H1 : 0 > a, H1) + -/ + + theorem sign_neg (a : A) : sign (-a) = -(sign a) := + sorry + /- + lt.by_cases + (assume H1 : 0 < a, + calc + sign (-a) = -1 : sign_of_neg (neg_neg_of_pos H1) + ... = -(sign a) : by rewrite (sign_of_pos H1)) + (assume H1 : 0 = a, + calc + sign (-a) = sign (-0) : by rewrite H1 + ... = sign 0 : by rewrite neg_zero + ... = 0 : by rewrite sign_zero + ... = -0 : by rewrite neg_zero + ... = -(sign 0) : by rewrite sign_zero + ... = -(sign a) : by rewrite -H1) + (assume H1 : 0 > a, + calc + sign (-a) = 1 : sign_of_pos (neg_pos_of_neg H1) + ... = -(-1) : by rewrite neg_neg + ... = -(sign a) : by rewrite (sign_of_neg H1)) + -/ + + theorem sign_mul (a b : A) : sign (a * b) = sign a * sign b := + sorry + /- + lt.by_cases + (assume z_lt_a : 0 < a, + lt.by_cases + (assume z_lt_b : 0 < b, + by rewrite [sign_of_pos z_lt_a, sign_of_pos z_lt_b, + sign_of_pos (mul_pos z_lt_a z_lt_b), one_mul]) + (assume z_eq_b : 0 = b, by rewrite [-z_eq_b, mul_zero, *sign_zero, mul_zero]) + (assume z_gt_b : 0 > b, + by rewrite [sign_of_pos z_lt_a, sign_of_neg z_gt_b, + sign_of_neg (mul_neg_of_pos_of_neg z_lt_a z_gt_b), one_mul])) + (assume z_eq_a : 0 = a, by rewrite [-z_eq_a, zero_mul, *sign_zero, zero_mul]) + (assume z_gt_a : 0 > a, + lt.by_cases + (assume z_lt_b : 0 < b, + by rewrite [sign_of_neg z_gt_a, sign_of_pos z_lt_b, + sign_of_neg (mul_neg_of_neg_of_pos z_gt_a z_lt_b), mul_one]) + (assume z_eq_b : 0 = b, by rewrite [-z_eq_b, mul_zero, *sign_zero, mul_zero]) + (assume z_gt_b : 0 > b, + by rewrite [sign_of_neg z_gt_a, sign_of_neg z_gt_b, + sign_of_pos (mul_pos_of_neg_of_neg z_gt_a z_gt_b), + neg_mul_neg, one_mul])) + -/ + + theorem abs_eq_sign_mul (a : A) : abs a = sign a * a := + sorry + /- + lt.by_cases + (assume H1 : 0 < a, + calc + abs a = a : abs_of_pos H1 + ... = 1 * a : by rewrite one_mul + ... = sign a * a : by rewrite (sign_of_pos H1)) + (assume H1 : 0 = a, + calc + abs a = abs 0 : by rewrite H1 + ... = 0 : by rewrite abs_zero + ... = 0 * a : by rewrite zero_mul + ... = sign 0 * a : by rewrite sign_zero + ... = sign a * a : by rewrite H1) + (assume H1 : a < 0, + calc + abs a = -a : abs_of_neg H1 + ... = -1 * a : by rewrite neg_eq_neg_one_mul + ... = sign a * a : by rewrite (sign_of_neg H1)) + -/ + + theorem eq_sign_mul_abs (a : A) : a = sign a * abs a := + sorry + /- + lt.by_cases + (assume H1 : 0 < a, + calc + a = abs a : by rewrite (abs_of_pos H1) + ... = 1 * abs a : by rewrite one_mul + ... = sign a * abs a : by rewrite (sign_of_pos H1)) + (assume H1 : 0 = a, + calc + a = 0 : H1⁻¹ + ... = 0 * abs a : by rewrite zero_mul + ... = sign 0 * abs a : by rewrite sign_zero + ... = sign a * abs a : by rewrite H1) + (assume H1 : a < 0, + calc + a = -(-a) : by rewrite neg_neg + ... = -abs a : by rewrite (abs_of_neg H1) + ... = -1 * abs a : by rewrite neg_eq_neg_one_mul + ... = sign a * abs a : by rewrite (sign_of_neg H1)) + -/ + + theorem abs_dvd_iff (a b : A) : abs a ∣ b ↔ a ∣ b := + abs.by_cases (iff.refl $ a ∣ b) (neg_dvd_iff_dvd a b) + + theorem abs_dvd_of_dvd {a b : A} : a ∣ b → abs a ∣ b := + iff.mpr $ abs_dvd_iff a b + + theorem dvd_abs_iff (a b : A) : a ∣ abs b ↔ a ∣ b := + abs.by_cases (iff.refl $ a ∣ b) (dvd_neg_iff_dvd a b) + + theorem dvd_abs_of_dvd {a b : A} : a ∣ b → a ∣ abs b := + iff.mpr $ dvd_abs_iff a b + + theorem abs_mul (a b : A) : abs (a * b) = abs a * abs b := + sorry + /- + or.elim (le.total 0 a) + (assume H1 : 0 ≤ a, + or.elim (le.total 0 b) + (assume H2 : 0 ≤ b, + calc + abs (a * b) = a * b : abs_of_nonneg (mul_nonneg H1 H2) + ... = abs a * b : by rewrite (abs_of_nonneg H1) + ... = abs a * abs b : by rewrite (abs_of_nonneg H2)) + (assume H2 : b ≤ 0, + calc + abs (a * b) = -(a * b) : abs_of_nonpos (mul_nonpos_of_nonneg_of_nonpos H1 H2) + ... = a * -b : by rewrite neg_mul_eq_mul_neg + ... = abs a * -b : by rewrite (abs_of_nonneg H1) + ... = abs a * abs b : by rewrite (abs_of_nonpos H2))) + (assume H1 : a ≤ 0, + or.elim (le.total 0 b) + (assume H2 : 0 ≤ b, + calc + abs (a * b) = -(a * b) : abs_of_nonpos (mul_nonpos_of_nonpos_of_nonneg H1 H2) + ... = -a * b : by rewrite neg_mul_eq_neg_mul + ... = abs a * b : by rewrite (abs_of_nonpos H1) + ... = abs a * abs b : by rewrite (abs_of_nonneg H2)) + (assume H2 : b ≤ 0, + calc + abs (a * b) = a * b : abs_of_nonneg (mul_nonneg_of_nonpos_of_nonpos H1 H2) + ... = -a * -b : by rewrite neg_mul_neg + ... = abs a * -b : by rewrite (abs_of_nonpos H1) + ... = abs a * abs b : by rewrite (abs_of_nonpos H2))) + -/ + + theorem abs_mul_abs_self (a : A) : abs a * abs a = a * a := + abs.by_cases rfl (neg_mul_neg a a) + + theorem abs_mul_self (a : A) : abs (a * a) = a * a := + sorry -- by rewrite [abs_mul, abs_mul_abs_self] + + theorem sub_le_of_abs_sub_le_left (H : abs (a - b) ≤ c) : b - c ≤ a := + sorry + /- + if Hz : 0 ≤ a - b then + (calc + a ≥ b : (iff.mp !sub_nonneg_iff_le) Hz + ... ≥ b - c : sub_le_of_nonneg _ (le.trans !abs_nonneg H)) + else + (have Habs : b - a ≤ c, by rewrite [abs_of_neg (lt_of_not_ge Hz) at H, neg_sub at H]; apply H, + have Habs' : b ≤ c + a, from (iff.mpr !le_add_iff_sub_right_le) Habs, + (iff.mp !le_add_iff_sub_left_le) Habs') + -/ + + theorem sub_le_of_abs_sub_le_right (H : abs (a - b) ≤ c) : a - c ≤ b := + sub_le_of_abs_sub_le_left (abs_sub a b ▸ H) + + theorem sub_lt_of_abs_sub_lt_left (H : abs (a - b) < c) : b - c < a := + sorry + /- + if Hz : 0 ≤ a - b then + (calc + a ≥ b : (iff.mp !sub_nonneg_iff_le) Hz + ... > b - c : sub_lt_of_pos _ (lt_of_le_of_lt !abs_nonneg H)) + else + (have Habs : b - a < c, by rewrite [abs_of_neg (lt_of_not_ge Hz) at H, neg_sub at H]; apply H, + have Habs' : b < c + a, from lt_add_of_sub_lt_right Habs, + sub_lt_left_of_lt_add Habs') + -/ + + theorem sub_lt_of_abs_sub_lt_right (H : abs (a - b) < c) : a - c < b := + sub_lt_of_abs_sub_lt_left (abs_sub a b ▸ H) + + theorem abs_sub_square (a b : A) : abs (a - b) * abs (a - b) = a * a + b * b - (1 + 1) * a * b := + sorry + /- + begin + rewrite [abs_mul_abs_self, *mul_sub_left_distrib, *mul_sub_right_distrib, + sub_eq_add_neg (a*b), sub_add_eq_sub_sub, sub_neg_eq_add, *right_distrib, sub_add_eq_sub_sub, *one_mul, + *add.assoc, {_ + b * b}add.comm, *sub_eq_add_neg], + rewrite [{a*a + b*b}add.comm], + rewrite [mul.comm b a, *add.assoc] + end + -/ + + theorem abs_abs_sub_abs_le_abs_sub (a b : A) : abs (abs a - abs b) ≤ abs (a - b) := + sorry + /- + begin + apply nonneg_le_nonneg_of_squares_le, + repeat apply abs_nonneg, + rewrite [*abs_sub_square, *abs_abs, *abs_mul_abs_self], + apply sub_le_sub_left, + rewrite *mul.assoc, + apply mul_le_mul_of_nonneg_left, + rewrite -abs_mul, + apply le_abs_self, + apply le_of_lt, + apply add_pos, + apply zero_lt_one, + apply zero_lt_one + end + -/ + + lemma eq_zero_of_mul_self_add_mul_self_eq_zero {x y : A} (H : x * x + y * y = 0) : x = 0 := + have x * x ≤ (0 : A), from calc + x * x ≤ x * x + y * y : le_add_of_nonneg_right (mul_self_nonneg y) + ... = 0 : H, + eq_zero_of_mul_self_eq_zero (le.antisymm this (mul_self_nonneg x)) +end + +/- TODO: Multiplication and one, starting with mult_right_le_one_le. -/ + +namespace norm_num + +theorem pos_bit0_helper [s : linear_ordered_semiring A] (a : A) (H : a > 0) : bit0 a > 0 := +sorry -- by rewrite ↑bit0; apply add_pos H H + +theorem nonneg_bit0_helper [s : linear_ordered_semiring A] (a : A) (H : a ≥ 0) : bit0 a ≥ 0 := +sorry -- by rewrite ↑bit0; apply add_nonneg H H + +theorem pos_bit1_helper [s : linear_ordered_semiring A] (a : A) (H : a ≥ 0) : bit1 a > 0 := +sorry +/- + begin + rewrite ↑bit1, + apply add_pos_of_nonneg_of_pos, + apply nonneg_bit0_helper _ H, + apply zero_lt_one + end +-/ + +theorem nonneg_bit1_helper [s : linear_ordered_semiring A] (a : A) (H : a ≥ 0) : bit1 a ≥ 0 := +sorry -- by apply le_of_lt; apply pos_bit1_helper _ H + +theorem nonzero_of_pos_helper [s : linear_ordered_semiring A] (a : A) (H : a > 0) : a ≠ 0 := + ne_of_gt H + +theorem nonzero_of_neg_helper [s : linear_ordered_ring A] (a : A) (H : a ≠ 0) : -a ≠ 0 := +sorry -- begin intro Ha, apply H, apply eq_of_neg_eq_neg, rewrite neg_zero, exact Ha end + +end norm_num diff --git a/old_library/algebra/priority.lean b/old_library/algebra/priority.lean new file mode 100644 index 0000000000..aa2ac4c5c8 --- /dev/null +++ b/old_library/algebra/priority.lean @@ -0,0 +1,6 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +protected definition algebra.prio := num.sub std.priority.default 100 diff --git a/old_library/algebra/relation.lean b/old_library/algebra/relation.lean new file mode 100644 index 0000000000..3fd9c70ced --- /dev/null +++ b/old_library/algebra/relation.lean @@ -0,0 +1,122 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +General properties of relations, and classes for equivalence relations and congruences. +-/ + +namespace relation + +/- properties of binary relations -/ + +section + variables {T : Type} (R : T → T → Type) + + definition reflexive : Type := ∀x, R x x + definition symmetric : Type := ∀⦃x y⦄, R x y → R y x + definition transitive : Type := ∀⦃x y z⦄, R x y → R y z → R x z +end + + +/- classes for equivalence relations -/ + +structure is_reflexive [class] {T : Type} (R : T → T → Type) := (refl : reflexive R) +structure is_symmetric [class] {T : Type} (R : T → T → Type) := (symm : symmetric R) +structure is_transitive [class] {T : Type} (R : T → T → Type) := (trans : transitive R) + +structure is_equivalence [class] {T : Type} (R : T → T → Type) +extends is_reflexive R, is_symmetric R, is_transitive R + +-- partial equivalence relation +structure is_PER {T : Type} (R : T → T → Type) extends is_symmetric R, is_transitive R + +-- Generic notation. For example, is_refl R is the reflexivity of R, if that can be +-- inferred by type class inference +section + variables {T : Type} (R : T → T → Type) + definition rel_refl [C : is_reflexive R] := is_reflexive.refl R + definition rel_symm [C : is_symmetric R] := is_symmetric.symm R + definition rel_trans [C : is_transitive R] := is_transitive.trans R +end + + +/- classes for unary and binary congruences with respect to arbitrary relations -/ + +structure is_congruence [class] + {T1 : Type} (R1 : T1 → T1 → Prop) + {T2 : Type} (R2 : T2 → T2 → Prop) + (f : T1 → T2) := +(congr : ∀{x y}, R1 x y → R2 (f x) (f y)) + +structure is_congruence2 [class] + {T1 : Type} (R1 : T1 → T1 → Prop) + {T2 : Type} (R2 : T2 → T2 → Prop) + {T3 : Type} (R3 : T3 → T3 → Prop) + (f : T1 → T2 → T3) := +(congr2 : ∀{x1 y1 : T1} {x2 y2 : T2}, R1 x1 y1 → R2 x2 y2 → R3 (f x1 x2) (f y1 y2)) + +namespace is_congruence + + -- makes the type class explicit + definition app {T1 : Type} {R1 : T1 → T1 → Prop} {T2 : Type} {R2 : T2 → T2 → Prop} + {f : T1 → T2} (C : is_congruence R1 R2 f) ⦃x y : T1⦄ : R1 x y → R2 (f x) (f y) := + is_congruence.rec (λu, u) C x y + + definition app2 {T1 : Type} {R1 : T1 → T1 → Prop} {T2 : Type} {R2 : T2 → T2 → Prop} + {T3 : Type} {R3 : T3 → T3 → Prop} + {f : T1 → T2 → T3} (C : is_congruence2 R1 R2 R3 f) ⦃x1 y1 : T1⦄ ⦃x2 y2 : T2⦄ : + R1 x1 y1 → R2 x2 y2 → R3 (f x1 x2) (f y1 y2) := + is_congruence2.rec (λu, u) C x1 y1 x2 y2 + + /- tools to build instances -/ + + definition compose + {T2 : Type} {R2 : T2 → T2 → Prop} + {T3 : Type} {R3 : T3 → T3 → Prop} + {g : T2 → T3} (C2 : is_congruence R2 R3 g) + ⦃T1 : Type⦄ {R1 : T1 → T1 → Prop} + {f : T1 → T2} [C1 : is_congruence R1 R2 f] : + is_congruence R1 R3 (λx, g (f x)) := + is_congruence.mk (λx1 x2 H, app C2 (app C1 H)) + + definition compose21 + {T2 : Type} {R2 : T2 → T2 → Prop} + {T3 : Type} {R3 : T3 → T3 → Prop} + {T4 : Type} {R4 : T4 → T4 → Prop} + {g : T2 → T3 → T4} (C3 : is_congruence2 R2 R3 R4 g) + ⦃T1 : Type⦄ {R1 : T1 → T1 → Prop} + {f1 : T1 → T2} [C1 : is_congruence R1 R2 f1] + {f2 : T1 → T3} [C2 : is_congruence R1 R3 f2] : + is_congruence R1 R4 (λx, g (f1 x) (f2 x)) := + is_congruence.mk (λx1 x2 H, app2 C3 (app C1 H) (app C2 H)) + + definition const {T2 : Type} (R2 : T2 → T2 → Prop) (H : relation.reflexive R2) + ⦃T1 : Type⦄ (R1 : T1 → T1 → Prop) (c : T2) : + is_congruence R1 R2 (λu : T1, c) := + is_congruence.mk (λx y H1, H c) + +end is_congruence + +attribute [instance] +definition congruence_const {T2 : Type} (R2 : T2 → T2 → Prop) + [C : is_reflexive R2] ⦃T1 : Type⦄ (R1 : T1 → T1 → Prop) (c : T2) : + is_congruence R1 R2 (λu : T1, c) := +is_congruence.const R2 (is_reflexive.refl R2) R1 c + +attribute [instance] +definition congruence_trivial {T : Type} (R : T → T → Prop) : + is_congruence R R (λu, u) := +is_congruence.mk (λx y H, H) + + +/- relations that can be coerced to functions / implications-/ + +structure mp_like [class] (R : Type → Type → Type) := +(app : Π{a b : Type}, R a b → (a → b)) + +definition rel_mp (R : Type → Type → Type) [C : mp_like R] {a b : Type} (H : R a b) := +mp_like.app H + + +end relation diff --git a/old_library/algebra/ring.lean b/old_library/algebra/ring.lean new file mode 100644 index 0000000000..8a25328ed0 --- /dev/null +++ b/old_library/algebra/ring.lean @@ -0,0 +1,577 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad, Leonardo de Moura + +Structures with multiplicative and additive components, including semirings, rings, and fields. +The development is modeled after Isabelle's library. +-/ +import algebra.group +open eq + +variable {A : Type} + +/- auxiliary classes -/ + +structure distrib [class] (A : Type) extends has_mul A, has_add A := +(left_distrib : ∀a b c, mul a (add b c) = add (mul a b) (mul a c)) +(right_distrib : ∀a b c, mul (add a b) c = add (mul a c) (mul b c)) + +theorem left_distrib [distrib A] (a b c : A) : a * (b + c) = a * b + a * c := +distrib.left_distrib a b c + +theorem right_distrib [distrib A] (a b c : A) : (a + b) * c = a * c + b * c := +distrib.right_distrib a b c + +structure mul_zero_class [class] (A : Type) extends has_mul A, has_zero A := +(zero_mul : ∀a, mul zero a = zero) +(mul_zero : ∀a, mul a zero = zero) + +attribute [simp] +theorem zero_mul [mul_zero_class A] (a : A) : 0 * a = 0 := mul_zero_class.zero_mul a +attribute [simp] +theorem mul_zero [mul_zero_class A] (a : A) : a * 0 = 0 := mul_zero_class.mul_zero a + +structure zero_ne_one_class [class] (A : Type) extends has_zero A, has_one A := +(zero_ne_one : zero ≠ one) + +theorem zero_ne_one [s: zero_ne_one_class A] : 0 ≠ (1:A) := @zero_ne_one_class.zero_ne_one A s + +/- semiring -/ + +structure semiring [class] (A : Type) extends add_comm_monoid A, monoid A, distrib A, + mul_zero_class A + +section semiring + variables [s : semiring A] (a b c : A) + include s + + theorem one_add_one_eq_two : 1 + 1 = (2:A) := + sorry -- by unfold bit0 + + theorem ne_zero_of_mul_ne_zero_right {a b : A} (H : a * b ≠ 0) : a ≠ 0 := + sorry + /- + suppose a = 0, + have a * b = 0, by rewrite [this, zero_mul], + H this + -/ + + theorem ne_zero_of_mul_ne_zero_left {a b : A} (H : a * b ≠ 0) : b ≠ 0 := + sorry + /- + suppose b = 0, + have a * b = 0, by rewrite [this, mul_zero], + H this + -/ + + local attribute right_distrib [simp] + + theorem distrib_three_right (a b c d : A) : (a + b + c) * d = a * d + b * d + c * d := + sorry -- by simp +end semiring + +/- comm semiring -/ + +structure comm_semiring [class] (A : Type) extends semiring A, comm_monoid A +-- TODO: we could also define a cancelative comm_semiring, i.e. satisfying +-- c ≠ 0 → c * a = c * b → a = b. + +section comm_semiring + variables [s : comm_semiring A] (a b c : A) + include s + + protected definition algebra.dvd (a b : A) : Prop := ∃c, b = a * c + + attribute [instance, priority algebra.prio] + definition comm_semiring_has_dvd : has_dvd A := + has_dvd.mk algebra.dvd + + theorem dvd.intro {a b c : A} (H : a * c = b) : a ∣ b := + exists.intro _ (eq.symm H) + + theorem dvd_of_mul_right_eq {a b c : A} (H : a * c = b) : a ∣ b := dvd.intro H + + theorem dvd.intro_left {a b c : A} (H : c * a = b) : a ∣ b := + sorry -- dvd.intro (by rewrite mul.comm at H; exact H) + + theorem dvd_of_mul_left_eq {a b c : A} (H : c * a = b) : a ∣ b := dvd.intro_left H + + theorem exists_eq_mul_right_of_dvd {a b : A} (H : a ∣ b) : ∃c, b = a * c := H + + theorem dvd.elim {P : Prop} {a b : A} (H₁ : a ∣ b) (H₂ : ∀c, b = a * c → P) : P := + exists.elim H₁ H₂ + + theorem exists_eq_mul_left_of_dvd {a b : A} (H : a ∣ b) : ∃c, b = c * a := + dvd.elim H (take c, assume H1 : b = a * c, exists.intro c (eq.trans H1 (mul.comm a c))) + + theorem dvd.elim_left {P : Prop} {a b : A} (H₁ : a ∣ b) (H₂ : ∀c, b = c * a → P) : P := + exists.elim (exists_eq_mul_left_of_dvd H₁) (take c, assume H₃ : b = c * a, H₂ c H₃) + + attribute [simp] + theorem dvd.refl : a ∣ a := + dvd.intro (mul_one a) + + theorem dvd.trans {a b c : A} (H₁ : a ∣ b) (H₂ : b ∣ c) : a ∣ c := + sorry + /- + dvd.elim H₁ + (take d, assume H₃ : b = a * d, + dvd.elim H₂ + (take e, assume H₄ : c = b * e, + dvd.intro + (show a * (d * e) = c, by rewrite [-mul.assoc, -H₃, H₄]))) + -/ + + theorem eq_zero_of_zero_dvd {a : A} (H : 0 ∣ a) : a = 0 := + dvd.elim H (take c, assume H' : a = 0 * c, eq.trans H' (zero_mul c)) + + attribute [simp] + theorem dvd_zero : a ∣ 0 := dvd.intro (mul_zero a) + + attribute [simp] + theorem one_dvd : 1 ∣ a := dvd.intro (one_mul a) + + attribute [simp] + theorem dvd_mul_right : a ∣ a * b := dvd.intro rfl + + attribute [simp] + theorem dvd_mul_left : a ∣ b * a := + sorry -- by simp + + theorem dvd_mul_of_dvd_left {a b : A} (H : a ∣ b) (c : A) : a ∣ b * c := + sorry + /- + dvd.elim H + (take d, + suppose b = a * d, + dvd.intro + (show a * (d * c) = b * c, by simp)) + -/ + + theorem dvd_mul_of_dvd_right {a b : A} (H : a ∣ b) (c : A) : a ∣ c * b := + sorry -- begin rewrite mul.comm, exact dvd_mul_of_dvd_left H _ end + + theorem mul_dvd_mul {a b c d : A} (dvd_ab : a ∣ b) (dvd_cd : c ∣ d) : a * c ∣ b * d := + sorry + /- + dvd.elim dvd_ab + (take e, suppose b = a * e, + dvd.elim dvd_cd + (take f, suppose d = c * f, + dvd.intro + (show a * c * (e * f) = b * d, + by simp))) + -/ + + theorem dvd_of_mul_right_dvd {a b c : A} (H : a * b ∣ c) : a ∣ c := + dvd.elim H (take d, assume Habdc : c = a * b * d, dvd.intro (eq.symm (eq.trans Habdc (mul.assoc a b d)))) + + theorem dvd_of_mul_left_dvd {a b c : A} (H : a * b ∣ c) : b ∣ c := + sorry -- dvd_of_mul_right_dvd begin rewrite mul.comm at H, apply H end + + theorem dvd_add {a b c : A} (Hab : a ∣ b) (Hac : a ∣ c) : a ∣ b + c := + sorry + /- + dvd.elim Hab + (take d, suppose b = a * d, + dvd.elim Hac + (take e, suppose c = a * e, + dvd.intro (show a * (d + e) = b + c, + by rewrite [left_distrib]; substvars))) + -/ +end comm_semiring + +/- ring -/ + +structure ring [class] (A : Type) extends add_comm_group A, monoid A, distrib A + +attribute [simp] +theorem ring.mul_zero [ring A] (a : A) : a * 0 = 0 := +sorry +/- +have a * 0 + 0 = a * 0 + a * 0, from calc + a * 0 + 0 = a * (0 + 0) : by simp + ... = a * 0 + a * 0 : by rewrite left_distrib, +show a * 0 = 0, from (add.left_cancel this)⁻¹ +-/ + +attribute [simp] +theorem ring.zero_mul [ring A] (a : A) : 0 * a = 0 := +sorry +/- +have 0 * a + 0 = 0 * a + 0 * a, from calc + 0 * a + 0 = (0 + 0) * a : by simp + ... = 0 * a + 0 * a : by rewrite right_distrib, +show 0 * a = 0, from (add.left_cancel this)⁻¹ +-/ + +attribute [instance] +definition ring.to_semiring [s : ring A] : semiring A := +⦃ semiring, s, + mul_zero := ring.mul_zero, + zero_mul := ring.zero_mul ⦄ + +section + variables [s : ring A] (a b c d e : A) + include s + + theorem neg_mul_eq_neg_mul : -(a * b) = -a * b := + sorry + /- + neg_eq_of_add_eq_zero + begin + rewrite [-right_distrib, add.right_inv, zero_mul] + end + -/ + + theorem neg_mul_eq_mul_neg : -(a * b) = a * -b := + sorry + /- + neg_eq_of_add_eq_zero + begin + rewrite [-left_distrib, add.right_inv, mul_zero] + end + -/ + + attribute [simp] + theorem neg_mul_eq_neg_mul_symm : - a * b = - (a * b) := eq.symm (neg_mul_eq_neg_mul a b) + attribute [simp] + theorem mul_neg_eq_neg_mul_symm : a * - b = - (a * b) := eq.symm (neg_mul_eq_mul_neg a b) + + theorem neg_mul_neg : -a * -b = a * b := + sorry -- by simp + + theorem neg_mul_comm : -a * b = a * -b := + sorry -- by simp + + theorem neg_eq_neg_one_mul : -a = -1 * a := + sorry -- by simp + + theorem mul_sub_left_distrib : a * (b - c) = a * b - a * c := + calc + a * (b - c) = a * b + a * -c : left_distrib a b (-c) + ... = a * b - a * c : sorry -- by simp + + theorem mul_sub_right_distrib : (a - b) * c = a * c - b * c := + calc + (a - b) * c = a * c + -b * c : right_distrib a (-b) c + ... = a * c - b * c : sorry -- by simp + + -- TODO: can calc mode be improved to make this easier? + -- TODO: there is also the other direction. It will be easier when we + -- have the simplifier. + + theorem mul_add_eq_mul_add_iff_sub_mul_add_eq : a * e + c = b * e + d ↔ (a - b) * e + c = d := + sorry + /- + calc + a * e + c = b * e + d ↔ a * e + c = d + b * e : by rewrite {b*e+_}add.comm + ... ↔ a * e + c - b * e = d : iff.symm !sub_eq_iff_eq_add + ... ↔ a * e - b * e + c = d : by rewrite sub_add_eq_add_sub + ... ↔ (a - b) * e + c = d : by rewrite mul_sub_right_distrib + -/ + + theorem mul_add_eq_mul_add_of_sub_mul_add_eq : (a - b) * e + c = d → a * e + c = b * e + d := + iff.mpr (mul_add_eq_mul_add_iff_sub_mul_add_eq a b c d e) + + theorem sub_mul_add_eq_of_mul_add_eq_mul_add : a * e + c = b * e + d → (a - b) * e + c = d := + iff.mp (mul_add_eq_mul_add_iff_sub_mul_add_eq a b c d e) + + theorem mul_neg_one_eq_neg : a * (-1) = -a := + have a + a * -1 = 0, from calc + a + a * -1 = a * 1 + a * -1 : sorry -- by simp + ... = a * (1 + -1) : eq.symm (left_distrib a 1 (-1)) + ... = 0 : sorry, -- by simp, + 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 := + sorry + /- + have a ≠ 0, from + (suppose a = 0, + have a * b = 0, by rewrite [this, zero_mul], + absurd this H), + have b ≠ 0, from + (suppose b = 0, + have a * b = 0, by rewrite [this, mul_zero], + absurd this H), + and.intro `a ≠ 0` `b ≠ 0` + -/ +end + +structure comm_ring [class] (A : Type) extends ring A, comm_semigroup A + +attribute [instance] +definition comm_ring.to_comm_semiring [s : comm_ring A] : comm_semiring A := +⦃ comm_semiring, s, + mul_zero := mul_zero, + zero_mul := zero_mul ⦄ + +section + variables [s : comm_ring A] (a b c d e : A) + include s + + local attribute left_distrib right_distrib [simp] + + theorem mul_self_sub_mul_self_eq : a * a - b * b = (a + b) * (a - b) := + sorry -- by simp + + theorem mul_self_sub_one_eq : a * a - 1 = (a + 1) * (a - 1) := + sorry -- by simp + + theorem add_mul_self_eq : (a + b) * (a + b) = a*a + 2*a*b + b*b := + calc (a + b)*(a + b) = a*a + (1+1)*a*b + b*b : sorry -- by simp + ... = a*a + 2*a*b + b*b : sorry -- by rewrite one_add_one_eq_two + + theorem dvd_neg_iff_dvd : (a ∣ -b) ↔ (a ∣ b) := + sorry + /- + iff.intro + (suppose a ∣ -b, + dvd.elim this + (take c, suppose -b = a * c, + dvd.intro + (show a * -c = b, + by rewrite [-neg_mul_eq_mul_neg, -this, neg_neg]))) + (suppose a ∣ b, + dvd.elim this + (take c, suppose b = a * c, + dvd.intro + (show a * -c = -b, + by rewrite [-neg_mul_eq_mul_neg, -this]))) + -/ + + theorem dvd_neg_of_dvd : (a ∣ b) → (a ∣ -b) := + iff.mpr (dvd_neg_iff_dvd a b) + + theorem dvd_of_dvd_neg : (a ∣ -b) → (a ∣ b) := + iff.mp (dvd_neg_iff_dvd a b) + + theorem neg_dvd_iff_dvd : (-a ∣ b) ↔ (a ∣ b) := + sorry + /- + iff.intro + (suppose -a ∣ b, + dvd.elim this + (take c, suppose b = -a * c, + dvd.intro + (show a * -c = b, by rewrite [-neg_mul_comm, this]))) + (suppose a ∣ b, + dvd.elim this + (take c, suppose b = a * c, + dvd.intro + (show -a * -c = b, by rewrite [neg_mul_neg, this]))) + -/ + + theorem neg_dvd_of_dvd : (a ∣ b) → (-a ∣ b) := + iff.mpr (neg_dvd_iff_dvd a b) + + theorem dvd_of_neg_dvd : (-a ∣ b) → (a ∣ b) := + iff.mp (neg_dvd_iff_dvd a b) + + theorem dvd_sub (H₁ : (a ∣ b)) (H₂ : (a ∣ c)) : (a ∣ b - c) := + dvd_add H₁ (dvd_neg_of_dvd a c H₂) +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) + +theorem eq_zero_or_eq_zero_of_mul_eq_zero {A : Type} [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 a b H + +theorem eq_zero_of_mul_self_eq_zero {A : Type} [no_zero_divisors A] {a : A} (H : a * a = 0) : + a = 0 := +or.elim (eq_zero_or_eq_zero_of_mul_eq_zero H) (assume H', H') (assume H', H') + +structure integral_domain [class] (A : Type) extends comm_ring A, no_zero_divisors A, + zero_ne_one_class A + +section + variables [s : integral_domain A] (a b c d e : A) + include s + + theorem mul_ne_zero {a b : A} (H1 : a ≠ 0) (H2 : b ≠ 0) : a * b ≠ 0 := + suppose a * b = 0, + or.elim (eq_zero_or_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 := + sorry + /- + have b * a - c * a = 0, from iff.mp !eq_iff_sub_eq_zero H, + have (b - c) * a = 0, by rewrite [mul_sub_right_distrib, this], + have b - c = 0, from or_resolve_left (eq_zero_or_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 := + sorry + /- + have a * b - a * c = 0, from iff.mp !eq_iff_sub_eq_zero H, + have a * (b - c) = 0, by rewrite [mul_sub_left_distrib, this], + have b - c = 0, from or_resolve_right (eq_zero_or_eq_zero_of_mul_eq_zero this) Ha, + iff.elim_right !eq_iff_sub_eq_zero this + -/ + + -- TODO: do we want the iff versions? + + theorem eq_zero_of_mul_eq_self_right {a b : A} (H₁ : b ≠ 1) (H₂ : a * b = a) : a = 0 := + sorry + /- + have b - 1 ≠ 0, from + suppose b - 1 = 0, + have b = 0 + 1, from eq_add_of_sub_eq this, + have b = 1, by rewrite zero_add at this; exact this, + H₁ this, + have a * b - a = 0, by simp, + have a * (b - 1) = 0, by rewrite [mul_sub_left_distrib, mul_one]; apply this, + show a = 0, from or_resolve_left (eq_zero_or_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 := + sorry -- eq_zero_of_mul_eq_self_right H₁ (begin rewrite mul.comm at H₂, exact H₂ end) + + theorem mul_self_eq_mul_self_iff (a b : A) : a * a = b * b ↔ a = b ∨ a = -b := + sorry + /- + iff.intro + (suppose a * a = b * b, + have (a - b) * (a + b) = 0, + by rewrite [mul.comm, -mul_self_sub_mul_self_eq, this, sub_self], + have a - b = 0 ∨ a + b = 0, from !eq_zero_or_eq_zero_of_mul_eq_zero this, + or.elim this + (suppose a - b = 0, or.inl (eq_of_sub_eq_zero this)) + (suppose a + b = 0, or.inr (eq_neg_of_add_eq_zero this))) + (suppose a = b ∨ a = -b, or.elim this + (suppose a = b, by rewrite this) + (suppose a = -b, by rewrite [this, neg_mul_neg])) + -/ + + theorem mul_self_eq_one_iff (a : A) : a * a = 1 ↔ a = 1 ∨ a = -1 := + sorry + /- + have a * a = 1 * 1 ↔ a = 1 ∨ a = -1, from mul_self_eq_mul_self_iff a 1, + by rewrite mul_one at this; exact this + -/ + -- TODO: c - b * c → c = 0 ∨ b = 1 and variants + + theorem dvd_of_mul_dvd_mul_left {a b c : A} (Ha : a ≠ 0) (Hdvd : (a * b ∣ a * c)) : (b ∣ c) := + sorry + /- + dvd.elim Hdvd + (take d, + suppose a * c = a * b * d, + have b * d = c, from eq_of_mul_eq_mul_left Ha begin rewrite -mul.assoc, symmetry, exact this end, + dvd.intro this) + -/ + + theorem dvd_of_mul_dvd_mul_right {a b c : A} (Ha : a ≠ 0) (Hdvd : (b * a ∣ c * a)) : (b ∣ c) := + sorry + /- + dvd.elim Hdvd + (take d, + suppose c * a = b * a * d, + have b * d * a = c * a, from by rewrite [mul.right_comm, -this], + have b * d = c, from eq_of_mul_eq_mul_right Ha this, + dvd.intro this) + -/ +end + +namespace norm_num + +local attribute bit0 bit1 add1 [reducible] +local attribute right_distrib left_distrib [simp] + +theorem mul_zero [mul_zero_class A] (a : A) : a * zero = zero := +sorry -- by simp + +theorem zero_mul [mul_zero_class A] (a : A) : zero * a = zero := +sorry -- by simp + +theorem mul_one [monoid A] (a : A) : a * one = a := +sorry -- by simp + +theorem mul_bit0 [distrib A] (a b : A) : a * (bit0 b) = bit0 (a * b) := +sorry -- by simp + +theorem mul_bit0_helper [distrib A] (a b t : A) (H : a * b = t) : a * (bit0 b) = bit0 t := +sorry -- by rewrite -H; simp + +theorem mul_bit1 [semiring A] (a b : A) : a * (bit1 b) = bit0 (a * b) + a := +sorry -- by simp + +theorem mul_bit1_helper [semiring A] (a b s t : A) (Hs : a * b = s) (Ht : bit0 s + a = t) : + a * (bit1 b) = t := +sorry -- by simp + +theorem subst_into_prod [has_mul A] (l r tl tr t : A) (prl : l = tl) (prr : r = tr) + (prt : tl * tr = t) : + l * r = t := +sorry -- by simp + +theorem mk_cong (op : A → A) (a b : A) (H : a = b) : op a = op b := +sorry -- by simp + +theorem neg_add_neg_eq_of_add_add_eq_zero [add_comm_group A] (a b c : A) (H : c + a + b = 0) : + -a + -b = c := +sorry +/- +begin + apply add_neg_eq_of_eq_add, + apply neg_eq_of_add_eq_zero, + simp +end +-/ + +theorem neg_add_neg_helper [add_comm_group A] (a b c : A) (H : a + b = c) : -a + -b = -c := +sorry -- begin apply iff.mp !neg_eq_neg_iff_eq, simp end + +theorem neg_add_pos_eq_of_eq_add [add_comm_group A] (a b c : A) (H : b = c + a) : -a + b = c := +sorry -- begin apply neg_add_eq_of_eq_add, simp end + +theorem neg_add_pos_helper1 [add_comm_group A] (a b c : A) (H : b + c = a) : -a + b = -c := +sorry -- begin apply neg_add_eq_of_eq_add, apply eq_add_neg_of_add_eq H end + +theorem neg_add_pos_helper2 [add_comm_group A] (a b c : A) (H : a + c = b) : -a + b = c := +sorry -- begin apply neg_add_eq_of_eq_add, rewrite H end + +theorem pos_add_neg_helper [add_comm_group A] (a b c : A) (H : b + a = c) : a + b = c := +sorry -- by simp + +theorem sub_eq_add_neg_helper [add_comm_group A] (t₁ t₂ e w₁ w₂: A) (H₁ : t₁ = w₁) + (H₂ : t₂ = w₂) (H : w₁ + -w₂ = e) : t₁ - t₂ = e := +sorry -- by simp + +theorem pos_add_pos_helper [add_comm_group A] (a b c h₁ h₂ : A) (H₁ : a = h₁) (H₂ : b = h₂) + (H : h₁ + h₂ = c) : a + b = c := +sorry -- by simp + +theorem subst_into_subtr [add_group A] (l r t : A) (prt : l + -r = t) : l - r = t := +sorry -- by simp + +theorem neg_neg_helper [add_group A] (a b : A) (H : a = -b) : -a = b := +sorry -- by simp + +theorem neg_mul_neg_helper [ring A] (a b c : A) (H : a * b = c) : (-a) * (-b) = c := +sorry -- by simp + +theorem neg_mul_pos_helper [ring A] (a b c : A) (H : a * b = c) : (-a) * b = -c := +sorry -- by simp + +theorem pos_mul_neg_helper [ring A] (a b c : A) (H : a * b = c) : a * (-b) = -c := +sorry -- by simp + +end norm_num + +attribute [simp] + zero_mul mul_zero + +attribute [simp] + neg_mul_eq_neg_mul_symm mul_neg_eq_neg_mul_symm + +attribute [simp] + left_distrib right_distrib diff --git a/old_library/algebra/ring_bigops.lean b/old_library/algebra/ring_bigops.lean new file mode 100644 index 0000000000..0b5d468d8c --- /dev/null +++ b/old_library/algebra/ring_bigops.lean @@ -0,0 +1,183 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Properties of finite sums and products in various structures, including ordered rings and fields. +There are two versions of every theorem: one for finsets, and one for finite sets. +-/ +import .group_bigops .ordered_field + +variables {A B : Type} +variable [deceqA : decidable_eq A] + +/- +-- finset versions +-/ + +namespace finset + +section comm_semiring + variable [csB : comm_semiring B] + include deceqA csB + + proposition mul_Sum (f : A → B) {s : finset A} (b : B) : + b * (∑ x ∈ s, f x) = ∑ x ∈ s, b * f x := + begin + induction s with a s ans ih, + {rewrite [+Sum_empty, mul_zero]}, + rewrite [Sum_insert_of_not_mem f ans, Sum_insert_of_not_mem (λ x, b * f x) ans], + rewrite [-ih, left_distrib] + end + + proposition Sum_mul (f : A → B) {s : finset A} (b : B) : + (∑ x ∈ s, f x) * b = ∑ x ∈ s, f x * b := + by rewrite [mul.comm _ b, mul_Sum]; apply Sum_ext; intros; apply mul.comm + + proposition Prod_eq_zero (f : A → B) {s : finset A} {a : A} (H : a ∈ s) (fa0 : f a = 0) : + (∏ x ∈ s, f x) = 0 := + begin + induction s with b s bns ih, + {exact absurd H !not_mem_empty}, + rewrite [Prod_insert_of_not_mem f bns], + have a = b ∨ a ∈ s, from eq_or_mem_of_mem_insert H, + cases this with aeqb ains, + {rewrite [-aeqb, fa0, zero_mul]}, + rewrite [ih ains, mul_zero] + end +end comm_semiring + +section ordered_comm_group + variable [ocgB : ordered_comm_group B] + include deceqA ocgB + + proposition Sum_le_Sum (f g : A → B) {s : finset A} (H: ∀ x, x ∈ s → f x ≤ g x) : + (∑ x ∈ s, f x) ≤ (∑ x ∈ s, g x) := + begin + induction s with a s ans ih, + {exact le.refl _}, + have H1 : f a ≤ g a, from H _ !mem_insert, + have H2 : (∑ x ∈ s, f x) ≤ (∑ x ∈ s, g x), from ih (forall_of_forall_insert H), + rewrite [Sum_insert_of_not_mem f ans, Sum_insert_of_not_mem g ans], + apply add_le_add H1 H2 + end + + proposition Sum_nonneg (f : A → B) {s : finset A} (H : ∀x, x ∈ s → f x ≥ 0) : + (∑ x ∈ s, f x) ≥ 0 := + calc + 0 = (∑ x ∈ s, 0) : Sum_zero + ... ≤ (∑ x ∈ s, f x) : Sum_le_Sum (λ x, 0) f H + + proposition Sum_nonpos (f : A → B) {s : finset A} (H : ∀x, x ∈ s → f x ≤ 0) : + (∑ x ∈ s, f x) ≤ 0 := + calc + 0 = (∑ x ∈ s, 0) : Sum_zero + ... ≥ (∑ x ∈ s, f x) : Sum_le_Sum f (λ x, 0) H +end ordered_comm_group + +section decidable_linear_ordered_comm_group + variable [dloocgB : decidable_linear_ordered_comm_group B] + include deceqA dloocgB + + proposition abs_Sum_le (f : A → B) (s : finset A) : abs (∑ x ∈ s, f x) ≤ (∑ x ∈ s, abs (f x)) := + begin + induction s with a s ans ih, + {rewrite [+Sum_empty, abs_zero]}, + rewrite [Sum_insert_of_not_mem f ans, Sum_insert_of_not_mem _ ans], + apply le.trans, + apply abs_add_le_abs_add_abs, + apply add_le_add_left ih + end +end decidable_linear_ordered_comm_group + +end finset + +/- +-- set versions +-/ + +namespace set +local attribute classical.prop_decidable [instance] + +section comm_semiring + variable [csB : comm_semiring B] + include csB + + proposition mul_Sum (f : A → B) {s : set A} (b : B) : + b * (∑ x ∈ s, f x) = ∑ x ∈ s, b * f x := + begin + cases (em (finite s)) with fins nfins, + rotate 1, + {rewrite [+Sum_of_not_finite nfins, mul_zero]}, + induction fins with a s fins ans ih, + {rewrite [+Sum_empty, mul_zero]}, + rewrite [Sum_insert_of_not_mem f ans, Sum_insert_of_not_mem (λ x, b * f x) ans], + rewrite [-ih, left_distrib] + end + + proposition Sum_mul (f : A → B) {s : set A} (b : B) : + (∑ x ∈ s, f x) * b = ∑ x ∈ s, f x * b := + by rewrite [mul.comm _ b, mul_Sum]; apply Sum_ext; intros; apply mul.comm + + proposition Prod_eq_zero (f : A → B) {s : set A} [fins : finite s] {a : A} (H : a ∈ s) (fa0 : f a = 0) : + (∏ x ∈ s, f x) = 0 := + begin + induction fins with b s fins bns ih, + {exact absurd H !not_mem_empty}, + rewrite [Prod_insert_of_not_mem f bns], + have a = b ∨ a ∈ s, from eq_or_mem_of_mem_insert H, + cases this with aeqb ains, + {rewrite [-aeqb, fa0, zero_mul]}, + rewrite [ih ains, mul_zero] + end +end comm_semiring + +section ordered_comm_group + variable [ocgB : ordered_comm_group B] + include ocgB + + proposition Sum_le_Sum (f g : A → B) {s : set A} (H: ∀₀ x ∈ s, f x ≤ g x) : + (∑ x ∈ s, f x) ≤ (∑ x ∈ s, g x) := + begin + cases (em (finite s)) with fins nfins, + {induction fins with a s fins ans ih, + {rewrite +Sum_empty}, + {rewrite [Sum_insert_of_not_mem f ans, Sum_insert_of_not_mem g ans], + have H1 : f a ≤ g a, from H !mem_insert, + have H2 : (∑ x ∈ s, f x) ≤ (∑ x ∈ s, g x), from ih (forall_of_forall_insert H), + apply add_le_add H1 H2}}, + rewrite [+Sum_of_not_finite nfins] + end + + proposition Sum_nonneg (f : A → B) {s : set A} (H : ∀₀ x ∈ s, f x ≥ 0) : + (∑ x ∈ s, f x) ≥ 0 := + calc + 0 = (∑ x ∈ s, 0) : Sum_zero + ... ≤ (∑ x ∈ s, f x) : Sum_le_Sum (λ x, 0) f H + + proposition Sum_nonpos (f : A → B) {s : set A} (H : ∀₀ x ∈ s, f x ≤ 0) : + (∑ x ∈ s, f x) ≤ 0 := + calc + 0 = (∑ x ∈ s, 0) : Sum_zero + ... ≥ (∑ x ∈ s, f x) : Sum_le_Sum f (λ x, 0) H +end ordered_comm_group + +section decidable_linear_ordered_comm_group + variable [dloocgB : decidable_linear_ordered_comm_group B] + include deceqA dloocgB + + proposition abs_Sum_le (f : A → B) (s : set A) : abs (∑ x ∈ s, f x) ≤ (∑ x ∈ s, abs (f x)) := + begin + cases (em (finite s)) with fins nfins, + rotate 1, + {rewrite [+Sum_of_not_finite nfins, abs_zero]}, + induction fins with a s fins ans ih, + {rewrite [+Sum_empty, abs_zero]}, + rewrite [Sum_insert_of_not_mem f ans, Sum_insert_of_not_mem _ ans], + apply le.trans, + apply abs_add_le_abs_add_abs, + apply add_le_add_left ih + end +end decidable_linear_ordered_comm_group + +end set diff --git a/old_library/algebra/ring_power.lean b/old_library/algebra/ring_power.lean new file mode 100644 index 0000000000..96140dfa14 --- /dev/null +++ b/old_library/algebra/ring_power.lean @@ -0,0 +1,203 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Properties of the power operation in various structures, including ordered rings and fields. +-/ +import .group_power .ordered_field +open nat + +variable {A : Type} + +section semiring +variable [s : semiring A] +include s + +attribute [instance] +definition semiring_has_pow_nat : has_pow_nat A := +monoid_has_pow_nat + +theorem zero_pow {m : ℕ} (mpos : m > 0) : 0^m = (0 : A) := +have h₁ : ∀ m : nat, (0 : A)^(succ m) = (0 : A), + begin + intro m, induction m, + krewrite pow_one, + apply zero_mul + end, +obtain m' (h₂ : m = succ m'), from exists_eq_succ_of_pos mpos, +show 0^m = 0, by rewrite h₂; apply h₁ + +end semiring + +section integral_domain +variable [s : integral_domain A] +include s + +attribute [instance] +definition integral_domain_has_pow_nat : has_pow_nat A := +monoid_has_pow_nat + +theorem eq_zero_of_pow_eq_zero {a : A} {m : ℕ} (H : a^m = 0) : a = 0 := +or.elim (eq_zero_or_pos m) + (suppose m = 0, + by rewrite [`m = 0` at H, pow_zero at H]; apply absurd H (ne.symm zero_ne_one)) + (suppose m > 0, + have h₁ : ∀ m, a^succ m = 0 → a = 0, + begin + intro m, + induction m with m ih, + {krewrite pow_one; intros; assumption}, + rewrite pow_succ, + intro H, + cases eq_zero_or_eq_zero_of_mul_eq_zero H with h₃ h₄, + assumption, + exact ih h₄ + end, + obtain m' (h₂ : m = succ m'), from exists_eq_succ_of_pos `m > 0`, + show a = 0, by rewrite h₂ at H; apply h₁ m' H) + +theorem pow_ne_zero_of_ne_zero {a : A} {m : ℕ} (H : a ≠ 0) : a^m ≠ 0 := +assume H', H (eq_zero_of_pow_eq_zero H') + +end integral_domain + +section division_ring +variable [s : division_ring A] +include s + +theorem division_ring.pow_ne_zero_of_ne_zero {a : A} {m : ℕ} (H : a ≠ 0) : a^m ≠ 0 := +or.elim (eq_zero_or_pos m) + (suppose m = 0, + by rewrite [`m = 0`, pow_zero]; exact (ne.symm zero_ne_one)) + (suppose m > 0, + have h₁ : ∀ m, a^succ m ≠ 0, + begin + intro m, + induction m with m ih, + { krewrite pow_one; assumption }, + rewrite pow_succ, + apply division_ring.mul_ne_zero H ih + end, + obtain m' (h₂ : m = succ m'), from exists_eq_succ_of_pos `m > 0`, + show a^m ≠ 0, by rewrite h₂; apply h₁ m') + +end division_ring + +section linear_ordered_semiring +variable [s : linear_ordered_semiring A] +include s + +theorem pow_pos_of_pos {x : A} (i : ℕ) (H : x > 0) : x^i > 0 := +begin + induction i with [j, ih], + {show (1 : A) > 0, from zero_lt_one}, + {show x^(succ j) > 0, from mul_pos H ih} +end + +theorem pow_nonneg_of_nonneg {x : A} (i : ℕ) (H : x ≥ 0) : x^i ≥ 0 := +begin + induction i with j ih, + {show (1 : A) ≥ 0, from le_of_lt zero_lt_one}, + {show x^(succ j) ≥ 0, from mul_nonneg H ih} +end + +theorem pow_le_pow_of_le {x y : A} (i : ℕ) (H₁ : 0 ≤ x) (H₂ : x ≤ y) : x^i ≤ y^i := +begin + induction i with i ih, + {rewrite *pow_zero, apply le.refl}, + rewrite *pow_succ, + have H : 0 ≤ x^i, from pow_nonneg_of_nonneg i H₁, + apply mul_le_mul H₂ ih H (le.trans H₁ H₂) +end + +theorem pow_ge_one {x : A} (i : ℕ) (xge1 : x ≥ 1) : x^i ≥ 1 := +have H : x^i ≥ 1^i, from pow_le_pow_of_le i (le_of_lt zero_lt_one) xge1, +by rewrite one_pow at H; exact H + +theorem pow_gt_one {x : A} {i : ℕ} (xgt1 : x > 1) (ipos : i > 0) : x^i > 1 := +have xpos : x > 0, from lt.trans zero_lt_one xgt1, +begin + induction i with [i, ih], + {exfalso, exact !lt.irrefl ipos}, + have xige1 : x^i ≥ 1, from pow_ge_one _ (le_of_lt xgt1), + rewrite [pow_succ, -mul_one 1], + apply mul_lt_mul xgt1 xige1 zero_lt_one, + apply le_of_lt xpos +end + +theorem squared_lt_squared {x y : A} (H1 : 0 ≤ x) (H2 : x < y) : x^2 < y^2 := +by rewrite [*pow_two]; apply mul_self_lt_mul_self H1 H2 + +theorem squared_le_squared {x y : A} (H1 : 0 ≤ x) (H2 : x ≤ y) : x^2 ≤ y^2 := +or.elim (lt_or_eq_of_le H2) + (assume xlty, le_of_lt (squared_lt_squared H1 xlty)) + (assume xeqy, by rewrite xeqy; apply le.refl) + +theorem lt_of_squared_lt_squared {x y : A} (H1 : y ≥ 0) (H2 : x^2 < y^2) : x < y := +lt_of_not_ge (assume H : x ≥ y, not_le_of_gt H2 (squared_le_squared H1 H)) + +theorem le_of_squared_le_squared {x y : A} (H1 : y ≥ 0) (H2 : x^2 ≤ y^2) : x ≤ y := +le_of_not_gt (assume H : x > y, not_lt_of_ge H2 (squared_lt_squared H1 H)) + +theorem eq_of_squared_eq_squared_of_nonneg {x y : A} (H1 : x ≥ 0) (H2 : y ≥ 0) (H3 : x^2 = y^2) : + x = y := +lt.by_cases + (suppose x < y, absurd (eq.subst H3 (squared_lt_squared H1 this)) !lt.irrefl) + (suppose x = y, this) + (suppose x > y, absurd (eq.subst H3 (squared_lt_squared H2 this)) !lt.irrefl) + +end linear_ordered_semiring + +section decidable_linear_ordered_comm_ring +variable [s : decidable_linear_ordered_comm_ring A] +include s + +attribute [instance] +definition decidable_linear_ordered_comm_ring_has_pow_nat : has_pow_nat A := +monoid_has_pow_nat + +theorem abs_pow (a : A) (n : ℕ) : abs (a^n) = abs a^n := +begin + induction n with n ih, + krewrite [*pow_zero, (abs_of_nonneg zero_le_one : abs (1 : A) = 1)], + rewrite [*pow_succ, abs_mul, ih] +end + +theorem squared_nonneg (x : A) : x^2 ≥ 0 := by rewrite [pow_two]; apply mul_self_nonneg + +theorem eq_zero_of_squared_eq_zero {x : A} (H : x^2 = 0) : x = 0 := +by rewrite [pow_two at H]; exact eq_zero_of_mul_self_eq_zero H + +theorem abs_eq_abs_of_squared_eq_squared {x y : A} (H : x^2 = y^2) : abs x = abs y := +have (abs x)^2 = (abs y)^2, by rewrite [-+abs_pow, H], +eq_of_squared_eq_squared_of_nonneg (abs_nonneg x) (abs_nonneg y) this + +end decidable_linear_ordered_comm_ring + +section field +variable [s : field A] +include s + +theorem field.div_pow (a : A) {b : A} {n : ℕ} (bnz : b ≠ 0) : (a / b)^n = a^n / b^n := +begin + induction n with n ih, + krewrite [*pow_zero, div_one], + have bnnz : b^n ≠ 0, from division_ring.pow_ne_zero_of_ne_zero bnz, + rewrite [*pow_succ, ih, !field.div_mul_div bnz bnnz] +end + +end field + +section discrete_field +variable [s : discrete_field A] +include s + +theorem div_pow (a : A) {b : A} {n : ℕ} : (a / b)^n = a^n / b^n := +begin + induction n with n ih, + krewrite [*pow_zero, div_one], + rewrite [*pow_succ, ih, div_mul_div] +end + +end discrete_field diff --git a/old_library/data/bag.lean b/old_library/data/bag.lean new file mode 100644 index 0000000000..69397bb1ea --- /dev/null +++ b/old_library/data/bag.lean @@ -0,0 +1,695 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Finite bags. +-/ +import data.nat data.list.perm algebra.binary +open nat quot list subtype binary function eq.ops +open [decl] perm + +variable {A : Type} + +attribute [instance] +definition bag.setoid (A : Type) : setoid (list A) := +setoid.mk (@perm A) (mk_equivalence (@perm A) (@perm.refl A) (@perm.symm A) (@perm.trans A)) + +definition bag (A : Type) : Type := +quot (bag.setoid A) + +namespace bag +definition of_list (l : list A) : bag A := +⟦l⟧ + +definition empty : bag A := +of_list nil + +definition singleton (a : A) : bag A := +of_list [a] + +definition insert (a : A) (b : bag A) : bag A := +quot.lift_on b (λ l, ⟦a::l⟧) + (λ l₁ l₂ h, quot.sound (perm.skip a h)) + +lemma insert_empty_eq_singleton (a : A) : insert a empty = singleton a := +rfl + +definition insert.comm (a₁ a₂ : A) (b : bag A) : insert a₁ (insert a₂ b) = insert a₂ (insert a₁ b) := +quot.induction_on b (λ l, quot.sound !perm.swap) + +definition append (b₁ b₂ : bag A) : bag A := +quot.lift_on₂ b₁ b₂ (λ l₁ l₂, ⟦l₁++l₂⟧) + (λ l₁ l₂ l₃ l₄ h₁ h₂, quot.sound (perm_app h₁ h₂)) + +infix ++ := append + +lemma append.comm (b₁ b₂ : bag A) : b₁ ++ b₂ = b₂ ++ b₁ := +quot.induction_on₂ b₁ b₂ (λ l₁ l₂, quot.sound !perm_app_comm) + +lemma append.assoc (b₁ b₂ b₃ : bag A) : (b₁ ++ b₂) ++ b₃ = b₁ ++ (b₂ ++ b₃) := +quot.induction_on₃ b₁ b₂ b₃ (λ l₁ l₂ l₃, quot.sound (by rewrite list.append.assoc; apply perm.refl)) + +lemma append_empty_left (b : bag A) : empty ++ b = b := +quot.induction_on b (λ l, quot.sound (by rewrite append_nil_left; apply perm.refl)) + +lemma append_empty_right (b : bag A) : b ++ empty = b := +quot.induction_on b (λ l, quot.sound (by rewrite append_nil_right; apply perm.refl)) + +lemma append_insert_left (a : A) (b₁ b₂ : bag A) : insert a b₁ ++ b₂ = insert a (b₁ ++ b₂) := +quot.induction_on₂ b₁ b₂ (λ l₁ l₂, quot.sound (by rewrite append_cons; apply perm.refl)) + +lemma append_insert_right (a : A) (b₁ b₂ : bag A) : b₁ ++ insert a b₂ = insert a (b₁ ++ b₂) := +calc b₁ ++ insert a b₂ = insert a b₂ ++ b₁ : append.comm + ... = insert a (b₂ ++ b₁) : append_insert_left + ... = insert a (b₁ ++ b₂) : append.comm + +attribute [recursor 3] +protected lemma induction_on {C : bag A → Prop} (b : bag A) (h₁ : C empty) (h₂ : ∀ a b, C b → C (insert a b)) : C b := +quot.induction_on b (λ l, list.induction_on l h₁ (λ h t ih, h₂ h ⟦t⟧ ih)) + +section decidable_eq +variable [decA : decidable_eq A] +include decA +open decidable + +attribute [instance] +definition has_decidable_eq (b₁ b₂ : bag A) : decidable (b₁ = b₂) := +quot.rec_on_subsingleton₂ b₁ b₂ (λ l₁ l₂, + match decidable_perm l₁ l₂ with + | inl h := inl (quot.sound h) + | inr h := inr (λ n, absurd (quot.exact n) h) + end) +end decidable_eq + +section count +variable [decA : decidable_eq A] +include decA + +definition count (a : A) (b : bag A) : nat := +quot.lift_on b (λ l, count a l) + (λ l₁ l₂ h, count_eq_of_perm h a) + +lemma count_empty (a : A) : count a empty = 0 := +rfl + +lemma count_insert (a : A) (b : bag A) : count a (insert a b) = succ (count a b) := +quot.induction_on b (λ l, begin unfold [insert, count], rewrite count_cons_eq end) + +lemma count_insert_of_ne {a₁ a₂ : A} (h : a₁ ≠ a₂) (b : bag A) : count a₁ (insert a₂ b) = count a₁ b := +quot.induction_on b (λ l, begin unfold [insert, count], rewrite (count_cons_of_ne h) end) + +lemma count_singleton (a : A) : count a (singleton a) = 1 := +begin rewrite [-insert_empty_eq_singleton, count_insert] end + +lemma count_append (a : A) (b₁ b₂ : bag A) : count a (append b₁ b₂) = count a b₁ + count a b₂ := +quot.induction_on₂ b₁ b₂ (λ l₁ l₂, begin unfold [append, count], rewrite list.count_append end) + +open perm decidable +protected lemma ext {b₁ b₂ : bag A} : (∀ a, count a b₁ = count a b₂) → b₁ = b₂ := +quot.induction_on₂ b₁ b₂ (λ l₁ l₂ (h : ∀ a, count a ⟦l₁⟧ = count a ⟦l₂⟧), + have gen : ∀ (l₁ l₂ : list A), (∀ a, list.count a l₁ = list.count a l₂) → l₁ ~ l₂ + | [] [] h₁ := !perm.refl + | [] (a₂::s₂) h₁ := have list.count a₂ [] = list.count a₂ (a₂::s₂), from h₁ a₂, by rewrite [count_nil at this, count_cons_eq at this]; contradiction + | (a::s₁) s₂ h₁ := + have g₁ : list.count a (a::s₁) > 0, from count_gt_zero_of_mem !mem_cons, + have list.count a (a::s₁) = list.count a s₂, from h₁ a, + have list.count a s₂ > 0, by rewrite [-this]; exact g₁, + have a ∈ s₂, from mem_of_count_gt_zero this, + have ∃ l r, s₂ = l++(a::r), from mem_split this, + obtain l r (e₁ : s₂ = l++(a::r)), from this, + have ∀ a, list.count a s₁ = list.count a (l++r), from + take a₁, + have e₂ : list.count a₁ (a::s₁) = list.count a₁ (l++(a::r)), by rewrite -e₁; exact h₁ a₁, + by_cases + (suppose a₁ = a, begin + rewrite [-this at e₂, list.count_append at e₂, *count_cons_eq at e₂, add_succ at e₂], + injection e₂ with e₃, rewrite e₃, + rewrite list.count_append + end) + (suppose a₁ ≠ a, + by rewrite [list.count_append at e₂, *count_cons_of_ne this at e₂, e₂, list.count_append]), + have ih : s₁ ~ l++r, from gen s₁ (l++r) this, + calc a::s₁ ~ a::(l++r) : perm.skip a ih + ... ~ l++(a::r) : perm_middle + ... = s₂ : e₁, + quot.sound (gen l₁ l₂ h)) + +definition insert.inj {a : A} {b₁ b₂ : bag A} : insert a b₁ = insert a b₂ → b₁ = b₂ := +assume h, bag.ext (take x, + have e : count x (insert a b₁) = count x (insert a b₂), by rewrite h, + by_cases + (suppose x = a, begin subst x, rewrite [*count_insert at e], injection e, assumption end) + (suppose x ≠ a, begin rewrite [*count_insert_of_ne this at e], assumption end)) +end count + +section extract +open decidable +variable [decA : decidable_eq A] +include decA + +definition extract (a : A) (b : bag A) : bag A := +quot.lift_on b (λ l, ⟦filter (λ c, c ≠ a) l⟧) + (λ l₁ l₂ h, quot.sound (perm_filter h)) + +lemma extract_singleton (a : A) : extract a (singleton a) = empty := +begin unfold [extract, singleton, of_list, filter], rewrite [if_neg (λ h : a ≠ a, absurd rfl h)] end + +lemma extract_insert (a : A) (b : bag A) : extract a (insert a b) = extract a b := +quot.induction_on b (λ l, begin + unfold [insert, extract], + rewrite [@filter_cons_of_neg _ (λ c, c ≠ a) _ _ l (not_not_intro (eq.refl a))] +end) + +lemma extract_insert_of_ne {a₁ a₂ : A} (h : a₁ ≠ a₂) (b : bag A) : extract a₁ (insert a₂ b) = insert a₂ (extract a₁ b) := +quot.induction_on b (λ l, begin + unfold [insert, extract], + rewrite [@filter_cons_of_pos _ (λ c, c ≠ a₁) _ _ l (ne.symm h)] +end) + +lemma count_extract (a : A) (b : bag A) : count a (extract a b) = 0 := +bag.induction_on b rfl + (λ c b ih, by_cases + (suppose a = c, begin subst c, rewrite [extract_insert, ih] end) + (suppose a ≠ c, begin rewrite [extract_insert_of_ne this, count_insert_of_ne this, ih] end)) + +lemma count_extract_of_ne {a₁ a₂ : A} (h : a₁ ≠ a₂) (b : bag A) : count a₁ (extract a₂ b) = count a₁ b := +bag.induction_on b rfl + (take x b ih, by_cases + (suppose x = a₁, begin subst x, rewrite [extract_insert_of_ne (ne.symm h), *count_insert, ih] end) + (suppose x ≠ a₁, by_cases + (suppose x = a₂, begin subst x, rewrite [extract_insert, ih, count_insert_of_ne h] end) + (suppose x ≠ a₂, begin + rewrite [count_insert_of_ne (ne.symm `x ≠ a₁`), extract_insert_of_ne (ne.symm this)], + rewrite [count_insert_of_ne (ne.symm `x ≠ a₁`), ih] + end))) +end extract + +section erase +variable [decA : decidable_eq A] +include decA + +definition erase (a : A) (b : bag A) : bag A := +quot.lift_on b (λ l, ⟦erase a l⟧) + (λ l₁ l₂ h, quot.sound (erase_perm_erase_of_perm _ h)) + +lemma erase_empty (a : A) : erase a empty = empty := +rfl + +lemma erase_insert (a : A) (b : bag A) : erase a (insert a b) = b := +quot.induction_on b (λ l, quot.sound (by rewrite erase_cons_head; apply perm.refl)) + +lemma erase_insert_of_ne {a₁ a₂ : A} (h : a₁ ≠ a₂) (b : bag A) : erase a₁ (insert a₂ b) = insert a₂ (erase a₁ b) := +quot.induction_on b (λ l, quot.sound (by rewrite (erase_cons_tail _ h); apply perm.refl)) + +end erase + +section member +variable [decA : decidable_eq A] +include decA + +definition mem (a : A) (b : bag A) := count a b > 0 +infix ∈ := mem + +lemma mem_def (a : A) (b : bag A) : (a ∈ b) = (count a b > 0) := +rfl + +lemma mem_insert (a : A) (b : bag A) : a ∈ insert a b := +begin unfold mem, rewrite count_insert, exact dec_trivial end + +lemma mem_of_list_iff_mem (a : A) (l : list A) : a ∈ of_list l ↔ a ∈ l := +iff.intro !mem_of_count_gt_zero !count_gt_zero_of_mem + +lemma count_of_list_eq_count (a : A) (l : list A) : count a (of_list l) = list.count a l := +rfl +end member + +section union_inter +variable [decA : decidable_eq A] +include decA +open perm decidable + +private definition union_list (l₁ l₂ : list A) := +erase_dup (l₁ ++ l₂) + +private lemma perm_union_list {l₁ l₂ l₃ l₄ : list A} (h₁ : l₁ ~ l₃) (h₂ : l₂ ~ l₄) : union_list l₁ l₂ ~ union_list l₃ l₄ := +perm_erase_dup_of_perm (perm_app h₁ h₂) + +private lemma nodup_union_list (l₁ l₂ : list A) : nodup (union_list l₁ l₂) := +!nodup_erase_dup + +private definition not_mem_of_not_mem_union_list_left {a : A} {l₁ l₂ : list A} (h : a ∉ union_list l₁ l₂) : a ∉ l₁ := +suppose a ∈ l₁, +have a ∈ l₁ ++ l₂, from mem_append_left _ this, +have a ∈ erase_dup (l₁ ++ l₂), from mem_erase_dup this, +absurd this h + +private definition not_mem_of_not_mem_union_list_right {a : A} {l₁ l₂ : list A} (h : a ∉ union_list l₁ l₂) : a ∉ l₂ := +suppose a ∈ l₂, +have a ∈ l₁ ++ l₂, from mem_append_right _ this, +have a ∈ erase_dup (l₁ ++ l₂), from mem_erase_dup this, +absurd this h + +private definition gen : nat → A → list A +| 0 a := nil +| (n+1) a := a :: gen n a + +private lemma not_mem_gen_of_ne {a b : A} (h : a ≠ b) : ∀ n, a ∉ gen n b +| 0 := !not_mem_nil +| (n+1) := not_mem_cons_of_ne_of_not_mem h (not_mem_gen_of_ne n) + +private lemma count_gen : ∀ (a : A) (n : nat), list.count a (gen n a) = n +| a 0 := rfl +| a (n+1) := begin unfold gen, rewrite [count_cons_eq, count_gen] end + +private lemma count_gen_eq_zero_of_ne {a b : A} (h : a ≠ b) : ∀ n, list.count a (gen n b) = 0 +| 0 := rfl +| (n+1) := begin unfold gen, rewrite [count_cons_of_ne h, count_gen_eq_zero_of_ne] end + +private definition max_count (l₁ l₂ : list A) : list A → list A +| [] := [] +| (a::l) := if list.count a l₁ ≥ list.count a l₂ then gen (list.count a l₁) a ++ max_count l else gen (list.count a l₂) a ++ max_count l + +private definition min_count (l₁ l₂ : list A) : list A → list A +| [] := [] +| (a::l) := if list.count a l₁ ≤ list.count a l₂ then gen (list.count a l₁) a ++ min_count l else gen (list.count a l₂) a ++ min_count l + +private lemma not_mem_max_count_of_not_mem (l₁ l₂ : list A) : ∀ {a l}, a ∉ l → a ∉ max_count l₁ l₂ l +| a [] h := !not_mem_nil +| a (b::l) h := + have ih : a ∉ max_count l₁ l₂ l, from not_mem_max_count_of_not_mem (not_mem_of_not_mem_cons h), + have a ≠ b, from ne_of_not_mem_cons h, + by_cases + (suppose list.count b l₁ ≥ list.count b l₂, begin + unfold max_count, rewrite [if_pos this], + exact not_mem_append (not_mem_gen_of_ne `a ≠ b` _) ih + end) + (suppose ¬ list.count b l₁ ≥ list.count b l₂, begin + unfold max_count, rewrite [if_neg this], + exact not_mem_append (not_mem_gen_of_ne `a ≠ b` _) ih + end) + +private lemma max_count_eq (l₁ l₂ : list A) : ∀ {a : A} {l : list A}, a ∈ l → nodup l → list.count a (max_count l₁ l₂ l) = max (list.count a l₁) (list.count a l₂) +| a [] h₁ h₂ := absurd h₁ !not_mem_nil +| a (b::l) h₁ h₂ := + have nodup l, from nodup_of_nodup_cons h₂, + have b ∉ l, from not_mem_of_nodup_cons h₂, + or.elim (eq_or_mem_of_mem_cons h₁) + (suppose a = b, + have a ∉ l, by rewrite this; assumption, + have a ∉ max_count l₁ l₂ l, from not_mem_max_count_of_not_mem l₁ l₂ this, + by_cases + (suppose i : list.count a l₁ ≥ list.count a l₂, begin + unfold max_count, subst b, + rewrite [if_pos i, list.count_append, count_gen, max_eq_left i, count_eq_zero_of_not_mem `a ∉ max_count l₁ l₂ l`] + end) + (suppose i : ¬ list.count a l₁ ≥ list.count a l₂, begin + unfold max_count, subst b, + rewrite [if_neg i, list.count_append, count_gen, max_eq_right_of_lt (lt_of_not_ge i), count_eq_zero_of_not_mem `a ∉ max_count l₁ l₂ l`] + end)) + (suppose a ∈ l, + have a ≠ b, from suppose a = b, begin subst b, contradiction end, + have ih : list.count a (max_count l₁ l₂ l) = max (list.count a l₁) (list.count a l₂), from + max_count_eq `a ∈ l` `nodup l`, + by_cases + (suppose i : list.count b l₁ ≥ list.count b l₂, begin + unfold max_count, + rewrite [if_pos i, -ih, list.count_append, count_gen_eq_zero_of_ne `a ≠ b`, zero_add] + end) + (suppose i : ¬ list.count b l₁ ≥ list.count b l₂, begin + unfold max_count, + rewrite [if_neg i, -ih, list.count_append, count_gen_eq_zero_of_ne `a ≠ b`, zero_add] + end)) + +private lemma not_mem_min_count_of_not_mem (l₁ l₂ : list A) : ∀ {a l}, a ∉ l → a ∉ min_count l₁ l₂ l +| a [] h := !not_mem_nil +| a (b::l) h := + have ih : a ∉ min_count l₁ l₂ l, from not_mem_min_count_of_not_mem (not_mem_of_not_mem_cons h), + have a ≠ b, from ne_of_not_mem_cons h, + by_cases + (suppose list.count b l₁ ≤ list.count b l₂, begin + unfold min_count, rewrite [if_pos this], + exact not_mem_append (not_mem_gen_of_ne `a ≠ b` _) ih + end) + (suppose ¬ list.count b l₁ ≤ list.count b l₂, begin + unfold min_count, rewrite [if_neg this], + exact not_mem_append (not_mem_gen_of_ne `a ≠ b` _) ih + end) + +private lemma min_count_eq (l₁ l₂ : list A) : ∀ {a : A} {l : list A}, a ∈ l → nodup l → list.count a (min_count l₁ l₂ l) = min (list.count a l₁) (list.count a l₂) +| a [] h₁ h₂ := absurd h₁ !not_mem_nil +| a (b::l) h₁ h₂ := + have nodup l, from nodup_of_nodup_cons h₂, + have b ∉ l, from not_mem_of_nodup_cons h₂, + or.elim (eq_or_mem_of_mem_cons h₁) + (suppose a = b, + have a ∉ l, by rewrite this; assumption, + have a ∉ min_count l₁ l₂ l, from not_mem_min_count_of_not_mem l₁ l₂ this, + by_cases + (suppose i : list.count a l₁ ≤ list.count a l₂, begin + unfold min_count, subst b, + rewrite [if_pos i, list.count_append, count_gen, min_eq_left i, count_eq_zero_of_not_mem `a ∉ min_count l₁ l₂ l`] + end) + (suppose i : ¬ list.count a l₁ ≤ list.count a l₂, begin + unfold min_count, subst b, + rewrite [if_neg i, list.count_append, count_gen, min_eq_right (le_of_lt (lt_of_not_ge i)), count_eq_zero_of_not_mem `a ∉ min_count l₁ l₂ l`] + end)) + (suppose a ∈ l, + have a ≠ b, from suppose a = b, by subst b; contradiction, + have ih : list.count a (min_count l₁ l₂ l) = min (list.count a l₁) (list.count a l₂), from min_count_eq `a ∈ l` `nodup l`, + by_cases + (suppose i : list.count b l₁ ≤ list.count b l₂, begin + unfold min_count, + rewrite [if_pos i, -ih, list.count_append, count_gen_eq_zero_of_ne `a ≠ b`, zero_add] + end) + (suppose i : ¬ list.count b l₁ ≤ list.count b l₂, begin + unfold min_count, + rewrite [if_neg i, -ih, list.count_append, count_gen_eq_zero_of_ne `a ≠ b`, zero_add] + end)) + +private lemma perm_max_count_left {l₁ l₂ l₃ l₄ : list A} (h₁ : l₁ ~ l₃) (h₂ : l₂ ~ l₄) : ∀ l, max_count l₁ l₂ l ~ max_count l₃ l₄ l +| [] := by esimp +| (a::l) := + have e₁ : list.count a l₁ = list.count a l₃, from count_eq_of_perm h₁ a, + have e₂ : list.count a l₂ = list.count a l₄, from count_eq_of_perm h₂ a, + by_cases + (suppose list.count a l₁ ≥ list.count a l₂, + begin unfold max_count, rewrite [-e₁, -e₂, *if_pos this], exact perm_app !perm.refl !perm_max_count_left end) + (suppose ¬ list.count a l₁ ≥ list.count a l₂, + begin unfold max_count, rewrite [-e₁, -e₂, *if_neg this], exact perm_app !perm.refl !perm_max_count_left end) + +private lemma perm_app_left_comm (l₁ l₂ l₃ : list A) : l₁ ++ (l₂ ++ l₃) ~ l₂ ++ (l₁ ++ l₃) := +calc l₁ ++ (l₂ ++ l₃) = (l₁ ++ l₂) ++ l₃ : list.append.assoc + ... ~ (l₂ ++ l₁) ++ l₃ : perm_app !perm_app_comm !perm.refl + ... = l₂ ++ (l₁ ++ l₃) : list.append.assoc + +private lemma perm_max_count_right {l r : list A} (h : l ~ r) : ∀ l₁ l₂, max_count l₁ l₂ l ~ max_count l₁ l₂ r := +perm.induction_on h + (λ l₁ l₂, !perm.refl) + (λ x s₁ s₂ p ih l₁ l₂, by_cases + (suppose i : list.count x l₁ ≥ list.count x l₂, + begin unfold max_count, rewrite [*if_pos i], exact perm_app !perm.refl !ih end) + (suppose i : ¬ list.count x l₁ ≥ list.count x l₂, + begin unfold max_count, rewrite [*if_neg i], exact perm_app !perm.refl !ih end)) + (λ x y l l₁ l₂, by_cases + (suppose i₁ : list.count x l₁ ≥ list.count x l₂, by_cases + (suppose i₂ : list.count y l₁ ≥ list.count y l₂, + begin unfold max_count, unfold max_count, rewrite [*if_pos i₁, *if_pos i₂], apply perm_app_left_comm end) + (suppose i₂ : ¬ list.count y l₁ ≥ list.count y l₂, + begin unfold max_count, unfold max_count, rewrite [*if_pos i₁, *if_neg i₂], apply perm_app_left_comm end)) + (suppose i₁ : ¬ list.count x l₁ ≥ list.count x l₂, by_cases + (suppose i₂ : list.count y l₁ ≥ list.count y l₂, + begin unfold max_count, unfold max_count, rewrite [*if_neg i₁, *if_pos i₂], apply perm_app_left_comm end) + (suppose i₂ : ¬ list.count y l₁ ≥ list.count y l₂, + begin unfold max_count, unfold max_count, rewrite [*if_neg i₁, *if_neg i₂], apply perm_app_left_comm end))) + (λ s₁ s₂ s₃ p₁ p₂ ih₁ ih₂ l₁ l₂, perm.trans (ih₁ l₁ l₂) (ih₂ l₁ l₂)) + +private lemma perm_max_count {l₁ l₂ l₃ r₁ r₂ r₃ : list A} (p₁ : l₁ ~ r₁) (p₂ : l₂ ~ r₂) (p₃ : l₃ ~ r₃) : max_count l₁ l₂ l₃ ~ max_count r₁ r₂ r₃ := +calc max_count l₁ l₂ l₃ ~ max_count r₁ r₂ l₃ : perm_max_count_left p₁ p₂ + ... ~ max_count r₁ r₂ r₃ : perm_max_count_right p₃ + +private lemma perm_min_count_left {l₁ l₂ l₃ l₄ : list A} (h₁ : l₁ ~ l₃) (h₂ : l₂ ~ l₄) : ∀ l, min_count l₁ l₂ l ~ min_count l₃ l₄ l +| [] := by esimp +| (a::l) := + have e₁ : list.count a l₁ = list.count a l₃, from count_eq_of_perm h₁ a, + have e₂ : list.count a l₂ = list.count a l₄, from count_eq_of_perm h₂ a, + by_cases + (suppose list.count a l₁ ≤ list.count a l₂, + begin unfold min_count, rewrite [-e₁, -e₂, *if_pos this], exact perm_app !perm.refl !perm_min_count_left end) + (suppose ¬ list.count a l₁ ≤ list.count a l₂, + begin unfold min_count, rewrite [-e₁, -e₂, *if_neg this], exact perm_app !perm.refl !perm_min_count_left end) + +private lemma perm_min_count_right {l r : list A} (h : l ~ r) : ∀ l₁ l₂, min_count l₁ l₂ l ~ min_count l₁ l₂ r := +perm.induction_on h + (λ l₁ l₂, !perm.refl) + (λ x s₁ s₂ p ih l₁ l₂, by_cases + (suppose i : list.count x l₁ ≤ list.count x l₂, + begin unfold min_count, rewrite [*if_pos i], exact perm_app !perm.refl !ih end) + (suppose i : ¬ list.count x l₁ ≤ list.count x l₂, + begin unfold min_count, rewrite [*if_neg i], exact perm_app !perm.refl !ih end)) + (λ x y l l₁ l₂, by_cases + (suppose i₁ : list.count x l₁ ≤ list.count x l₂, by_cases + (suppose i₂ : list.count y l₁ ≤ list.count y l₂, + begin unfold min_count, unfold min_count, rewrite [*if_pos i₁, *if_pos i₂], apply perm_app_left_comm end) + (suppose i₂ : ¬ list.count y l₁ ≤ list.count y l₂, + begin unfold min_count, unfold min_count, rewrite [*if_pos i₁, *if_neg i₂], apply perm_app_left_comm end)) + (suppose i₁ : ¬ list.count x l₁ ≤ list.count x l₂, by_cases + (suppose i₂ : list.count y l₁ ≤ list.count y l₂, + begin unfold min_count, unfold min_count, rewrite [*if_neg i₁, *if_pos i₂], apply perm_app_left_comm end) + (suppose i₂ : ¬ list.count y l₁ ≤ list.count y l₂, + begin unfold min_count, unfold min_count, rewrite [*if_neg i₁, *if_neg i₂], apply perm_app_left_comm end))) + (λ s₁ s₂ s₃ p₁ p₂ ih₁ ih₂ l₁ l₂, perm.trans (ih₁ l₁ l₂) (ih₂ l₁ l₂)) + +private lemma perm_min_count {l₁ l₂ l₃ r₁ r₂ r₃ : list A} (p₁ : l₁ ~ r₁) (p₂ : l₂ ~ r₂) (p₃ : l₃ ~ r₃) : min_count l₁ l₂ l₃ ~ min_count r₁ r₂ r₃ := +calc min_count l₁ l₂ l₃ ~ min_count r₁ r₂ l₃ : perm_min_count_left p₁ p₂ + ... ~ min_count r₁ r₂ r₃ : perm_min_count_right p₃ + +definition union (b₁ b₂ : bag A) : bag A := +quot.lift_on₂ b₁ b₂ (λ l₁ l₂, ⟦max_count l₁ l₂ (union_list l₁ l₂)⟧) + (λ l₁ l₂ l₃ l₄ p₁ p₂, quot.sound (perm_max_count p₁ p₂ (perm_union_list p₁ p₂))) +infix ∪ := union + +definition inter (b₁ b₂ : bag A) : bag A := +quot.lift_on₂ b₁ b₂ (λ l₁ l₂, ⟦min_count l₁ l₂ (union_list l₁ l₂)⟧) + (λ l₁ l₂ l₃ l₄ p₁ p₂, quot.sound (perm_min_count p₁ p₂ (perm_union_list p₁ p₂))) +infix ∩ := inter + +lemma count_union (a : A) (b₁ b₂ : bag A) : count a (b₁ ∪ b₂) = max (count a b₁) (count a b₂) := +quot.induction_on₂ b₁ b₂ (λ l₁ l₂, by_cases + (suppose a ∈ union_list l₁ l₂, !max_count_eq this !nodup_union_list) + (suppose ¬ a ∈ union_list l₁ l₂, + have ¬ a ∈ l₁, from not_mem_of_not_mem_union_list_left `¬ a ∈ union_list l₁ l₂`, + have ¬ a ∈ l₂, from not_mem_of_not_mem_union_list_right `¬ a ∈ union_list l₁ l₂`, + have n : ¬ a ∈ max_count l₁ l₂ (union_list l₁ l₂), from not_mem_max_count_of_not_mem l₁ l₂ `¬ a ∈ union_list l₁ l₂`, + begin + unfold [union, count], + rewrite [count_eq_zero_of_not_mem `¬ a ∈ l₁`, count_eq_zero_of_not_mem `¬ a ∈ l₂`, max_self], + rewrite [count_eq_zero_of_not_mem n] + end)) + +lemma count_inter (a : A) (b₁ b₂ : bag A) : count a (b₁ ∩ b₂) = min (count a b₁) (count a b₂) := +quot.induction_on₂ b₁ b₂ (λ l₁ l₂, by_cases + (suppose a ∈ union_list l₁ l₂, !min_count_eq this !nodup_union_list) + (suppose ¬ a ∈ union_list l₁ l₂, + have ¬ a ∈ l₁, from not_mem_of_not_mem_union_list_left `¬ a ∈ union_list l₁ l₂`, + have ¬ a ∈ l₂, from not_mem_of_not_mem_union_list_right `¬ a ∈ union_list l₁ l₂`, + have n : ¬ a ∈ min_count l₁ l₂ (union_list l₁ l₂), from not_mem_min_count_of_not_mem l₁ l₂ `¬ a ∈ union_list l₁ l₂`, + begin + unfold [inter, count], + rewrite [count_eq_zero_of_not_mem `¬ a ∈ l₁`, count_eq_zero_of_not_mem `¬ a ∈ l₂`, min_self], + rewrite [count_eq_zero_of_not_mem n] + end)) + +lemma union_comm (b₁ b₂ : bag A) : b₁ ∪ b₂ = b₂ ∪ b₁ := +bag.ext (λ a, by rewrite [*count_union, max.comm]) + +lemma union_assoc (b₁ b₂ b₃ : bag A) : (b₁ ∪ b₂) ∪ b₃ = b₁ ∪ (b₂ ∪ b₃) := +bag.ext (λ a, by rewrite [*count_union, max.assoc]) + +theorem union_left_comm (s₁ s₂ s₃ : bag A) : s₁ ∪ (s₂ ∪ s₃) = s₂ ∪ (s₁ ∪ s₃) := +!left_comm union_comm union_assoc s₁ s₂ s₃ + +lemma union_self (b : bag A) : b ∪ b = b := +bag.ext (λ a, by rewrite [*count_union, max_self]) + +lemma union_empty (b : bag A) : b ∪ empty = b := +bag.ext (λ a, by rewrite [*count_union, count_empty, max_zero]) + +lemma empty_union (b : bag A) : empty ∪ b = b := +calc empty ∪ b = b ∪ empty : union_comm + ... = b : union_empty + +lemma inter_comm (b₁ b₂ : bag A) : b₁ ∩ b₂ = b₂ ∩ b₁ := +bag.ext (λ a, by rewrite [*count_inter, min.comm]) + +lemma inter_assoc (b₁ b₂ b₃ : bag A) : (b₁ ∩ b₂) ∩ b₃ = b₁ ∩ (b₂ ∩ b₃) := +bag.ext (λ a, by rewrite [*count_inter, min.assoc]) + +theorem inter_left_comm (s₁ s₂ s₃ : bag A) : s₁ ∩ (s₂ ∩ s₃) = s₂ ∩ (s₁ ∩ s₃) := +!left_comm inter_comm inter_assoc s₁ s₂ s₃ + +lemma inter_self (b : bag A) : b ∩ b = b := +bag.ext (λ a, by rewrite [*count_inter, min_self]) + +lemma inter_empty (b : bag A) : b ∩ empty = empty := +bag.ext (λ a, by rewrite [*count_inter, count_empty, min_zero]) + +lemma empty_inter (b : bag A) : empty ∩ b = empty := +calc empty ∩ b = b ∩ empty : inter_comm + ... = empty : inter_empty + +lemma append_union_inter (b₁ b₂ : bag A) : (b₁ ∪ b₂) ++ (b₁ ∩ b₂) = b₁ ++ b₂ := +bag.ext (λ a, begin + rewrite [*count_append, count_inter, count_union], + apply (or.elim (lt_or_ge (count a b₁) (count a b₂))), + { intro H, rewrite [min_eq_left_of_lt H, max_eq_right_of_lt H, add.comm] }, + { intro H, rewrite [min_eq_right H, max_eq_left H, add.comm] } +end) + +lemma inter_left_distrib (b₁ b₂ b₃ : bag A) : b₁ ∩ (b₂ ∪ b₃) = (b₁ ∩ b₂) ∪ (b₁ ∩ b₃) := +bag.ext (λ a, begin + rewrite [*count_inter, *count_union, *count_inter], + apply (@by_cases (count a b₁ ≤ count a b₂)), + { intro H₁₂, apply (@by_cases (count a b₂ ≤ count a b₃)), + { intro H₂₃, + have H₁₃ : count a b₁ ≤ count a b₃, from le.trans H₁₂ H₂₃, + rewrite [max_eq_right H₂₃, min_eq_left H₁₂, min_eq_left H₁₃, max_self]}, + { intro H₂₃, + rewrite [min_eq_left H₁₂, max.comm, max_eq_right_of_lt (lt_of_not_ge H₂₃) ], + apply (@by_cases (count a b₁ ≤ count a b₃)), + { intro H₁₃, rewrite [min_eq_left H₁₃, max_self, min_eq_left H₁₂] }, + { intro H₁₃, + rewrite [min.comm (count a b₁) (count a b₃), min_eq_left_of_lt (lt_of_not_ge H₁₃), + min_eq_left H₁₂, max.comm, max_eq_right_of_lt (lt_of_not_ge H₁₃)]}}}, + { intro H₁₂, apply (@by_cases (count a b₂ ≤ count a b₃)), + { intro H₂₃, + rewrite [max_eq_right H₂₃], + apply (@by_cases (count a b₁ ≤ count a b₃)), + { intro H₁₃, rewrite [min_eq_left H₁₃, min.comm, min_eq_left_of_lt (lt_of_not_ge H₁₂), max_eq_right_of_lt (lt_of_not_ge H₁₂)] }, + { intro H₁₃, rewrite [min.comm, min_eq_left_of_lt (lt_of_not_ge H₁₃), min.comm, min_eq_left_of_lt (lt_of_not_ge H₁₂), max_eq_right H₂₃] } }, + { intro H₂₃, + have H₁₃ : count a b₁ > count a b₃, from lt.trans (lt_of_not_ge H₂₃) (lt_of_not_ge H₁₂), + rewrite [max.comm, max_eq_right_of_lt (lt_of_not_ge H₂₃), min.comm, min_eq_left_of_lt (lt_of_not_ge H₁₂)], + rewrite [min.comm, min_eq_left_of_lt H₁₃, max.comm, max_eq_right_of_lt (lt_of_not_ge H₂₃)] } } +end) + +lemma inter_right_distrib (b₁ b₂ b₃ : bag A) : (b₁ ∪ b₂) ∩ b₃ = (b₁ ∩ b₃) ∪ (b₂ ∩ b₃) := +calc (b₁ ∪ b₂) ∩ b₃ = b₃ ∩ (b₁ ∪ b₂) : inter_comm + ... = (b₃ ∩ b₁) ∪ (b₃ ∩ b₂) : inter_left_distrib + ... = (b₁ ∩ b₃) ∪ (b₃ ∩ b₂) : inter_comm + ... = (b₁ ∩ b₃) ∪ (b₂ ∩ b₃) : inter_comm +end union_inter + +section subbag +variable [decA : decidable_eq A] +include decA + +definition subbag (b₁ b₂ : bag A) := ∀ a, count a b₁ ≤ count a b₂ + +infix ⊆ := subbag + +lemma subbag.refl (b : bag A) : b ⊆ b := +take a, !le.refl + +lemma subbag.trans {b₁ b₂ b₃ : bag A} : b₁ ⊆ b₂ → b₂ ⊆ b₃ → b₁ ⊆ b₃ := +assume h₁ h₂, take a, le.trans (h₁ a) (h₂ a) + +lemma subbag.antisymm {b₁ b₂ : bag A} : b₁ ⊆ b₂ → b₂ ⊆ b₁ → b₁ = b₂ := +assume h₁ h₂, bag.ext (take a, le.antisymm (h₁ a) (h₂ a)) + +lemma count_le_of_subbag {b₁ b₂ : bag A} : b₁ ⊆ b₂ → ∀ a, count a b₁ ≤ count a b₂ := +assume h, h + +lemma subbag.intro {b₁ b₂ : bag A} : (∀ a, count a b₁ ≤ count a b₂) → b₁ ⊆ b₂ := +assume h, h + +lemma empty_subbag (b : bag A) : empty ⊆ b := +subbag.intro (take a, !zero_le) + +lemma eq_empty_of_subbag_empty {b : bag A} : b ⊆ empty → b = empty := +assume h, subbag.antisymm h (empty_subbag b) + +lemma union_subbag_of_subbag_of_subbag {b₁ b₂ b₃ : bag A} : b₁ ⊆ b₃ → b₂ ⊆ b₃ → b₁ ∪ b₂ ⊆ b₃ := +assume h₁ h₂, subbag.intro (λ a, calc + count a (b₁ ∪ b₂) = max (count a b₁) (count a b₂) : by rewrite count_union + ... ≤ count a b₃ : max_le (h₁ a) (h₂ a)) + +lemma subbag_inter_of_subbag_of_subbag {b₁ b₂ b₃ : bag A} : b₁ ⊆ b₂ → b₁ ⊆ b₃ → b₁ ⊆ b₂ ∩ b₃ := +assume h₁ h₂, subbag.intro (λ a, calc + count a b₁ ≤ min (count a b₂) (count a b₃) : le_min (h₁ a) (h₂ a) + ... = count a (b₂ ∩ b₃) : by rewrite count_inter) + +lemma subbag_union_left (b₁ b₂ : bag A) : b₁ ⊆ b₁ ∪ b₂ := +subbag.intro (take a, by rewrite [count_union]; apply le_max_left) + +lemma subbag_union_right (b₁ b₂ : bag A) : b₂ ⊆ b₁ ∪ b₂ := +subbag.intro (take a, by rewrite [count_union]; apply le_max_right) + +lemma inter_subbag_left (b₁ b₂ : bag A) : b₁ ∩ b₂ ⊆ b₁ := +subbag.intro (take a, by rewrite [count_inter]; apply min_le_left) + +lemma inter_subbag_right (b₁ b₂ : bag A) : b₁ ∩ b₂ ⊆ b₂ := +subbag.intro (take a, by rewrite [count_inter]; apply min_le_right) + +lemma subbag_append_left (b₁ b₂ : bag A) : b₁ ⊆ b₁ ++ b₂ := +subbag.intro (take a, by rewrite [count_append]; apply le_add_right) + +lemma subbag_append_right (b₁ b₂ : bag A) : b₂ ⊆ b₁ ++ b₂ := +subbag.intro (take a, by rewrite [count_append]; apply le_add_left) + +lemma inter_subbag_union (b₁ b₂ : bag A) : b₁ ∩ b₂ ⊆ b₁ ∪ b₂ := +subbag.trans (inter_subbag_left b₁ b₂) (subbag_union_left b₁ b₂) + +open decidable + +lemma union_subbag_append (b₁ b₂ : bag A) : b₁ ∪ b₂ ⊆ b₁ ++ b₂ := +subbag.intro (take a, begin + rewrite [count_append, count_union], + exact (or.elim !lt_or_ge) + (suppose count a b₁ < count a b₂, by rewrite [max_eq_right_of_lt this]; apply le_add_left) + (suppose count a b₁ ≥ count a b₂, by rewrite [max_eq_left this]; apply le_add_right) +end) + +lemma subbag_insert (a : A) (b : bag A) : b ⊆ insert a b := +subbag.intro (take x, by_cases + (suppose x = a, by rewrite [this, count_insert]; apply le_succ) + (suppose x ≠ a, by rewrite [count_insert_of_ne this])) + +lemma mem_of_subbag_of_mem {a : A} {b₁ b₂ : bag A} : b₁ ⊆ b₂ → a ∈ b₁ → a ∈ b₂ := +assume h₁ h₂, +have count a b₁ ≤ count a b₂, from count_le_of_subbag h₁ a, +have count a b₁ > 0, from h₂, +show count a b₂ > 0, from lt_of_lt_of_le `0 < count a b₁` `count a b₁ ≤ count a b₂` + +lemma extract_subbag (a : A) (b : bag A) : extract a b ⊆ b := +subbag.intro (take x, by_cases + (suppose x = a, by rewrite [this, count_extract]; apply zero_le) + (suppose x ≠ a, by rewrite [count_extract_of_ne this])) + +open bool + +private definition subcount : list A → list A → bool +| [] l₂ := tt +| (a::l₁) l₂ := if list.count a (a::l₁) ≤ list.count a l₂ then subcount l₁ l₂ else ff + +private lemma all_of_subcount_eq_tt : ∀ {l₁ l₂ : list A}, subcount l₁ l₂ = tt → ∀ a, list.count a l₁ ≤ list.count a l₂ +| [] l₂ h := take x, !zero_le +| (a::l₁) l₂ h := take x, + have subcount l₁ l₂ = tt, from by_contradiction (suppose subcount l₁ l₂ ≠ tt, + have subcount l₁ l₂ = ff, from eq_ff_of_ne_tt this, + begin unfold subcount at h, rewrite [this at h, if_t_t at h], contradiction end), + have ih : ∀ a, list.count a l₁ ≤ list.count a l₂, from all_of_subcount_eq_tt this, + have i : list.count a (a::l₁) ≤ list.count a l₂, from by_contradiction (suppose ¬ list.count a (a::l₁) ≤ list.count a l₂, + begin unfold subcount at h, rewrite [if_neg this at h], contradiction end), + by_cases + (suppose x = a, by rewrite this; apply i) + (suppose x ≠ a, by rewrite [list.count_cons_of_ne this]; apply ih) + +private lemma ex_of_subcount_eq_ff : ∀ {l₁ l₂ : list A}, subcount l₁ l₂ = ff → ∃ a, ¬ list.count a l₁ ≤ list.count a l₂ +| [] l₂ h := by contradiction +| (a::l₁) l₂ h := by_cases + (suppose i : list.count a (a::l₁) ≤ list.count a l₂, + have subcount l₁ l₂ = ff, from by_contradiction (suppose subcount l₁ l₂ ≠ ff, + have subcount l₁ l₂ = tt, from eq_tt_of_ne_ff this, + begin + unfold subcount at h, + rewrite [if_pos i at h, this at h], + contradiction + end), + have ih : ∃ a, ¬ list.count a l₁ ≤ list.count a l₂, from ex_of_subcount_eq_ff this, + obtain w hw, from ih, by_cases + (suppose w = a, begin subst w, existsi a, rewrite list.count_cons_eq, apply not_lt_of_ge, apply le_of_lt (lt_of_not_ge hw) end) + (suppose w ≠ a, exists.intro w (by rewrite (list.count_cons_of_ne `w ≠ a`); exact hw))) + (suppose ¬ list.count a (a::l₁) ≤ list.count a l₂, exists.intro a this) + +attribute [instance] +definition decidable_subbag (b₁ b₂ : bag A) : decidable (b₁ ⊆ b₂) := +quot.rec_on_subsingleton₂ b₁ b₂ (λ l₁ l₂, + match subcount l₁ l₂ with + | tt := suppose subcount l₁ l₂ = tt, inl (all_of_subcount_eq_tt this) + | ff := suppose subcount l₁ l₂ = ff, inr (suppose h : (∀ a, list.count a l₁ ≤ list.count a l₂), + obtain w hw, from ex_of_subcount_eq_ff `subcount l₁ l₂ = ff`, + absurd (h w) hw) + end rfl) +end subbag +end bag diff --git a/old_library/data/bool.lean b/old_library/data/bool.lean new file mode 100644 index 0000000000..37496b500c --- /dev/null +++ b/old_library/data/bool.lean @@ -0,0 +1,180 @@ +/- +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 logic.eq + +namespace bool + local attribute bor [reducible] + local attribute band [reducible] + + theorem dichotomy (b : bool) : b = ff ∨ b = tt := + sorry -- by rec_simp + + attribute [simp] + theorem cond_ff {A : Type} (t e : A) : cond ff t e = e := + rfl + + attribute [simp] + 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 := + sorry -- by rec_simp + + theorem eq_ff_of_ne_tt : ∀ {a : bool}, a ≠ tt → a = ff := + sorry -- by rec_simp + + theorem absurd_of_eq_ff_of_eq_tt {B : Prop} {a : bool} (H₁ : a = ff) (H₂ : a = tt) : B := + sorry -- by rec_simp + + attribute [simp] + theorem tt_bor (a : bool) : bor tt a = tt := + rfl + + notation a || b := bor a b + + attribute [simp] + theorem bor_tt (a : bool) : a || tt = tt := + sorry -- by rec_simp + + attribute [simp] + theorem ff_bor (a : bool) : ff || a = a := + sorry -- by rec_simp + + attribute [simp] + theorem bor_ff (a : bool) : a || ff = a := + sorry -- by rec_simp + + attribute [simp] + theorem bor_self (a : bool) : a || a = a := + sorry -- by rec_simp + + attribute [simp] + theorem bor_comm (a b : bool) : a || b = b || a := + sorry -- by rec_simp + + attribute [simp] + theorem bor_assoc (a b c : bool) : (a || b) || c = a || (b || c) := + sorry -- by rec_simp + + attribute [simp] + theorem bor_left_comm (a b c : bool) : a || (b || c) = b || (a || c) := + sorry -- by rec_simp + + theorem or_of_bor_eq {a b : bool} : a || b = tt → a = tt ∨ b = tt := + sorry -- by rec_simp + + theorem bor_inl {a b : bool} (H : a = tt) : a || b = tt := + sorry -- by rec_simp + + theorem bor_inr {a b : bool} (H : b = tt) : a || b = tt := + sorry -- by rec_simp + + attribute [simp] + theorem ff_band (a : bool) : ff && a = ff := + rfl + + attribute [simp] + theorem tt_band (a : bool) : tt && a = a := + sorry -- by rec_simp + + attribute [simp] + theorem band_ff (a : bool) : a && ff = ff := + sorry -- by rec_simp + + attribute [simp] + theorem band_tt (a : bool) : a && tt = a := + sorry -- by rec_simp + + attribute [simp] + theorem band_self (a : bool) : a && a = a := + sorry -- by rec_simp + + attribute [simp] + theorem band_comm (a b : bool) : a && b = b && a := + sorry -- by rec_simp + + attribute [simp] + theorem band_assoc (a b c : bool) : (a && b) && c = a && (b && c) := + sorry -- by rec_simp + + attribute [simp] + theorem band_left_comm (a b c : bool) : a && (b && c) = b && (a && c) := + sorry -- by rec_simp + + theorem band_elim_left {a b : bool} (H : a && b = tt) : a = tt := + sorry -- by rec_simp + + theorem band_intro {a b : bool} (H₁ : a = tt) (H₂ : b = tt) : a && b = tt := + sorry -- by rec_simp + + theorem band_elim_right {a b : bool} (H : a && b = tt) : b = tt := + sorry -- by rec_simp + + attribute [simp] + theorem bnot_false : bnot ff = tt := + rfl + + attribute [simp] + theorem bnot_true : bnot tt = ff := + rfl + + attribute [simp] + theorem bnot_bnot (a : bool) : bnot (bnot a) = a := + sorry -- by rec_simp + + theorem eq_tt_of_bnot_eq_ff {a : bool} : bnot a = ff → a = tt := + sorry -- by rec_simp + + theorem eq_ff_of_bnot_eq_tt {a : bool} : bnot a = tt → a = ff := + sorry -- by rec_simp + + definition bxor : bool → bool → bool + | ff ff := ff + | ff tt := tt + | tt ff := tt + | tt tt := ff + + attribute [simp] + lemma ff_bxor_ff : bxor ff ff = ff := rfl + attribute [simp] + lemma ff_bxor_tt : bxor ff tt = tt := rfl + attribute [simp] + lemma tt_bxor_ff : bxor tt ff = tt := rfl + attribute [simp] + lemma tt_bxor_tt : bxor tt tt = ff := rfl + + attribute [simp] + lemma bxor_self (a : bool) : bxor a a = ff := + sorry -- by rec_simp + + attribute [simp] + lemma bxor_ff (a : bool) : bxor a ff = a := + sorry -- by rec_simp + + attribute [simp] + lemma bxor_tt (a : bool) : bxor a tt = bnot a := + sorry -- by rec_simp + + attribute [simp] + lemma ff_bxor (a : bool) : bxor ff a = a := + sorry -- by rec_simp + + attribute [simp] + lemma tt_bxor (a : bool) : bxor tt a = bnot a := + sorry -- by rec_simp + + attribute [simp] + lemma bxor_comm (a b : bool) : bxor a b = bxor b a := + sorry -- by rec_simp + + attribute [simp] + lemma bxor_assoc (a b c : bool) : bxor (bxor a b) c = bxor a (bxor b c) := + sorry -- by rec_simp + + attribute [simp] + lemma bxor_left_comm (a b c : bool) : bxor a (bxor b c) = bxor b (bxor a c) := + sorry -- by rec_simp +end bool diff --git a/old_library/data/bv.lean b/old_library/data/bv.lean new file mode 100644 index 0000000000..3c23b85eea --- /dev/null +++ b/old_library/data/bv.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2015 Joe Hendrix. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Joe Hendrix + +Basic operations on bitvectors. + +This is a work-in-progress, and contains additions to other theories. +-/ +import data.list +import data.tuple + +namespace bv +open bool +open eq.ops +open list +open nat +open prod +open subtype +open tuple + +attribute [reducible] +definition bv (n : ℕ) := tuple bool n + +-- Create a zero bitvector +definition bv_zero (n : ℕ) : bv n := replicate ff + +-- Create a bitvector with the constant one. +definition bv_one : Π (n : ℕ), bv n + | 0 := replicate ff + | (succ n) := (replicate ff : bv n) ++ (tt :: nil) + +definition bv_cong {a b : ℕ} : (a = b) → bv a → bv b +| c (tag x p) := tag x (c ▸ p) + +section shift + + -- shift left + definition bv_shl {n:ℕ} : bv n → ℕ → bv n + | x i := + if le : i ≤ n then + let r := dropn i x ++ replicate ff in + let eq := calc (n-i) + i = n : nat.sub_add_cancel le in + bv_cong eq r + else + bv_zero n + + -- unsigned shift right + definition bv_ushr {n:ℕ} : bv n → ℕ → bv n + | x i := + if le : i ≤ n then + let y : bv (n-i) := @firstn _ _ (n - i) (sub_le n i) x in + let eq := calc (i+(n-i)) = (n - i) + i : add.comm + ... = n : nat.sub_add_cancel le in + bv_cong eq (replicate ff ++ y) + else + bv_zero n + + -- signed shift right + definition bv_sshr {m:ℕ} : bv (succ m) → ℕ → bv (succ m) + | x i := + let n := succ m in + if le : i ≤ n then + let z : bv i := replicate (head x) in + let y : bv (n-i) := @firstn _ _ (n - i) (sub_le n i) x in + let eq := calc (i+(n-i)) = (n-i) + i : add.comm + ... = n : nat.sub_add_cancel le in + bv_cong eq (z ++ y) + else + bv_zero n + +end shift + +section bitwise + variable { n : ℕ } + + definition bv_not : bv n → bv n := map bnot + definition bv_and : bv n → bv n → bv n := map₂ band + definition bv_or : bv n → bv n → bv n := map₂ bor + definition bv_xor : bv n → bv n → bv n := map₂ bxor + +end bitwise + +section arith + + variable { n : ℕ } + + protected definition xor3 (x:bool) (y:bool) (c:bool) := bxor (bxor x y) c + protected definition carry (x:bool) (y:bool) (c:bool) := + x && y || x && c || y && c + + definition bv_neg : bv n → bv n + | x := + let f := λy c, (y || c, bxor y c) in + pr₂ (mapAccumR f x ff) + + -- Add with carry (no overflow) + definition bv_adc : bv n → bv n → bool → bv (n+1) + | x y c := + let f := λx y c, (bv.carry x y c, bv.xor3 x y c) in + let z := tuple.mapAccumR₂ f x y c in + (pr₁ z) :: (pr₂ z) + + definition bv_add : bv n → bv n → bv n + | x y := tail (bv_adc x y ff) + + protected definition borrow (x:bool) (y:bool) (b:bool) := + bnot x && y || bnot x && b || y && b + + -- Subtract with borrow + definition bv_sbb : bv n → bv n → bool → bool × bv n + | x y b := + let f := λx y c, (bv.borrow x y c, bv.xor3 x y c) in + tuple.mapAccumR₂ f x y b + + definition bv_sub : bv n → bv n → bv n + | x y := pr₂ (bv_sbb x y ff) + + attribute [instance] + definition bv_has_zero : has_zero (bv n) := has_zero.mk (bv_zero n) + attribute [instance] + definition bv_has_one : has_one (bv n) := has_one.mk (bv_one n) + attribute [instance] + definition bv_has_add : has_add (bv n) := has_add.mk bv_add + attribute [instance] + definition bv_has_sub : has_sub (bv n) := has_sub.mk bv_sub + attribute [instance] + definition bv_has_neg : has_neg (bv n) := has_neg.mk bv_neg + + definition bv_mul : bv n → bv n → bv n + | x y := + let f := λr b, cond b (r + r + y) (r + r) in + foldl f 0 (to_list x) + + attribute [instance] + definition bv_has_mul : has_mul (bv n) := has_mul.mk bv_mul + + definition bv_ult : bv n → bv n → bool := λx y, pr₁ (bv_sbb x y ff) + definition bv_ugt : bv n → bv n → bool := λx y, bv_ult y x + definition bv_ule : bv n → bv n → bool := λx y, bnot (bv_ult y x) + definition bv_uge : bv n → bv n → bool := λx y, bv_ule y x + + definition bv_slt : bv (succ n) → bv (succ n) → bool := λx y, + cond (head x) + (cond (head y) + (bv_ult (tail x) (tail y)) -- both negative + tt) -- x is negative and y is not + (cond (head y) + ff -- y is negative and x is not + (bv_ult (tail x) (tail y))) -- both positive + definition bv_sgt : bv (succ n) → bv (succ n) → bool := λx y, bv_slt y x + definition bv_sle : bv (succ n) → bv (succ n) → bool := λx y, bnot (bv_slt y x) + definition bv_sge : bv (succ n) → bv (succ n) → bool := λx y, bv_sle y x +end arith + + +section from_bv + variable {A : Type} + + -- Convert a bitvector to another number. + definition from_bv [p : has_add A] [q0 : has_zero A] [q1 : has_one A] {n:nat} (v:bv n) : A := + let f := λr b, cond b (r + r + 1) (r + r) in + foldl f 0 (to_list v) +end from_bv + +end bv diff --git a/old_library/data/complex.lean b/old_library/data/complex.lean new file mode 100644 index 0000000000..e3a1c83e36 --- /dev/null +++ b/old_library/data/complex.lean @@ -0,0 +1,375 @@ +/- +Copyright (c) 2015 Jacob Gross. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jacob Gross, Jeremy Avigad + +The complex numbers. +-/ +import data.real +open real eq.ops + +record complex : Type := +(re : ℝ) (im : ℝ) + +notation `ℂ` := complex + +namespace complex + +variables (u w z : ℂ) +variable n : ℕ + +protected proposition eq {z w : ℂ} (H1 : complex.re z = complex.re w) +(H2 : complex.im z = complex.im w) : z = w := +begin + induction z, + induction w, + rewrite [H1, H2] +end + +protected proposition eta (z : ℂ) : complex.mk (complex.re z) (complex.im z) = z := +by cases z; exact rfl + +-- definition of_real [coercion] (x : ℝ) : ℂ := complex.mk x 0 +-- definition of_rat [coercion] (q : ℚ) : ℂ := q +-- definition of_int [coercion] (i : ℤ) : ℂ := i +-- definition of_nat [coercion] (n : ℕ) : ℂ := n +-- definition of_num [coercion] [reducible] (n : num) : ℂ := n + +protected definition prio : num := num.pred real.prio + +attribute [instance, priority complex.prio] +definition complex_has_zero : has_zero ℂ := +has_zero.mk (of_nat 0) + +attribute [instance, priority complex.prio] +definition complex_has_one : has_one ℂ := +has_one.mk (of_nat 1) + +theorem re_of_real (x : ℝ) : re (of_real x) = x := rfl + +theorem im_of_real (x : ℝ) : im (of_real x) = 0 := rfl + +protected definition add (z w : ℂ) : ℂ := +complex.mk (complex.re z + complex.re w) (complex.im z + complex.im w) + +protected definition neg (z : ℂ) : ℂ := +complex.mk (-(re z)) (-(im z)) + +protected definition mul (z w : ℂ) : ℂ := +complex.mk + (complex.re w * complex.re z - complex.im w * complex.im z) + (complex.re w * complex.im z + complex.im w * complex.re z) + +/- notation -/ + +attribute [instance, priority complex.prio] +definition complex_has_add : has_add complex := +has_add.mk complex.add + +attribute [instance, priority complex.prio] +definition complex_has_neg : has_neg complex := +has_neg.mk complex.neg + +attribute [instance, priority complex.prio] +definition complex_has_mul : has_mul complex := +has_mul.mk complex.mul + +protected theorem add_def (z w : ℂ) : + z + w = complex.mk (complex.re z + complex.re w) (complex.im z + complex.im w) := rfl + +protected theorem neg_def (z : ℂ) : -z = complex.mk (-(re z)) (-(im z)) := rfl + +protected theorem mul_def (z w : ℂ) : + z * w = complex.mk + (complex.re w * complex.re z - complex.im w * complex.im z) + (complex.re w * complex.im z + complex.im w * complex.re z) := rfl + +-- TODO: what notation should we use for i? + +definition ii := complex.mk 0 1 + +theorem i_mul_i : ii * ii = -1 := rfl + +/- basic properties -/ + +protected theorem add_comm (w z : ℂ) : w + z = z + w := +complex.eq !add.comm !add.comm + +protected theorem add_assoc (w z u : ℂ) : (w + z) + u = w + (z + u) := +complex.eq !add.assoc !add.assoc + +protected theorem add_zero (z : ℂ) : z + 0 = z := +complex.eq !add_zero !add_zero + +protected theorem zero_add (z : ℂ) : 0 + z = z := !complex.add_comm ▸ !complex.add_zero + +definition smul (x : ℝ) (z : ℂ) : ℂ := +complex.mk (x*re z) (x*im z) + +protected theorem add_right_inv : z + - z = 0 := +complex.eq !add.right_inv !add.right_inv + +protected theorem add_left_inv : - z + z = 0 := +!complex.add_comm ▸ !complex.add_right_inv + +protected theorem mul_comm : w * z = z * w := +by rewrite [*complex.mul_def, *mul.comm (re w), *mul.comm (im w), add.comm] + +protected theorem one_mul : 1 * z = z := +by krewrite [complex.mul_def, *mul_one, *mul_zero, sub_zero, zero_add, complex.eta] + +protected theorem mul_one : z * 1 = z := !complex.mul_comm ▸ !complex.one_mul + +protected theorem left_distrib : u * (w + z) = u * w + u * z := +begin + rewrite [*complex.mul_def, *complex.add_def, ▸*, *right_distrib, -sub_sub, *sub_eq_add_neg], + rewrite [*add.assoc, add.left_comm (re z * im u), add.left_comm (-_)] +end + +protected theorem right_distrib : (u + w) * z = u * z + w * z := +by rewrite [*complex.mul_comm _ z, complex.left_distrib] + +protected theorem mul_assoc : (u * w) * z = u * (w * z) := +begin + rewrite [*complex.mul_def, ▸*, *sub_eq_add_neg, *left_distrib, *right_distrib, *neg_add], + rewrite [-*neg_mul_eq_neg_mul, -*neg_mul_eq_mul_neg, *add.assoc, *mul.assoc], + rewrite [add.comm (-(im z * (im w * _))), add.comm (-(im z * (im w * _))), *add.assoc] +end + +theorem re_add (z w : ℂ) : re (z + w) = re z + re w := rfl + +theorem im_add (z w : ℂ) : im (z + w) = im z + im w := rfl + +/- coercions -/ + +theorem of_real_add (a b : ℝ) : of_real (a + b) = of_real a + of_real b := rfl + +theorem of_real_mul (a b : ℝ) : of_real (a * b) = (of_real a) * (of_real b) := +by rewrite [complex.mul_def, *re_of_real, *im_of_real, *mul_zero, *zero_mul, sub_zero, add_zero, + mul.comm] + +theorem of_real_neg (a : ℝ) : of_real (-a) = -(of_real a) := rfl + +theorem of_real.inj {a b : ℝ} (H : of_real a = of_real b) : a = b := +show re (of_real a) = re (of_real b), from congr_arg re H + +theorem eq_of_of_real_eq_of_real {a b : ℝ} (H : of_real a = of_real b) : a = b := +of_real.inj H + +theorem of_real_eq_of_real_iff (a b : ℝ) : of_real a = of_real b ↔ a = b := +iff.intro eq_of_of_real_eq_of_real !congr_arg + +/- make complex an instance of ring -/ + +attribute [reducible] +protected definition comm_ring : comm_ring complex := + begin + fapply comm_ring.mk, + exact complex.add, + exact complex.add_assoc, + exact 0, + exact complex.zero_add, + exact complex.add_zero, + exact complex.neg, + exact complex.add_left_inv, + exact complex.add_comm, + exact complex.mul, + exact complex.mul_assoc, + exact 1, + apply complex.one_mul, + apply complex.mul_one, + apply complex.left_distrib, + apply complex.right_distrib, + apply complex.mul_comm + end + +local attribute complex.comm_ring [instance] + +attribute [instance, priority complex.prio] +definition complex_has_sub : has_sub complex := +has_sub.mk has_sub.sub + +theorem of_real_sub (x y : ℝ) : of_real (x - y) = of_real x - of_real y := +rfl + +/- complex modulus and conjugate-/ + +definition cmod (z : ℂ) : ℝ := +(complex.re z) * (complex.re z) + (complex.im z) * (complex.im z) + +theorem cmod_zero : cmod 0 = 0 := rfl + +theorem cmod_of_real (x : ℝ) : cmod x = x * x := +by rewrite [↑cmod, re_of_real, im_of_real, mul_zero, add_zero] + +theorem eq_zero_of_cmod_eq_zero {z : ℂ} (H : cmod z = 0) : z = 0 := +have H1 : (complex.re z) * (complex.re z) + (complex.im z) * (complex.im z) = 0, + from H, +have H2 : complex.re z = 0, from eq_zero_of_mul_self_add_mul_self_eq_zero H1, +have H3 : complex.im z = 0, from eq_zero_of_mul_self_add_mul_self_eq_zero (!add.comm ▸ H1), +show z = 0, from complex.eq H2 H3 + +definition conj (z : ℂ) : ℂ := complex.mk (complex.re z) (-(complex.im z)) + +theorem conj_of_real {x : ℝ} : conj (of_real x) = of_real x := rfl + +theorem conj_add (z w : ℂ) : conj (z + w) = conj z + conj w := +by rewrite [↑conj, *complex.add_def, ▸*, neg_add] + +theorem conj_mul (z w : ℂ) : conj (z * w) = conj z * conj w := +by rewrite [↑conj, *complex.mul_def, ▸*, neg_mul_neg, neg_add, + -neg_mul_eq_mul_neg, -neg_mul_eq_neg_mul] + +theorem conj_conj (z : ℂ) : conj (conj z) = z := +by rewrite [↑conj, neg_neg, complex.eta] + +theorem mul_conj_eq_of_real_cmod (z : ℂ) : z * conj z = of_real (cmod z) := +by rewrite [↑conj, ↑cmod, ↑of_real, complex.mul_def, ▸*, -*neg_mul_eq_neg_mul, + sub_neg_eq_add, mul.comm (re z) (im z), add.right_inv] + +theorem cmod_conj (z : ℂ) : cmod (conj z) = cmod z := +begin + apply eq_of_of_real_eq_of_real, + rewrite [-*mul_conj_eq_of_real_cmod, conj_conj, mul.comm] +end + +theorem cmod_mul (z w : ℂ) : cmod (z * w) = cmod z * cmod w := +begin + apply eq_of_of_real_eq_of_real, + rewrite [of_real_mul, -*mul_conj_eq_of_real_cmod, conj_mul, *mul.assoc, mul.left_comm w] +end + +protected noncomputable definition inv (z : ℂ) : complex := conj z * of_real (cmod z)⁻¹ + +attribute [instance, priority complex.prio] +protected noncomputable definition complex_has_inv : + has_inv complex := has_inv.mk complex.inv + +protected theorem inv_def (z : ℂ) : z⁻¹ = conj z * of_real (cmod z)⁻¹ := rfl + +protected theorem inv_zero : 0⁻¹ = (0 : ℂ) := +by krewrite [complex.inv_def, conj_of_real, zero_mul] + +theorem of_real_inv (x : ℝ) : of_real x⁻¹ = (of_real x)⁻¹ := +classical.by_cases + (assume H : x = 0, + by krewrite [H, inv_zero, complex.inv_zero]) + (assume H : x ≠ 0, + by rewrite [complex.inv_def, cmod_of_real, conj_of_real, mul_inv_eq H H, -of_real_mul, + -mul.assoc, mul_inv_cancel H, one_mul]) + +protected noncomputable definition div (z w : ℂ) : ℂ := z * w⁻¹ + +attribute [instance, priority complex.prio] +noncomputable definition complex_has_div : + has_div complex := + has_div.mk complex.div + +protected theorem div_def (z w : ℂ) : z / w = z * w⁻¹ := rfl + +theorem of_real_div (x y : ℝ) : of_real (x / y) = of_real x / of_real y := +have H : x / y = x * y⁻¹, from rfl, +by rewrite [H, complex.div_def, of_real_mul, of_real_inv] + +theorem conj_inv (z : ℂ) : (conj z)⁻¹ = conj (z⁻¹) := +by rewrite [*complex.inv_def, conj_mul, *conj_conj, conj_of_real, cmod_conj] + +protected theorem mul_inv_cancel {z : ℂ} (H : z ≠ 0) : z * z⁻¹ = 1 := +by rewrite [complex.inv_def, -mul.assoc, mul_conj_eq_of_real_cmod, -of_real_mul, + mul_inv_cancel (assume H', H (eq_zero_of_cmod_eq_zero H'))] + +protected theorem inv_mul_cancel {z : ℂ} (H : z ≠ 0) : z⁻¹ * z = 1 := +!mul.comm ▸ complex.mul_inv_cancel H + +protected noncomputable definition has_decidable_eq : decidable_eq ℂ := +take z w, classical.prop_decidable (z = w) + +protected theorem zero_ne_one : (0 : ℂ) ≠ 1 := +assume H, zero_ne_one (eq_of_of_real_eq_of_real H) + +attribute [trans_instance] +protected noncomputable definition discrete_field : + discrete_field ℂ := +⦃ discrete_field, complex.comm_ring, + mul_inv_cancel := @complex.mul_inv_cancel, + inv_mul_cancel := @complex.inv_mul_cancel, + zero_ne_one := complex.zero_ne_one, + inv_zero := complex.inv_zero, + has_decidable_eq := complex.has_decidable_eq +⦄ + +-- TODO : we still need the whole family of coercion properties, for nat, int, rat + +-- coercions + +theorem of_rat_eq (a : ℚ) : of_rat a = of_real (real.of_rat a) := rfl + +theorem of_int_eq (a : ℤ) : of_int a = of_real (real.of_int a) := rfl + +theorem of_nat_eq (a : ℕ) : of_nat a = of_real (real.of_nat a) := rfl + +theorem of_rat.inj {x y : ℚ} (H : of_rat x = of_rat y) : x = y := +real.of_rat.inj (of_real.inj H) + +theorem eq_of_of_rat_eq_of_rat {x y : ℚ} (H : of_rat x = of_rat y) : x = y := +of_rat.inj H + +theorem of_rat_eq_of_rat_iff (x y : ℚ) : of_rat x = of_rat y ↔ x = y := +iff.intro eq_of_of_rat_eq_of_rat !congr_arg + +theorem of_int.inj {a b : ℤ} (H : of_int a = of_int b) : a = b := +rat.of_int.inj (of_rat.inj H) + +theorem eq_of_of_int_eq_of_int {a b : ℤ} (H : of_int a = of_int b) : a = b := +of_int.inj H + +theorem of_int_eq_of_int_iff (a b : ℤ) : of_int a = of_int b ↔ a = b := +iff.intro of_int.inj !congr_arg + +theorem of_nat.inj {a b : ℕ} (H : of_nat a = of_nat b) : a = b := +int.of_nat.inj (of_int.inj H) + +theorem eq_of_of_nat_eq_of_nat {a b : ℕ} (H : of_nat a = of_nat b) : a = b := +of_nat.inj H + +theorem of_nat_eq_of_nat_iff (a b : ℕ) : of_nat a = of_nat b ↔ a = b := +iff.intro of_nat.inj !congr_arg + +open rat + +theorem of_rat_add (a b : ℚ) : of_rat (a + b) = of_rat a + of_rat b := +by rewrite [of_rat_eq] + +theorem of_rat_neg (a : ℚ) : of_rat (-a) = -of_rat a := +by rewrite [of_rat_eq] + +-- these show why we have to use krewrite in the next theorem: there are +-- two different instances of "has_mul". + +-- set_option pp.notation false +-- set_option pp.coercions true +-- set_option pp.implicit true + +theorem of_rat_mul (a b : ℚ) : of_rat (a * b) = of_rat a * of_rat b := +by krewrite [of_rat_eq, real.of_rat_mul, of_real_mul] + +open int + +theorem of_int_add (a b : ℤ) : of_int (a + b) = of_int a + of_int b := + by krewrite [of_int_eq, real.of_int_add, of_real_add] + +theorem of_int_neg (a : ℤ) : of_int (-a) = -of_int a := + by krewrite [of_int_eq, real.of_int_neg, of_real_neg] + +theorem of_int_mul (a b : ℤ) : of_int (a * b) = of_int a * of_int b := + by krewrite [of_int_eq, real.of_int_mul, of_real_mul] + +open nat + +theorem of_nat_add (a b : ℕ) : of_nat (a + b) = of_nat a + of_nat b := + by krewrite [of_nat_eq, real.of_nat_add, of_real_add] + +theorem of_nat_mul (a b : ℕ) : of_nat (a * b) = of_nat a * of_nat b := + by krewrite [of_nat_eq, real.of_nat_mul, of_real_mul] + +end complex diff --git a/old_library/data/countable.lean b/old_library/data/countable.lean new file mode 100644 index 0000000000..c635b67b1c --- /dev/null +++ b/old_library/data/countable.lean @@ -0,0 +1,10 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Define countable types +-/ +open function + +definition countable (A : Type) : Prop := ∃ f : A → nat, injective f diff --git a/old_library/data/data.md b/old_library/data/data.md new file mode 100644 index 0000000000..d847f54ee0 --- /dev/null +++ b/old_library/data/data.md @@ -0,0 +1,37 @@ +data +==== + +Various data types. + +Basic types: + +* [empty](empty.lean) : the empty type +* [unit](unit.lean) : the singleton type +* [bool](bool.lean) : the boolean values +* [num](num.lean) : generic numerals +* [string](string.lean) : ascii strings +* [nat](nat/nat.md) : the natural numbers +* [fin](fin.lean) : finite ordinals +* [int](int/int.md) : the integers +* [rat](rat/rat.md) : the rationals +* [pnat](pnat.lean) : the positive natural numbers +* [real](real/real.md) : the real numbers +* [complex](complex.lean) : the complex numbers + +Constructors: + +* [prod](prod.lean) : cartesian product +* [sum](sum.lean) +* [sigma](sigma.lean) : the dependent product +* [uprod](uprod.lean) : unordered pairs +* [option](option.lean) +* [squash](squash.lean) : propositional truncation +* [list](list/list.md) +* [finset](finset/finset.md) : finite sets +* [stream](stream.lean) +* [set](set/set.md) + +Types with extra information: + +* [fintype](fintype/fintype.md) : finite types +* [encodable](encodable.lean) : types with a coding to nat diff --git a/old_library/data/default.lean b/old_library/data/default.lean new file mode 100644 index 0000000000..cb0806956a --- /dev/null +++ b/old_library/data/default.lean @@ -0,0 +1,10 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad +-/ + +import .empty .bool .num .nat .list +-- .set +-- import .string .int .rat .fintype .prod .sum .sigma .option .list .finset .set .stream +-- import .fin .real .complex diff --git a/old_library/data/empty.lean b/old_library/data/empty.lean new file mode 100644 index 0000000000..29e4b2e07e --- /dev/null +++ b/old_library/data/empty.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad, Floris van Doorn +-/ +import logic.cast + +namespace empty + protected definition elim (A : Type) : empty → A := + empty.rec (λe, A) + + attribute [instance] + protected definition subsingleton : subsingleton empty := + subsingleton.intro (λ a b, empty.elim _ a) +end empty + +attribute [instance] +protected definition empty.has_decidable_eq : decidable_eq empty := +take (a b : empty), decidable.tt (empty.elim _ a) + +definition tneg.tneg (A : Type) := A → empty +prefix `~` := tneg.tneg +namespace tneg +variables {A B : Type} +protected definition intro (H : A → empty) : ~A := H +protected definition elim (H1 : ~A) (H2 : A) : empty := H1 H2 +protected definition empty : ~empty := λH : empty, H +definition tabsurd (H1 : A) (H2 : ~A) : B := empty.elim _ (H2 H1) +definition tneg_tneg_intro (H : A) : ~~A := λH2 : ~A, tneg.elim H2 H +definition tmt (H1 : A → B) (H2 : ~B) : ~A := λHA : A, tabsurd (H1 HA) H2 + +definition tneg_pi_left {B : A → Type} (H : ~Πa, B a) : ~~A := +λHnA : ~A, tneg.elim H (λHA : A, tabsurd HA HnA) + +definition tneg_function_right (H : ~(A → B)) : ~B := +λHB : B, tneg.elim H (λHA : A, HB) + + +end tneg diff --git a/old_library/data/encodable.lean b/old_library/data/encodable.lean new file mode 100644 index 0000000000..6075562dfa --- /dev/null +++ b/old_library/data/encodable.lean @@ -0,0 +1,483 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Type class for encodable types. +Note that every encodable type is countable. +-/ +import data.fintype data.list data.list.sort data.sum data.nat.div data.countable data.equiv +import data.finset +open option list nat function + +structure encodable [class] (A : Type) := +(encode : A → nat) (decode : nat → option A) (encodek : ∀ a, decode (encode a) = some a) + +open encodable + +definition countable_of_encodable {A : Type} : encodable A → countable A := +assume e : encodable A, +have injective encode, from + λ (a₁ a₂ : A) (h : encode a₁ = encode a₂), + have decode A (encode a₁) = decode A (encode a₂), by rewrite h, + by rewrite [*encodek at this]; injection this; assumption, +exists.intro encode this + +attribute [instance] +definition encodable_fintype {A : Type} [h₁ : fintype A] [h₂ : decidable_eq A] : + encodable A := +encodable.mk + (λ a, find a (elements_of A)) + (λ n, nth (elements_of A) n) + (λ a, find_nth (fintype.complete a)) + +attribute [instance] +definition encodable_nat : encodable nat := +encodable.mk (λ a, a) (λ n, some n) (λ a, rfl) + +attribute [instance] +definition encodable_option {A : Type} [h : encodable A] : encodable (option A) := +encodable.mk + (λ o, match o with + | some a := succ (encode a) + | none := 0 + end) + (λ n, if n = 0 then some none else some (decode A (pred n))) + (λ o, + begin + cases o with a, + begin esimp end, + begin esimp, rewrite [if_neg !succ_ne_zero, encodable.encodek] end + end) + +section sum +variables {A B : Type} +variables [h₁ : encodable A] [h₂ : encodable B] +include h₁ h₂ + +private definition encode_sum : sum A B → nat +| (sum.inl a) := 2 * encode a +| (sum.inr b) := 2 * encode b + 1 + +private definition decode_sum (n : nat) : option (sum A B) := +if n % 2 = 0 then + match decode A (n / 2) with + | some a := some (sum.inl a) + | none := none + end +else + match decode B ((n - 1) / 2) with + | some b := some (sum.inr b) + | none := none + end + +open decidable +private theorem decode_encode_sum : ∀ s : sum A B, decode_sum (encode_sum s) = some s +| (sum.inl a) := + have aux : 2 > (0:nat), from dec_trivial, + begin + esimp [encode_sum, decode_sum], + rewrite [mul_mod_right, if_pos (eq.refl (0 : nat)), nat.mul_div_cancel_left _ aux, + encodable.encodek] + end +| (sum.inr b) := + have aux₁ : 2 > (0:nat), from dec_trivial, + have aux₂ : 1 % 2 = (1:nat), by rewrite [nat.mod_def], + have aux₃ : 1 ≠ (0:nat), from dec_trivial, + begin + esimp [encode_sum, decode_sum], + rewrite [add.comm, add_mul_mod_self_left, aux₂, if_neg aux₃, nat.add_sub_cancel_left, + nat.mul_div_cancel_left _ aux₁, encodable.encodek] + end + +attribute [instance] +definition encodable_sum : encodable (sum A B) := +encodable.mk + (λ s, encode_sum s) + (λ n, decode_sum n) + (λ s, decode_encode_sum s) +end sum + +section prod +variables {A B : Type} +variables [h₁ : encodable A] [h₂ : encodable B] +include h₁ h₂ + +private definition encode_prod : A × B → nat +| (a, b) := mkpair (encode a) (encode b) + +private definition decode_prod (n : nat) : option (A × B) := +match unpair n with +| (n₁, n₂) := + match decode A n₁ with + | some a := + match decode B n₂ with + | some b := some (a, b) + | none := none + end + | none := none + end +end + +private theorem decode_encode_prod : ∀ p : A × B, decode_prod (encode_prod p) = some p +| (a, b) := + begin + esimp [encode_prod, decode_prod, prod.cases_on], + rewrite [unpair_mkpair], + esimp, + rewrite [*encodable.encodek] + end + +attribute [instance] +definition encodable_product : encodable (A × B) := +encodable.mk + encode_prod + decode_prod + decode_encode_prod +end prod + +section list +variables {A : Type} +variables [h : encodable A] +include h + +private definition encode_list_core : list A → nat +| [] := 0 +| (a::l) := mkpair (encode a) (encode_list_core l) + +private theorem encode_list_core_cons (a : A) (l : list A) : encode_list_core (a::l) = mkpair (encode a) (encode_list_core l) := +rfl + +private definition encode_list (l : list A) : nat := +mkpair (length l) (encode_list_core l) + +private definition decode_list_core : nat → nat → option (list A) +| 0 v := some [] +| (succ n) v := + match unpair v with + | (v₁, v₂) := + match decode A v₁ with + | some a := + match decode_list_core n v₂ with + | some l := some (a::l) + | none := none + end + | none := none + end + end + +private theorem decode_list_core_succ (n v : nat) : + decode_list_core (succ n) v = + match unpair v with + | (v₁, v₂) := + match decode A v₁ with + | some a := + match decode_list_core n v₂ with + | some l := some (a::l) + | none := none + end + | none := none + end + end +:= rfl + +private definition decode_list (n : nat) : option (list A) := +match unpair n with +| (l, v) := decode_list_core l v +end + +private theorem decode_encode_list_core : ∀ l : list A, decode_list_core (length l) (encode_list_core l) = some l +| [] := rfl +| (a::l) := + begin + rewrite [encode_list_core_cons, length_cons, add_one (length l), decode_list_core_succ], + rewrite [unpair_mkpair], + esimp [prod.cases_on], + rewrite [decode_encode_list_core l], + rewrite [encodable.encodek], + end + +private theorem decode_encode_list (l : list A) : decode_list (encode_list l) = some l := +begin + esimp [encode_list, decode_list], + rewrite [unpair_mkpair], + esimp [prod.cases_on], + apply decode_encode_list_core +end + +attribute [instance] +definition encodable_list : encodable (list A) := +encodable.mk + encode_list + decode_list + decode_encode_list +end list + +section finset +variable {A : Type} +variable [encA : encodable A] +include encA + +private definition enle (a b : A) : Prop := encode a ≤ encode b + +private lemma enle.refl (a : A) : enle a a := +!le.refl + +private lemma enle.trans (a b c : A) : enle a b → enle b c → enle a c := +assume h₁ h₂, le.trans h₁ h₂ + +private lemma enle.total (a b : A) : enle a b ∨ enle b a := +!le.total + +private lemma enle.antisymm (a b : A) : enle a b → enle b a → a = b := +assume h₁ h₂, +have encode a = encode b, from le.antisymm h₁ h₂, +have decode A (encode a) = decode A (encode b), by rewrite this, +have some a = some b, by rewrite [*encodek at this]; exact this, +option.no_confusion this (λ e, e) + +attribute [instance] +private definition decidable_enle (a b : A) : decidable (enle a b) := +decidable_le (encode a) (encode b) + +variables [decA : decidable_eq A] +include decA + +private definition ensort (l : list A) : list A := +sort enle l + +open subtype perm +private lemma sorted_eq_of_perm {l₁ l₂ : list A} (h : l₁ ~ l₂) : ensort l₁ = ensort l₂ := +list.sort_eq_of_perm_core enle.total enle.trans enle.refl enle.antisymm h + +private definition encode_finset (s : finset A) : nat := +quot.lift_on s + (λ l, encode (ensort (elt_of l))) + (λ l₁ l₂ p, + have elt_of l₁ ~ elt_of l₂, from p, + have ensort (elt_of l₁) = ensort (elt_of l₂), from sorted_eq_of_perm this, + by rewrite this) + +private definition decode_finset (n : nat) : option (finset A) := +match decode (list A) n with +| some l₁ := some (finset.to_finset l₁) +| none := none +end + +private theorem decode_encode_finset (s : finset A) : decode_finset (encode_finset s) = some s := +quot.induction_on s (λ l, + begin + unfold encode_finset, unfold decode_finset, rewrite encodek, esimp, congruence, + apply quot.sound, cases l with l nd, + show erase_dup (ensort l) ~ l, from + have nodup (ensort l), from nodup_of_perm_of_nodup (perm.symm !sort_perm) nd, + calc erase_dup (ensort l) = ensort l : erase_dup_eq_of_nodup this + ... ~ l : sort_perm + end) + +attribute [instance] +definition encodable_finset : encodable (finset A) := +encodable.mk + encode_finset + decode_finset + decode_encode_finset +end finset + +section subtype +open subtype decidable +variable {A : Type} +variable {P : A → Prop} +variable [encA : encodable A] +variable [decP : decidable_pred P] + +include encA +private definition encode_subtype : {a : A | P a} → nat +| (tag v h) := encode v + +include decP +private definition decode_subtype (v : nat) : option {a : A | P a} := +match decode A v with +| some a := if h : P a then some (tag a h) else none +| none := none +end + +private lemma decode_encode_subtype : ∀ s : {a : A | P a}, decode_subtype (encode_subtype s) = some s +| (tag v h) := + begin + unfold [encode_subtype, decode_subtype], rewrite encodek, esimp, + rewrite [dif_pos h] + end + +attribute [instance] +definition encodable_subtype : encodable {a : A | P a} := +encodable.mk + encode_subtype + decode_subtype + decode_encode_subtype +end subtype + +definition encodable_of_left_injection + {A B : Type} [h₁ : encodable A] + (f : B → A) (finv : A → option B) (linv : ∀ b, finv (f b) = some b) : encodable B := +encodable.mk + (λ b, encode (f b)) + (λ n, + match decode A n with + | some a := finv a + | none := none + end) + (λ b, + begin + esimp, + rewrite [encodable.encodek], + esimp [option.cases_on], + rewrite [linv] + end) + +section +open equiv + +definition encodable_of_equiv {A B : Type} [h : encodable A] : A ≃ B → encodable B +| (mk f g l r) := + encodable_of_left_injection g (λ a, some (f a)) + (λ b, by rewrite r; reflexivity) +end + +/- +Choice function for encodable types and decidable predicates. +We provide the following API + +choose {A : Type} {p : A → Prop} [c : encodable A] [d : decidable_pred p] : (∃ x, p x) → A := +choose_spec {A : Type} {p : A → Prop} [c : encodable A] [d : decidable_pred p] (ex : ∃ x, p x) : p (choose ex) := +-/ +section find_a +parameters {A : Type} {p : A → Prop} [c : encodable A] [d : decidable_pred p] +include c +include d + +private definition pn (n : nat) : Prop := +match decode A n with +| some a := p a +| none := false +end + +private definition decidable_pn : decidable_pred pn := +λ n, +match decode A n with +| some a := λ e : decode A n = some a, + match d a with + | decidable.inl t := + begin + unfold pn, rewrite e, esimp [option.cases_on], + exact (decidable.inl t) + end + | decidable.inr f := + begin + unfold pn, rewrite e, esimp [option.cases_on], + exact (decidable.inr f) + end + end +| none := λ e : decode A n = none, + begin + unfold pn, rewrite e, esimp [option.cases_on], + exact decidable_false + end +end (eq.refl (decode A n)) + +private definition ex_pn_of_ex : (∃ x, p x) → (∃ x, pn x) := +assume ex, +obtain (w : A) (pw : p w), from ex, +exists.intro (encode w) + begin + unfold pn, rewrite [encodek], esimp, exact pw + end + +private lemma decode_ne_none_of_pn {n : nat} : pn n → decode A n ≠ none := +assume pnn e, +begin + rewrite [▸ (match decode A n with | some a := p a | none := false end) at pnn], + rewrite [e at pnn], esimp [option.cases_on] at pnn, + exact (false.elim pnn) +end + +open subtype + +private definition of_nat (n : nat) : pn n → { a : A | p a } := +match decode A n with +| some a := λ (e : decode A n = some a), + begin + unfold pn, rewrite e, esimp [option.cases_on], intro pa, + exact (tag a pa) + end +| none := λ (e : decode A n = none) h, absurd e (decode_ne_none_of_pn h) +end (eq.refl (decode A n)) + +private definition find_a : (∃ x, p x) → {a : A | p a} := +suppose ∃ x, p x, +have ∃ x, pn x, from ex_pn_of_ex this, +let r := @nat.find _ decidable_pn this in +have pn r, from @nat.find_spec pn decidable_pn this, +of_nat r this +end find_a + +namespace encodable +open subtype + +definition choose {A : Type} {p : A → Prop} [c : encodable A] [d : decidable_pred p] : (∃ x, p x) → A := +assume ex, elt_of (find_a ex) + +theorem choose_spec {A : Type} {p : A → Prop} [c : encodable A] [d : decidable_pred p] (ex : ∃ x, p x) : p (choose ex) := +has_property (find_a ex) + +theorem axiom_of_choice {A : Type} {B : A → Type} {R : Π x, B x → Prop} [c : Π a, encodable (B a)] [d : ∀ x y, decidable (R x y)] + : (∀x, ∃y, R x y) → ∃f, ∀x, R x (f x) := +assume H, +have ∀x, R x (choose (H x)), from take x, choose_spec (H x), +exists.intro _ this + +theorem skolem {A : Type} {B : A → Type} {P : Π x, B x → Prop} [c : Π a, encodable (B a)] [d : ∀ x y, decidable (P x y)] + : (∀x, ∃y, P x y) ↔ ∃f, (∀x, P x (f x)) := +iff.intro + (suppose (∀ x, ∃y, P x y), axiom_of_choice this) + (suppose (∃ f, (∀x, P x (f x))), + take x, obtain (fw : ∀x, B x) (Hw : ∀x, P x (fw x)), from this, + exists.intro (fw x) (Hw x)) +end encodable + +namespace quot +section +open setoid encodable +parameter {A : Type} +parameter {s : setoid A} +parameter [decR : ∀ a b : A, decidable (a ≈ b)] +parameter [encA : encodable A] +include decR +include encA + +-- Choose equivalence class representative +definition rep (q : quot s) : A := +choose (exists_rep q) + +theorem rep_spec (q : quot s) : ⟦rep q⟧ = q := +choose_spec (exists_rep q) + +private definition encode_quot (q : quot s) : nat := +encode (rep q) + +private definition decode_quot (n : nat) : option (quot s) := +match decode A n with +| some a := some ⟦ a ⟧ +| none := none +end + +private lemma decode_encode_quot (q : quot s) : decode_quot (encode_quot q) = some q := +quot.induction_on q (λ l, begin unfold [encode_quot, decode_quot], rewrite encodek, esimp, rewrite rep_spec end) + +definition encodable_quot : encodable (quot s) := +encodable.mk + encode_quot + decode_quot + decode_encode_quot +end +end quot +attribute quot.encodable_quot [instance] diff --git a/old_library/data/equiv.lean b/old_library/data/equiv.lean new file mode 100644 index 0000000000..f7a5ac8d4e --- /dev/null +++ b/old_library/data/equiv.lean @@ -0,0 +1,411 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +In the standard library we cannot assume the univalence axiom. +We say two types are equivalent if they are isomorphic. + +Two equivalent types have the same cardinality. +-/ +import data.sum data.nat +open function + +structure equiv [class] (A B : Type) := + (to_fun : A → B) + (inv_fun : B → A) + (left_inv : left_inverse inv_fun to_fun) + (right_inv : right_inverse inv_fun to_fun) + +namespace equiv +attribute [reducible] +definition perm (A : Type) := equiv A A + +infix ` ≃ `:50 := equiv + +definition fn {A B : Type} (e : equiv A B) : A → B := +@equiv.to_fun A B e + +infixr ` ∙ `:100 := fn + +definition inv {A B : Type} [e : equiv A B] : B → A := +@equiv.inv_fun A B e + +lemma eq_of_to_fun_eq {A B : Type} : ∀ {e₁ e₂ : equiv A B}, fn e₁ = fn e₂ → e₁ = e₂ +| (mk f₁ g₁ l₁ r₁) (mk f₂ g₂ l₂ r₂) h := + have f₁ = f₂, from h, + have g₁ = g₂, from funext (λ x, + have f₁ (g₁ x) = f₂ (g₂ x), from eq.trans (r₁ x) (eq.symm (r₂ x)), + have f₁ (g₁ x) = f₁ (g₂ x), begin subst f₂, exact this end, + show g₁ x = g₂ x, from injective_of_left_inverse l₁ this), + by congruence; repeat assumption + +attribute [refl] +protected definition refl (A : Type) : A ≃ A := +mk (@id A) (@id A) (λ x, rfl) (λ x, rfl) + +attribute [symm] +protected definition symm {A B : Type} : A ≃ B → B ≃ A +| (mk f g h₁ h₂) := mk g f h₂ h₁ + +attribute [trans] +protected definition trans {A B C : Type} : A ≃ B → B ≃ C → A ≃ C +| (mk f₁ g₁ l₁ r₁) (mk f₂ g₂ l₂ r₂) := + mk (f₂ ∘ f₁) (g₁ ∘ g₂) + (show ∀ x, g₁ (g₂ (f₂ (f₁ x))) = x, by intros; rewrite [l₂, l₁]; reflexivity) + (show ∀ x, f₂ (f₁ (g₁ (g₂ x))) = x, by intros; rewrite [r₁, r₂]; reflexivity) + +abbreviation id {A : Type} := equiv.refl A + +namespace ops + postfix ⁻¹ := equiv.symm + postfix ⁻¹ := equiv.inv + notation e₁ ∘ e₂ := equiv.trans e₂ e₁ +end ops +open equiv.ops + +lemma id_apply {A : Type} (x : A) : id ∙ x = x := +rfl + +lemma comp_apply {A B C : Type} (g : B ≃ C) (f : A ≃ B) (x : A) : (g ∘ f) ∙ x = g ∙ f ∙ x := +begin cases g, cases f, esimp end + +lemma inverse_apply_apply {A B : Type} : ∀ (e : A ≃ B) (x : A), e⁻¹ ∙ e ∙ x = x +| (mk f₁ g₁ l₁ r₁) x := begin unfold [equiv.symm, fn], rewrite l₁ end + +lemma eq_iff_eq_of_injective {A B : Type} {f : A → B} (inj : injective f) (a b : A) : f a = f b ↔ a = b := +iff.intro + (suppose f a = f b, inj this) + (suppose a = b, by rewrite this) + +lemma apply_eq_iff_eq {A B : Type} : ∀ (f : A ≃ B) (x y : A), f ∙ x = f ∙ y ↔ x = y +| (mk f₁ g₁ l₁ r₁) x y := eq_iff_eq_of_injective (injective_of_left_inverse l₁) x y + +lemma apply_eq_iff_eq_inverse_apply {A B : Type} : ∀ (f : A ≃ B) (x : A) (y : B), f ∙ x = y ↔ x = f⁻¹ ∙ y +| (mk f₁ g₁ l₁ r₁) x y := + begin + esimp, unfold [equiv.symm, fn], apply iff.intro, + suppose f₁ x = y, by subst y; rewrite l₁, + suppose x = g₁ y, by subst x; rewrite r₁ + end + +definition false_equiv_empty : empty ≃ false := +mk (λ e, empty.rec _ e) (λ h, false.rec _ h) (λ e, empty.rec _ e) (λ h, false.rec _ h) + +attribute [congr] +definition arrow_congr {A₁ B₁ A₂ B₂ : Type} : A₁ ≃ A₂ → B₁ ≃ B₂ → (A₁ → B₁) ≃ (A₂ → B₂) +| (mk f₁ g₁ l₁ r₁) (mk f₂ g₂ l₂ r₂) := + mk + (λ (h : A₁ → B₁) (a : A₂), f₂ (h (g₁ a))) + (λ (h : A₂ → B₂) (a : A₁), g₂ (h (f₁ a))) + (λ h, funext (λ a, by rewrite [l₁, l₂]; reflexivity)) + (λ h, funext (λ a, by rewrite [r₁, r₂]; reflexivity)) + +section +open unit +attribute [simp] +definition arrow_unit_equiv_unit (A : Type) : (A → unit) ≃ unit := +mk (λ f, star) (λ u, (λ f, star)) + (λ f, funext (λ x, by cases (f x); reflexivity)) + (λ u, by cases u; reflexivity) + +attribute [simp] +definition unit_arrow_equiv (A : Type) : (unit → A) ≃ A := +mk (λ f, f star) (λ a, (λ u, a)) + (λ f, funext (λ x, by cases x; reflexivity)) + (λ u, rfl) + +attribute [simp] +definition empty_arrow_equiv_unit (A : Type) : (empty → A) ≃ unit := +mk (λ f, star) (λ u, λ e, empty.rec _ e) + (λ f, funext (λ x, empty.rec _ x)) + (λ u, by cases u; reflexivity) + +attribute [simp] +definition false_arrow_equiv_unit (A : Type) : (false → A) ≃ unit := +calc (false → A) ≃ (empty → A) : arrow_congr false_equiv_empty !equiv.refl + ... ≃ unit : empty_arrow_equiv_unit +end + +attribute [congr] +definition prod_congr {A₁ B₁ A₂ B₂ : Type} : A₁ ≃ A₂ → B₁ ≃ B₂ → (A₁ × B₁) ≃ (A₂ × B₂) +| (mk f₁ g₁ l₁ r₁) (mk f₂ g₂ l₂ r₂) := + mk + (λ p, match p with (a₁, b₁) := (f₁ a₁, f₂ b₁) end) + (λ p, match p with (a₂, b₂) := (g₁ a₂, g₂ b₂) end) + (λ p, begin cases p, esimp, rewrite [l₁, l₂], reflexivity end) + (λ p, begin cases p, esimp, rewrite [r₁, r₂], reflexivity end) + +attribute [simp] +definition prod_comm (A B : Type) : (A × B) ≃ (B × A) := +mk (λ p, match p with (a, b) := (b, a) end) + (λ p, match p with (b, a) := (a, b) end) + (λ p, begin cases p, esimp end) + (λ p, begin cases p, esimp end) + +attribute [simp] +definition prod_assoc (A B C : Type) : ((A × B) × C) ≃ (A × (B × C)) := +mk (λ t, match t with ((a, b), c) := (a, (b, c)) end) + (λ t, match t with (a, (b, c)) := ((a, b), c) end) + (λ t, begin cases t with ab c, cases ab, esimp end) + (λ t, begin cases t with a bc, cases bc, esimp end) + +section +open unit prod.ops +attribute [simp] +definition prod_unit_right (A : Type) : (A × unit) ≃ A := +mk (λ p, p.1) + (λ a, (a, star)) + (λ p, begin cases p with a u, cases u, esimp end) + (λ a, rfl) + +attribute [simp] +definition prod_unit_left (A : Type) : (unit × A) ≃ A := +calc (unit × A) ≃ (A × unit) : prod_comm + ... ≃ A : prod_unit_right + +attribute [simp] +definition prod_empty_right (A : Type) : (A × empty) ≃ empty := +mk (λ p, empty.rec _ p.2) (λ e, empty.rec _ e) (λ p, empty.rec _ p.2) (λ e, empty.rec _ e) + +attribute [simp] +definition prod_empty_left (A : Type) : (empty × A) ≃ empty := +calc (empty × A) ≃ (A × empty) : prod_comm + ... ≃ empty : prod_empty_right +end + +section +open sum +attribute [congr] +definition sum_congr {A₁ B₁ A₂ B₂ : Type} : A₁ ≃ A₂ → B₁ ≃ B₂ → (A₁ + B₁) ≃ (A₂ + B₂) +| (mk f₁ g₁ l₁ r₁) (mk f₂ g₂ l₂ r₂) := + mk + (λ s, match s with inl a₁ := inl (f₁ a₁) | inr b₁ := inr (f₂ b₁) end) + (λ s, match s with inl a₂ := inl (g₁ a₂) | inr b₂ := inr (g₂ b₂) end) + (λ s, begin cases s, {esimp, rewrite l₁, reflexivity}, {esimp, rewrite l₂, reflexivity} end) + (λ s, begin cases s, {esimp, rewrite r₁, reflexivity}, {esimp, rewrite r₂, reflexivity} end) + +open bool unit +definition bool_equiv_unit_sum_unit : bool ≃ (unit + unit) := +mk (λ b, match b with tt := inl star | ff := inr star end) + (λ s, match s with inl star := tt | inr star := ff end) + (λ b, begin cases b, esimp, esimp end) + (λ s, begin cases s with u u, {cases u, esimp}, {cases u, esimp} end) + +attribute [simp] +definition sum_comm (A B : Type) : (A + B) ≃ (B + A) := +mk (λ s, match s with inl a := inr a | inr b := inl b end) + (λ s, match s with inl b := inr b | inr a := inl a end) + (λ s, begin cases s, esimp, esimp end) + (λ s, begin cases s, esimp, esimp end) + +attribute [simp] +definition sum_assoc (A B C : Type) : ((A + B) + C) ≃ (A + (B + C)) := +mk (λ s, match s with inl (inl a) := inl a | inl (inr b) := inr (inl b) | inr c := inr (inr c) end) + (λ s, match s with inl a := inl (inl a) | inr (inl b) := inl (inr b) | inr (inr c) := inr c end) + (λ s, begin cases s with ab c, cases ab, repeat esimp end) + (λ s, begin cases s with a bc, esimp, cases bc, repeat esimp end) + +attribute [simp] +definition sum_empty_right (A : Type) : (A + empty) ≃ A := +mk (λ s, match s with inl a := a | inr e := empty.rec _ e end) + (λ a, inl a) + (λ s, begin cases s with a e, esimp, exact empty.rec _ e end) + (λ a, rfl) + +attribute [simp] +definition sum_empty_left (A : Type) : (empty + A) ≃ A := +calc (empty + A) ≃ (A + empty) : sum_comm + ... ≃ A : sum_empty_right +end + +section +open prod.ops +definition arrow_prod_equiv_prod_arrow (A B C : Type) : (C → A × B) ≃ ((C → A) × (C → B)) := +mk (λ f, (λ c, (f c).1, λ c, (f c).2)) + (λ p, λ c, (p.1 c, p.2 c)) + (λ f, funext (λ c, begin esimp, cases f c, esimp end)) + (λ p, begin cases p, esimp end) + +definition arrow_arrow_equiv_prod_arrow (A B C : Type) : (A → B → C) ≃ (A × B → C) := +mk (λ f, λ p, f p.1 p.2) + (λ f, λ a b, f (a, b)) + (λ f, rfl) + (λ f, funext (λ p, begin cases p, esimp end)) + +open sum +definition sum_arrow_equiv_prod_arrow (A B C : Type) : ((A + B) → C) ≃ ((A → C) × (B → C)) := +mk (λ f, (λ a, f (inl a), λ b, f (inr b))) + (λ p, (λ s, match s with inl a := p.1 a | inr b := p.2 b end)) + (λ f, funext (λ s, begin cases s, esimp, esimp end)) + (λ p, begin cases p, esimp end) + +definition sum_prod_distrib (A B C : Type) : ((A + B) × C) ≃ ((A × C) + (B × C)) := +mk (λ p, match p with (inl a, c) := inl (a, c) | (inr b, c) := inr (b, c) end) + (λ s, match s with inl (a, c) := (inl a, c) | inr (b, c) := (inr b, c) end) + (λ p, begin cases p with ab c, cases ab, repeat esimp end) + (λ s, begin cases s with ac bc, cases ac, esimp, cases bc, esimp end) + +definition prod_sum_distrib (A B C : Type) : (A × (B + C)) ≃ ((A × B) + (A × C)) := +calc (A × (B + C)) ≃ ((B + C) × A) : prod_comm + ... ≃ ((B × A) + (C × A)) : sum_prod_distrib + ... ≃ ((A × B) + (A × C)) : sum_congr !prod_comm !prod_comm + +definition bool_prod_equiv_sum (A : Type) : (bool × A) ≃ (A + A) := +calc (bool × A) ≃ ((unit + unit) × A) : prod_congr bool_equiv_unit_sum_unit !equiv.refl + ... ≃ (A × (unit + unit)) : prod_comm + ... ≃ ((A × unit) + (A × unit)) : prod_sum_distrib + ... ≃ (A + A) : sum_congr !prod_unit_right !prod_unit_right +end + +section +open sum nat unit prod.ops +definition nat_equiv_nat_sum_unit : nat ≃ (nat + unit) := +mk (λ n, match n with zero := inr star | succ a := inl a end) + (λ s, match s with inl n := succ n | inr star := zero end) + (λ n, begin cases n, repeat esimp end) + (λ s, begin cases s with a u, esimp, {cases u, esimp} end) + +attribute [simp] +definition nat_sum_unit_equiv_nat : (nat + unit) ≃ nat := +equiv.symm nat_equiv_nat_sum_unit + +attribute [simp] +definition nat_prod_nat_equiv_nat : (nat × nat) ≃ nat := +mk (λ p, mkpair p.1 p.2) + (λ n, unpair n) + (λ p, begin cases p, apply unpair_mkpair end) + (λ n, mkpair_unpair n) + +attribute [simp] +definition nat_sum_bool_equiv_nat : (nat + bool) ≃ nat := +calc (nat + bool) ≃ (nat + (unit + unit)) : sum_congr !equiv.refl bool_equiv_unit_sum_unit + ... ≃ ((nat + unit) + unit) : sum_assoc + ... ≃ (nat + unit) : sum_congr nat_sum_unit_equiv_nat !equiv.refl + ... ≃ nat : nat_sum_unit_equiv_nat + +open decidable +attribute [simp] +definition nat_sum_nat_equiv_nat : (nat + nat) ≃ nat := +mk (λ s, match s with inl n := 2*n | inr n := 2*n+1 end) + (λ n, if even n then inl (n / 2) else inr ((n - 1) / 2)) + (λ s, begin + have two_gt_0 : 2 > zero, from dec_trivial, + cases s, + {esimp, rewrite [if_pos (even_two_mul _), nat.mul_div_cancel_left _ two_gt_0]}, + {esimp, rewrite [if_neg (not_even_two_mul_plus_one _), nat.add_sub_cancel, + nat.mul_div_cancel_left _ two_gt_0]} + end) + (λ n, by_cases + (λ h : even n, + by rewrite [if_pos h]; esimp; rewrite [nat.mul_div_cancel' (dvd_of_even h)]) + (λ h : ¬ even n, + begin + rewrite [if_neg h], esimp, + cases n, + {exact absurd even_zero h}, + {rewrite [-(add_one a), nat.add_sub_cancel, + nat.mul_div_cancel' (dvd_of_even (even_of_odd_succ (odd_of_not_even h)))]} + end)) + +definition prod_equiv_of_equiv_nat {A : Type} : A ≃ nat → (A × A) ≃ A := +take e, calc + (A × A) ≃ (nat × nat) : prod_congr e e + ... ≃ nat : nat_prod_nat_equiv_nat + ... ≃ A : equiv.symm e +end + +section +open decidable +definition decidable_eq_of_equiv {A B : Type} [h : decidable_eq A] : A ≃ B → decidable_eq B +| (mk f g l r) := + take b₁ b₂, match h (g b₁) (g b₂) with + | inl he := inl (have aux : f (g b₁) = f (g b₂), from congr_arg f he, + begin rewrite *r at aux, exact aux end) + | inr hn := inr (λ b₁eqb₂, by subst b₁eqb₂; exact absurd rfl hn) + end +end + +definition inhabited_of_equiv {A B : Type} [h : inhabited A] : A ≃ B → inhabited B +| (mk f g l r) := inhabited.mk (f (inhabited.value h)) + +section +open subtype +definition subtype_equiv_of_subtype {A B : Type} {p : A → Prop} : A ≃ B → {a : A | p a} ≃ {b : B | p b⁻¹} +| (mk f g l r) := + mk (λ s, match s with tag v h := tag (f v) (eq.rec_on (eq.symm (l v)) h) end) + (λ s, match s with tag v h := tag (g v) (eq.rec_on (eq.symm (r v)) h) end) + (λ s, begin cases s, esimp, congruence, rewrite l, reflexivity end) + (λ s, begin cases s, esimp, congruence, rewrite r, reflexivity end) +end + +section swap +variable {A : Type} +variable [h : decidable_eq A] +include h +open decidable + +definition swap_core (a b r : A) : A := +if r = a then b +else if r = b then a +else r + +lemma swap_core_swap_core (r a b : A) : swap_core a b (swap_core a b r) = r := +by_cases + (suppose r = a, by_cases + (suppose r = b, begin unfold swap_core, rewrite [if_pos `r = a`, if_pos (eq.refl b), -`r = a`, -`r = b`, if_pos (eq.refl r)] end) + (suppose ¬ r = b, + have b ≠ a, from assume h, begin rewrite h at this, contradiction end, + begin unfold swap_core, rewrite [*if_pos `r = a`, if_pos (eq.refl b), if_neg `b ≠ a`, `r = a`] end)) + (suppose ¬ r = a, by_cases + (suppose r = b, begin unfold swap_core, rewrite [if_neg `¬ r = a`, *if_pos `r = b`, if_pos (eq.refl a), this] end) + (suppose ¬ r = b, begin unfold swap_core, rewrite [*if_neg `¬ r = a`, *if_neg `¬ r = b`, if_neg `¬ r = a`] end)) + +lemma swap_core_self (r a : A) : swap_core a a r = r := +by_cases + (suppose r = a, begin unfold swap_core, rewrite [*if_pos this, this] end) + (suppose r ≠ a, begin unfold swap_core, rewrite [*if_neg this] end) + +lemma swap_core_comm (r a b : A) : swap_core a b r = swap_core b a r := +by_cases + (suppose r = a, by_cases + (suppose r = b, begin unfold swap_core, rewrite [if_pos `r = a`, if_pos `r = b`, -`r = a`, -`r = b`] end) + (suppose ¬ r = b, begin unfold swap_core, rewrite [*if_pos `r = a`, if_neg `¬ r = b`] end)) + (suppose ¬ r = a, by_cases + (suppose r = b, begin unfold swap_core, rewrite [if_neg `¬ r = a`, *if_pos `r = b`] end) + (suppose ¬ r = b, begin unfold swap_core, rewrite [*if_neg `¬ r = a`, *if_neg `¬ r = b`] end)) + +definition swap (a b : A) : perm A := +mk (swap_core a b) + (swap_core a b) + (λ x, abstract by rewrite swap_core_swap_core end) + (λ x, abstract by rewrite swap_core_swap_core end) + +lemma swap_self (a : A) : swap a a = id := +eq_of_to_fun_eq (funext (λ x, begin unfold [swap, fn], rewrite swap_core_self end)) + +lemma swap_comm (a b : A) : swap a b = swap b a := +eq_of_to_fun_eq (funext (λ x, begin unfold [swap, fn], rewrite swap_core_comm end)) + +lemma swap_apply_def (a b : A) (x : A) : swap a b ∙ x = if x = a then b else if x = b then a else x := +rfl + +lemma swap_apply_left (a b : A) : swap a b ∙ a = b := +if_pos rfl + +lemma swap_apply_right (a b : A) : swap a b ∙ b = a := +by_cases + (suppose b = a, by rewrite [swap_apply_def, this, *if_pos rfl]) + (suppose b ≠ a, by rewrite [swap_apply_def, if_pos rfl, if_neg this]) + +lemma swap_apply_of_ne_of_ne {a b : A} {x : A} : x ≠ a → x ≠ b → swap a b ∙ x = x := +assume h₁ h₂, by rewrite [swap_apply_def, if_neg h₁, if_neg h₂] + +lemma swap_swap (a b : A) : swap a b ∘ swap a b = id := +eq_of_to_fun_eq (funext (λ x, begin unfold [swap, fn, equiv.trans, equiv.refl], rewrite swap_core_swap_core end)) + +lemma swap_comp_apply (a b : A) (π : perm A) (x : A) : (swap a b ∘ π) ∙ x = if π ∙ x = a then b else if π ∙ x = b then a else π ∙ x := +begin cases π, reflexivity end + +end swap +end equiv diff --git a/old_library/data/examples/depchoice.lean b/old_library/data/examples/depchoice.lean new file mode 100644 index 0000000000..4dd12d1ffe --- /dev/null +++ b/old_library/data/examples/depchoice.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +import data.encodable +open nat encodable + +/- +In mathematics, the axiom of dependent choice is a weak form of the axiom of choice that is +sufficient to develop most of real analysis. See http://en.wikipedia.org/wiki/Axiom_of_dependent_choice. +We can state it as follows: +-/ +definition dependent_choice {A : Type} (R : A → A → Prop) := +(∀ a : A, ∃ b : A, R a b) → (∀ a : A, ∃ f : nat → A, f 0 = a ∧ ∀ n, R (f n) (f (n+1))) + +/- +If A is an encodable type, and R is a decidable relation, we can prove (dependent_choice R) using the +constructive choice function "choose" +-/ +section depchoice + parameters {A : Type} {R : A → A → Prop} + parameters [encA : encodable A] [decR : decidable_rel R] + include encA decR + + local infix `~` := R + + private definition f_aux (a : A) (H : ∀ a, ∃ b, a ~ b) : nat → A + | 0 := a + | (n+1) := choose (H (f_aux n)) + + theorem dependent_choice_of_encodable_of_decidable : dependent_choice R := + assume H : ∀ a, ∃ b, a ~ b, + take a : A, + let f : nat → A := f_aux a H in + have f_zero : f 0 = a, from rfl, + have R_seq : ∀ n, f n ~ f (n+1), from + take n, show f n ~ choose (H (f n)), from !choose_spec, + exists.intro f (and.intro f_zero R_seq) + + /- + The following slightly stronger version can be proved, where we also "return" the constructed function f. + We just have to use Σ instead of ∃, and use Σ-constructor instead of exists.intro. + Recall that ⟨f, H⟩ is notation for (sigma.mk f H) + -/ + theorem stronger_dependent_choice_of_encodable_of_decidable + : (∀ a, ∃ b, R a b) → (∀ a, Σ f, f (0:nat) = a ∧ ∀ n, f n ~ f (n+1)) := + assume H : ∀ a, ∃ b, a ~ b, + take a : A, + let f : nat → A := f_aux a H in + have f_zero : f 0 = a, from rfl, + have R_seq : ∀ n, f n ~ f (n+1), from + take n, show f n ~ choose (H (f n)), from !choose_spec, + ⟨f, and.intro f_zero R_seq⟩ + +end depchoice + +/- +If we encode dependent_choice using Σ instead of ∃. +Then, we can prove this version without using any extra hypothesis (e.g., A is encodable or R is decidable). +The function f can be constructed directly from the hypothesis: ∀ a : A, Σ b : A, R a b +because Σ "carries" the witness 'b'. That is, we don't have to search for anything using "choose". +-/ +open sigma.ops + +section sigma_depchoice + parameters {A : Type} {R : A → A → Prop} + local infix `~` := R + + private definition f_aux (a : A) (H : ∀ a, Σ b, a ~ b) : nat → A + | 0 := a + | (n+1) := (H (f_aux n)).1 + + theorem sigma_dependent_choice : (∀ a, Σ b, R a b) → (∀ a, Σ f, f (0:nat) = a ∧ ∀ n, f n ~ f (n+1)) := + assume H : ∀ a, Σ b, a ~ b, + take a : A, + let f : nat → A := f_aux a H in + have f_zero : f 0 = a, from rfl, + have R_seq : ∀ n, f n ~ f (n+1), from take n, (H (f n)).2, + ⟨f, and.intro f_zero R_seq⟩ +end sigma_depchoice diff --git a/old_library/data/examples/notencodable.lean b/old_library/data/examples/notencodable.lean new file mode 100644 index 0000000000..c751420847 --- /dev/null +++ b/old_library/data/examples/notencodable.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Small example showing that (nat → nat) is not encodable. +-/ +import data.encodable +open nat encodable option + +section +hypothesis nat_nat_encodable : encodable (nat → nat) + +private definition decode_fun (n : nat) : option (nat → nat) := +@decode (nat → nat) nat_nat_encodable n + +private definition encode_fun (f : nat → nat) : nat := +@encode (nat → nat) nat_nat_encodable f + +private lemma encodek_fun : ∀ f : nat → nat, decode_fun (encode_fun f) = some f := +λ f, !encodek + +private definition f (n : nat) : nat := +match decode_fun n with +| some g := succ (g n) +| none := 0 +end + +private definition v : nat := encode_fun f + +private lemma f_eq : succ (f v) = f v := +begin + change succ (f v) = + match decode_fun (encode_fun f) with + | some g := succ (g v) + | none := 0 + end, + rewrite encodek_fun +end +end + +theorem not_encodable_nat_arrow_nat : (encodable (nat → nat)) → false := +assume h, absurd (f_eq h) succ_ne_self diff --git a/old_library/data/examples/vector.lean b/old_library/data/examples/vector.lean new file mode 100644 index 0000000000..7a392c6662 --- /dev/null +++ b/old_library/data/examples/vector.lean @@ -0,0 +1,345 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Floris van Doorn, Leonardo de Moura + +This file demonstrates how to encode vectors using indexed inductive families. +In standard library we do not use this approach. +-/ +import data.nat data.list data.fin +open nat prod fin + +inductive vector (A : Type) : nat → Type := +| nil {} : vector A zero +| cons : Π {n}, A → vector A n → vector A (succ n) + +namespace vector + notation a :: b := cons a b + notation `[` l:(foldr `, ` (h t, cons h t) nil `]`) := l + + variables {A B C : Type} + + attribute [instance] + protected definition is_inhabited [h : inhabited A] : ∀ (n : nat), inhabited (vector A n) + | 0 := inhabited.mk [] + | (n+1) := inhabited.mk (inhabited.value h :: inhabited.value (is_inhabited n)) + + theorem vector0_eq_nil : ∀ (v : vector A 0), v = [] + | [] := rfl + + definition head : Π {n : nat}, vector A (succ n) → A + | n (a::v) := a + + definition tail : Π {n : nat}, vector A (succ n) → vector A n + | n (a::v) := v + + theorem head_cons {n : nat} (h : A) (t : vector A n) : head (h :: t) = h := + rfl + + theorem tail_cons {n : nat} (h : A) (t : vector A n) : tail (h :: t) = t := + rfl + + theorem eta : ∀ {n : nat} (v : vector A (succ n)), head v :: tail v = v + | n (a::v) := rfl + + definition last : Π {n : nat}, vector A (succ n) → A + | last [a] := a + | last (a::v) := last v + + theorem last_singleton (a : A) : last [a] = a := + rfl + + theorem last_cons {n : nat} (a : A) (v : vector A (succ n)) : last (a :: v) = last v := + rfl + + definition const : Π (n : nat), A → vector A n + | 0 a := [] + | (succ n) a := a :: const n a + + theorem head_const (n : nat) (a : A) : head (const (succ n) a) = a := + rfl + + theorem last_const : ∀ (n : nat) (a : A), last (const (succ n) a) = a + | 0 a := rfl + | (n+1) a := last_const n a + + definition nth : Π {n : nat}, vector A n → fin n → A + | ⌞0⌟ [] i := elim0 i + | ⌞n+1⌟ (a :: v) (mk 0 _) := a + | ⌞n+1⌟ (a :: v) (mk (succ i) h) := nth v (mk_pred i h) + + lemma nth_zero {n : nat} (a : A) (v : vector A n) (h : 0 < succ n) : nth (a::v) (mk 0 h) = a := + rfl + + lemma nth_succ {n : nat} (a : A) (v : vector A n) (i : nat) (h : succ i < succ n) + : nth (a::v) (mk (succ i) h) = nth v (mk_pred i h) := + rfl + + definition tabulate : Π {n : nat}, (fin n → A) → vector A n + | 0 f := [] + | (n+1) f := f (fin.zero n) :: tabulate (λ i : fin n, f (succ i)) + + theorem nth_tabulate : ∀ {n : nat} (f : fin n → A) (i : fin n), nth (tabulate f) i = f i + | 0 f i := elim0 i + | (n+1) f (mk 0 h) := by reflexivity + | (n+1) f (mk (succ i) h) := + begin + change nth (f (fin.zero n) :: tabulate (λ i : fin n, f (succ i))) (mk (succ i) h) = f (mk (succ i) h), + rewrite nth_succ, + rewrite nth_tabulate + end + + definition map (f : A → B) : Π {n : nat}, vector A n → vector B n + | map [] := [] + | map (a::v) := f a :: map v + + theorem map_nil (f : A → B) : map f [] = [] := + rfl + + theorem map_cons {n : nat} (f : A → B) (h : A) (t : vector A n) : map f (h :: t) = f h :: map f t := + rfl + + theorem nth_map (f : A → B) : ∀ {n : nat} (v : vector A n) (i : fin n), nth (map f v) i = f (nth v i) + | 0 v i := elim0 i + | (succ n) (a :: t) (mk 0 h) := by reflexivity + | (succ n) (a :: t) (mk (succ i) h) := by rewrite [map_cons, *nth_succ, nth_map] + + section + open function + theorem map_id : ∀ {n : nat} (v : vector A n), map id v = v + | 0 [] := rfl + | (succ n) (x::xs) := by rewrite [map_cons, map_id] + + theorem map_map (g : B → C) (f : A → B) : ∀ {n :nat} (v : vector A n), map g (map f v) = map (g ∘ f) v + | 0 [] := rfl + | (succ n) (a :: l) := + show (g ∘ f) a :: map g (map f l) = map (g ∘ f) (a :: l), + by rewrite (map_map l) + end + + definition map2 (f : A → B → C) : Π {n : nat}, vector A n → vector B n → vector C n + | map2 [] [] := [] + | map2 (a::va) (b::vb) := f a b :: map2 va vb + + theorem map2_nil (f : A → B → C) : map2 f [] [] = [] := + rfl + + theorem map2_cons {n : nat} (f : A → B → C) (h₁ : A) (h₂ : B) (t₁ : vector A n) (t₂ : vector B n) : + map2 f (h₁ :: t₁) (h₂ :: t₂) = f h₁ h₂ :: map2 f t₁ t₂ := + rfl + + definition append : Π {n m : nat}, vector A n → vector A m → vector A (n ⊕ m) + | 0 m [] w := w + | (succ n) m (a::v) w := a :: (append v w) + + theorem append_nil_left {n : nat} (v : vector A n) : append [] v = v := + rfl + + theorem append_cons {n m : nat} (h : A) (t : vector A n) (v : vector A m) : + append (h::t) v = h :: (append t v) := + rfl + + theorem map_append (f : A → B) : ∀ {n m : nat} (v : vector A n) (w : vector A m), map f (append v w) = append (map f v) (map f w) + | 0 m [] w := rfl + | (n+1) m (h :: t) w := + begin + change (f h :: map f (append t w) = f h :: append (map f t) (map f w)), + rewrite map_append + end + + definition unzip : Π {n : nat}, vector (A × B) n → vector A n × vector B n + | unzip [] := ([], []) + | unzip ((a, b) :: v) := (a :: pr₁ (unzip v), b :: pr₂ (unzip v)) + + theorem unzip_nil : unzip (@nil (A × B)) = ([], []) := + rfl + + theorem unzip_cons {n : nat} (a : A) (b : B) (v : vector (A × B) n) : + unzip ((a, b) :: v) = (a :: pr₁ (unzip v), b :: pr₂ (unzip v)) := + rfl + + definition zip : Π {n : nat}, vector A n → vector B n → vector (A × B) n + | zip [] [] := [] + | zip (a::va) (b::vb) := ((a, b) :: zip va vb) + + theorem zip_nil_nil : zip (@nil A) (@nil B) = nil := + rfl + + theorem zip_cons_cons {n : nat} (a : A) (b : B) (va : vector A n) (vb : vector B n) : + zip (a::va) (b::vb) = ((a, b) :: zip va vb) := + rfl + + theorem unzip_zip : ∀ {n : nat} (v₁ : vector A n) (v₂ : vector B n), unzip (zip v₁ v₂) = (v₁, v₂) + | 0 [] [] := rfl + | (n+1) (a::va) (b::vb) := calc + unzip (zip (a :: va) (b :: vb)) + = (a :: pr₁ (unzip (zip va vb)), b :: pr₂ (unzip (zip va vb))) : rfl + ... = (a :: pr₁ (va, vb), b :: pr₂ (va, vb)) : by rewrite unzip_zip + ... = (a :: va, b :: vb) : rfl + + theorem zip_unzip : ∀ {n : nat} (v : vector (A × B) n), zip (pr₁ (unzip v)) (pr₂ (unzip v)) = v + | 0 [] := rfl + | (n+1) ((a, b) :: v) := calc + zip (pr₁ (unzip ((a, b) :: v))) (pr₂ (unzip ((a, b) :: v))) + = (a, b) :: zip (pr₁ (unzip v)) (pr₂ (unzip v)) : rfl + ... = (a, b) :: v : by rewrite zip_unzip + + /- Concat -/ + + definition concat : Π {n : nat}, vector A n → A → vector A (succ n) + | concat [] a := [a] + | concat (b::v) a := b :: concat v a + + theorem concat_nil (a : A) : concat [] a = [a] := + rfl + + theorem concat_cons {n : nat} (b : A) (v : vector A n) (a : A) : concat (b :: v) a = b :: concat v a := + rfl + + theorem last_concat : ∀ {n : nat} (v : vector A n) (a : A), last (concat v a) = a + | 0 [] a := rfl + | (n+1) (b::v) a := calc + last (concat (b::v) a) = last (concat v a) : rfl + ... = a : last_concat v a + + /- Reverse -/ + + definition reverse : Π {n : nat}, vector A n → vector A n + | 0 [] := [] + | (n+1) (x :: xs) := concat (reverse xs) x + + theorem reverse_concat : Π {n : nat} (xs : vector A n) (a : A), reverse (concat xs a) = a :: reverse xs + | 0 [] a := rfl + | (n+1) (x :: xs) a := + begin + change (concat (reverse (concat xs a)) x = a :: reverse (x :: xs)), + rewrite reverse_concat + end + + theorem reverse_reverse : Π {n : nat} (xs : vector A n), reverse (reverse xs) = xs + | 0 [] := rfl + | (n+1) (x :: xs) := + begin + change (reverse (concat (reverse xs) x) = x :: xs), + rewrite [reverse_concat, reverse_reverse] + end + + /- list <-> vector -/ + + definition of_list : Π (l : list A), vector A (list.length l) + | list.nil := [] + | (list.cons a l) := a :: (of_list l) + + definition to_list : Π {n : nat}, vector A n → list A + | 0 [] := list.nil + | (n+1) (a :: vs) := list.cons a (to_list vs) + + theorem to_list_of_list : ∀ (l : list A), to_list (of_list l) = l + | list.nil := rfl + | (list.cons a l) := + begin + change (list.cons a (to_list (of_list l)) = list.cons a l), + rewrite to_list_of_list + end + + theorem to_list_nil : to_list [] = (list.nil : list A) := + rfl + + theorem length_to_list : ∀ {n : nat} (v : vector A n), list.length (to_list v) = n + | 0 [] := rfl + | (n+1) (a :: vs) := + begin + change (succ (list.length (to_list vs)) = succ n), + rewrite length_to_list + end + + theorem heq_of_list_eq : ∀ {n m} {v₁ : vector A n} {v₂ : vector A m}, to_list v₁ = to_list v₂ → n = m → v₁ == v₂ + | 0 0 [] [] h₁ h₂ := !heq.refl + | 0 (m+1) [] (y::ys) h₁ h₂ := by contradiction + | (n+1) 0 (x::xs) [] h₁ h₂ := by contradiction + | (n+1) (m+1) (x::xs) (y::ys) h₁ h₂ := + have e₁ : n = m, from succ.inj h₂, + have e₂ : x = y, begin unfold to_list at h₁, injection h₁, assumption end, + have e₃ : to_list xs = to_list ys, begin unfold to_list at h₁, injection h₁, assumption end, + have xs == ys, from heq_of_list_eq e₃ e₁, + have y :: xs == y :: ys, begin clear heq_of_list_eq h₁ h₂ e₃, revert xs ys this, induction e₁, intro xs ys h, rewrite [eq_of_heq h] end, + show x :: xs == y :: ys, by rewrite e₂; exact this + + theorem list_eq_of_heq {n m} {v₁ : vector A n} {v₂ : vector A m} : v₁ == v₂ → n = m → to_list v₁ = to_list v₂ := + begin + intro h₁ h₂, revert v₁ v₂ h₁, + subst n, intro v₁ v₂ h₁, rewrite [eq_of_heq h₁] + end + + theorem of_list_to_list {n : nat} (v : vector A n) : of_list (to_list v) == v := + begin + apply heq_of_list_eq, rewrite to_list_of_list, rewrite length_to_list + end + + theorem to_list_append : ∀ {n m : nat} (v₁ : vector A n) (v₂ : vector A m), to_list (append v₁ v₂) = list.append (to_list v₁) (to_list v₂) + | 0 m [] ys := rfl + | (succ n) m (x::xs) ys := begin unfold append, unfold to_list at {1,2}, krewrite [to_list_append xs ys] end + + theorem to_list_map (f : A → B) : ∀ {n : nat} (v : vector A n), to_list (map f v) = list.map f (to_list v) + | 0 [] := rfl + | (succ n) (x::xs) := begin unfold [map, to_list], rewrite to_list_map end + + theorem to_list_concat : ∀ {n : nat} (v : vector A n) (a : A), to_list (concat v a) = list.concat a (to_list v) + | 0 [] a := rfl + | (succ n) (x::xs) a := begin unfold [concat, to_list], rewrite to_list_concat end + + theorem to_list_reverse : ∀ {n : nat} (v : vector A n), to_list (reverse v) = list.reverse (to_list v) + | 0 [] := rfl + | (succ n) (x::xs) := begin unfold [reverse], rewrite [to_list_concat, to_list_reverse] end + + theorem append_nil_right {n : nat} (v : vector A n) : append v [] == v := + begin + apply heq_of_list_eq, + rewrite [to_list_append, to_list_nil, list.append_nil_right], + rewrite [-add_eq_addl] + end + + theorem append.assoc {n₁ n₂ n₃ : nat} (v₁ : vector A n₁) (v₂ : vector A n₂) (v₃ : vector A n₃) : append v₁ (append v₂ v₃) == append (append v₁ v₂) v₃ := + begin + apply heq_of_list_eq, + rewrite [*to_list_append, list.append.assoc], + rewrite [-*add_eq_addl, add.assoc] + end + + theorem reverse_append {n m : nat} (v : vector A n) (w : vector A m) : reverse (append v w) == append (reverse w) (reverse v) := + begin + apply heq_of_list_eq, + rewrite [to_list_reverse, to_list_append, list.reverse_append, to_list_append, *to_list_reverse], + rewrite [-*add_eq_addl, add.comm] + end + + theorem concat_eq_append {n : nat} (v : vector A n) (a : A) : concat v a == append v [a] := + begin + apply heq_of_list_eq, + rewrite [to_list_concat, to_list_append, list.concat_eq_append], + rewrite [-add_eq_addl] + end + + /- decidable equality -/ + open decidable + definition decidable_eq [H : decidable_eq A] : ∀ {n : nat} (v₁ v₂ : vector A n), decidable (v₁ = v₂) + | ⌞0⌟ [] [] := by left; reflexivity + | ⌞n+1⌟ (a::v₁) (b::v₂) := + match H a b with + | inl Hab := + match decidable_eq v₁ v₂ with + | inl He := by left; congruence; repeat assumption + | inr Hn := by right; intro h; injection h; contradiction + end + | inr Hnab := by right; intro h; injection h; contradiction + end + + section + open equiv function + definition vector_equiv_of_equiv {A B : Type} : A ≃ B → ∀ n, vector A n ≃ vector B n + | (mk f g l r) n := + mk (map f) (map g) + begin intros, rewrite [map_map, id_of_left_inverse l, map_id], reflexivity end + begin intros, rewrite [map_map, id_of_right_inverse r, map_id], reflexivity end + end +end vector diff --git a/old_library/data/finset/basic.lean b/old_library/data/finset/basic.lean new file mode 100644 index 0000000000..625cf405e6 --- /dev/null +++ b/old_library/data/finset/basic.lean @@ -0,0 +1,740 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura, Jeremy Avigad + +Finite sets. +-/ +import data.fintype.basic data.nat data.list.perm algebra.binary +open nat quot list subtype binary function eq.ops +open [decl] perm + +definition nodup_list (A : Type) := {l : list A | nodup l} + +variable {A : Type} + +definition to_nodup_list_of_nodup {l : list A} (n : nodup l) : nodup_list A := +tag l n + +definition to_nodup_list [decidable_eq A] (l : list A) : nodup_list A := +@to_nodup_list_of_nodup A (erase_dup l) (nodup_erase_dup l) + +private definition eqv (l₁ l₂ : nodup_list A) := +perm (elt_of l₁) (elt_of l₂) + +local infix ~ := eqv + +private definition eqv.refl (l : nodup_list A) : l ~ l := +!perm.refl + +private definition eqv.symm {l₁ l₂ : nodup_list A} : l₁ ~ l₂ → l₂ ~ l₁ := +perm.symm + +private definition eqv.trans {l₁ l₂ l₃ : nodup_list A} : l₁ ~ l₂ → l₂ ~ l₃ → l₁ ~ l₃ := +perm.trans + +attribute [instance] +definition finset.nodup_list_setoid (A : Type) : setoid (nodup_list A) := +setoid.mk (@eqv A) (mk_equivalence (@eqv A) (@eqv.refl A) (@eqv.symm A) (@eqv.trans A)) + +definition finset (A : Type) : Type := +quot (finset.nodup_list_setoid A) + +namespace finset + +-- give finset notation higher priority than set notation, so that it is tried first +protected definition prio : num := num.succ std.priority.default + +definition to_finset_of_nodup (l : list A) (n : nodup l) : finset A := +⟦to_nodup_list_of_nodup n⟧ + +definition to_finset [decidable_eq A] (l : list A) : finset A := +⟦to_nodup_list l⟧ + +lemma to_finset_eq_of_nodup [decidable_eq A] {l : list A} (n : nodup l) : + to_finset_of_nodup l n = to_finset l := +have P : to_nodup_list_of_nodup n = to_nodup_list l, from + begin + rewrite [↑to_nodup_list, ↑to_nodup_list_of_nodup], + congruence, + rewrite [erase_dup_eq_of_nodup n] + end, +quot.sound (eq.subst P !setoid.refl) + +attribute [instance] +definition has_decidable_eq [decidable_eq A] : decidable_eq (finset A) := +λ s₁ s₂, quot.rec_on_subsingleton₂ s₁ s₂ + (λ l₁ l₂, + match decidable_perm (elt_of l₁) (elt_of l₂) with + | decidable.inl e := decidable.inl (quot.sound e) + | decidable.inr n := decidable.inr (λ e : ⟦l₁⟧ = ⟦l₂⟧, absurd (quot.exact e) n) + end) + +definition mem (a : A) (s : finset A) : Prop := +quot.lift_on s (λ l, a ∈ elt_of l) + (λ l₁ l₂ (e : l₁ ~ l₂), propext (iff.intro + (λ ainl₁, mem_perm e ainl₁) + (λ ainl₂, mem_perm (perm.symm e) ainl₂))) + +infix [priority finset.prio] ∈ := mem +notation [priority finset.prio] a ∉ b := ¬ mem a b + +theorem mem_of_mem_list {a : A} {l : nodup_list A} : a ∈ elt_of l → a ∈ ⟦l⟧ := +λ ainl, ainl + +theorem mem_list_of_mem {a : A} {l : nodup_list A} : a ∈ ⟦l⟧ → a ∈ elt_of l := +λ ainl, ainl + +attribute [instance] +definition decidable_mem [h : decidable_eq A] : ∀ (a : A) (s : finset A), decidable (a ∈ s) := +λ a s, quot.rec_on_subsingleton s + (λ l, match list.decidable_mem a (elt_of l) with + | decidable.inl p := decidable.inl (mem_of_mem_list p) + | decidable.inr n := decidable.inr (λ p, absurd (mem_list_of_mem p) n) + end) + +theorem mem_to_finset [decidable_eq A] {a : A} {l : list A} : a ∈ l → a ∈ to_finset l := +λ ainl, mem_erase_dup ainl + +theorem mem_to_finset_of_nodup {a : A} {l : list A} (n : nodup l) : a ∈ l → a ∈ to_finset_of_nodup l n := +λ ainl, ainl + +/- extensionality -/ +theorem ext {s₁ s₂ : finset A} : (∀ a, a ∈ s₁ ↔ a ∈ s₂) → s₁ = s₂ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ e, quot.sound (perm_ext (has_property l₁) (has_property l₂) e)) + +/- empty -/ +definition empty : finset A := +to_finset_of_nodup [] nodup_nil + +notation [priority finset.prio] `∅` := !empty + +attribute [simp] +theorem not_mem_empty (a : A) : a ∉ ∅ := +λ aine : a ∈ ∅, aine + +attribute [simp] +theorem mem_empty_iff (x : A) : x ∈ ∅ ↔ false := +iff_false_intro !not_mem_empty + +theorem mem_empty_eq (x : A) : x ∈ ∅ = false := +propext !mem_empty_iff + +theorem eq_empty_of_forall_not_mem {s : finset A} (H : ∀x, ¬ x ∈ s) : s = ∅ := +ext (take x, iff_false_intro (H x)) + +/- universe -/ +definition univ [h : fintype A] : finset A := +to_finset_of_nodup (@fintype.elems A h) (@fintype.unique A h) + +theorem mem_univ [fintype A] (x : A) : x ∈ univ := +fintype.complete x + +theorem mem_univ_eq [fintype A] (x : A) : x ∈ univ = true := propext (iff_true_intro !mem_univ) + +/- card -/ +definition card (s : finset A) : nat := +quot.lift_on s + (λ l, length (elt_of l)) + (λ l₁ l₂ p, length_eq_length_of_perm p) + +theorem card_empty : card (@empty A) = 0 := +rfl + +lemma ne_empty_of_card_eq_succ {s : finset A} {n : nat} : card s = succ n → s ≠ ∅ := +by intros; substvars; contradiction + +/- insert -/ +section insert +variable [h : decidable_eq A] +include h + +definition insert (a : A) (s : finset A) : finset A := +quot.lift_on s + (λ l, to_finset_of_nodup (insert a (elt_of l)) (nodup_insert a (has_property l))) + (λ (l₁ l₂ : nodup_list A) (p : l₁ ~ l₂), quot.sound (perm_insert a p)) + +-- set builder notation +notation [priority finset.prio] `'{`:max a:(foldr `, ` (x b, insert x b) ∅) `}`:0 := a + +theorem mem_insert (a : A) (s : finset A) : a ∈ insert a s := +quot.induction_on s + (λ l : nodup_list A, mem_to_finset_of_nodup _ !list.mem_insert) + +theorem mem_insert_of_mem {a : A} {s : finset A} (b : A) : a ∈ s → a ∈ insert b s := +quot.induction_on s + (λ (l : nodup_list A) (ainl : a ∈ ⟦l⟧), mem_to_finset_of_nodup _ (list.mem_insert_of_mem _ ainl)) + +theorem eq_or_mem_of_mem_insert {x a : A} {s : finset A} : x ∈ insert a s → x = a ∨ x ∈ s := +quot.induction_on s (λ l : nodup_list A, λ H, list.eq_or_mem_of_mem_insert H) + +theorem mem_of_mem_insert_of_ne {x a : A} {s : finset A} (xin : x ∈ insert a s) : x ≠ a → x ∈ s := +or_resolve_right (eq_or_mem_of_mem_insert xin) + +theorem mem_insert_iff (x a : A) (s : finset A) : x ∈ insert a s ↔ (x = a ∨ x ∈ s) := +iff.intro !eq_or_mem_of_mem_insert + (or.rec (λH', (eq.substr H' !mem_insert)) !mem_insert_of_mem) + +theorem mem_insert_eq (x a : A) (s : finset A) : x ∈ insert a s = (x = a ∨ x ∈ s) := +propext !mem_insert_iff + +theorem mem_singleton_iff (x a : A) : x ∈ '{a} ↔ (x = a) := +by rewrite [mem_insert_eq, mem_empty_eq, or_false] + +theorem mem_singleton (a : A) : a ∈ '{a} := mem_insert a ∅ + +theorem mem_singleton_of_eq {x a : A} (H : x = a) : x ∈ '{a} := +by rewrite H; apply mem_insert + +theorem eq_of_mem_singleton {x a : A} (H : x ∈ '{a}) : x = a := iff.mp !mem_singleton_iff H + +theorem eq_of_singleton_eq {a b : A} (H : '{a} = '{b}) : a = b := +have a ∈ '{b}, by rewrite -H; apply mem_singleton, +eq_of_mem_singleton this + +theorem insert_eq_of_mem {a : A} {s : finset A} (H : a ∈ s) : insert a s = s := +ext (λ x, eq.substr (mem_insert_eq x a s) + (or_iff_right_of_imp (λH1, eq.substr H1 H))) + +theorem singleton_ne_empty (a : A) : '{a} ≠ ∅ := +begin + intro H, + apply not_mem_empty a, + rewrite -H, + apply mem_insert +end + +theorem pair_eq_singleton (a : A) : '{a, a} = '{a} := +by rewrite [insert_eq_of_mem !mem_singleton] + +-- useful in proofs by induction +theorem forall_of_forall_insert {P : A → Prop} {a : A} {s : finset A} + (H : ∀ x, x ∈ insert a s → P x) : + ∀ x, x ∈ s → P x := +λ x xs, H x (!mem_insert_of_mem xs) + +theorem insert.comm (x y : A) (s : finset A) : insert x (insert y s) = insert y (insert x s) := +ext (take a, by rewrite [*mem_insert_eq, propext !or.left_comm]) + +theorem card_insert_of_mem {a : A} {s : finset A} : a ∈ s → card (insert a s) = card s := +quot.induction_on s + (λ (l : nodup_list A) (ainl : a ∈ ⟦l⟧), list.length_insert_of_mem ainl) + +theorem card_insert_of_not_mem {a : A} {s : finset A} : a ∉ s → card (insert a s) = card s + 1 := +quot.induction_on s + (λ (l : nodup_list A) (nainl : a ∉ ⟦l⟧), list.length_insert_of_not_mem nainl) + +theorem card_insert_le (a : A) (s : finset A) : + card (insert a s) ≤ card s + 1 := +if H : a ∈ s then by rewrite [card_insert_of_mem H]; apply le_succ +else by rewrite [card_insert_of_not_mem H] + +attribute [recursor 6] +protected theorem induction {P : finset A → Prop} + (H1 : P empty) + (H2 : ∀ ⦃a : A⦄, ∀{s : finset A}, a ∉ s → P s → P (insert a s)) : + ∀s, P s := +take s, +quot.induction_on s + (take u, + subtype.destruct u + (take l, + list.induction_on l + (assume nodup_l, H1) + (take a l', + assume IH nodup_al', + have aux₁: a ∉ l', from not_mem_of_nodup_cons nodup_al', + have e : list.insert a l' = a :: l', from insert_eq_of_not_mem aux₁, + have nodup l', from nodup_of_nodup_cons nodup_al', + have P (quot.mk (subtype.tag l' this)), from IH this, + have P (insert a (quot.mk (subtype.tag l' _))), from H2 aux₁ this, + begin + revert nodup_al', + rewrite [-e], + intros, + apply this + end))) + +protected theorem induction_on {P : finset A → Prop} (s : finset A) + (H1 : P empty) + (H2 : ∀ ⦃a : A⦄, ∀ {s : finset A}, a ∉ s → P s → P (insert a s)) : + P s := +finset.induction H1 H2 s + +theorem exists_mem_of_ne_empty {s : finset A} : s ≠ ∅ → ∃ a : A, a ∈ s := +begin + induction s with a s nin ih, + {intro h, exact absurd rfl h}, + {intro h, existsi a, apply mem_insert} +end + +theorem eq_empty_of_card_eq_zero {s : finset A} (H : card s = 0) : s = ∅ := +begin + induction s with a s' H1 IH, + { reflexivity }, + { rewrite (card_insert_of_not_mem H1) at H, apply nat.no_confusion H} +end + +end insert + +/- erase -/ +section erase +variable [h : decidable_eq A] +include h + +definition erase (a : A) (s : finset A) : finset A := +quot.lift_on s + (λ l, to_finset_of_nodup (erase a (elt_of l)) (nodup_erase_of_nodup a (has_property l))) + (λ (l₁ l₂ : nodup_list A) (p : l₁ ~ l₂), quot.sound (erase_perm_erase_of_perm a p)) + +theorem not_mem_erase (a : A) (s : finset A) : a ∉ erase a s := +quot.induction_on s + (λ l, list.mem_erase_of_nodup _ (has_property l)) + +theorem card_erase_of_mem {a : A} {s : finset A} : a ∈ s → card (erase a s) = pred (card s) := +quot.induction_on s (λ l ainl, list.length_erase_of_mem ainl) + +theorem card_erase_of_not_mem {a : A} {s : finset A} : a ∉ s → card (erase a s) = card s := +quot.induction_on s (λ l nainl, list.length_erase_of_not_mem nainl) + +theorem erase_empty (a : A) : erase a ∅ = ∅ := +rfl + +theorem ne_of_mem_erase {a b : A} {s : finset A} : b ∈ erase a s → b ≠ a := +by intro h beqa; subst b; exact absurd h !not_mem_erase + +theorem mem_of_mem_erase {a b : A} {s : finset A} : b ∈ erase a s → b ∈ s := +quot.induction_on s (λ l bin, mem_of_mem_erase bin) + +theorem mem_erase_of_ne_of_mem {a b : A} {s : finset A} : a ≠ b → a ∈ s → a ∈ erase b s := +quot.induction_on s (λ l n ain, list.mem_erase_of_ne_of_mem n ain) + +theorem mem_erase_iff (a b : A) (s : finset A) : a ∈ erase b s ↔ a ∈ s ∧ a ≠ b := +iff.intro + (assume H, and.intro (mem_of_mem_erase H) (ne_of_mem_erase H)) + (assume H, mem_erase_of_ne_of_mem (and.right H) (and.left H)) + +theorem mem_erase_eq (a b : A) (s : finset A) : a ∈ erase b s = (a ∈ s ∧ a ≠ b) := +propext !mem_erase_iff + +open decidable +theorem erase_insert {a : A} {s : finset A} : a ∉ s → erase a (insert a s) = s := +λ anins, finset.ext (λ b, by_cases + (λ beqa : b = a, iff.intro + (λ bin, by subst b; exact absurd bin !not_mem_erase) + (λ bin, by subst b; contradiction)) + (λ bnea : b ≠ a, iff.intro + (λ bin, + have b ∈ insert a s, from mem_of_mem_erase bin, + mem_of_mem_insert_of_ne this bnea) + (λ bin, + have b ∈ insert a s, from mem_insert_of_mem _ bin, + mem_erase_of_ne_of_mem bnea this))) + +theorem insert_erase {a : A} {s : finset A} : a ∈ s → insert a (erase a s) = s := +λ ains, finset.ext (λ b, by_cases + (suppose b = a, iff.intro + (λ bin, by subst b; assumption) + (λ bin, by subst b; apply mem_insert)) + (suppose b ≠ a, iff.intro + (λ bin, mem_of_mem_erase (mem_of_mem_insert_of_ne bin `b ≠ a`)) + (λ bin, mem_insert_of_mem _ (mem_erase_of_ne_of_mem `b ≠ a` bin)))) +end erase + +/- union -/ +section union +variable [h : decidable_eq A] +include h + +definition union (s₁ s₂ : finset A) : finset A := +quot.lift_on₂ s₁ s₂ + (λ l₁ l₂, + to_finset_of_nodup (list.union (elt_of l₁) (elt_of l₂)) + (nodup_union_of_nodup_of_nodup (has_property l₁) (has_property l₂))) + (λ v₁ v₂ w₁ w₂ p₁ p₂, quot.sound (perm_union p₁ p₂)) + +infix [priority finset.prio] ∪ := union + +theorem mem_union_left {a : A} {s₁ : finset A} (s₂ : finset A) : a ∈ s₁ → a ∈ s₁ ∪ s₂ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₁, list.mem_union_left _ ainl₁) + +theorem mem_union_l {a : A} {s₁ : finset A} {s₂ : finset A} : a ∈ s₁ → a ∈ s₁ ∪ s₂ := +mem_union_left s₂ + +theorem mem_union_right {a : A} {s₂ : finset A} (s₁ : finset A) : a ∈ s₂ → a ∈ s₁ ∪ s₂ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₂, list.mem_union_right _ ainl₂) + +theorem mem_union_r {a : A} {s₂ : finset A} {s₁ : finset A} : a ∈ s₂ → a ∈ s₁ ∪ s₂ := +mem_union_right s₁ + +theorem mem_or_mem_of_mem_union {a : A} {s₁ s₂ : finset A} : a ∈ s₁ ∪ s₂ → a ∈ s₁ ∨ a ∈ s₂ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₁l₂, list.mem_or_mem_of_mem_union ainl₁l₂) + +theorem mem_union_iff (a : A) (s₁ s₂ : finset A) : a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ := +iff.intro + (λ h, mem_or_mem_of_mem_union h) + (λ d, or.elim d + (λ i, mem_union_left _ i) + (λ i, mem_union_right _ i)) + +theorem mem_union_eq (a : A) (s₁ s₂ : finset A) : (a ∈ s₁ ∪ s₂) = (a ∈ s₁ ∨ a ∈ s₂) := +propext !mem_union_iff + +theorem union_comm (s₁ s₂ : finset A) : s₁ ∪ s₂ = s₂ ∪ s₁ := +ext (λ a, by rewrite [*mem_union_eq]; exact or.comm) + +theorem union_assoc (s₁ s₂ s₃ : finset A) : (s₁ ∪ s₂) ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) := +ext (λ a, by rewrite [*mem_union_eq]; exact or.assoc) + +theorem union_left_comm (s₁ s₂ s₃ : finset A) : s₁ ∪ (s₂ ∪ s₃) = s₂ ∪ (s₁ ∪ s₃) := +!left_comm union_comm union_assoc s₁ s₂ s₃ + +theorem union_right_comm (s₁ s₂ s₃ : finset A) : (s₁ ∪ s₂) ∪ s₃ = (s₁ ∪ s₃) ∪ s₂ := +!right_comm union_comm union_assoc s₁ s₂ s₃ + +theorem union_self (s : finset A) : s ∪ s = s := +ext (λ a, iff.intro + (λ ain, or.elim (mem_or_mem_of_mem_union ain) (λ i, i) (λ i, i)) + (λ i, mem_union_left _ i)) + +theorem union_empty (s : finset A) : s ∪ ∅ = s := +ext (λ a, iff.intro + (suppose a ∈ s ∪ ∅, or.elim (mem_or_mem_of_mem_union this) (λ i, i) (λ i, absurd i !not_mem_empty)) + (suppose a ∈ s, mem_union_left _ this)) + +theorem empty_union (s : finset A) : ∅ ∪ s = s := +calc ∅ ∪ s = s ∪ ∅ : union_comm + ... = s : union_empty + +theorem insert_eq (a : A) (s : finset A) : insert a s = '{a} ∪ s := +ext (take x, by rewrite [mem_insert_iff, mem_union_iff, mem_singleton_iff]) + +theorem insert_union (a : A) (s t : finset A) : insert a (s ∪ t) = insert a s ∪ t := +by rewrite [insert_eq, insert_eq a s, union_assoc] +end union + +/- inter -/ +section inter +variable [h : decidable_eq A] +include h + +definition inter (s₁ s₂ : finset A) : finset A := +quot.lift_on₂ s₁ s₂ + (λ l₁ l₂, + to_finset_of_nodup (list.inter (elt_of l₁) (elt_of l₂)) + (nodup_inter_of_nodup _ (has_property l₁))) + (λ v₁ v₂ w₁ w₂ p₁ p₂, quot.sound (perm_inter p₁ p₂)) + +infix [priority finset.prio] ∩ := inter + +theorem mem_of_mem_inter_left {a : A} {s₁ s₂ : finset A} : a ∈ s₁ ∩ s₂ → a ∈ s₁ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₁l₂, list.mem_of_mem_inter_left ainl₁l₂) + +theorem mem_of_mem_inter_right {a : A} {s₁ s₂ : finset A} : a ∈ s₁ ∩ s₂ → a ∈ s₂ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₁l₂, list.mem_of_mem_inter_right ainl₁l₂) + +theorem mem_inter {a : A} {s₁ s₂ : finset A} : a ∈ s₁ → a ∈ s₂ → a ∈ s₁ ∩ s₂ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ ainl₁ ainl₂, list.mem_inter_of_mem_of_mem ainl₁ ainl₂) + +theorem mem_inter_iff (a : A) (s₁ s₂ : finset A) : a ∈ s₁ ∩ s₂ ↔ a ∈ s₁ ∧ a ∈ s₂ := +iff.intro + (λ h, and.intro (mem_of_mem_inter_left h) (mem_of_mem_inter_right h)) + (λ h, mem_inter (and.elim_left h) (and.elim_right h)) + +theorem mem_inter_eq (a : A) (s₁ s₂ : finset A) : (a ∈ s₁ ∩ s₂) = (a ∈ s₁ ∧ a ∈ s₂) := +propext !mem_inter_iff + +theorem inter_comm (s₁ s₂ : finset A) : s₁ ∩ s₂ = s₂ ∩ s₁ := +ext (λ a, by rewrite [*mem_inter_eq]; exact and.comm) + +theorem inter_assoc (s₁ s₂ s₃ : finset A) : (s₁ ∩ s₂) ∩ s₃ = s₁ ∩ (s₂ ∩ s₃) := +ext (λ a, by rewrite [*mem_inter_eq]; exact and.assoc) + +theorem inter_left_comm (s₁ s₂ s₃ : finset A) : s₁ ∩ (s₂ ∩ s₃) = s₂ ∩ (s₁ ∩ s₃) := +!left_comm inter_comm inter_assoc s₁ s₂ s₃ + +theorem inter_right_comm (s₁ s₂ s₃ : finset A) : (s₁ ∩ s₂) ∩ s₃ = (s₁ ∩ s₃) ∩ s₂ := +!right_comm inter_comm inter_assoc s₁ s₂ s₃ + +theorem inter_self (s : finset A) : s ∩ s = s := +ext (λ a, iff.intro + (λ h, mem_of_mem_inter_right h) + (λ h, mem_inter h h)) + +theorem inter_empty (s : finset A) : s ∩ ∅ = ∅ := +ext (λ a, iff.intro + (suppose a ∈ s ∩ ∅, absurd (mem_of_mem_inter_right this) !not_mem_empty) + (suppose a ∈ ∅, absurd this !not_mem_empty)) + +theorem empty_inter (s : finset A) : ∅ ∩ s = ∅ := +calc ∅ ∩ s = s ∩ ∅ : inter_comm + ... = ∅ : inter_empty + +theorem singleton_inter_of_mem {a : A} {s : finset A} (H : a ∈ s) : + '{a} ∩ s = '{a} := +ext (take x, + begin + rewrite [mem_inter_eq, !mem_singleton_iff], + exact iff.intro + (suppose x = a ∧ x ∈ s, and.left this) + (suppose x = a, and.intro this (eq.subst (eq.symm this) H)) + end) + +theorem singleton_inter_of_not_mem {a : A} {s : finset A} (H : a ∉ s) : + '{a} ∩ s = ∅ := +ext (take x, + begin + rewrite [mem_inter_eq, !mem_singleton_iff, mem_empty_eq], + exact iff.intro + (suppose x = a ∧ x ∈ s, H (eq.subst (and.left this) (and.right this))) + (false.elim) + end) +end inter + +/- distributivity laws -/ +section inter +variable [h : decidable_eq A] +include h + +theorem inter_distrib_left (s t u : finset A) : s ∩ (t ∪ u) = (s ∩ t) ∪ (s ∩ u) := +ext (take x, by rewrite [mem_inter_eq, *mem_union_eq, *mem_inter_eq]; apply and.left_distrib) + +theorem inter_distrib_right (s t u : finset A) : (s ∪ t) ∩ u = (s ∩ u) ∪ (t ∩ u) := +ext (take x, by rewrite [mem_inter_eq, *mem_union_eq, *mem_inter_eq]; apply and.right_distrib) + +theorem union_distrib_left (s t u : finset A) : s ∪ (t ∩ u) = (s ∪ t) ∩ (s ∪ u) := +ext (take x, by rewrite [mem_union_eq, *mem_inter_eq, *mem_union_eq]; apply or.left_distrib) + +theorem union_distrib_right (s t u : finset A) : (s ∩ t) ∪ u = (s ∪ u) ∩ (t ∪ u) := +ext (take x, by rewrite [mem_union_eq, *mem_inter_eq, *mem_union_eq]; apply or.right_distrib) +end inter + +/- disjoint -/ +-- Mainly for internal use; library will use s₁ ∩ s₂ = ∅. Note that it does not require decidable equality. +definition disjoint (s₁ s₂ : finset A) : Prop := +quot.lift_on₂ s₁ s₂ (λ l₁ l₂, disjoint (elt_of l₁) (elt_of l₂)) + (λ v₁ v₂ w₁ w₂ p₁ p₂, propext (iff.intro + (λ d₁ a (ainw₁ : a ∈ elt_of w₁), + have a ∈ elt_of v₁, from mem_perm (perm.symm p₁) ainw₁, + have a ∉ elt_of v₂, from disjoint_left d₁ this, + not_mem_perm p₂ this) + (λ d₂ a (ainv₁ : a ∈ elt_of v₁), + have a ∈ elt_of w₁, from mem_perm p₁ ainv₁, + have a ∉ elt_of w₂, from disjoint_left d₂ this, + not_mem_perm (perm.symm p₂) this))) + +theorem disjoint.elim {s₁ s₂ : finset A} {x : A} : + disjoint s₁ s₂ → x ∈ s₁ → x ∈ s₂ → false := +quot.induction_on₂ s₁ s₂ (take u₁ u₂, assume H H1 H2, H x H1 H2) + +theorem disjoint.intro {s₁ s₂ : finset A} : (∀{x : A}, x ∈ s₁ → x ∈ s₂ → false) → disjoint s₁ s₂ := +quot.induction_on₂ s₁ s₂ (take u₁ u₂, assume H, H) + +theorem inter_eq_empty_of_disjoint [h : decidable_eq A] {s₁ s₂ : finset A} (H : disjoint s₁ s₂) : s₁ ∩ s₂ = ∅ := +ext (take x, iff_false_intro (assume H1, + disjoint.elim H (mem_of_mem_inter_left H1) (mem_of_mem_inter_right H1))) + +theorem disjoint_of_inter_eq_empty [h : decidable_eq A] {s₁ s₂ : finset A} (H : s₁ ∩ s₂ = ∅) : disjoint s₁ s₂ := +disjoint.intro (take x H1 H2, + have x ∈ s₁ ∩ s₂, from mem_inter H1 H2, + !not_mem_empty (eq.subst H this)) + +theorem disjoint.comm {s₁ s₂ : finset A} : disjoint s₁ s₂ → disjoint s₂ s₁ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ d, list.disjoint.comm d) + +theorem inter_eq_empty [h : decidable_eq A] {s₁ s₂ : finset A} + (H : ∀x : A, x ∈ s₁ → x ∈ s₂ → false) : s₁ ∩ s₂ = ∅ := +inter_eq_empty_of_disjoint (disjoint.intro H) + +/- subset -/ +definition subset (s₁ s₂ : finset A) : Prop := +quot.lift_on₂ s₁ s₂ + (λ l₁ l₂, sublist (elt_of l₁) (elt_of l₂)) + (λ v₁ v₂ w₁ w₂ p₁ p₂, propext (iff.intro + (λ s₁ a i, mem_perm p₂ (s₁ a (mem_perm (perm.symm p₁) i))) + (λ s₂ a i, mem_perm (perm.symm p₂) (s₂ a (mem_perm p₁ i))))) + +infix [priority finset.prio] ⊆ := subset + +theorem empty_subset (s : finset A) : ∅ ⊆ s := +quot.induction_on s (λ l, list.nil_sub (elt_of l)) + +theorem subset_univ [h : fintype A] (s : finset A) : s ⊆ univ := +quot.induction_on s (λ l a i, fintype.complete a) + +theorem subset.refl (s : finset A) : s ⊆ s := +quot.induction_on s (λ l, list.sub.refl (elt_of l)) + +theorem subset.trans {s₁ s₂ s₃ : finset A} : s₁ ⊆ s₂ → s₂ ⊆ s₃ → s₁ ⊆ s₃ := +quot.induction_on₃ s₁ s₂ s₃ (λ l₁ l₂ l₃ h₁ h₂, list.sub.trans h₁ h₂) + +theorem mem_of_subset_of_mem {s₁ s₂ : finset A} {a : A} : s₁ ⊆ s₂ → a ∈ s₁ → a ∈ s₂ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ h₁ h₂, h₁ a h₂) + +theorem subset.antisymm {s₁ s₂ : finset A} (H₁ : s₁ ⊆ s₂) (H₂ : s₂ ⊆ s₁) : s₁ = s₂ := +ext (take x, iff.intro (assume H, mem_of_subset_of_mem H₁ H) (assume H, mem_of_subset_of_mem H₂ H)) + +-- alternative name +theorem eq_of_subset_of_subset {s₁ s₂ : finset A} (H₁ : s₁ ⊆ s₂) (H₂ : s₂ ⊆ s₁) : s₁ = s₂ := +subset.antisymm H₁ H₂ + +theorem subset_of_forall {s₁ s₂ : finset A} : (∀x, x ∈ s₁ → x ∈ s₂) → s₁ ⊆ s₂ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ H, H) + +theorem subset_insert [h : decidable_eq A] (s : finset A) (a : A) : s ⊆ insert a s := +subset_of_forall (take x, suppose x ∈ s, mem_insert_of_mem _ this) + +theorem eq_empty_of_subset_empty {x : finset A} (H : x ⊆ ∅) : x = ∅ := +subset.antisymm H (empty_subset x) + +theorem subset_empty_iff (x : finset A) : x ⊆ ∅ ↔ x = ∅ := +iff.intro eq_empty_of_subset_empty (take xeq, by rewrite xeq; apply subset.refl ∅) + +section +variable [decA : decidable_eq A] +include decA + +theorem erase_subset_erase (a : A) {s t : finset A} (H : s ⊆ t) : erase a s ⊆ erase a t := +begin + apply subset_of_forall, + intro x, + rewrite *mem_erase_eq, + intro H', + show x ∈ t ∧ x ≠ a, from and.intro (mem_of_subset_of_mem H (and.left H')) (and.right H') +end + +theorem erase_subset (a : A) (s : finset A) : erase a s ⊆ s := +begin + apply subset_of_forall, + intro x, + rewrite mem_erase_eq, + intro H, + apply and.left H +end + +theorem erase_eq_of_not_mem {a : A} {s : finset A} (anins : a ∉ s) : erase a s = s := +eq_of_subset_of_subset !erase_subset + (subset_of_forall (take x, assume xs : x ∈ s, + have x ≠ a, from assume H', anins (eq.subst H' xs), + mem_erase_of_ne_of_mem this xs)) + +theorem erase_insert_subset (a : A) (s : finset A) : erase a (insert a s) ⊆ s := +decidable.by_cases + (assume ains : a ∈ s, by rewrite [insert_eq_of_mem ains]; apply erase_subset) + (assume nains : a ∉ s, by rewrite [!erase_insert nains]; apply subset.refl) + +theorem erase_subset_of_subset_insert {a : A} {s t : finset A} (H : s ⊆ insert a t) : + erase a s ⊆ t := +subset.trans (!erase_subset_erase H) !erase_insert_subset + +theorem insert_erase_subset (a : A) (s : finset A) : s ⊆ insert a (erase a s) := +decidable.by_cases + (assume ains : a ∈ s, by rewrite [!insert_erase ains]; apply subset.refl) + (assume nains : a ∉ s, by rewrite[erase_eq_of_not_mem nains]; apply subset_insert) + +theorem insert_subset_insert (a : A) {s t : finset A} (H : s ⊆ t) : insert a s ⊆ insert a t := +begin + apply subset_of_forall, + intro x, + rewrite *mem_insert_eq, + intro H', + cases H' with [xeqa, xins], + exact (or.inl xeqa), + exact (or.inr (mem_of_subset_of_mem H xins)) +end + +theorem subset_insert_of_erase_subset {s t : finset A} {a : A} (H : erase a s ⊆ t) : + s ⊆ insert a t := +subset.trans (insert_erase_subset a s) (!insert_subset_insert H) + +theorem subset_insert_iff (s t : finset A) (a : A) : s ⊆ insert a t ↔ erase a s ⊆ t := +iff.intro !erase_subset_of_subset_insert !subset_insert_of_erase_subset + +end + +/- upto -/ +section upto +definition upto (n : nat) : finset nat := +to_finset_of_nodup (list.upto n) (nodup_upto n) + +theorem card_upto : ∀ n, card (upto n) = n := +list.length_upto + +theorem lt_of_mem_upto {n a : nat} : a ∈ upto n → a < n := +list.lt_of_mem_upto + +theorem mem_upto_succ_of_mem_upto {n a : nat} : a ∈ upto n → a ∈ upto (succ n) := +list.mem_upto_succ_of_mem_upto + +theorem mem_upto_of_lt {n a : nat} : a < n → a ∈ upto n := +list.mem_upto_of_lt + +theorem mem_upto_iff (a n : nat) : a ∈ upto n ↔ a < n := +iff.intro lt_of_mem_upto mem_upto_of_lt + +theorem mem_upto_eq (a n : nat) : a ∈ upto n = (a < n) := +propext !mem_upto_iff +end upto + +theorem upto_zero : upto 0 = ∅ := rfl + +theorem upto_succ (n : ℕ) : upto (succ n) = upto n ∪ '{n} := +begin + apply ext, intro x, + rewrite [mem_union_iff, *mem_upto_iff, mem_singleton_iff, lt_succ_iff_le, nat.le_iff_lt_or_eq], +end + +/- useful rules for calculations with quantifiers -/ +theorem exists_mem_empty_iff {A : Type} (P : A → Prop) : (∃ x, x ∈ ∅ ∧ P x) ↔ false := +iff.intro + (assume H, + obtain x (H1 : x ∈ ∅ ∧ P x), from H, + !not_mem_empty (and.left H1)) + (assume H, false.elim H) + +theorem exists_mem_empty_eq {A : Type} (P : A → Prop) : (∃ x, x ∈ ∅ ∧ P x) = false := +propext !exists_mem_empty_iff + +theorem exists_mem_insert_iff {A : Type} [d : decidable_eq A] + (a : A) (s : finset A) (P : A → Prop) : + (∃ x, x ∈ insert a s ∧ P x) ↔ P a ∨ (∃ x, x ∈ s ∧ P x) := +iff.intro + (assume H, + obtain x [H1 H2], from H, + or.elim (eq_or_mem_of_mem_insert H1) + (suppose x = a, or.inl (eq.subst this H2)) + (suppose x ∈ s, or.inr (exists.intro x (and.intro this H2)))) + (assume H, + or.elim H + (suppose P a, exists.intro a (and.intro !mem_insert this)) + (suppose ∃ x, x ∈ s ∧ P x, + obtain x [H2 H3], from this, + exists.intro x (and.intro (!mem_insert_of_mem H2) H3))) + +theorem exists_mem_insert_eq {A : Type} [d : decidable_eq A] (a : A) (s : finset A) (P : A → Prop) : + (∃ x, x ∈ insert a s ∧ P x) = (P a ∨ (∃ x, x ∈ s ∧ P x)) := +propext !exists_mem_insert_iff + +theorem forall_mem_empty_iff {A : Type} (P : A → Prop) : (∀ x, x ∈ ∅ → P x) ↔ true := +iff.intro + (assume H, trivial) + (assume H, take x, assume H', absurd H' !not_mem_empty) + +theorem forall_mem_empty_eq {A : Type} (P : A → Prop) : (∀ x, x ∈ ∅ → P x) = true := +propext !forall_mem_empty_iff + +theorem forall_mem_insert_iff {A : Type} [d : decidable_eq A] + (a : A) (s : finset A) (P : A → Prop) : + (∀ x, x ∈ insert a s → P x) ↔ P a ∧ (∀ x, x ∈ s → P x) := +iff.intro + (assume H, and.intro (H _ !mem_insert) (take x, assume H', H _ (!mem_insert_of_mem H'))) + (assume H, take x, assume H' : x ∈ insert a s, + or.elim (eq_or_mem_of_mem_insert H') + (suppose x = a, eq.subst (eq.symm this) (and.left H)) + (suppose x ∈ s, and.right H _ this)) + +theorem forall_mem_insert_eq {A : Type} [d : decidable_eq A] (a : A) (s : finset A) (P : A → Prop) : + (∀ x, x ∈ insert a s → P x) = (P a ∧ (∀ x, x ∈ s → P x)) := +propext !forall_mem_insert_iff + +end finset diff --git a/old_library/data/finset/bigops.lean b/old_library/data/finset/bigops.lean new file mode 100644 index 0000000000..a700cdc338 --- /dev/null +++ b/old_library/data/finset/bigops.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad, Haitao Zhang + +Finite unions and intersections on finsets. + +Note: for the moment we only do unions. We need to generalize bigops for intersections. +-/ +import data.finset.comb algebra.group_bigops +open list + +namespace finset + +variables {A B : Type} [deceqA : decidable_eq A] [deceqB : decidable_eq B] + +/- Unionl and Union -/ + +section union + +definition to_comm_monoid_Union (B : Type) [decidable_eq B] : + comm_monoid (finset B) := +⦃ comm_monoid, + mul := union, + mul_assoc := union_assoc, + one := empty, + mul_one := union_empty, + one_mul := empty_union, + mul_comm := union_comm +⦄ + +local attribute finset.to_comm_monoid_Union [instance] + +include deceqB + +definition Unionl (l : list A) (f : A → finset B) : finset B := Prodl l f +notation `⋃` binders `←` l, r:(scoped f, Unionl l f) := r +definition Union (s : finset A) (f : A → finset B) : finset B := finset.Prod s f +notation `⋃` binders `∈` s, r:(scoped f, finset.Union s f) := r + +theorem Unionl_nil (f : A → finset B) : Unionl [] f = ∅ := Prodl_nil f +theorem Unionl_cons (f : A → finset B) (a : A) (l : list A) : + Unionl (a::l) f = f a ∪ Unionl l f := Prodl_cons f a l +theorem Unionl_append (l₁ l₂ : list A) (f : A → finset B) : + Unionl (l₁++l₂) f = Unionl l₁ f ∪ Unionl l₂ f := Prodl_append l₁ l₂ f +theorem Unionl_mul (l : list A) (f g : A → finset B) : + Unionl l (λx, f x ∪ g x) = Unionl l f ∪ Unionl l g := Prodl_mul l f g +section deceqA + include deceqA + theorem Unionl_insert_of_mem (f : A → finset B) {a : A} {l : list A} (H : a ∈ l) : + Unionl (list.insert a l) f = Unionl l f := Prodl_insert_of_mem f H + theorem Unionl_insert_of_not_mem (f : A → finset B) {a : A} {l : list A} (H : a ∉ l) : + Unionl (list.insert a l) f = f a ∪ Unionl l f := Prodl_insert_of_not_mem f H + theorem Unionl_union {l₁ l₂ : list A} (f : A → finset B) (d : list.disjoint l₁ l₂) : + Unionl (list.union l₁ l₂) f = Unionl l₁ f ∪ Unionl l₂ f := Prodl_union f d + theorem Unionl_empty (l : list A) : Unionl l (λ x, ∅) = (∅ : finset B) := Prodl_one l +end deceqA + +theorem Union_empty (f : A → finset B) : Union ∅ f = ∅ := finset.Prod_empty f +theorem Union_mul (s : finset A) (f g : A → finset B) : + Union s (λx, f x ∪ g x) = Union s f ∪ Union s g := finset.Prod_mul s f g +section deceqA + include deceqA + theorem Union_insert_of_mem (f : A → finset B) {a : A} {s : finset A} (H : a ∈ s) : + Union (insert a s) f = Union s f := finset.Prod_insert_of_mem f H + private theorem Union_insert_of_not_mem (f : A → finset B) {a : A} {s : finset A} (H : a ∉ s) : + Union (insert a s) f = f a ∪ Union s f := finset.Prod_insert_of_not_mem f H + theorem Union_union (f : A → finset B) {s₁ s₂ : finset A} (disj : s₁ ∩ s₂ = ∅) : + Union (s₁ ∪ s₂) f = Union s₁ f ∪ Union s₂ f := finset.Prod_union f disj + theorem Union_ext {s : finset A} {f g : A → finset B} (H : ∀x, x ∈ s → f x = g x) : + Union s f = Union s g := finset.Prod_ext H + theorem Union_empty' (s : finset A) : Union s (λ x, ∅) = (∅ : finset B) := finset.Prod_one s + + -- this will eventually be an instance of something more general + theorem inter_Union (s : finset B) (t : finset A) (f : A → finset B) : + s ∩ (⋃ x ∈ t, f x) = (⋃ x ∈ t, s ∩ f x) := + begin + induction t with s' x H IH, + rewrite [*Union_empty, inter_empty], + rewrite [*Union_insert_of_not_mem _ H, inter_distrib_left, IH], + end + + theorem mem_Union_iff (s : finset A) (f : A → finset B) (b : B) : + b ∈ (⋃ x ∈ s, f x) ↔ (∃ x, x ∈ s ∧ b ∈ f x ) := + begin + induction s with s' a H IH, + rewrite [exists_mem_empty_eq], + rewrite [Union_insert_of_not_mem _ H, mem_union_eq, IH, exists_mem_insert_eq] + end + + theorem mem_Union_eq (s : finset A) (f : A → finset B) (b : B) : + b ∈ (⋃ x ∈ s, f x) = (∃ x, x ∈ s ∧ b ∈ f x ) := + propext !mem_Union_iff + + theorem Union_insert (f : A → finset B) {a : A} {s : finset A} : + Union (insert a s) f = f a ∪ Union s f := + decidable.by_cases + (assume Pin : a ∈ s, + begin + rewrite [Union_insert_of_mem f Pin], + apply ext, + intro x, + apply iff.intro, + exact mem_union_r, + rewrite [mem_union_eq], + intro Por, + exact or.elim Por + (assume Pl, begin + rewrite mem_Union_eq, exact (exists.intro a (and.intro Pin Pl)) end) + (assume Pr, Pr) + end) + (assume H : a ∉ s, !Union_insert_of_not_mem H) + + lemma image_eq_Union_index_image (s : finset A) (f : A → finset B) : + Union s f = Union (image f s) id := + finset.induction_on s + (by rewrite Union_empty) + (take s1 a Pa IH, by rewrite [image_insert, *Union_insert, IH]) + + lemma Union_const [decidable_eq B] {f : A → finset B} {s : finset A} {t : finset B} : + s ≠ ∅ → (∀ x, x ∈ s → f x = t) → Union s f = t := + begin + induction s with a' s' H IH, + {intros [H1, H2], exfalso, apply H1 !rfl}, + intros [H1, H2], + rewrite [Union_insert, H2 _ !mem_insert], + cases (decidable.em (s' = ∅)) with [seq, sne], + {rewrite [seq, Union_empty, union_empty]}, + have H3 : ∀ x, x ∈ s' → f x = t, from (λ x H', H2 x (mem_insert_of_mem _ H')), + rewrite [IH sne H3, union_self] + end +end deceqA + +end union + +end finset diff --git a/old_library/data/finset/card.lean b/old_library/data/finset/card.lean new file mode 100644 index 0000000000..fff8184b4a --- /dev/null +++ b/old_library/data/finset/card.lean @@ -0,0 +1,239 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Cardinality calculations for finite sets. +-/ +import .to_set .bigops data.set.function data.nat.power +open nat eq.ops + +namespace finset + +variables {A B : Type} +variables [deceqA : decidable_eq A] [deceqB : decidable_eq B] +include deceqA + +theorem card_add_card (s₁ s₂ : finset A) : card s₁ + card s₂ = card (s₁ ∪ s₂) + card (s₁ ∩ s₂) := +begin + induction s₂ with a s₂ ans2 IH, + show card s₁ + card (∅:finset A) = card (s₁ ∪ ∅) + card (s₁ ∩ ∅), + by rewrite [union_empty, card_empty, inter_empty], + show card s₁ + card (insert a s₂) = card (s₁ ∪ (insert a s₂)) + card (s₁ ∩ (insert a s₂)), + from decidable.by_cases + (assume as1 : a ∈ s₁, + have H : a ∉ s₁ ∩ s₂, from assume H', ans2 (mem_of_mem_inter_right H'), + begin + rewrite [card_insert_of_not_mem ans2, union_comm, -insert_union, union_comm], + rewrite [insert_union, insert_eq_of_mem as1, insert_eq, inter_distrib_left, inter_comm], + rewrite [singleton_inter_of_mem as1, -insert_eq, card_insert_of_not_mem H, -*add.assoc], + rewrite IH + end) + (assume ans1 : a ∉ s₁, + have H : a ∉ s₁ ∪ s₂, from assume H', + or.elim (mem_or_mem_of_mem_union H') (assume as1, ans1 as1) (assume as2, ans2 as2), + begin + rewrite [card_insert_of_not_mem ans2, union_comm, -insert_union, union_comm], + rewrite [card_insert_of_not_mem H, insert_eq, inter_distrib_left, inter_comm], + rewrite [singleton_inter_of_not_mem ans1, empty_union, add.right_comm], + rewrite [-add.assoc, IH] + end) +end + +theorem card_union (s₁ s₂ : finset A) : card (s₁ ∪ s₂) = card s₁ + card s₂ - card (s₁ ∩ s₂) := +calc + card (s₁ ∪ s₂) = card (s₁ ∪ s₂) + card (s₁ ∩ s₂) - card (s₁ ∩ s₂) : nat.add_sub_cancel + ... = card s₁ + card s₂ - card (s₁ ∩ s₂) : card_add_card + +theorem card_union_of_disjoint {s₁ s₂ : finset A} (H : s₁ ∩ s₂ = ∅) : + card (s₁ ∪ s₂) = card s₁ + card s₂ := +by rewrite [card_union, H] + +theorem card_eq_card_add_card_diff {s₁ s₂ : finset A} (H : s₁ ⊆ s₂) : + card s₂ = card s₁ + card (s₂ \ s₁) := +have H1 : s₁ ∩ (s₂ \ s₁) = ∅, + from inter_eq_empty (take x, assume H1 H2, not_mem_of_mem_diff H2 H1), +calc + card s₂ = card (s₁ ∪ (s₂ \ s₁)) : union_diff_cancel H + ... = card s₁ + card (s₂ \ s₁) : card_union_of_disjoint H1 + +theorem card_le_card_of_subset {s₁ s₂ : finset A} (H : s₁ ⊆ s₂) : card s₁ ≤ card s₂ := +calc + card s₂ = card s₁ + card (s₂ \ s₁) : card_eq_card_add_card_diff H + ... ≥ card s₁ : le_add_right + +section card_image +open set +include deceqB + +theorem card_image_eq_of_inj_on {f : A → B} {s : finset A} (H1 : inj_on f (ts s)) : + card (image f s) = card s := +begin + induction s with a t H IH, + { rewrite [card_empty] }, + { have H2 : ts t ⊆ ts (insert a t), by rewrite [-subset_eq_to_set_subset]; apply subset_insert, + have H3 : card (image f t) = card t, from IH (inj_on_of_inj_on_of_subset H1 H2), + have H4 : f a ∉ image f t, + proof + assume H5 : f a ∈ image f t, + obtain x (H6l : x ∈ t) (H6r : f x = f a), from exists_of_mem_image H5, + have H7 : x = a, from H1 (mem_insert_of_mem _ H6l) !mem_insert H6r, + show false, from H (H7 ▸ H6l) + qed, + calc + card (image f (insert a t)) = card (insert (f a) (image f t)) : image_insert + ... = card (image f t) + 1 : card_insert_of_not_mem H4 + ... = card t + 1 : H3 + ... = card (insert a t) : card_insert_of_not_mem H + } +end + +lemma card_le_of_inj_on (a : finset A) (b : finset B) + (Pex : ∃ f : A → B, set.inj_on f (ts a) ∧ (image f a ⊆ b)): + card a ≤ card b := +obtain f Pinj, from Pex, +have Psub : _, from and.right Pinj, +have Ple : card (image f a) ≤ card b, from card_le_card_of_subset Psub, +by rewrite [(card_image_eq_of_inj_on (and.left Pinj))⁻¹]; exact Ple + +theorem card_image_le (f : A → B) (s : finset A) : card (image f s) ≤ card s := +finset.induction_on s + (by rewrite finset.image_empty) + (take a s', + assume Ha : a ∉ s', + assume IH : card (image f s') ≤ card s', + begin + rewrite [image_insert, card_insert_of_not_mem Ha], + apply le.trans !card_insert_le, + apply add_le_add_right IH + end) + +theorem inj_on_of_card_image_eq {f : A → B} {s : finset A} : + card (image f s) = card s → inj_on f (ts s) := +finset.induction_on s + (by intro H; rewrite to_set_empty; apply inj_on_empty) + (begin + intro a s' Ha IH, + rewrite [image_insert, card_insert_of_not_mem Ha, to_set_insert], + assume H1 : card (insert (f a) (image f s')) = card s' + 1, + show inj_on f (set.insert a (ts s')), from + decidable.by_cases + (assume Hfa : f a ∈ image f s', + have H2 : card (image f s') = card s' + 1, + by rewrite [card_insert_of_mem Hfa at H1]; assumption, + absurd + (calc + card (image f s') ≤ card s' : !card_image_le + ... < card s' + 1 : lt_succ_self + ... = card (image f s') : H2) + !lt.irrefl) + (assume Hnfa : f a ∉ image f s', + have H2 : card (image f s') + 1 = card s' + 1, + by rewrite [card_insert_of_not_mem Hnfa at H1]; assumption, + have H3 : card (image f s') = card s', from add.right_cancel H2, + have injf : inj_on f (ts s'), from IH H3, + show inj_on f (set.insert a (ts s')), from + take x1 x2, + assume Hx1 : x1 ∈ set.insert a (ts s'), + assume Hx2 : x2 ∈ set.insert a (ts s'), + assume feq : f x1 = f x2, + or.elim Hx1 + (assume Hx1' : x1 = a, + or.elim Hx2 + (assume Hx2' : x2 = a, by rewrite [Hx1', Hx2']) + (assume Hx2' : x2 ∈ ts s', + have Hfa : f a ∈ image f s', + by rewrite [-Hx1', feq]; apply mem_image_of_mem f Hx2', + absurd Hfa Hnfa)) + (assume Hx1' : x1 ∈ ts s', + or.elim Hx2 + (assume Hx2' : x2 = a, + have Hfa : f a ∈ image f s', + by rewrite [-Hx2', -feq]; apply mem_image_of_mem f Hx1', + absurd Hfa Hnfa) + (assume Hx2' : x2 ∈ ts s', injf Hx1' Hx2' feq))) + end) + +end card_image + +theorem card_pos_of_mem {a : A} {s : finset A} (H : a ∈ s) : card s > 0 := +begin + induction s with a s' H1 IH, + { contradiction }, + { rewrite (card_insert_of_not_mem H1), apply succ_pos } +end + +theorem eq_of_card_eq_of_subset {s₁ s₂ : finset A} (Hcard : card s₁ = card s₂) (Hsub : s₁ ⊆ s₂) : + s₁ = s₂ := +have H : card s₁ + 0 = card s₁ + card (s₂ \ s₁), + by rewrite [Hcard at {1}, card_eq_card_add_card_diff Hsub], +have H1 : s₂ \ s₁ = ∅, from eq_empty_of_card_eq_zero (add.left_cancel H)⁻¹, +by rewrite [-union_diff_cancel Hsub, H1, union_empty] + +lemma exists_two_of_card_gt_one {s : finset A} : 1 < card s → ∃ a b, a ∈ s ∧ b ∈ s ∧ a ≠ b := +begin + intro h, + induction s with a s nain ih₁, + {exact absurd h dec_trivial}, + {induction s with b s nbin ih₂, + {exact absurd h dec_trivial}, + clear ih₁ ih₂, + existsi a, existsi b, split, + {apply mem_insert}, + split, + {apply mem_insert_of_mem _ !mem_insert}, + {intro aeqb, subst a, exact absurd !mem_insert nain}} +end + +theorem Sum_const_eq_card_mul (s : finset A) (n : nat) : (∑ x ∈ s, n) = card s * n := +begin + induction s with a s' H IH, + rewrite [Sum_empty, card_empty, zero_mul], + rewrite [Sum_insert_of_not_mem _ H, IH, card_insert_of_not_mem H, add.comm, + right_distrib, one_mul] +end + +theorem Sum_one_eq_card (s : finset A) : (∑ x ∈ s, (1 : nat)) = card s := +eq.trans !Sum_const_eq_card_mul !mul_one + +section deceqB +include deceqB + +theorem card_Union_of_disjoint (s : finset A) (f : A → finset B) : + (∀{a₁ a₂}, a₁ ∈ s → a₂ ∈ s → a₁ ≠ a₂ → f a₁ ∩ f a₂ = ∅) → + card (⋃ x ∈ s, f x) = ∑ x ∈ s, card (f x) := +finset.induction_on s + (assume H, by rewrite [Union_empty, Sum_empty, card_empty]) + (take a s', assume H : a ∉ s', + assume IH, + assume H1 : ∀ {a₁ a₂ : A}, a₁ ∈ insert a s' → a₂ ∈ insert a s' → a₁ ≠ a₂ → f a₁ ∩ f a₂ = ∅, + have H2 : ∀ a₁ a₂ : A, a₁ ∈ s' → a₂ ∈ s' → a₁ ≠ a₂ → f a₁ ∩ f a₂ = ∅, from + take a₁ a₂, assume H3 H4 H5, + H1 (!mem_insert_of_mem H3) (!mem_insert_of_mem H4) H5, + have H6 : card (⋃ (x : A) ∈ s', f x) = ∑ (x : A) ∈ s', card (f x), from IH H2, + have H7 : ∀ x, x ∈ s' → f a ∩ f x = ∅, from + take x, assume xs', + have anex : a ≠ x, from assume aex, (eq.subst aex H) xs', + H1 !mem_insert (!mem_insert_of_mem xs') anex, + have H8 : f a ∩ (⋃ (x : A) ∈ s', f x) = ∅, from + calc + f a ∩ (⋃ (x : A) ∈ s', f x) = (⋃ (x : A) ∈ s', f a ∩ f x) : by rewrite inter_Union + ... = (⋃ (x : A) ∈ s', ∅) : by rewrite [Union_ext H7] + ... = ∅ : by rewrite Union_empty', + by rewrite [Union_insert, Sum_insert_of_not_mem _ H, + card_union_of_disjoint H8, H6]) +end deceqB + +lemma dvd_Sum_of_dvd (f : A → nat) (n : nat) (s : finset A) : (∀ a, a ∈ s → n ∣ f a) → n ∣ Sum s f := +begin + induction s with a s nain ih, + {intros, rewrite [Sum_empty], apply dvd_zero}, + {intro h, + have h₁ : ∀ a, a ∈ s → n ∣ f a, from + take a, assume ains, h a (mem_insert_of_mem _ ains), + have h₂ : n ∣ Sum s f, from ih h₁, + have h₃ : n ∣ f a, from h a !mem_insert, + rewrite [Sum_insert_of_not_mem f nain], + apply dvd_add h₃ h₂} +end +end finset diff --git a/old_library/data/finset/comb.lean b/old_library/data/finset/comb.lean new file mode 100644 index 0000000000..183c298cb8 --- /dev/null +++ b/old_library/data/finset/comb.lean @@ -0,0 +1,487 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura, Jeremy Avigad + +Combinators for finite sets. +-/ +import data.finset.basic logic.identities +open list quot subtype decidable perm function + +namespace finset + +/- image (corresponds to map on list) -/ +section image +variables {A B : Type} +variable [h : decidable_eq B] +include h + +definition image (f : A → B) (s : finset A) : finset B := +quot.lift_on s + (λ l, to_finset (list.map f (elt_of l))) + (λ l₁ l₂ p, quot.sound (perm_erase_dup_of_perm (perm_map _ p))) + +infix [priority finset.prio] `'` := image + +theorem image_empty (f : A → B) : image f ∅ = ∅ := +rfl + +theorem mem_image_of_mem (f : A → B) {s : finset A} {a : A} : a ∈ s → f a ∈ image f s := +quot.induction_on s (take l, assume H : a ∈ elt_of l, mem_to_finset (mem_map f H)) + +theorem mem_image {f : A → B} {s : finset A} {a : A} {b : B} + (H1 : a ∈ s) (H2 : f a = b) : + b ∈ image f s := +eq.subst H2 (mem_image_of_mem f H1) + +theorem exists_of_mem_image {f : A → B} {s : finset A} {b : B} : + b ∈ image f s → ∃a, a ∈ s ∧ f a = b := +quot.induction_on s + (take l, assume H : b ∈ erase_dup (list.map f (elt_of l)), + exists_of_mem_map (mem_of_mem_erase_dup H)) + +theorem mem_image_iff (f : A → B) {s : finset A} {y : B} : y ∈ image f s ↔ ∃x, x ∈ s ∧ f x = y := +iff.intro exists_of_mem_image + (assume H, + obtain x (H₁ : x ∈ s) (H₂ : f x = y), from H, + mem_image H₁ H₂) + +theorem mem_image_eq (f : A → B) {s : finset A} {y : B} : y ∈ image f s = ∃x, x ∈ s ∧ f x = y := +propext (mem_image_iff f) + +theorem mem_image_of_mem_image_of_subset {f : A → B} {s t : finset A} {y : B} + (H1 : y ∈ image f s) (H2 : s ⊆ t) : y ∈ image f t := +obtain x (H3: x ∈ s) (H4 : f x = y), from exists_of_mem_image H1, +have H5 : x ∈ t, from mem_of_subset_of_mem H2 H3, +show y ∈ image f t, from mem_image H5 H4 + +theorem image_insert [h' : decidable_eq A] (f : A → B) (s : finset A) (a : A) : + image f (insert a s) = insert (f a) (image f s) := +ext (take y, iff.intro + (assume H : y ∈ image f (insert a s), + obtain x (H1l : x ∈ insert a s) (H1r :f x = y), from exists_of_mem_image H, + have x = a ∨ x ∈ s, from eq_or_mem_of_mem_insert H1l, + or.elim this + (suppose x = a, + have f a = y, from eq.subst this H1r, + show y ∈ insert (f a) (image f s), from eq.subst this !mem_insert) + (suppose x ∈ s, + have f x ∈ image f s, from mem_image_of_mem f this, + show y ∈ insert (f a) (image f s), from eq.subst H1r (mem_insert_of_mem _ this))) + (suppose y ∈ insert (f a) (image f s), + have y = f a ∨ y ∈ image f s, from eq_or_mem_of_mem_insert this, + or.elim this + (suppose y = f a, + have f a ∈ image f (insert a s), from mem_image_of_mem f !mem_insert, + show y ∈ image f (insert a s), from eq.subst (eq.symm `y = f a`) this) + (suppose y ∈ image f s, + show y ∈ image f (insert a s), from mem_image_of_mem_image_of_subset this !subset_insert))) + +lemma image_comp {C : Type} [deceqC : decidable_eq C] {f : B → C} {g : A → B} {s : finset A} : + image (f∘g) s = image f (image g s) := +ext (take z, iff.intro + (suppose z ∈ image (f∘g) s, + obtain x (Hx : x ∈ s) (Hgfx : f (g x) = z), from exists_of_mem_image this, + by rewrite -Hgfx; apply mem_image_of_mem _ (mem_image_of_mem _ Hx)) + (suppose z ∈ image f (image g s), + obtain y (Hy : y ∈ image g s) (Hfy : f y = z), from exists_of_mem_image this, + obtain x (Hx : x ∈ s) (Hgx : g x = y), from exists_of_mem_image Hy, + mem_image Hx (by esimp; rewrite [Hgx, Hfy]))) + +lemma image_subset {a b : finset A} (f : A → B) (H : a ⊆ b) : f ' a ⊆ f ' b := +subset_of_forall + (take y, assume Hy : y ∈ f ' a, + obtain x (Hx₁ : x ∈ a) (Hx₂ : f x = y), from exists_of_mem_image Hy, + mem_image (mem_of_subset_of_mem H Hx₁) Hx₂) + +theorem image_union [h' : decidable_eq A] (f : A → B) (s t : finset A) : + image f (s ∪ t) = image f s ∪ image f t := +ext (take y, iff.intro + (assume H : y ∈ image f (s ∪ t), + obtain x [(xst : x ∈ s ∪ t) (fxy : f x = y)], from exists_of_mem_image H, + or.elim (mem_or_mem_of_mem_union xst) + (assume xs, mem_union_l (mem_image xs fxy)) + (assume xt, mem_union_r (mem_image xt fxy))) + (assume H : y ∈ image f s ∪ image f t, + or.elim (mem_or_mem_of_mem_union H) + (assume yifs : y ∈ image f s, + obtain x [(xs : x ∈ s) (fxy : f x = y)], from exists_of_mem_image yifs, + mem_image (mem_union_l xs) fxy) + (assume yift : y ∈ image f t, + obtain x [(xt : x ∈ t) (fxy : f x = y)], from exists_of_mem_image yift, + mem_image (mem_union_r xt) fxy))) +end image + +/- separation and set-builder notation -/ +section sep +variables {A : Type} [deceq : decidable_eq A] +include deceq +variables (p : A → Prop) [decp : decidable_pred p] (s : finset A) {x : A} +include decp + +definition sep : finset A := +quot.lift_on s + (λl, to_finset_of_nodup + (list.filter p (subtype.elt_of l)) + (list.nodup_filter p (subtype.has_property l))) + (λ l₁ l₂ u, quot.sound (perm.perm_filter u)) + +notation [priority finset.prio] `{` binder ` ∈ ` s ` | ` r:(scoped:1 p, sep p s) `}` := r + +theorem sep_empty : sep p ∅ = ∅ := rfl + +variables {p s} + +theorem of_mem_sep : x ∈ sep p s → p x := +quot.induction_on s (take l, list.of_mem_filter) + +theorem mem_of_mem_sep : x ∈ sep p s → x ∈ s := +quot.induction_on s (take l, list.mem_of_mem_filter) + +theorem mem_sep_of_mem {x : A} : x ∈ s → p x → x ∈ sep p s := +quot.induction_on s (take l, list.mem_filter_of_mem) + +variables (p s) + +theorem mem_sep_iff : x ∈ sep p s ↔ x ∈ s ∧ p x := +iff.intro + (assume H, and.intro (mem_of_mem_sep H) (of_mem_sep H)) + (assume H, mem_sep_of_mem (and.left H) (and.right H)) + +theorem mem_sep_eq : x ∈ sep p s = (x ∈ s ∧ p x) := +propext !mem_sep_iff + +variable t : finset A + +theorem mem_sep_union_iff : x ∈ sep p (s ∪ t) ↔ x ∈ sep p s ∨ x ∈ sep p t := +by rewrite [*mem_sep_iff, mem_union_iff, and.right_distrib] + +end sep + +section + +variables {A : Type} [deceqA : decidable_eq A] +include deceqA + +theorem eq_sep_of_subset {s t : finset A} (ssubt : s ⊆ t) : s = {x ∈ t | x ∈ s} := +ext (take x, iff.intro + (suppose x ∈ s, mem_sep_of_mem (mem_of_subset_of_mem ssubt this) this) + (suppose x ∈ {x ∈ t | x ∈ s}, of_mem_sep this)) + +end + +/- set difference -/ +section diff +variables {A : Type} [deceq : decidable_eq A] +include deceq + +definition diff (s t : finset A) : finset A := {x ∈ s | x ∉ t} +infix [priority finset.prio] ` \ `:70 := diff + +theorem mem_of_mem_diff {s t : finset A} {x : A} (H : x ∈ s \ t) : x ∈ s := +mem_of_mem_sep H + +theorem not_mem_of_mem_diff {s t : finset A} {x : A} (H : x ∈ s \ t) : x ∉ t := +of_mem_sep H + +theorem mem_diff {s t : finset A} {x : A} (H1 : x ∈ s) (H2 : x ∉ t) : x ∈ s \ t := +mem_sep_of_mem H1 H2 + +theorem mem_diff_iff (s t : finset A) (x : A) : x ∈ s \ t ↔ x ∈ s ∧ x ∉ t := +iff.intro + (assume H, and.intro (mem_of_mem_diff H) (not_mem_of_mem_diff H)) + (assume H, mem_diff (and.left H) (and.right H)) + +theorem mem_diff_eq (s t : finset A) (x : A) : x ∈ s \ t = (x ∈ s ∧ x ∉ t) := +propext !mem_diff_iff + +theorem union_diff_cancel {s t : finset A} (H : s ⊆ t) : s ∪ (t \ s) = t := +ext (take x, iff.intro + (suppose x ∈ s ∪ (t \ s), + or.elim (mem_or_mem_of_mem_union this) + (suppose x ∈ s, mem_of_subset_of_mem H this) + (suppose x ∈ t \ s, mem_of_mem_diff this)) + (suppose x ∈ t, + decidable.by_cases + (suppose x ∈ s, mem_union_left _ this) + (suppose x ∉ s, mem_union_right _ (mem_diff `x ∈ t` this)))) + +theorem diff_union_cancel {s t : finset A} (H : s ⊆ t) : (t \ s) ∪ s = t := +eq.subst !union_comm (!union_diff_cancel H) +end diff + +/- set complement -/ +section complement + +variables {A : Type} [deceqA : decidable_eq A] [h : fintype A] +include deceqA h + +definition compl (s : finset A) : finset A := univ \ s +prefix [priority finset.prio] - := compl + +theorem mem_compl {s : finset A} {x : A} (H : x ∉ s) : x ∈ -s := +mem_diff !mem_univ H + +theorem not_mem_of_mem_compl {s : finset A} {x : A} (H : x ∈ -s) : x ∉ s := +not_mem_of_mem_diff H + +theorem mem_compl_iff (s : finset A) (x : A) : x ∈ -s ↔ x ∉ s := +iff.intro not_mem_of_mem_compl mem_compl + +section + local attribute classical.prop_decidable [instance] + + theorem union_eq_compl_compl_inter_compl (s t : finset A) : s ∪ t = -(-s ∩ -t) := + ext (take x, by rewrite [mem_union_iff, mem_compl_iff, mem_inter_iff, *mem_compl_iff, + or_iff_not_and_not]) + + theorem inter_eq_compl_compl_union_compl (s t : finset A) : s ∩ t = -(-s ∪ -t) := + ext (take x, by rewrite [mem_inter_iff, mem_compl_iff, mem_union_iff, *mem_compl_iff, + and_iff_not_or_not]) +end + +end complement + +/- all -/ +section all +variables {A : Type} +definition all (s : finset A) (p : A → Prop) : Prop := +quot.lift_on s + (λ l, all (elt_of l) p) + (λ l₁ l₂ p, foldr_eq_of_perm (λ a₁ a₂ q, propext !and.left_comm) p true) + +theorem all_empty (p : A → Prop) : all ∅ p = true := +rfl + +theorem of_mem_of_all {p : A → Prop} {a : A} {s : finset A} : a ∈ s → all s p → p a := +quot.induction_on s (λ l i h, list.of_mem_of_all i h) + +theorem forall_of_all {p : A → Prop} {s : finset A} (H : all s p) : ∀{a}, a ∈ s → p a := +λ a H', of_mem_of_all H' H + +theorem all_of_forall {p : A → Prop} {s : finset A} : (∀a, a ∈ s → p a) → all s p := +quot.induction_on s (λ l H, list.all_of_forall H) + +theorem all_iff_forall (p : A → Prop) (s : finset A) : all s p ↔ (∀a, a ∈ s → p a) := +iff.intro forall_of_all all_of_forall + +attribute [instance] +definition decidable_all (p : A → Prop) [h : decidable_pred p] (s : finset A) : + decidable (all s p) := +quot.rec_on_subsingleton s (λ l, list.decidable_all p (elt_of l)) + +theorem all_implies {p q : A → Prop} {s : finset A} : all s p → (∀ x, p x → q x) → all s q := +quot.induction_on s (λ l h₁ h₂, list.all_implies h₁ h₂) + +variable [h : decidable_eq A] +include h + +theorem all_union {p : A → Prop} {s₁ s₂ : finset A} : all s₁ p → all s₂ p → all (s₁ ∪ s₂) p := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ a₁ a₂, all_union a₁ a₂) + +theorem all_of_all_union_left {p : A → Prop} {s₁ s₂ : finset A} : all (s₁ ∪ s₂) p → all s₁ p := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ a, list.all_of_all_union_left a) + +theorem all_of_all_union_right {p : A → Prop} {s₁ s₂ : finset A} : all (s₁ ∪ s₂) p → all s₂ p := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ a, list.all_of_all_union_right a) + +theorem all_insert_of_all {p : A → Prop} {a : A} {s : finset A} : p a → all s p → all (insert a s) p := +quot.induction_on s (λ l h₁ h₂, list.all_insert_of_all h₁ h₂) + +theorem all_erase_of_all {p : A → Prop} (a : A) {s : finset A}: all s p → all (erase a s) p := +quot.induction_on s (λ l h, list.all_erase_of_all a h) + +theorem all_inter_of_all_left {p : A → Prop} {s₁ : finset A} (s₂ : finset A) : all s₁ p → all (s₁ ∩ s₂) p := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ h, list.all_inter_of_all_left _ h) + +theorem all_inter_of_all_right {p : A → Prop} {s₁ : finset A} (s₂ : finset A) : all s₂ p → all (s₁ ∩ s₂) p := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ h, list.all_inter_of_all_right _ h) + +theorem subset_iff_all (s t : finset A) : s ⊆ t ↔ all s (λ x, x ∈ t) := +iff.intro + (suppose s ⊆ t, all_of_forall (take x, suppose x ∈ s, mem_of_subset_of_mem `s ⊆ t` `x ∈ s`)) + (suppose all s (λ x, x ∈ t), subset_of_forall (take x, suppose x ∈ s, of_mem_of_all `x ∈ s` `all s (λ x, x ∈ t)`)) + +attribute [instance] +definition decidable_subset (s t : finset A) : decidable (s ⊆ t) := +decidable_of_decidable_of_iff _ (iff.symm !subset_iff_all) +end all + +/- any -/ +section any +variables {A : Type} +definition any (s : finset A) (p : A → Prop) : Prop := +quot.lift_on s + (λ l, any (elt_of l) p) + (λ l₁ l₂ p, foldr_eq_of_perm (λ a₁ a₂ q, propext !or.left_comm) p false) + +theorem any_empty (p : A → Prop) : any ∅ p = false := rfl + +theorem exists_of_any {p : A → Prop} {s : finset A} : any s p → ∃a, a ∈ s ∧ p a := +quot.induction_on s (λ l H, list.exists_of_any H) + +theorem any_of_mem {p : A → Prop} {s : finset A} {a : A} : a ∈ s → p a → any s p := +quot.induction_on s (λ l H1 H2, list.any_of_mem H1 H2) + +theorem any_of_exists {p : A → Prop} {s : finset A} (H : ∃a, a ∈ s ∧ p a) : any s p := +obtain a H₁ H₂, from H, +any_of_mem H₁ H₂ + +theorem any_iff_exists (p : A → Prop) (s : finset A) : any s p ↔ (∃a, a ∈ s ∧ p a) := +iff.intro exists_of_any any_of_exists + +theorem any_of_insert [h : decidable_eq A] {p : A → Prop} (s : finset A) {a : A} (H : p a) : + any (insert a s) p := +any_of_mem (mem_insert a s) H + +theorem any_of_insert_right [h : decidable_eq A] {p : A → Prop} {s : finset A} (a : A) (H : any s p) : + any (insert a s) p := +obtain b (H₁ : b ∈ s) (H₂ : p b), from exists_of_any H, +any_of_mem (mem_insert_of_mem a H₁) H₂ + +attribute [instance] +definition decidable_any (p : A → Prop) [h : decidable_pred p] (s : finset A) : + decidable (any s p) := +quot.rec_on_subsingleton s (λ l, list.decidable_any p (elt_of l)) +end any + +section product +variables {A B : Type} +definition product (s₁ : finset A) (s₂ : finset B) : finset (A × B) := +quot.lift_on₂ s₁ s₂ + (λ l₁ l₂, + to_finset_of_nodup (product (elt_of l₁) (elt_of l₂)) + (nodup_product (has_property l₁) (has_property l₂))) + (λ v₁ v₂ w₁ w₂ p₁ p₂, begin apply @quot.sound, apply perm_product p₁ p₂ end) + +infix [priority finset.prio] * := product + +theorem empty_product (s : finset B) : @empty A * s = ∅ := +quot.induction_on s (λ l, rfl) + +theorem mem_product {a : A} {b : B} {s₁ : finset A} {s₂ : finset B} + : a ∈ s₁ → b ∈ s₂ → (a, b) ∈ s₁ * s₂ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ i₁ i₂, list.mem_product i₁ i₂) + +theorem mem_of_mem_product_left {a : A} {b : B} {s₁ : finset A} {s₂ : finset B} + : (a, b) ∈ s₁ * s₂ → a ∈ s₁ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ i, list.mem_of_mem_product_left i) + +theorem mem_of_mem_product_right {a : A} {b : B} {s₁ : finset A} {s₂ : finset B} + : (a, b) ∈ s₁ * s₂ → b ∈ s₂ := +quot.induction_on₂ s₁ s₂ (λ l₁ l₂ i, list.mem_of_mem_product_right i) + +theorem product_empty (s : finset A) : s * @empty B = ∅ := +ext (λ p, + match p with + | (a, b) := iff.intro + (λ i, absurd (mem_of_mem_product_right i) !not_mem_empty) + (λ i, absurd i !not_mem_empty) + end) +end product + +/- powerset -/ +section powerset +variables {A : Type} [deceqA : decidable_eq A] +include deceqA + + section list_powerset + open list + + definition list_powerset : list A → finset (finset A) + | [] := '{∅} + | (a :: l) := list_powerset l ∪ image (insert a) (list_powerset l) + + end list_powerset + +private theorem image_insert_comm (a b : A) (s : finset (finset A)) : + image (insert a) (image (insert b) s) = image (insert b) (image (insert a) s) := +have aux' : ∀ a b : A, ∀ x : finset A, + x ∈ image (insert a) (image (insert b) s) → + x ∈ image (insert b) (image (insert a) s), from + begin + intros [a, b, x, H], + cases (exists_of_mem_image H) with [y, Hy], + cases Hy with [Hy1, Hy2], + cases (exists_of_mem_image Hy1) with [z, Hz], + cases Hz with [Hz1, Hz2], + substvars, + rewrite insert.comm, + repeat (apply mem_image_of_mem), + assumption + end, +ext (take x, iff.intro (aux' a b x) (aux' b a x)) + +theorem list_powerset_eq_list_powerset_of_perm {l₁ l₂ : list A} (p : l₁ ~ l₂) : + list_powerset l₁ = list_powerset l₂ := +perm.induction_on p + rfl + (λ x l₁ l₂ p ih, by rewrite [↑list_powerset, ih]) + (λ x y l, by rewrite [↑list_powerset, ↑list_powerset, *image_union, image_insert_comm, + *union_assoc, union_left_comm (finset.image (finset.insert x) _)]) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, eq.trans r₁ r₂) + +definition powerset (s : finset A) : finset (finset A) := +quot.lift_on s + (λ l, list_powerset (elt_of l)) + (λ l₁ l₂ p, list_powerset_eq_list_powerset_of_perm p) + +prefix [priority finset.prio] `𝒫`:100 := powerset + +theorem powerset_empty : 𝒫 (∅ : finset A) = '{∅} := rfl + +theorem powerset_insert {a : A} {s : finset A} : a ∉ s → 𝒫 (insert a s) = 𝒫 s ∪ image (insert a) (𝒫 s) := +quot.induction_on s + (λ l, + assume H : a ∉ quot.mk l, + calc + 𝒫 (insert a (quot.mk l)) + = list_powerset (list.insert a (elt_of l)) : rfl + ... = list_powerset (#list a :: elt_of l) : by rewrite [list.insert_eq_of_not_mem H] + ... = 𝒫 (quot.mk l) ∪ image (insert a) (𝒫 (quot.mk l)) : rfl) + +theorem mem_powerset_iff_subset (s : finset A) : ∀ x, x ∈ 𝒫 s ↔ x ⊆ s := +begin + induction s with a s nains ih, + intro x, + rewrite powerset_empty, + show x ∈ '{∅} ↔ x ⊆ ∅, by rewrite [mem_singleton_iff, subset_empty_iff], + intro x, + rewrite [powerset_insert nains, mem_union_iff, ih, mem_image_iff], + exact + (iff.intro + (assume H, + or.elim H + (suppose x ⊆ s, subset.trans this !subset_insert) + (suppose ∃ y, y ∈ 𝒫 s ∧ insert a y = x, + obtain y [yps iay], from this, + show x ⊆ insert a s, + begin + rewrite [-iay], + apply insert_subset_insert, + rewrite -ih, + apply yps + end)) + (assume H : x ⊆ insert a s, + have H' : erase a x ⊆ s, from erase_subset_of_subset_insert H, + decidable.by_cases + (suppose a ∈ x, + or.inr (exists.intro (erase a x) + (and.intro + (show erase a x ∈ 𝒫 s, by rewrite ih; apply H') + (show insert a (erase a x) = x, from insert_erase this)))) + (suppose a ∉ x, or.inl + (show x ⊆ s, by rewrite [(erase_eq_of_not_mem this) at H']; apply H')))) +end + +theorem subset_of_mem_powerset {s t : finset A} (H : s ∈ 𝒫 t) : s ⊆ t := +iff.mp (mem_powerset_iff_subset t s) H + +theorem mem_powerset_of_subset {s t : finset A} (H : s ⊆ t) : s ∈ 𝒫 t := +iff.mpr (mem_powerset_iff_subset t s) H + +theorem empty_mem_powerset (s : finset A) : ∅ ∈ 𝒫 s := +mem_powerset_of_subset (empty_subset s) + +end powerset +end finset diff --git a/old_library/data/finset/default.lean b/old_library/data/finset/default.lean new file mode 100644 index 0000000000..fbda901595 --- /dev/null +++ b/old_library/data/finset/default.lean @@ -0,0 +1,8 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Finite sets. +-/ +import .basic .comb .to_set .card .bigops .partition diff --git a/old_library/data/finset/equiv.lean b/old_library/data/finset/equiv.lean new file mode 100644 index 0000000000..92cc2d4b54 --- /dev/null +++ b/old_library/data/finset/equiv.lean @@ -0,0 +1,287 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +import data.finset.card +open nat decidable + +namespace finset +variable {A : Type} + +protected definition to_nat (s : finset nat) : nat := +finset.Sum s (λ n, 2^n) + +open finset (to_nat) + +lemma to_nat_empty : to_nat ∅ = 0 := +rfl + +lemma to_nat_insert {n : nat} {s : finset nat} : n ∉ s → to_nat (insert n s) = 2^n + to_nat s := +assume h, Sum_insert_of_not_mem _ h + +protected definition of_nat (s : nat) : finset nat := +{ n ∈ upto (succ s) | odd (s / 2^n) } + +open finset (of_nat) + +private lemma of_nat_zero : of_nat 0 = ∅ := +rfl + +private lemma odd_of_mem_of_nat {n : nat} {s : nat} : n ∈ of_nat s → odd (s / 2^n) := +assume h, of_mem_sep h + +private lemma mem_of_nat_of_odd {n : nat} {s : nat} : odd (s / 2^n) → n ∈ of_nat s := +assume h, +have 2^n < succ s, from by_contradiction + (suppose ¬(2^n < succ s), + have 2^n > s, from lt_of_succ_le (le_of_not_gt this), + have s / 2^n = 0, from div_eq_zero_of_lt this, + by rewrite this at h; exact absurd h dec_trivial), +have n < succ s, from calc + n ≤ 2^n : le_pow_self dec_trivial n + ... < succ s : this, +have n ∈ upto (succ s), from mem_upto_of_lt this, +mem_sep_of_mem this h + +private lemma succ_mem_of_nat (n : nat) (s : nat) : succ n ∈ of_nat s ↔ n ∈ of_nat (s / 2) := +iff.intro + (suppose succ n ∈ of_nat s, + have odd (s / 2^(succ n)), from odd_of_mem_of_nat this, + have odd ((s / 2) / (2 ^ n)), by rewrite [pow_succ' at this, nat.div_div_eq_div_mul, mul.comm]; assumption, + show n ∈ of_nat (s / 2), from mem_of_nat_of_odd this) + (suppose n ∈ of_nat (s / 2), + have odd ((s / 2) / (2 ^ n)), from odd_of_mem_of_nat this, + have odd (s / 2^(succ n)), by rewrite [pow_succ', mul.comm, -nat.div_div_eq_div_mul]; assumption, + show succ n ∈ of_nat s, from mem_of_nat_of_odd this) + +private lemma odd_of_zero_mem (s : nat) : 0 ∈ of_nat s ↔ odd s := +begin + unfold of_nat, rewrite [mem_sep_eq, pow_zero, nat.div_one, mem_upto_eq], + show 0 < succ s ∧ odd s ↔ odd s, from + iff.intro + (assume h, and.right h) + (assume h, and.intro (zero_lt_succ s) h) +end + +private lemma even_of_not_zero_mem (s : nat) : 0 ∉ of_nat s ↔ even s := +have aux : 0 ∉ of_nat s ↔ ¬odd s, from not_iff_not_of_iff (odd_of_zero_mem s), +iff.intro + (suppose 0 ∉ of_nat s, even_of_not_odd (iff.mp aux this)) + (suppose even s, iff.mpr aux (not_odd_of_even this)) + +private lemma even_to_nat (s : finset nat) : even (to_nat s) ↔ 0 ∉ s := +finset.induction_on s dec_trivial + (λ a s nains ih, + begin + rewrite [to_nat_insert nains], apply iff.intro, + suppose even (2^a + to_nat s), by_cases + (suppose e : even (2^a), by_cases + (suppose even (to_nat s), + have 0 ∉ s, from iff.mp ih this, + suppose 0 ∈ insert a s, or.elim (eq_or_mem_of_mem_insert this) + (suppose 0 = a, begin rewrite [-this at e], exact absurd e not_even_one end) + (by contradiction)) + (suppose odd (to_nat s), absurd `even (2^a + to_nat s)` (odd_add_of_even_of_odd `even (2^a)` this))) + (suppose o : odd (2^a), by_cases + (suppose even (to_nat s), absurd `even (2^a + to_nat s)` (odd_add_of_odd_of_even `odd (2^a)` this)) + (suppose odd (to_nat s), suppose 0 ∈ insert a s, or.elim (eq_or_mem_of_mem_insert this) + (suppose 0 = a, + have even (to_nat s), from iff.mpr ih (by rewrite -this at nains; exact nains), + absurd this `odd (to_nat s)`) + (suppose 0 ∈ s, + have a ≠ 0, from suppose a = 0, by subst a; contradiction, + begin + cases a with a, exact absurd rfl `0 ≠ 0`, + have odd (2*2^a), by rewrite [pow_succ' at o, mul.comm]; exact o, + have even (2*2^a), from !even_two_mul, + exact absurd `even (2*2^a)` `odd (2*2^a)` + end))), + suppose 0 ∉ insert a s, + have a ≠ 0, from suppose a = 0, absurd (by rewrite this; apply mem_insert) `0 ∉ insert a s`, + have 0 ∉ s, from suppose 0 ∈ s, absurd (mem_insert_of_mem _ this) `0 ∉ insert a s`, + have even (to_nat s), from iff.mpr ih this, + match a with + | 0 := suppose a = 0, absurd this `a ≠ 0` + | (succ a') := suppose a = succ a', + have even (2^(succ a')), by rewrite [pow_succ', mul.comm]; apply even_two_mul, + even_add_of_even_of_even this `even (to_nat s)` + end rfl + end) + +private lemma of_nat_eq_insert_zero {s : nat} : 0 ∉ of_nat s → of_nat (2^0 + s) = insert 0 (of_nat s) := +assume h : 0 ∉ of_nat s, +have even s, from iff.mp (even_of_not_zero_mem s) h, +have odd (s+1), from odd_succ_of_even this, +have zmem : 0 ∈ of_nat (s+1), from iff.mpr (odd_of_zero_mem (s+1)) this, +obtain w (hw : s = 2*w), from exists_of_even `even s`, +begin + rewrite [pow_zero, add.comm, hw], + show of_nat (2*w+1) = insert 0 (of_nat (2*w)), from + finset.ext (λ n, + match n with + | 0 := iff.intro (λ h, !mem_insert) (λ h, by rewrite [hw at zmem]; exact zmem) + | succ m := + have d₁ : 1 / 2 = (0:nat), from dec_trivial, + have aux : _, from calc + succ m ∈ of_nat (2 * w + 1) ↔ m ∈ of_nat ((2*w+1) / 2) : succ_mem_of_nat + ... ↔ m ∈ of_nat w : by rewrite [add.comm, add_mul_div_self_left _ _ (dec_trivial : 2 > 0), d₁, zero_add] + ... ↔ m ∈ of_nat (2*w / 2) : by rewrite [mul.comm, nat.mul_div_cancel _ (dec_trivial : 2 > 0)] + ... ↔ succ m ∈ of_nat (2*w) : succ_mem_of_nat, + iff.intro + (λ hl, finset.mem_insert_of_mem _ (iff.mp aux hl)) + (λ hr, or.elim (eq_or_mem_of_mem_insert hr) + (by contradiction) + (iff.mpr aux)) + end) +end + +private lemma of_nat_eq_insert : ∀ {n s : nat}, n ∉ of_nat s → of_nat (2^n + s) = insert n (of_nat s) +| 0 s h := of_nat_eq_insert_zero h +| (succ n) s h := + have n ∉ of_nat (s / 2), + from iff.mp (not_iff_not_of_iff !succ_mem_of_nat) h, + have ih : of_nat (2^n + s / 2) = insert n (of_nat (s / 2)), from of_nat_eq_insert this, + finset.ext (λ x, + have gen : ∀ m, m ∈ of_nat (2^(succ n) + s) ↔ m ∈ insert (succ n) (of_nat s) + | zero := + have even (2^(succ n)), by rewrite [pow_succ', mul.comm]; apply even_two_mul, + have aux₁ : odd (2^(succ n) + s) ↔ odd s, from iff.intro + (suppose odd (2^(succ n) + s), by_contradiction + (suppose ¬ odd s, + have even s, from even_of_not_odd this, + have even (2^(succ n) + s), from even_add_of_even_of_even `even (2^(succ n))` this, + absurd `odd (2^(succ n) + s)` (not_odd_of_even this))) + (suppose odd s, odd_add_of_even_of_odd `even (2^(succ n))` this), + have aux₂ : odd s ↔ 0 ∈ insert (succ n) (of_nat s), from iff.intro + (suppose odd s, finset.mem_insert_of_mem _ (iff.mpr !odd_of_zero_mem this)) + (suppose 0 ∈ insert (succ n) (of_nat s), or.elim (eq_or_mem_of_mem_insert this) + (by contradiction) + (suppose 0 ∈ of_nat s, iff.mp !odd_of_zero_mem this)), + calc + 0 ∈ of_nat (2^(succ n) + s) ↔ odd (2^(succ n) + s) : odd_of_zero_mem + ... ↔ odd s : aux₁ + ... ↔ 0 ∈ insert (succ n) (of_nat s) : aux₂ + | (succ m) := + have aux : m ∈ insert n (of_nat (s / 2)) ↔ succ m ∈ insert (succ n) (of_nat s), from iff.intro + (assume hl, or.elim (eq_or_mem_of_mem_insert hl) + (suppose m = n, by subst m; apply mem_insert) + (suppose m ∈ of_nat (s / 2), finset.mem_insert_of_mem _ (iff.mpr !succ_mem_of_nat this))) + (assume hr, or.elim (eq_or_mem_of_mem_insert hr) + (suppose succ m = succ n, + have m = n, by injection this; assumption, + by subst m; apply mem_insert) + (suppose succ m ∈ of_nat s, finset.mem_insert_of_mem _ (iff.mp !succ_mem_of_nat this))), + calc + succ m ∈ of_nat (2^(succ n) + s) ↔ succ m ∈ of_nat (2^n * 2 + s) : by rewrite pow_succ' + ... ↔ m ∈ of_nat ((2^n * 2 + s) / 2) : succ_mem_of_nat + ... ↔ m ∈ of_nat (2^n + s / 2) : by rewrite [add.comm, add_mul_div_self (dec_trivial : 2 > 0), add.comm] + ... ↔ m ∈ insert n (of_nat (s / 2)) : by rewrite ih + ... ↔ succ m ∈ insert (succ n) (of_nat s) : aux, + gen x) + +lemma of_nat_to_nat (s : finset nat) : of_nat (to_nat s) = s := +finset.induction_on s rfl + (λ a s nains ih, by rewrite [to_nat_insert nains, -ih at nains, of_nat_eq_insert nains, ih]) + +private definition predimage (s : finset nat) : finset nat := +{ n ∈ image pred s | succ n ∈ s } + +private lemma mem_image_pred_of_succ_mem {n : nat} {s : finset nat} : succ n ∈ s → n ∈ image pred s := +assume h, + have pred (succ n) ∈ image pred s, from mem_image_of_mem _ h, + begin rewrite [pred_succ at this], assumption end + +private lemma mem_predimage_of_succ_mem {n : nat} {s : finset nat} : succ n ∈ s → n ∈ predimage s := +assume h, begin unfold predimage, rewrite [mem_sep_eq], exact and.intro (mem_image_pred_of_succ_mem h) h end + +private lemma succ_mem_of_mem_predimage {n : nat} {s : finset nat} : n ∈ predimage s → succ n ∈ s := +begin + unfold predimage, rewrite [mem_sep_eq], + suppose n ∈ image pred s ∧ succ n ∈ s, and.right this +end + +private lemma predimage_insert_zero (s : finset nat) : predimage (insert 0 s) = predimage s := +finset.ext (λ n, + begin + unfold predimage, rewrite [*mem_sep_eq, image_insert, pred_zero], apply iff.intro, + suppose n ∈ insert 0 (image pred s) ∧ succ n ∈ insert 0 s, + have succ n ∈ s, from or.elim (eq_or_mem_of_mem_insert (and.right this)) + (by contradiction) + (λ h, h), + and.intro (mem_image_pred_of_succ_mem this) this, + suppose n ∈ image pred s ∧ succ n ∈ s, + obtain h₁ h₂, from this, + and.intro (mem_insert_of_mem 0 h₁) (mem_insert_of_mem 0 h₂) + end) + +private lemma predimage_insert_succ (n : nat) (s : finset nat) : predimage (insert (succ n) s) = insert n (predimage s) := +finset.ext (λ m, + begin + unfold predimage, rewrite [*mem_sep_eq, *image_insert, pred_succ, *mem_insert_eq, *mem_sep_eq], apply iff.intro, + suppose (m = n ∨ m ∈ image pred s) ∧ (succ m = succ n ∨ succ m ∈ s), + obtain h₁ h₂, from this, + or.elim h₁ + (suppose m = n, or.inl this) + (suppose m ∈ image pred s, or.elim h₂ + (suppose succ m = succ n, by injection this; left; assumption) + (suppose succ m ∈ s, by right; split; repeat assumption)), + suppose m = n ∨ m ∈ image pred s ∧ succ m ∈ s, or.elim this + (suppose m = n, and.intro (or.inl this) (or.inl (by subst m))) + (suppose m ∈ image pred s ∧ succ m ∈ s, + obtain h₁ h₂, from this, + and.intro (or.inr h₁) (or.inr h₂)) + end) + +private lemma of_nat_div2 (s : nat) : of_nat (s / 2) = predimage (of_nat s) := +finset.ext (λ n, iff.intro + (suppose n ∈ of_nat (s / 2), + have succ n ∈ of_nat s, from iff.mpr !succ_mem_of_nat this, + mem_predimage_of_succ_mem this) + (suppose n ∈ predimage (of_nat s), + have succ n ∈ of_nat s, from succ_mem_of_mem_predimage this, + iff.mp !succ_mem_of_nat this)) + +private lemma to_nat_predimage (s : finset nat) : to_nat (predimage s) = (to_nat s) / 2 := +begin + induction s with a s nains ih, + reflexivity, + cases a with a, + { rewrite [predimage_insert_zero, ih, to_nat_insert nains, pow_zero], + have 0 ∉ of_nat (to_nat s), begin rewrite of_nat_to_nat, exact nains end, + have even (to_nat s), from iff.mp !even_of_not_zero_mem this, + obtain (w : nat) (hw : to_nat s = 2*w), from exists_of_even this, + begin + rewrite hw, + have d₁ : 1 / 2 = (0:nat), from dec_trivial, + show 2 * w / 2 = (1 + 2 * w) / 2, by + rewrite [add_mul_div_self_left _ _ (dec_trivial : 2 > 0), mul.comm, + nat.mul_div_cancel _ (dec_trivial : 2 > 0), d₁, zero_add] + end }, + { have a ∉ predimage s, from suppose a ∈ predimage s, absurd (succ_mem_of_mem_predimage this) nains, + rewrite [predimage_insert_succ, to_nat_insert nains, pow_succ', add.comm, + add_mul_div_self (dec_trivial : 2 > 0), -ih, to_nat_insert this, add.comm] } +end + +lemma to_nat_of_nat (s : nat) : to_nat (of_nat s) = s := +nat.strong_induction_on s + (λ n ih, by_cases + (suppose n = 0, by rewrite this) + (suppose n ≠ 0, + have n / 2 < n, from div_lt_of_ne_zero this, + have to_nat (of_nat (n / 2)) = n / 2, from ih _ this, + have e₁ : to_nat (of_nat n) / 2 = n / 2, from calc + to_nat (of_nat n) / 2 = to_nat (predimage (of_nat n)) : by rewrite to_nat_predimage + ... = to_nat (of_nat (n / 2)) : by rewrite of_nat_div2 + ... = n / 2 : this, + have e₂ : even (to_nat (of_nat n)) ↔ even n, from calc + even (to_nat (of_nat n)) ↔ 0 ∉ of_nat n : even_to_nat + ... ↔ even n : even_of_not_zero_mem, + eq_of_div2_of_even e₁ e₂)) + +open equiv + +definition finset_nat_equiv_nat : finset nat ≃ nat := +mk to_nat of_nat of_nat_to_nat to_nat_of_nat + +end finset diff --git a/old_library/data/finset/finset.md b/old_library/data/finset/finset.md new file mode 100644 index 0000000000..23e540f871 --- /dev/null +++ b/old_library/data/finset/finset.md @@ -0,0 +1,11 @@ +data.finset +=========== + +Finite sets. By default, `import list` imports everything here. + +[basic](basic.lean) : basic operations and properties +[comb](comb.lean) : combinators and list constructions +[to_set](to_set.lean) : interactions with sets +[card](card.lean) : cardinality +[bigops](bigops.lean) : finite unions and intersections +[partition](partition.lean) : partitions of a type into finsets diff --git a/old_library/data/finset/partition.lean b/old_library/data/finset/partition.lean new file mode 100644 index 0000000000..3015046f9a --- /dev/null +++ b/old_library/data/finset/partition.lean @@ -0,0 +1,142 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Haitao Zhang + +Partitions of a type A into finite subsets of A. Such a partition is represented by +a function f : A → finset A which maps every element a : A to its equivalence class. +-/ +import .card +open function eq.ops + +variable {A : Type} +variable [deceqA : decidable_eq A] +include deceqA + +namespace finset + +definition is_partition (f : A → finset A) := ∀ a b, a ∈ f b = (f a = f b) + +structure partition : Type := +(set : finset A) (part : A → finset A) (is_part : is_partition part) + (complete : set = Union set part) + +-- attribute partition.part [coercion] + +namespace partition + +definition equiv_classes (f : partition) : finset (finset A) := +image (partition.part f) (partition.set f) + +lemma equiv_class_disjoint (f : partition) (a1 a2 : finset A) (Pa1 : a1 ∈ equiv_classes f) + (Pa2 : a2 ∈ equiv_classes f) : + a1 ≠ a2 → a1 ∩ a2 = ∅ := +assume Pne, +have Pe1 : _, from exists_of_mem_image Pa1, obtain g1 Pg1, from Pe1, +have Pe2 : _, from exists_of_mem_image Pa2, obtain g2 Pg2, from Pe2, +begin + apply inter_eq_empty_of_disjoint, + apply disjoint.intro, + rewrite [eq.symm (and.right Pg1), eq.symm (and.right Pg2)], + intro x, + rewrite [*partition.is_part f], + intro Pxg1, rewrite [Pxg1, and.right Pg1, and.right Pg2], + intro Pe, exact absurd Pe Pne +end +open nat +theorem class_equation (f : @partition A _) : + card (partition.set f) = finset.Sum (equiv_classes f) card := +let s := (partition.set f), p := (partition.part f), img := image p s in + calc + card s = card (Union s p) : partition.complete f + ... = card (Union img id) : image_eq_Union_index_image s p + ... = card (Union (equiv_classes f) id) : rfl + ... = finset.Sum (equiv_classes f) card : card_Union_of_disjoint _ id (equiv_class_disjoint f) + +lemma equiv_class_refl {f : A → finset A} (Pequiv : is_partition f) : ∀ a, a ∈ f a := +take a, by rewrite [Pequiv a a] + +-- make it a little easier to prove union from restriction +lemma restriction_imp_union {s : finset A} (f : A → finset A) (Pequiv : is_partition f) + (Psub : ∀{a}, a ∈ s → f a ⊆ s) : + s = Union s f := +ext (take a, iff.intro + (assume Pains, + begin + rewrite [(Union_insert_of_mem f Pains)⁻¹, Union_insert], + apply mem_union_l, exact equiv_class_refl Pequiv a + end) + (assume Painu, + have Pclass : ∃ x, x ∈ s ∧ a ∈ f x, + from iff.elim_left (mem_Union_iff s f _) Painu, + obtain x Px, from Pclass, + have Pfx : f x ⊆ s, from Psub (and.left Px), + mem_of_subset_of_mem Pfx (and.right Px))) + +lemma binary_union (P : A → Prop) [decP : decidable_pred P] {S : finset A} : + S = {a ∈ S | P a} ∪ {a ∈ S | ¬(P a)} := +ext take a, iff.intro + (suppose a ∈ S, decidable.by_cases + (suppose P a, mem_union_l (mem_sep_of_mem `a ∈ S` this)) + (suppose ¬ P a, mem_union_r (mem_sep_of_mem `a ∈ S` this))) + (suppose a ∈ sep P S ∪ {a ∈ S | ¬ P a}, or.elim (mem_or_mem_of_mem_union this) + (suppose a ∈ sep P S, mem_of_mem_sep this) + (suppose a ∈ {a ∈ S | ¬ P a}, mem_of_mem_sep this)) + +lemma binary_inter_empty {P : A → Prop} [decP : decidable_pred P] {S : finset A} : + {a ∈ S | P a} ∩ {a ∈ S | ¬(P a)} = ∅ := +inter_eq_empty (take a, assume Pa nPa, absurd (of_mem_sep Pa) (of_mem_sep nPa)) + +definition disjoint_sets (S : finset (finset A)) : Prop := + ∀ s₁ s₂ (P₁ : s₁ ∈ S) (P₂ : s₂ ∈ S), s₁ ≠ s₂ → s₁ ∩ s₂ = ∅ + +lemma disjoint_sets_sep_of_disjoint_sets {P : finset A → Prop} [decP : decidable_pred P] {S : finset (finset A)} : + disjoint_sets S → disjoint_sets {s ∈ S | P s} := +assume Pds, take s₁ s₂, assume P₁ P₂, Pds s₁ s₂ (mem_of_mem_sep P₁) (mem_of_mem_sep P₂) + +lemma binary_inter_empty_Union_disjoint_sets {P : finset A → Prop} [decP : decidable_pred P] {S : finset (finset A)} : + disjoint_sets S → Union {s ∈ S | P s} id ∩ Union {s ∈ S | ¬P s} id = ∅ := +assume Pds, inter_eq_empty (take a, assume Pa nPa, + obtain s Psin Pains, from iff.elim_left !mem_Union_iff Pa, + obtain t Ptin Paint, from iff.elim_left !mem_Union_iff nPa, + have s ≠ t, + from assume Peq, absurd (Peq ▸ of_mem_sep Psin) (of_mem_sep Ptin), + have e₁ : s ∩ t = empty, from Pds s t (mem_of_mem_sep Psin) (mem_of_mem_sep Ptin) `s ≠ t`, + have a ∈ s ∩ t, from mem_inter Pains Paint, + have a ∈ empty, from e₁ ▸ this, + absurd this !not_mem_empty) + +section +variables {B: Type} [deceqB : decidable_eq B] +include deceqB + +lemma binary_Union (f : A → finset B) {P : A → Prop} [decP : decidable_pred P] {s : finset A} : + Union s f = Union {a ∈ s | P a} f ∪ Union {a ∈ s | ¬P a} f := +begin rewrite [binary_union P at {1}], apply Union_union, exact binary_inter_empty end + +end + +open nat +section + +variables {B : Type} [acmB : add_comm_monoid B] +include acmB + +lemma Sum_binary_union (f : A → B) (P : A → Prop) [decP : decidable_pred P] {S : finset A} : + Sum S f = Sum {s ∈ S | P s} f + Sum {s ∈ S | ¬P s} f := +calc + Sum S f = Sum ({s ∈ S | P s} ∪ {s ∈ S | ¬(P s)}) f : binary_union + ... = Sum {s ∈ S | P s} f + Sum {s ∈ S | ¬P s} f : Sum_union f binary_inter_empty + +end + +lemma card_binary_Union_disjoint_sets (P : finset A → Prop) [decP : decidable_pred P] {S : finset (finset A)} : + disjoint_sets S → card (Union S id) = Sum {s ∈ S | P s} card + Sum {s ∈ S | ¬P s} card := +assume Pds, calc + card (Union S id) + = card (Union {s ∈ S | P s} id ∪ Union {s ∈ S | ¬P s} id) : binary_Union + ... = card (Union {s ∈ S | P s} id) + card (Union {s ∈ S | ¬P s} id) : card_union_of_disjoint (binary_inter_empty_Union_disjoint_sets Pds) + ... = Sum {s ∈ S | P s} card + Sum {s ∈ S | ¬P s} card : by rewrite [*(card_Union_of_disjoint _ id (disjoint_sets_sep_of_disjoint_sets Pds))] + +end partition +end finset diff --git a/old_library/data/finset/to_set.lean b/old_library/data/finset/to_set.lean new file mode 100644 index 0000000000..432b15f2ae --- /dev/null +++ b/old_library/data/finset/to_set.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Interactions between finset and set. +-/ +import data.finset.comb data.set.function +open nat eq.ops set + +namespace finset + +variable {A : Type} +variable [deceq : decidable_eq A] + +definition to_set (s : finset A) : set A := λx, x ∈ s +abbreviation ts := @to_set A + +variables (s t : finset A) (x y : A) + +theorem mem_eq_mem_to_set : x ∈ s = (x ∈ ts s) := rfl + +definition to_set.inj {s₁ s₂ : finset A} : to_set s₁ = to_set s₂ → s₁ = s₂ := +λ h, ext (λ a, iff.of_eq (calc + (a ∈ s₁) = (a ∈ ts s₁) : mem_eq_mem_to_set + ... = (a ∈ ts s₂) : h + ... = (a ∈ s₂) : mem_eq_mem_to_set)) + +/- operations -/ + +theorem mem_to_set_empty : (x ∈ ts ∅) = (x ∈ ∅) := rfl +theorem to_set_empty : ts ∅ = (@set.empty A) := rfl + +theorem mem_to_set_univ [h : fintype A] : (x ∈ ts univ) = (x ∈ set.univ) := + propext (iff.intro (assume H, trivial) (assume H, !mem_univ)) +theorem to_set_univ [h : fintype A] : ts univ = (set.univ : set A) := funext (λ x, !mem_to_set_univ) + +theorem mem_to_set_upto (x n : ℕ) : x ∈ ts (upto n) = (x ∈ {a | a < n}) := !mem_upto_eq +theorem to_set_upto (n : ℕ) : ts (upto n) = {a | a < n} := funext (λ x, !mem_to_set_upto) + +include deceq + +theorem mem_to_set_insert : x ∈ insert y s = (x ∈ set.insert y s) := !mem_insert_eq +theorem to_set_insert : insert y s = set.insert y s := funext (λ x, !mem_to_set_insert) + +theorem mem_to_set_union : x ∈ s ∪ t = (x ∈ ts s ∪ ts t) := !mem_union_eq +theorem to_set_union : ts (s ∪ t) = ts s ∪ ts t := funext (λ x, !mem_to_set_union) + +theorem mem_to_set_inter : x ∈ s ∩ t = (x ∈ ts s ∩ ts t) := !mem_inter_eq +theorem to_set_inter : ts (s ∩ t) = ts s ∩ ts t := funext (λ x, !mem_to_set_inter) + +theorem mem_to_set_diff : x ∈ s \ t = (x ∈ ts s \ ts t) := !mem_diff_eq +theorem to_set_diff : ts (s \ t) = ts s \ ts t := funext (λ x, !mem_to_set_diff) + +theorem mem_to_set_sep (p : A → Prop) [h : decidable_pred p] : x ∈ sep p s = (x ∈ set.sep p s) := + !finset.mem_sep_eq +theorem to_set_sep (p : A → Prop) [h : decidable_pred p] : sep p s = set.sep p s := + funext (λ x, !mem_to_set_sep) + +theorem mem_to_set_image {B : Type} [h : decidable_eq B] (f : A → B) {s : finset A} {y : B} : + y ∈ image f s = (y ∈ set.image f s) := !mem_image_eq +theorem to_set_image {B : Type} [h : decidable_eq B] (f : A → B) (s : finset A) : + image f s = set.image f s := funext (λ x, !mem_to_set_image) + +/- relations -/ + +attribute [instance] +definition decidable_mem_to_set (x : A) (s : finset A) : decidable (x ∈ ts s) := +decidable_of_decidable_of_eq _ !mem_eq_mem_to_set + +theorem eq_of_to_set_eq_to_set {s t : finset A} (H : to_set s = to_set t) : s = t := +ext (take x, by rewrite [mem_eq_mem_to_set s, H]) + +theorem eq_eq_to_set_eq : (s = t) = (ts s = ts t) := +propext (iff.intro (assume H, H ▸ rfl) !eq_of_to_set_eq_to_set) + +attribute [instance] +definition decidable_to_set_eq (s t : finset A) : decidable (ts s = ts t) := +decidable_of_decidable_of_eq _ !eq_eq_to_set_eq + +theorem subset_eq_to_set_subset (s t : finset A) : (s ⊆ t) = (ts s ⊆ ts t) := +propext (iff.intro + (assume H, take x xs, mem_of_subset_of_mem H xs) + (assume H, subset_of_forall H)) + +definition decidable_to_set_subset (s t : finset A) : decidable (ts s ⊆ ts t) := +decidable_of_decidable_of_eq _ !subset_eq_to_set_subset + +/- bounded quantifiers -/ + +definition decidable_bounded_forall (s : finset A) (p : A → Prop) [h : decidable_pred p] : + decidable (∀₀ x ∈ ts s, p x) := +decidable_of_decidable_of_iff _ !all_iff_forall + +definition decidable_bounded_exists (s : finset A) (p : A → Prop) [h : decidable_pred p] : + decidable (∃₀ x ∈ ts s, p x) := +decidable_of_decidable_of_iff _ !any_iff_exists + +/- properties -/ + +theorem inj_on_to_set {B : Type} [h : decidable_eq B] (f : A → B) (s : finset A) : + inj_on f s = inj_on f (ts s) := +rfl + +end finset diff --git a/old_library/data/fintype/basic.lean b/old_library/data/fintype/basic.lean new file mode 100644 index 0000000000..455b5ad799 --- /dev/null +++ b/old_library/data/fintype/basic.lean @@ -0,0 +1,225 @@ +/- +Copyright (c) 2015 Leonardo de Moura. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Finite type (type class). +-/ +import data.list.perm data.list.as_type data.bool data.equiv +open list bool unit decidable option function + +structure fintype [class] (A : Type) : Type := +(elems : list A) (unique : nodup elems) (complete : ∀ a, a ∈ elems) + +definition elements_of (A : Type) [h : fintype A] : list A := +@fintype.elems A h + +section +open equiv +definition fintype_of_equiv {A B : Type} [h : fintype A] : A ≃ B → fintype B +| (mk f g l r) := + fintype.mk + (map f (elements_of A)) + (nodup_map (injective_of_left_inverse l) !fintype.unique) + (λ b, + have g b ∈ elements_of A, from fintype.complete (g b), + have f (g b) ∈ map f (elements_of A), from mem_map f this, + by rewrite r at this; exact this) +end + +attribute [instance] +definition fintype_unit : fintype unit := +fintype.mk [star] dec_trivial (λ u, match u with star := dec_trivial end) + +attribute [instance] +definition fintype_bool : fintype bool := +fintype.mk [ff, tt] + dec_trivial + (λ b, match b with | tt := dec_trivial | ff := dec_trivial end) + +attribute [instance] +definition fintype_product {A B : Type} : Π [h₁ : fintype A] [h₂ : fintype B], fintype (A × B) +| (fintype.mk e₁ u₁ c₁) (fintype.mk e₂ u₂ c₂) := + fintype.mk + (product e₁ e₂) + (nodup_product u₁ u₂) + (λ p, + match p with + (a, b) := mem_product (c₁ a) (c₂ b) + end) + +/- auxiliary function for finding 'a' s.t. f a ≠ g a -/ +section find_discr +variables {A B : Type} +variable [h : decidable_eq B] +include h +definition find_discr (f g : A → B) : list A → option A +| [] := none +| (a::l) := if f a = g a then find_discr l else some a + +theorem find_discr_nil (f g : A → B) : find_discr f g [] = none := +rfl + +theorem find_discr_cons_of_ne {f g : A → B} {a : A} (l : list A) : f a ≠ g a → find_discr f g (a::l) = some a := +assume ne, if_neg ne + +theorem find_discr_cons_of_eq {f g : A → B} {a : A} (l : list A) : f a = g a → find_discr f g (a::l) = find_discr f g l := +assume eq, if_pos eq + +theorem ne_of_find_discr_eq_some {f g : A → B} {a : A} : ∀ {l}, find_discr f g l = some a → f a ≠ g a +| [] e := by contradiction +| (x::l) e := by_cases + (suppose f x = g x, + have find_discr f g l = some a, by rewrite [find_discr_cons_of_eq l this at e]; exact e, + ne_of_find_discr_eq_some this) + (assume h : f x ≠ g x, + have some x = some a, by rewrite [find_discr_cons_of_ne l h at e]; exact e, + by clear ne_of_find_discr_eq_some; injection this; subst a; exact h) + +theorem all_eq_of_find_discr_eq_none {f g : A → B} : ∀ {l}, find_discr f g l = none → ∀ a, a ∈ l → f a = g a +| [] e a i := absurd i !not_mem_nil +| (x::l) e a i := by_cases + (assume fx_eq_gx : f x = g x, + or.elim (eq_or_mem_of_mem_cons i) + (suppose a = x, by rewrite [-this at fx_eq_gx]; exact fx_eq_gx) + (suppose a ∈ l, + have aux : find_discr f g l = none, by rewrite [find_discr_cons_of_eq l fx_eq_gx at e]; exact e, + all_eq_of_find_discr_eq_none aux a this)) + (suppose f x ≠ g x, + by rewrite [find_discr_cons_of_ne l this at e]; contradiction) +end find_discr + +attribute [instance] +definition decidable_eq_fun {A B : Type} [h₁ : fintype A] [h₂ : decidable_eq B] : decidable_eq (A → B) := +λ f g, + match h₁ with + | fintype.mk e u c := + match find_discr f g e with + | some a := λ h : find_discr f g e = some a, inr (λ f_eq_g : f = g, absurd (by rewrite f_eq_g; reflexivity) (ne_of_find_discr_eq_some h)) + | none := λ h : find_discr f g e = none, inl (show f = g, from funext (λ a : A, all_eq_of_find_discr_eq_none h a (c a))) + end rfl + end + +section check_pred +variables {A : Type} + +definition check_pred (p : A → Prop) [h : decidable_pred p] : list A → bool +| [] := tt +| (a::l) := if p a then check_pred l else ff + +theorem check_pred_cons_of_pos {p : A → Prop} [h : decidable_pred p] {a : A} (l : list A) : p a → check_pred p (a::l) = check_pred p l := +assume pa, if_pos pa + +theorem check_pred_cons_of_neg {p : A → Prop} [h : decidable_pred p] {a : A} (l : list A) : ¬ p a → check_pred p (a::l) = ff := +assume npa, if_neg npa + +theorem all_of_check_pred_eq_tt {p : A → Prop} [h : decidable_pred p] : ∀ {l : list A}, check_pred p l = tt → ∀ {a}, a ∈ l → p a +| [] eqtt a ainl := absurd ainl !not_mem_nil +| (b::l) eqtt a ainbl := by_cases + (suppose p b, or.elim (eq_or_mem_of_mem_cons ainbl) + (suppose a = b, by rewrite [this]; exact `p b`) + (suppose a ∈ l, + have check_pred p l = tt, by rewrite [check_pred_cons_of_pos _ `p b` at eqtt]; exact eqtt, + all_of_check_pred_eq_tt this `a ∈ l`)) + (suppose ¬ p b, + by rewrite [check_pred_cons_of_neg _ this at eqtt]; exact (bool.no_confusion eqtt)) + +theorem ex_of_check_pred_eq_ff {p : A → Prop} [h : decidable_pred p] : ∀ {l : list A}, check_pred p l = ff → ∃ w, ¬ p w +| [] eqtt := bool.no_confusion eqtt +| (a::l) eqtt := by_cases + (suppose p a, + have check_pred p l = ff, by rewrite [check_pred_cons_of_pos _ this at eqtt]; exact eqtt, + ex_of_check_pred_eq_ff this) + (suppose ¬ p a, exists.intro a this) +end check_pred + +attribute [instance] +definition decidable_forall_finite {A : Type} {p : A → Prop} [h₁ : fintype A] [h₂ : decidable_pred p] + : decidable (∀ x : A, p x) := +match h₁ with +| fintype.mk e u c := + match check_pred p e with + | tt := suppose check_pred p e = tt, inl (take a : A, all_of_check_pred_eq_tt this (c a)) + | ff := suppose check_pred p e = ff, + inr (suppose ∀ x, p x, + obtain (a : A) (w : ¬ p a), from ex_of_check_pred_eq_ff `check_pred p e = ff`, + absurd (this a) w) + end rfl +end + +attribute [instance] +definition decidable_exists_finite {A : Type} {p : A → Prop} [h₁ : fintype A] [h₂ : decidable_pred p] + : decidable (∃ x : A, p x) := +match h₁ with +| fintype.mk e u c := + match check_pred (λ a, ¬ p a) e with + | tt := λ h : check_pred (λ a, ¬ p a) e = tt, inr (λ ex : (∃ x, p x), + obtain x px, from ex, + absurd px (all_of_check_pred_eq_tt h (c x))) + | ff := λ h : check_pred (λ a, ¬ p a) e = ff, inl ( + have ∃ x, ¬¬p x, from ex_of_check_pred_eq_ff h, + obtain x nnpx, from this, exists.intro x (not_not_elim nnpx)) + end rfl +end + +open list.as_type +-- Auxiliary function for returning a list with all elements of the type: (list.as_type l) +-- Remark ⟪s⟫ is notation for (list.as_type l) +-- We use this function to define the instance for (fintype ⟪s⟫) +private definition ltype_elems {A : Type} {s : list A} : Π {l : list A}, l ⊆ s → list ⟪s⟫ +| [] h := [] +| (a::l) h := lval a (h a !mem_cons) :: ltype_elems (sub_of_cons_sub h) + +private theorem mem_of_mem_ltype_elems {A : Type} {a : A} {s : list A} + : Π {l : list A} {h : l ⊆ s} {m : a ∈ s}, mk a m ∈ ltype_elems h → a ∈ l +| [] h m lin := absurd lin !not_mem_nil +| (b::l) h m lin := or.elim (eq_or_mem_of_mem_cons lin) + (suppose mk a m = mk b (h b (mem_cons b l)), + as_type.no_confusion this (λ aeqb em, by rewrite [aeqb]; exact !mem_cons)) + (suppose mk a m ∈ ltype_elems (sub_of_cons_sub h), + have a ∈ l, from mem_of_mem_ltype_elems this, + mem_cons_of_mem _ this) + +private theorem nodup_ltype_elems {A : Type} {s : list A} : Π {l : list A} (d : nodup l) (h : l ⊆ s), nodup (ltype_elems h) +| [] d h := nodup_nil +| (a::l) d h := + have d₁ : nodup l, from nodup_of_nodup_cons d, + have nainl : a ∉ l, from not_mem_of_nodup_cons d, + let h₁ : l ⊆ s := sub_of_cons_sub h in + have d₂ : nodup (ltype_elems h₁), from nodup_ltype_elems d₁ h₁, + have nin : mk a (h a (mem_cons a l)) ∉ ltype_elems h₁, from + assume ab, absurd (mem_of_mem_ltype_elems ab) nainl, + nodup_cons nin d₂ + +private theorem mem_ltype_elems {A : Type} {s : list A} {a : ⟪s⟫} + : Π {l : list A} (h : l ⊆ s), value a ∈ l → a ∈ ltype_elems h +| [] h vainl := absurd vainl !not_mem_nil +| (b::l) h vainbl := or.elim (eq_or_mem_of_mem_cons vainbl) + (λ vaeqb : value a = b, + begin + revert vaeqb h, + -- TODO(Leo): check why 'cases a with va, ma' produces an incorrect proof + eapply as_type.cases_on a, + intro va ma vaeqb, + rewrite -vaeqb, intro h, + apply mem_cons + end) + (λ vainl : value a ∈ l, + have aux : a ∈ ltype_elems (sub_of_cons_sub h), from mem_ltype_elems (sub_of_cons_sub h) vainl, + mem_cons_of_mem _ aux) + +attribute [instance] +definition fintype_list_as_type {A : Type} [h : decidable_eq A] {s : list A} : fintype ⟪s⟫ := +let nds : list A := erase_dup s in +have sub₁ : nds ⊆ s, from erase_dup_sub s, +have sub₂ : s ⊆ nds, from sub_erase_dup s, +have dnds : nodup nds, from nodup_erase_dup s, +let e : list ⟪s⟫ := ltype_elems sub₁ in +fintype.mk + e + (nodup_ltype_elems dnds sub₁) + (take a : ⟪s⟫, + show a ∈ e, from + have value a ∈ s, from is_member a, + have value a ∈ nds, from sub₂ this, + mem_ltype_elems sub₁ this) diff --git a/old_library/data/fintype/card.lean b/old_library/data/fintype/card.lean new file mode 100644 index 0000000000..c58cff507f --- /dev/null +++ b/old_library/data/fintype/card.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2015 Haitao Zhang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Haitao Zhang + +Cardinality for finite types. +-/ +import .basic data.list data.finset.card +open eq.ops nat function list finset + +namespace fintype + +attribute [reducible] +definition card (A : Type) [finA : fintype A] := finset.card (@finset.univ A _) + +lemma card_eq_card_image_of_inj + {A : Type} [finA : fintype A] [deceqA : decidable_eq A] + {B : Type} [finB : fintype B] [deceqB : decidable_eq B] + {f : A → B} : + injective f → finset.card (image f univ) = card A := +assume Pinj, +card_image_eq_of_inj_on (to_set_univ⁻¹ ▸ (iff.mp !set.injective_iff_inj_on_univ Pinj)) + +-- General version of the pigeonhole principle. See also data.less_than. +lemma card_le_of_inj (A : Type) [finA : fintype A] [deceqA : decidable_eq A] + (B : Type) [finB : fintype B] [deceqB : decidable_eq B] : + (∃ f : A → B, injective f) → card A ≤ card B := +assume Pex, obtain f Pinj, from Pex, +have Pinj_on_univ : _, from iff.mp !set.injective_iff_inj_on_univ Pinj, +have Pinj_ts : set.inj_on f (ts univ), from to_set_univ⁻¹ ▸ Pinj_on_univ, +have Psub : (image f univ) ⊆ univ, from !subset_univ, +finset.card_le_of_inj_on univ univ (exists.intro f (and.intro Pinj_ts Psub)) + +-- used to prove that inj ∧ eq card => surj +lemma univ_of_card_eq_univ {A : Type} [finA : fintype A] [deceqA : decidable_eq A] {s : finset A} : + finset.card s = card A → s = univ := +assume Pcardeq, ext (take a, +have D : decidable (a ∈ s), from decidable_mem a s, begin +apply iff.intro, + intro ain, apply mem_univ, + intro ain, cases D with Pin Pnin, + exact Pin, + have Pplus1 : finset.card (insert a s) = finset.card s + 1, + from card_insert_of_not_mem Pnin, + rewrite Pcardeq at Pplus1, + have Ple : finset.card (insert a s) ≤ card A, + begin apply card_le_card_of_subset, apply subset_univ end, + rewrite Pplus1 at Ple, + exact false.elim (not_succ_le_self Ple) +end) + +end fintype diff --git a/old_library/data/fintype/default.lean b/old_library/data/fintype/default.lean new file mode 100644 index 0000000000..6d54294983 --- /dev/null +++ b/old_library/data/fintype/default.lean @@ -0,0 +1,8 @@ +/- +Copyright (c) 2015 Leonardo de Moura. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Finite type (type class). +-/ +import .basic .card diff --git a/old_library/data/fintype/fintype.md b/old_library/data/fintype/fintype.md new file mode 100644 index 0000000000..f4e82edd1a --- /dev/null +++ b/old_library/data/fintype/fintype.md @@ -0,0 +1,8 @@ +data.fintype +============ + +Finite types. + +* [basic](basic.lean) +* [function](function.lean) +* [card](card.lean) diff --git a/old_library/data/fintype/function.lean b/old_library/data/fintype/function.lean new file mode 100644 index 0000000000..75de6c50eb --- /dev/null +++ b/old_library/data/fintype/function.lean @@ -0,0 +1,455 @@ +/- +Copyright (c) 2015 Haitao Zhang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author : Haitao Zhang +-/ +import data + +open nat function eq.ops + +namespace list +-- this is in preparation for counting the number of finite functions +section list_of_lists +open prod +variable {A : Type} + +definition cons_pair (pr : A × list A) := (pr1 pr) :: (pr2 pr) + +definition cons_all_of (elts : list A) (ls : list (list A)) : list (list A) := + map cons_pair (product elts ls) + +lemma pair_of_cons {a} {l} {pr : A × list A} : cons_pair pr = a::l → pr = (a, l) := + prod.destruct pr (λ p1 p2, assume Peq, list.no_confusion Peq (by intros; substvars)) + +lemma cons_pair_inj : injective (@cons_pair A) := + take p1 p2, assume Pl, + prod.eq (list.no_confusion Pl (λ P1 P2, P1)) (list.no_confusion Pl (λ P1 P2, P2)) + +lemma nodup_of_cons_all {elts : list A} {ls : list (list A)} + : nodup elts → nodup ls → nodup (cons_all_of elts ls) := + assume Pelts Pls, + nodup_map cons_pair_inj (nodup_product Pelts Pls) + +lemma length_cons_all {elts : list A} {ls : list (list A)} : + length (cons_all_of elts ls) = length elts * length ls := calc + length (cons_all_of elts ls) = length (product elts ls) : length_map + ... = length elts * length ls : length_product + +variable [finA : fintype A] +include finA + +definition all_lists_of_len : ∀ (n : nat), list (list A) +| 0 := [[]] +| (succ n) := cons_all_of (elements_of A) (all_lists_of_len n) + +definition all_nodups_of_len [deceqA : decidable_eq A] (n : nat) : list (list A) := + filter nodup (all_lists_of_len n) + +lemma nodup_all_lists : ∀ {n : nat}, nodup (@all_lists_of_len A _ n) +| 0 := nodup_singleton [] +| (succ n) := nodup_of_cons_all (fintype.unique A) nodup_all_lists + +lemma nodup_all_nodups [deceqA : decidable_eq A] {n : nat} : + nodup (@all_nodups_of_len A _ _ n) := + nodup_filter nodup nodup_all_lists + +lemma mem_all_lists : ∀ {n : nat} {l : list A}, length l = n → l ∈ all_lists_of_len n +| 0 [] := assume P, mem_cons [] [] +| 0 (a::l) := assume Peq, by contradiction +| (succ n) [] := assume Peq, by contradiction +| (succ n) (a::l) := assume Peq, begin + apply mem_map, apply mem_product, + exact fintype.complete a, + exact mem_all_lists (succ.inj Peq) + end + +lemma mem_all_nodups [deceqA : decidable_eq A] (n : nat) (l : list A) : + length l = n → nodup l → l ∈ all_nodups_of_len n := + assume Pl Pn, mem_filter_of_mem (mem_all_lists Pl) Pn + +lemma nodup_mem_all_nodups [deceqA : decidable_eq A] {n : nat} ⦃l : list A⦄ : + l ∈ all_nodups_of_len n → nodup l := + assume Pl, of_mem_filter Pl + +lemma length_mem_all_lists : ∀ {n : nat} ⦃l : list A⦄, + l ∈ all_lists_of_len n → length l = n +| 0 [] := assume P, rfl +| 0 (a::l) := assume Pin, have Peq : (a::l) = [], from mem_singleton Pin, + by contradiction +| (succ n) [] := assume Pin, obtain pr Pprin Ppr, from exists_of_mem_map Pin, + by contradiction +| (succ n) (a::l) := assume Pin, obtain pr Pprin Ppr, from exists_of_mem_map Pin, + have Pl : l ∈ all_lists_of_len n, + from mem_of_mem_product_right ((pair_of_cons Ppr) ▸ Pprin), + by rewrite [length_cons, length_mem_all_lists Pl] + +lemma length_mem_all_nodups [deceqA : decidable_eq A] {n : nat} ⦃l : list A⦄ : + l ∈ all_nodups_of_len n → length l = n := + assume Pl, length_mem_all_lists (mem_of_mem_filter Pl) + +open fintype +lemma length_all_lists : ∀ {n : nat}, length (@all_lists_of_len A _ n) = (card A) ^ n +| 0 := calc length [[]] = 1 : length_cons +| (succ n) := calc length _ = card A * length (all_lists_of_len n) : length_cons_all + ... = card A * (card A ^ n) : length_all_lists + ... = (card A ^ n) * card A : mul.comm + ... = (card A) ^ (succ n) : pow_succ' + + +end list_of_lists + +section kth + +variable {A : Type} + +definition kth : ∀ k (l : list A), k < length l → A +| k [] := begin rewrite length_nil, intro Pltz, exact absurd Pltz !not_lt_zero end +| 0 (a::l) := λ P, a +| (k+1) (a::l):= by rewrite length_cons; intro Plt; exact kth k l (lt_of_succ_lt_succ Plt) + +lemma kth_zero_of_cons {a} (l : list A) (P : 0 < length (a::l)) : kth 0 (a::l) P = a := + rfl +lemma kth_succ_of_cons {a} k (l : list A) (P : k+1 < length (a::l)) : + kth (succ k) (a::l) P = kth k l (lt_of_succ_lt_succ P) := + rfl + +lemma kth_mem : ∀ {k : nat} {l : list A} P, kth k l P ∈ l +| k [] := assume P, absurd P !not_lt_zero +| 0 (a::l) := assume P, by rewrite kth_zero_of_cons; apply mem_cons +| (succ k) (a::l) := assume P, by + rewrite [kth_succ_of_cons]; apply mem_cons_of_mem a; apply kth_mem + +-- Leo provided the following proof. +lemma eq_of_kth_eq [deceqA : decidable_eq A] + : ∀ {l1 l2 : list A} (Pleq : length l1 = length l2), + (∀ (k : nat) (Plt1 : k < length l1) (Plt2 : k < length l2), kth k l1 Plt1 = kth k l2 Plt2) → l1 = l2 +| [] [] h₁ h₂ := rfl +| (a₁::l₁) [] h₁ h₂ := by contradiction +| [] (a₂::l₂) h₁ h₂ := by contradiction +| (a₁::l₁) (a₂::l₂) h₁ h₂ := + have ih₁ : length l₁ = length l₂, by injection h₁; eassumption, + have ih₂ : ∀ (k : nat) (plt₁ : k < length l₁) (plt₂ : k < length l₂), kth k l₁ plt₁ = kth k l₂ plt₂, + begin + intro k plt₁ plt₂, + have splt₁ : succ k < length l₁ + 1, from succ_le_succ plt₁, + have splt₂ : succ k < length l₂ + 1, from succ_le_succ plt₂, + have keq : kth (succ k) (a₁::l₁) splt₁ = kth (succ k) (a₂::l₂) splt₂, from h₂ (succ k) splt₁ splt₂, + rewrite *kth_succ_of_cons at keq, + exact keq + end, + have ih : l₁ = l₂, from eq_of_kth_eq ih₁ ih₂, + have k₁ : a₁ = a₂, + begin + have lt₁ : 0 < length (a₁::l₁), from !zero_lt_succ, + have lt₂ : 0 < length (a₂::l₂), from !zero_lt_succ, + have e₁ : kth 0 (a₁::l₁) lt₁ = kth 0 (a₂::l₂) lt₂, from h₂ 0 lt₁ lt₂, + rewrite *kth_zero_of_cons at e₁, + assumption + end, + by subst l₁; subst a₁ + +lemma kth_of_map {B : Type} {f : A → B} : + ∀ {k : nat} {l : list A} Plt Pmlt, kth k (map f l) Pmlt = f (kth k l Plt) +| k [] := assume P, absurd P !not_lt_zero +| 0 (a::l) := assume Plt, by + rewrite [map_cons]; intro Pmlt; rewrite [kth_zero_of_cons] +| (succ k) (a::l) := assume P, begin + rewrite [map_cons], intro Pmlt, rewrite [*kth_succ_of_cons], + apply kth_of_map + end + +lemma kth_find [deceqA : decidable_eq A] : + ∀ {l : list A} {a} P, kth (find a l) l P = a +| [] := take a, assume P, absurd P !not_lt_zero +| (x::l) := take a, begin + have Pd : decidable (a = x), begin apply deceqA end, + cases Pd with Pe Pne, + rewrite [find_cons_of_eq l Pe], intro P, rewrite [kth_zero_of_cons, Pe], + rewrite [find_cons_of_ne l Pne], intro P, rewrite [kth_succ_of_cons], + apply kth_find + end + +lemma find_kth [deceqA : decidable_eq A] : + ∀ {k : nat} {l : list A} P, find (kth k l P) l < length l +| k [] := assume P, absurd P !not_lt_zero +| 0 (a::l) := assume P, begin + rewrite [kth_zero_of_cons, find_cons_of_eq l rfl, length_cons], + exact !zero_lt_succ + end +| (succ k) (a::l) := assume P, begin + rewrite [kth_succ_of_cons], + have Pd : decidable ((kth k l (lt_of_succ_lt_succ P)) = a), + begin apply deceqA end, + cases Pd with Pe Pne, + rewrite [find_cons_of_eq l Pe], apply zero_lt_succ, + rewrite [find_cons_of_ne l Pne], apply succ_lt_succ, apply find_kth + end + +lemma find_kth_of_nodup [deceqA : decidable_eq A] : + ∀ {k : nat} {l : list A} P, nodup l → find (kth k l P) l = k +| k [] := assume P, absurd P !not_lt_zero +| 0 (a::l) := assume Plt Pnodup, + by rewrite [kth_zero_of_cons, find_cons_of_eq l rfl] +| (succ k) (a::l) := assume Plt Pnodup, begin + rewrite [kth_succ_of_cons], + have Pd : decidable ((kth k l (lt_of_succ_lt_succ Plt)) = a), + begin apply deceqA end, + cases Pd with Pe Pne, + have Pin : a ∈ l, begin rewrite -Pe, apply kth_mem end, + exact absurd Pin (not_mem_of_nodup_cons Pnodup), + rewrite [find_cons_of_ne l Pne], apply congr (eq.refl succ), + apply find_kth_of_nodup (lt_of_succ_lt_succ Plt) (nodup_of_nodup_cons Pnodup) + end + +end kth + +end list + + +namespace fintype +open list + +section found + +variables {A B : Type} +variable [finA : fintype A] +include finA + +lemma find_in_range [deceqB : decidable_eq B] {f : A → B} (b : B) : + ∀ (l : list A) P, f (kth (find b (map f l)) l P) = b +| [] := assume P, begin exact absurd P !not_lt_zero end +| (a::l) := decidable.rec_on (deceqB b (f a)) + (assume Peq, begin + rewrite [map_cons f a l, find_cons_of_eq _ Peq], + intro P, rewrite [kth_zero_of_cons], exact (Peq⁻¹) + end) + (assume Pne, begin + rewrite [map_cons f a l, find_cons_of_ne _ Pne], + intro P, + rewrite [kth_succ_of_cons (find b (map f l)) l P], + exact find_in_range l (lt_of_succ_lt_succ P) + end) + +end found + +section list_to_fun +variables {A B : Type} +variable [finA : fintype A] +include finA + +definition fun_to_list (f : A → B) : list B := map f (elems A) + +lemma length_map_of_fintype (f : A → B) : length (map f (elems A)) = card A := + by apply length_map + +variable [deceqA : decidable_eq A] +include deceqA + +lemma fintype_find (a : A) : find a (elems A) < card A := + find_lt_length (complete a) + +definition list_to_fun (l : list B) (leq : length l = card A) : A → B := + take x, + kth _ _ (leq⁻¹ ▸ fintype_find x) + +definition all_funs [finB : fintype B] : list (A → B) := + dmap (λ l, length l = card A) list_to_fun (all_lists_of_len (card A)) + +lemma list_to_fun_apply (l : list B) (leq : length l = card A) (a : A) : + ∀ P, list_to_fun l leq a = kth (find a (elems A)) l P := + assume P, rfl + +variable [deceqB : decidable_eq B] +include deceqB + +lemma fun_eq_list_to_fun_map (f : A → B) : ∀ P, f = list_to_fun (map f (elems A)) P := + assume Pleq, funext (take a, + have Plt : _, from Pleq⁻¹ ▸ find_lt_length (complete a), begin + rewrite [list_to_fun_apply _ Pleq a (Pleq⁻¹ ▸ find_lt_length (complete a))], + have Pmlt : find a (elems A) < length (map f (elems A)), + begin rewrite length_map, exact Plt end, + rewrite [@kth_of_map A B f (find a (elems A)) (elems A) Plt _, kth_find] + end) + +lemma list_eq_map_list_to_fun (l : list B) (leq : length l = card A) + : l = map (list_to_fun l leq) (elems A) := + begin + apply eq_of_kth_eq, rewrite length_map, apply leq, + intro k Plt Plt2, + have Plt1 : k < length (elems A), begin apply leq ▸ Plt end, + have Plt3 : find (kth k (elems A) Plt1) (elems A) < length l, + begin rewrite leq, apply find_kth end, + rewrite [kth_of_map Plt1 Plt2, list_to_fun_apply l leq _ Plt3], + congruence, + rewrite [find_kth_of_nodup Plt1 (unique A)] + end + +lemma fun_to_list_to_fun (f : A → B) : ∀ P, list_to_fun (fun_to_list f) P = f := + assume P, (fun_eq_list_to_fun_map f P)⁻¹ + +lemma list_to_fun_to_list (l : list B) (leq : length l = card A) : + fun_to_list (list_to_fun l leq) = l + := (list_eq_map_list_to_fun l leq)⁻¹ + +lemma dinj_list_to_fun : dinj (λ (l : list B), length l = card A) list_to_fun := + take l1 l2 Pl1 Pl2 Peq, + by rewrite [list_eq_map_list_to_fun l1 Pl1, list_eq_map_list_to_fun l2 Pl2, Peq] + +variable [finB : fintype B] +include finB + +lemma nodup_all_funs : nodup (@all_funs A B _ _ _) := + dmap_nodup_of_dinj dinj_list_to_fun nodup_all_lists + +lemma all_funs_complete (f : A → B) : f ∈ all_funs := + have Plin : map f (elems A) ∈ all_lists_of_len (card A), + from mem_all_lists (by rewrite length_map), + have Plfin : list_to_fun (map f (elems A)) (length_map_of_fintype f) ∈ all_funs, + from mem_dmap _ Plin, + begin rewrite [fun_eq_list_to_fun_map f (length_map_of_fintype f)], apply Plfin end + +lemma all_funs_to_all_lists : + map fun_to_list (@all_funs A B _ _ _) = all_lists_of_len (card A) := + map_dmap_of_inv_of_pos list_to_fun_to_list length_mem_all_lists + +lemma length_all_funs : length (@all_funs A B _ _ _) = (card B) ^ (card A) := calc + length _ = length (map fun_to_list all_funs) : length_map + ... = length (all_lists_of_len (card A)) : all_funs_to_all_lists + ... = (card B) ^ (card A) : length_all_lists + +attribute [instance] +definition fun_is_fintype : fintype (A → B) := + fintype.mk all_funs nodup_all_funs all_funs_complete + +lemma card_funs : card (A → B) = (card B) ^ (card A) := length_all_funs + +end list_to_fun + +section surj_inv +variables {A B : Type} +variable [finA : fintype A] +include finA + +-- surj from fintype domain implies fintype range +lemma mem_map_of_surj {f : A → B} (surj : surjective f) : ∀ b, b ∈ map f (elems A) := + take b, obtain a Peq, from surj b, + Peq ▸ mem_map f (complete a) + +variable [deceqB : decidable_eq B] +include deceqB + +lemma found_of_surj {f : A → B} (surj : surjective f) : + ∀ b, let elts := elems A, k := find b (map f elts) in k < length elts := + λ b, let elts := elems A, img := map f elts, k := find b img in + have Pin : b ∈ img, from mem_map_of_surj surj b, + have Pfound : k < length img, from find_lt_length (mem_map_of_surj surj b), + length_map f elts ▸ Pfound + +definition right_inv {f : A → B} (surj : surjective f) : B → A := + λ b, let elts := elems A, k := find b (map f elts) in + kth k elts (found_of_surj surj b) + +lemma right_inv_of_surj {f : A → B} (surj : surjective f) : f ∘ (right_inv surj) = id := + funext (λ b, find_in_range b (elems A) (found_of_surj surj b)) +end surj_inv + +-- inj functions for equal card types are also surj and therefore bij +-- the right inv (since it is surj) is also the left inv +section inj +open finset + +variables {A B : Type} +variable [finA : fintype A] +include finA +variable [deceqA : decidable_eq A] +include deceqA + +lemma inj_of_card_image_eq [deceqB : decidable_eq B] {f : A → B} : + finset.card (image f univ) = card A → injective f := + assume Peq, by + rewrite [set.injective_iff_inj_on_univ, -to_set_univ]; + apply inj_on_of_card_image_eq Peq + +variable [deceqB : decidable_eq B] +include deceqB + +lemma nodup_of_inj {f : A → B} : injective f → nodup (map f (elems A)) := + assume Pinj, nodup_map Pinj (unique A) + +lemma inj_of_nodup {f : A → B} : + nodup (map f (elems A)) → injective f := + assume Pnodup, inj_of_card_image_eq (calc + finset.card (image f univ) = finset.card (to_finset (map f (elems A))) : rfl + ... = finset.card (to_finset_of_nodup (map f (elems A)) Pnodup) : {(to_finset_eq_of_nodup Pnodup)⁻¹} + ... = length (map f (elems A)) : rfl + ... = length (elems A) : length_map + ... = card A : rfl) + + +variable [finB : fintype B] +include finB + +lemma surj_of_inj_eq_card : card A = card B → ∀ {f : A → B}, injective f → surjective f := +assume Peqcard, take f, assume Pinj, +decidable.rec_on decidable_forall_finite + (assume P : surjective f, P) + (assume Pnsurj : ¬surjective f, + obtain b Pne, from exists_not_of_not_forall Pnsurj, + have Pall : ∀ a, f a ≠ b, from forall_not_of_not_exists Pne, + have Pbnin : b ∉ image f univ, from λ Pin, + obtain a Pa, from exists_of_mem_image Pin, absurd (and.right Pa) (Pall a), + have Puniv : finset.card (image f univ) = card A, from card_eq_card_image_of_inj Pinj, + have Punivb : finset.card (image f univ) = card B, from eq.trans Puniv Peqcard, + have P : image f univ = univ, from univ_of_card_eq_univ Punivb, + absurd (P⁻¹▸ mem_univ b) Pbnin) + +end inj + +section perm + +definition all_injs (A : Type) [finA : fintype A] [deceqA : decidable_eq A] : list (A → A) := + dmap (λ l, length l = card A) list_to_fun (all_nodups_of_len (card A)) + + +variable {A : Type} +variable [finA : fintype A] +include finA +variable [deceqA : decidable_eq A] +include deceqA + +lemma nodup_all_injs : nodup (all_injs A) := + dmap_nodup_of_dinj dinj_list_to_fun nodup_all_nodups + +lemma all_injs_complete {f : A → A} : injective f → f ∈ (all_injs A) := + assume Pinj, + have Plin : map f (elems A) ∈ all_nodups_of_len (card A), + from begin apply mem_all_nodups, apply length_map, apply nodup_of_inj Pinj end, + have Plfin : list_to_fun (map f (elems A)) (length_map_of_fintype f) ∈ !all_injs, + from mem_dmap _ Plin, + begin rewrite [fun_eq_list_to_fun_map f (length_map_of_fintype f)], apply Plfin end + +open finset + +lemma univ_of_leq_univ_of_nodup {l : list A} (n : nodup l) (leq : length l = card A) : + to_finset_of_nodup l n = univ := + univ_of_card_eq_univ (calc + finset.card (to_finset_of_nodup l n) = length l : rfl + ... = card A : leq) + +lemma inj_of_mem_all_injs {f : A → A} : f ∈ (all_injs A) → injective f := + assume Pfin, obtain l Pex, from exists_of_mem_dmap Pfin, + obtain leq Pin Peq, from Pex, + have Pmap : map f (elems A) = l, from Peq⁻¹ ▸ list_to_fun_to_list l leq, + begin apply inj_of_nodup, rewrite Pmap, apply nodup_mem_all_nodups Pin end + +lemma perm_of_inj {f : A → A} : injective f → perm (map f (elems A)) (elems A) := + assume Pinj, + have P1 : univ = to_finset_of_nodup (elems A) (unique A), from rfl, + have P2 : to_finset_of_nodup (map f (elems A)) (nodup_of_inj Pinj) = univ, + from univ_of_leq_univ_of_nodup _ !length_map, + quot.exact (P1 ▸ P2) + +end perm + +end fintype diff --git a/old_library/data/hf.lean b/old_library/data/hf.lean new file mode 100644 index 0000000000..858871a3fd --- /dev/null +++ b/old_library/data/hf.lean @@ -0,0 +1,614 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Hereditarily finite sets: finite sets whose elements are all hereditarily finite sets. + +Remark: all definitions compute, however the performace is quite poor since +we implement this module using a bijection from (finset nat) to nat, and +this bijection is implemeted using the Ackermann coding. +-/ +import data.nat data.finset.equiv data.list +open nat binary +open - [notation] finset + +definition hf := nat + +namespace hf +local attribute hf [reducible] + +protected definition prio : num := num.succ std.priority.default + +attribute [instance] +protected definition is_inhabited : inhabited hf := +nat.is_inhabited + +attribute [instance] +protected definition has_decidable_eq : decidable_eq hf := +nat.has_decidable_eq + +definition of_finset (s : finset hf) : hf := +@equiv.to_fun _ _ finset_nat_equiv_nat s + +definition to_finset (h : hf) : finset hf := +@equiv.inv _ _ finset_nat_equiv_nat h + +definition to_nat (h : hf) : nat := +h + +definition of_nat (n : nat) : hf := +n + +lemma to_finset_of_finset (s : finset hf) : to_finset (of_finset s) = s := +@equiv.left_inv _ _ finset_nat_equiv_nat s + +lemma of_finset_to_finset (s : hf) : of_finset (to_finset s) = s := +@equiv.right_inv _ _ finset_nat_equiv_nat s + +lemma to_finset_inj {s₁ s₂ : hf} : to_finset s₁ = to_finset s₂ → s₁ = s₂ := +λ h, function.injective_of_left_inverse of_finset_to_finset h + +lemma of_finset_inj {s₁ s₂ : finset hf} : of_finset s₁ = of_finset s₂ → s₁ = s₂ := +λ h, function.injective_of_left_inverse to_finset_of_finset h + +/- empty -/ +definition empty : hf := +of_finset (finset.empty) + +notation `∅` := hf.empty + +/- insert -/ +definition insert (a s : hf) : hf := +of_finset (finset.insert a (to_finset s)) + +/- mem -/ +definition mem (a : hf) (s : hf) : Prop := +finset.mem a (to_finset s) + +infix ∈ := mem +notation [priority finset.prio] a ∉ b := ¬ mem a b + +lemma insert_lt_of_not_mem {a s : hf} : a ∉ s → s < insert a s := +begin + unfold [insert, of_finset, equiv.to_fun, finset_nat_equiv_nat, mem, to_finset, equiv.inv], + intro h, + rewrite [finset.to_nat_insert h], + rewrite [to_nat_of_nat, -zero_add s at {1}], + apply add_lt_add_right, + apply pow_pos_of_pos _ dec_trivial +end + +lemma insert_lt_insert_of_not_mem_of_not_mem_of_lt {a s₁ s₂ : hf} + : a ∉ s₁ → a ∉ s₂ → s₁ < s₂ → insert a s₁ < insert a s₂ := +begin + unfold [insert, of_finset, equiv.to_fun, finset_nat_equiv_nat, mem, to_finset, equiv.inv], + intro h₁ h₂ h₃, + rewrite [finset.to_nat_insert h₁], + rewrite [finset.to_nat_insert h₂, *to_nat_of_nat], + apply add_lt_add_left h₃ +end + +open decidable +attribute [instance] +protected definition decidable_mem : ∀ a s, decidable (a ∈ s) := +λ a s, finset.decidable_mem a (to_finset s) + +lemma insert_le (a s : hf) : s ≤ insert a s := +by_cases + (suppose a ∈ s, by rewrite [↑insert, insert_eq_of_mem this, of_finset_to_finset]) + (suppose a ∉ s, le_of_lt (insert_lt_of_not_mem this)) + +lemma not_mem_empty (a : hf) : a ∉ ∅ := +begin unfold [mem, empty], rewrite to_finset_of_finset, apply finset.not_mem_empty end + +lemma mem_insert (a s : hf) : a ∈ insert a s := +begin unfold [mem, insert], rewrite to_finset_of_finset, apply finset.mem_insert end + +lemma mem_insert_of_mem {a s : hf} (b : hf) : a ∈ s → a ∈ insert b s := +begin unfold [mem, insert], intros, rewrite to_finset_of_finset, apply finset.mem_insert_of_mem, assumption end + +lemma eq_or_mem_of_mem_insert {a b s : hf} : a ∈ insert b s → a = b ∨ a ∈ s := +begin unfold [mem, insert], rewrite to_finset_of_finset, intros, apply eq_or_mem_of_mem_insert, assumption end + +theorem mem_of_mem_insert_of_ne {x a : hf} {s : hf} : x ∈ insert a s → x ≠ a → x ∈ s := +begin unfold [mem, insert], rewrite to_finset_of_finset, intros, apply mem_of_mem_insert_of_ne, repeat assumption end + +protected theorem ext {s₁ s₂ : hf} : (∀ a, a ∈ s₁ ↔ a ∈ s₂) → s₁ = s₂ := +assume h, +have to_finset s₁ = to_finset s₂, from finset.ext h, +have of_finset (to_finset s₁) = of_finset (to_finset s₂), by rewrite this, +by rewrite [*of_finset_to_finset at this]; exact this + +theorem insert_eq_of_mem {a : hf} {s : hf} : a ∈ s → insert a s = s := +begin unfold mem, intro h, unfold [mem, insert], rewrite (finset.insert_eq_of_mem h), rewrite of_finset_to_finset end + +attribute [recursor 4] +protected theorem induction {P : hf → Prop} + (h₁ : P empty) (h₂ : ∀ (a s : hf), a ∉ s → P s → P (insert a s)) (s : hf) : P s := +have P (of_finset (to_finset s)), from + @finset.induction _ _ _ h₁ + (λ a s nain ih, + begin + unfold [mem, insert] at h₂, + rewrite -(to_finset_of_finset s) at nain, + have P (insert a (of_finset s)), by exact h₂ a (of_finset s) nain ih, + rewrite [↑insert at this, to_finset_of_finset at this], + exact this + end) + (to_finset s), +by rewrite of_finset_to_finset at this; exact this + +lemma insert_le_insert_of_le {a s₁ s₂ : hf} : a ∈ s₁ ∨ a ∉ s₂ → s₁ ≤ s₂ → insert a s₁ ≤ insert a s₂ := +suppose a ∈ s₁ ∨ a ∉ s₂, +suppose s₁ ≤ s₂, +by_cases + (suppose s₁ = s₂, by rewrite this) + (suppose s₁ ≠ s₂, + have s₁ < s₂, from lt_of_le_of_ne `s₁ ≤ s₂` `s₁ ≠ s₂`, + by_cases + (suppose a ∈ s₁, by_cases + (suppose a ∈ s₂, by rewrite [insert_eq_of_mem `a ∈ s₁`, insert_eq_of_mem `a ∈ s₂`]; assumption) + (suppose a ∉ s₂, by rewrite [insert_eq_of_mem `a ∈ s₁`]; exact le.trans `s₁ ≤ s₂` !insert_le)) + (suppose a ∉ s₁, by_cases + (suppose a ∈ s₂, or.elim `a ∈ s₁ ∨ a ∉ s₂` (by contradiction) (by contradiction)) + (suppose a ∉ s₂, le_of_lt (insert_lt_insert_of_not_mem_of_not_mem_of_lt `a ∉ s₁` `a ∉ s₂` `s₁ < s₂`)))) + +/- union -/ +definition union (s₁ s₂ : hf) : hf := +of_finset (finset.union (to_finset s₁) (to_finset s₂)) + +infix [priority hf.prio] ∪ := union + +theorem mem_union_left {a : hf} {s₁ : hf} (s₂ : hf) : a ∈ s₁ → a ∈ s₁ ∪ s₂ := +begin unfold mem, intro h, unfold union, rewrite to_finset_of_finset, apply finset.mem_union_left _ h end + +theorem mem_union_l {a : hf} {s₁ : hf} {s₂ : hf} : a ∈ s₁ → a ∈ s₁ ∪ s₂ := +mem_union_left s₂ + +theorem mem_union_right {a : hf} {s₂ : hf} (s₁ : hf) : a ∈ s₂ → a ∈ s₁ ∪ s₂ := +begin unfold mem, intro h, unfold union, rewrite to_finset_of_finset, apply finset.mem_union_right _ h end + +theorem mem_union_r {a : hf} {s₂ : hf} {s₁ : hf} : a ∈ s₂ → a ∈ s₁ ∪ s₂ := +mem_union_right s₁ + +theorem mem_or_mem_of_mem_union {a : hf} {s₁ s₂ : hf} : a ∈ s₁ ∪ s₂ → a ∈ s₁ ∨ a ∈ s₂ := +begin unfold [mem, union], rewrite to_finset_of_finset, intro h, apply finset.mem_or_mem_of_mem_union h end + +theorem mem_union_iff {a : hf} (s₁ s₂ : hf) : a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ := +iff.intro + (λ h, mem_or_mem_of_mem_union h) + (λ d, or.elim d + (λ i, mem_union_left _ i) + (λ i, mem_union_right _ i)) + +theorem mem_union_eq {a : hf} (s₁ s₂ : hf) : (a ∈ s₁ ∪ s₂) = (a ∈ s₁ ∨ a ∈ s₂) := +propext !mem_union_iff + +theorem union_comm (s₁ s₂ : hf) : s₁ ∪ s₂ = s₂ ∪ s₁ := +hf.ext (λ a, by rewrite [*mem_union_eq]; exact or.comm) + +theorem union_assoc (s₁ s₂ s₃ : hf) : (s₁ ∪ s₂) ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) := +hf.ext (λ a, by rewrite [*mem_union_eq]; exact or.assoc) + +theorem union_left_comm (s₁ s₂ s₃ : hf) : s₁ ∪ (s₂ ∪ s₃) = s₂ ∪ (s₁ ∪ s₃) := +!left_comm union_comm union_assoc s₁ s₂ s₃ + +theorem union_right_comm (s₁ s₂ s₃ : hf) : (s₁ ∪ s₂) ∪ s₃ = (s₁ ∪ s₃) ∪ s₂ := +!right_comm union_comm union_assoc s₁ s₂ s₃ + +theorem union_self (s : hf) : s ∪ s = s := +hf.ext (λ a, iff.intro + (λ ain, or.elim (mem_or_mem_of_mem_union ain) (λ i, i) (λ i, i)) + (λ i, mem_union_left _ i)) + +theorem union_empty (s : hf) : s ∪ ∅ = s := +hf.ext (λ a, iff.intro + (suppose a ∈ s ∪ ∅, or.elim (mem_or_mem_of_mem_union this) (λ i, i) (λ i, absurd i !not_mem_empty)) + (suppose a ∈ s, mem_union_left _ this)) + +theorem empty_union (s : hf) : ∅ ∪ s = s := +calc ∅ ∪ s = s ∪ ∅ : union_comm + ... = s : union_empty + +/- inter -/ +definition inter (s₁ s₂ : hf) : hf := +of_finset (finset.inter (to_finset s₁) (to_finset s₂)) + +infix [priority hf.prio] ∩ := inter + +theorem mem_of_mem_inter_left {a : hf} {s₁ s₂ : hf} : a ∈ s₁ ∩ s₂ → a ∈ s₁ := +begin unfold mem, unfold inter, rewrite to_finset_of_finset, intro h, apply finset.mem_of_mem_inter_left h end + +theorem mem_of_mem_inter_right {a : hf} {s₁ s₂ : hf} : a ∈ s₁ ∩ s₂ → a ∈ s₂ := +begin unfold mem, unfold inter, rewrite to_finset_of_finset, intro h, apply finset.mem_of_mem_inter_right h end + +theorem mem_inter {a : hf} {s₁ s₂ : hf} : a ∈ s₁ → a ∈ s₂ → a ∈ s₁ ∩ s₂ := +begin unfold mem, intro h₁ h₂, unfold inter, rewrite to_finset_of_finset, apply finset.mem_inter h₁ h₂ end + +theorem mem_inter_iff (a : hf) (s₁ s₂ : hf) : a ∈ s₁ ∩ s₂ ↔ a ∈ s₁ ∧ a ∈ s₂ := +iff.intro + (λ h, and.intro (mem_of_mem_inter_left h) (mem_of_mem_inter_right h)) + (λ h, mem_inter (and.elim_left h) (and.elim_right h)) + +theorem mem_inter_eq (a : hf) (s₁ s₂ : hf) : (a ∈ s₁ ∩ s₂) = (a ∈ s₁ ∧ a ∈ s₂) := +propext !mem_inter_iff + +theorem inter_comm (s₁ s₂ : hf) : s₁ ∩ s₂ = s₂ ∩ s₁ := +hf.ext (λ a, by rewrite [*mem_inter_eq]; exact and.comm) + +theorem inter_assoc (s₁ s₂ s₃ : hf) : (s₁ ∩ s₂) ∩ s₃ = s₁ ∩ (s₂ ∩ s₃) := +hf.ext (λ a, by rewrite [*mem_inter_eq]; exact and.assoc) + +theorem inter_left_comm (s₁ s₂ s₃ : hf) : s₁ ∩ (s₂ ∩ s₃) = s₂ ∩ (s₁ ∩ s₃) := +!left_comm inter_comm inter_assoc s₁ s₂ s₃ + +theorem inter_right_comm (s₁ s₂ s₃ : hf) : (s₁ ∩ s₂) ∩ s₃ = (s₁ ∩ s₃) ∩ s₂ := +!right_comm inter_comm inter_assoc s₁ s₂ s₃ + +theorem inter_self (s : hf) : s ∩ s = s := +hf.ext (λ a, iff.intro + (λ h, mem_of_mem_inter_right h) + (λ h, mem_inter h h)) + +theorem inter_empty (s : hf) : s ∩ ∅ = ∅ := +hf.ext (λ a, iff.intro + (suppose a ∈ s ∩ ∅, absurd (mem_of_mem_inter_right this) !not_mem_empty) + (suppose a ∈ ∅, absurd this !not_mem_empty)) + +theorem empty_inter (s : hf) : ∅ ∩ s = ∅ := +calc ∅ ∩ s = s ∩ ∅ : inter_comm + ... = ∅ : inter_empty + +/- card -/ +definition card (s : hf) : nat := +finset.card (to_finset s) + +theorem card_empty : card ∅ = 0 := +rfl + +lemma ne_empty_of_card_eq_succ {s : hf} {n : nat} : card s = succ n → s ≠ ∅ := +by intros; substvars; contradiction + +/- erase -/ +definition erase (a : hf) (s : hf) : hf := +of_finset (erase a (to_finset s)) + +theorem not_mem_erase (a : hf) (s : hf) : a ∉ erase a s := +begin unfold [mem, erase], rewrite to_finset_of_finset, apply finset.not_mem_erase end + +theorem card_erase_of_mem {a : hf} {s : hf} : a ∈ s → card (erase a s) = pred (card s) := +begin unfold mem, intro h, unfold [erase, card], rewrite to_finset_of_finset, apply finset.card_erase_of_mem h end + +theorem card_erase_of_not_mem {a : hf} {s : hf} : a ∉ s → card (erase a s) = card s := +begin unfold [mem], intro h, unfold [erase, card], rewrite to_finset_of_finset, apply finset.card_erase_of_not_mem h end + +theorem erase_empty (a : hf) : erase a ∅ = ∅ := +rfl + +theorem ne_of_mem_erase {a b : hf} {s : hf} : b ∈ erase a s → b ≠ a := +by intro h beqa; subst b; exact absurd h !not_mem_erase + +theorem mem_of_mem_erase {a b : hf} {s : hf} : b ∈ erase a s → b ∈ s := +begin unfold [erase, mem], rewrite to_finset_of_finset, intro h, apply mem_of_mem_erase h end + +theorem mem_erase_of_ne_of_mem {a b : hf} {s : hf} : a ≠ b → a ∈ s → a ∈ erase b s := +begin intro h₁, unfold mem, intro h₂, unfold erase, rewrite to_finset_of_finset, apply mem_erase_of_ne_of_mem h₁ h₂ end + +theorem mem_erase_iff (a b : hf) (s : hf) : a ∈ erase b s ↔ a ∈ s ∧ a ≠ b := +iff.intro + (assume H, and.intro (mem_of_mem_erase H) (ne_of_mem_erase H)) + (assume H, mem_erase_of_ne_of_mem (and.right H) (and.left H)) + +theorem mem_erase_eq (a b : hf) (s : hf) : a ∈ erase b s = (a ∈ s ∧ a ≠ b) := +propext !mem_erase_iff + +theorem erase_insert {a : hf} {s : hf} : a ∉ s → erase a (insert a s) = s := +begin + unfold [mem, erase, insert], + intro h, rewrite [to_finset_of_finset, finset.erase_insert h, of_finset_to_finset] +end + +theorem insert_erase {a : hf} {s : hf} : a ∈ s → insert a (erase a s) = s := +begin + unfold mem, intro h, unfold [insert, erase], + rewrite [to_finset_of_finset, finset.insert_erase h, of_finset_to_finset] +end + + +/- subset -/ +definition subset (s₁ s₂ : hf) : Prop := +finset.subset (to_finset s₁) (to_finset s₂) + +infix [priority hf.prio] ⊆ := subset + +theorem empty_subset (s : hf) : ∅ ⊆ s := +begin unfold [empty, subset], rewrite to_finset_of_finset, apply finset.empty_subset (to_finset s) end + +theorem subset.refl (s : hf) : s ⊆ s := +begin unfold [subset], apply finset.subset.refl (to_finset s) end + +theorem subset.trans {s₁ s₂ s₃ : hf} : s₁ ⊆ s₂ → s₂ ⊆ s₃ → s₁ ⊆ s₃ := +begin unfold [subset], intro h₁ h₂, apply finset.subset.trans h₁ h₂ end + +theorem mem_of_subset_of_mem {s₁ s₂ : hf} {a : hf} : s₁ ⊆ s₂ → a ∈ s₁ → a ∈ s₂ := +begin unfold [subset, mem], intro h₁ h₂, apply finset.mem_of_subset_of_mem h₁ h₂ end + +theorem subset.antisymm {s₁ s₂ : hf} : s₁ ⊆ s₂ → s₂ ⊆ s₁ → s₁ = s₂ := +begin unfold [subset], intro h₁ h₂, apply to_finset_inj (finset.subset.antisymm h₁ h₂) end + +-- alternative name +theorem eq_of_subset_of_subset {s₁ s₂ : hf} (H₁ : s₁ ⊆ s₂) (H₂ : s₂ ⊆ s₁) : s₁ = s₂ := +subset.antisymm H₁ H₂ + +theorem subset_of_forall {s₁ s₂ : hf} : (∀x, x ∈ s₁ → x ∈ s₂) → s₁ ⊆ s₂ := +begin unfold [mem, subset], intro h, apply finset.subset_of_forall h end + +theorem subset_insert (s : hf) (a : hf) : s ⊆ insert a s := +begin unfold [subset, insert], rewrite to_finset_of_finset, apply finset.subset_insert (to_finset s) end + +theorem eq_empty_of_subset_empty {x : hf} (H : x ⊆ ∅) : x = ∅ := +subset.antisymm H (empty_subset x) + +theorem subset_empty_iff (x : hf) : x ⊆ ∅ ↔ x = ∅ := +iff.intro eq_empty_of_subset_empty (take xeq, by rewrite xeq; apply subset.refl ∅) + +theorem erase_subset_erase (a : hf) {s t : hf} : s ⊆ t → erase a s ⊆ erase a t := +begin unfold [subset, erase], intro h, rewrite *to_finset_of_finset, apply finset.erase_subset_erase a h end + +theorem erase_subset (a : hf) (s : hf) : erase a s ⊆ s := +begin unfold [subset, erase], rewrite to_finset_of_finset, apply finset.erase_subset a (to_finset s) end + +theorem erase_eq_of_not_mem {a : hf} {s : hf} : a ∉ s → erase a s = s := +begin unfold [mem, erase], intro h, rewrite [finset.erase_eq_of_not_mem h, of_finset_to_finset] end + +theorem erase_insert_subset (a : hf) (s : hf) : erase a (insert a s) ⊆ s := +begin unfold [erase, insert, subset], rewrite [*to_finset_of_finset], apply finset.erase_insert_subset a (to_finset s) end + +theorem erase_subset_of_subset_insert {a : hf} {s t : hf} (H : s ⊆ insert a t) : erase a s ⊆ t := +hf.subset.trans (!hf.erase_subset_erase H) (erase_insert_subset a t) + +theorem insert_erase_subset (a : hf) (s : hf) : s ⊆ insert a (erase a s) := +decidable.by_cases + (assume ains : a ∈ s, by rewrite [!insert_erase ains]; apply subset.refl) + (assume nains : a ∉ s, + suffices s ⊆ insert a s, by rewrite [erase_eq_of_not_mem nains]; assumption, + subset_insert s a) + +theorem insert_subset_insert (a : hf) {s t : hf} : s ⊆ t → insert a s ⊆ insert a t := +begin + unfold [subset, insert], intro h, + rewrite *to_finset_of_finset, apply finset.insert_subset_insert a h +end + +theorem subset_insert_of_erase_subset {s t : hf} {a : hf} (H : erase a s ⊆ t) : s ⊆ insert a t := +subset.trans (insert_erase_subset a s) (!insert_subset_insert H) + +theorem subset_insert_iff (s t : hf) (a : hf) : s ⊆ insert a t ↔ erase a s ⊆ t := +iff.intro !erase_subset_of_subset_insert !subset_insert_of_erase_subset + +theorem le_of_subset {s₁ s₂ : hf} : s₁ ⊆ s₂ → s₁ ≤ s₂ := +begin + revert s₂, induction s₁ with a s₁ nain ih, + take s₂, suppose ∅ ⊆ s₂, !zero_le, + take s₂, suppose insert a s₁ ⊆ s₂, + have a ∈ s₂, from mem_of_subset_of_mem this !mem_insert, + have a ∉ erase a s₂, from !not_mem_erase, + have s₁ ⊆ erase a s₂, from subset_of_forall + (take x xin, by_cases + (suppose x = a, by subst x; contradiction) + (suppose x ≠ a, + have x ∈ s₂, from mem_of_subset_of_mem `insert a s₁ ⊆ s₂` (mem_insert_of_mem _ `x ∈ s₁`), + mem_erase_of_ne_of_mem `x ≠ a` `x ∈ s₂`)), + have s₁ ≤ erase a s₂, from ih _ this, + have insert a s₁ ≤ insert a (erase a s₂), from + insert_le_insert_of_le (or.inr `a ∉ erase a s₂`) this, + by rewrite [insert_erase `a ∈ s₂` at this]; exact this +end + +/- image -/ +definition image (f : hf → hf) (s : hf) : hf := +of_finset (finset.image f (to_finset s)) + +theorem image_empty (f : hf → hf) : image f ∅ = ∅ := +rfl + +theorem mem_image_of_mem (f : hf → hf) {s : hf} {a : hf} : a ∈ s → f a ∈ image f s := +begin unfold [mem, image], intro h, rewrite to_finset_of_finset, apply finset.mem_image_of_mem f h end + +theorem mem_image {f : hf → hf} {s : hf} {a : hf} {b : hf} (H1 : a ∈ s) (H2 : f a = b) : b ∈ image f s := +eq.subst H2 (mem_image_of_mem f H1) + +theorem exists_of_mem_image {f : hf → hf} {s : hf} {b : hf} : b ∈ image f s → ∃a, a ∈ s ∧ f a = b := +begin unfold [mem, image], rewrite to_finset_of_finset, intro h, apply finset.exists_of_mem_image h end + +theorem mem_image_iff (f : hf → hf) {s : hf} {y : hf} : y ∈ image f s ↔ ∃x, x ∈ s ∧ f x = y := +begin unfold [mem, image], rewrite to_finset_of_finset, apply finset.mem_image_iff end + +theorem mem_image_eq (f : hf → hf) {s : hf} {y : hf} : y ∈ image f s = ∃x, x ∈ s ∧ f x = y := +propext (mem_image_iff f) + +theorem mem_image_of_mem_image_of_subset {f : hf → hf} {s t : hf} {y : hf} (H1 : y ∈ image f s) (H2 : s ⊆ t) : y ∈ image f t := +obtain x `x ∈ s` `f x = y`, from exists_of_mem_image H1, +have x ∈ t, from mem_of_subset_of_mem H2 `x ∈ s`, +show y ∈ image f t, from mem_image `x ∈ t` `f x = y` + +theorem image_insert (f : hf → hf) (s : hf) (a : hf) : image f (insert a s) = insert (f a) (image f s) := +begin unfold [image, insert], rewrite [*to_finset_of_finset, finset.image_insert] end + +open function +lemma image_comp {f : hf → hf} {g : hf → hf} {s : hf} : image (f∘g) s = image f (image g s) := +begin unfold image, rewrite [*to_finset_of_finset, finset.image_comp] end + +lemma image_subset {a b : hf} (f : hf → hf) : a ⊆ b → image f a ⊆ image f b := +begin unfold [subset, image], intro h, rewrite *to_finset_of_finset, apply finset.image_subset f h end + +theorem image_union (f : hf → hf) (s t : hf) : image f (s ∪ t) = image f s ∪ image f t := +begin unfold [image, union], rewrite [*to_finset_of_finset, finset.image_union] end + +/- powerset -/ +definition powerset (s : hf) : hf := +of_finset (finset.image of_finset (finset.powerset (to_finset s))) + +prefix [priority hf.prio] `𝒫`:100 := powerset + +theorem powerset_empty : 𝒫 ∅ = insert ∅ ∅ := +rfl + +theorem powerset_insert {a : hf} {s : hf} : a ∉ s → 𝒫 (insert a s) = 𝒫 s ∪ image (insert a) (𝒫 s) := +begin unfold [mem, powerset, insert, union, image], rewrite [*to_finset_of_finset], intro h, + have (λ (x : finset hf), of_finset (finset.insert a x)) = (λ (x : finset hf), of_finset (finset.insert a (to_finset (of_finset x)))), from + funext (λ x, by rewrite to_finset_of_finset), + rewrite [finset.powerset_insert h, finset.image_union, -*finset.image_comp, ↑comp, this] +end + +theorem mem_powerset_iff_subset (s : hf) : ∀ x : hf, x ∈ 𝒫 s ↔ x ⊆ s := +begin + intro x, unfold [mem, powerset, subset], rewrite [to_finset_of_finset, finset.mem_image_eq], apply iff.intro, + suppose (∃ (w : finset hf), finset.mem w (finset.powerset (to_finset s)) ∧ of_finset w = x), + obtain w h₁ h₂, from this, + begin subst x, rewrite to_finset_of_finset, exact iff.mp !finset.mem_powerset_iff_subset h₁ end, + suppose finset.subset (to_finset x) (to_finset s), + have finset.mem (to_finset x) (finset.powerset (to_finset s)), from iff.mpr !finset.mem_powerset_iff_subset this, + exists.intro (to_finset x) (and.intro this (of_finset_to_finset x)) +end + +theorem subset_of_mem_powerset {s t : hf} (H : s ∈ 𝒫 t) : s ⊆ t := +iff.mp (mem_powerset_iff_subset t s) H + +theorem mem_powerset_of_subset {s t : hf} (H : s ⊆ t) : s ∈ 𝒫 t := +iff.mpr (mem_powerset_iff_subset t s) H + +theorem empty_mem_powerset (s : hf) : ∅ ∈ 𝒫 s := +mem_powerset_of_subset (empty_subset s) + +/- hf as lists -/ +open - [notation] list + +definition of_list (s : list hf) : hf := +@equiv.to_fun _ _ list_nat_equiv_nat s + +definition to_list (h : hf) : list hf := +@equiv.inv _ _ list_nat_equiv_nat h + +lemma to_list_of_list (s : list hf) : to_list (of_list s) = s := +@equiv.left_inv _ _ list_nat_equiv_nat s + +lemma of_list_to_list (s : hf) : of_list (to_list s) = s := +@equiv.right_inv _ _ list_nat_equiv_nat s + +lemma to_list_inj {s₁ s₂ : hf} : to_list s₁ = to_list s₂ → s₁ = s₂ := +λ h, function.injective_of_left_inverse of_list_to_list h + +lemma of_list_inj {s₁ s₂ : list hf} : of_list s₁ = of_list s₂ → s₁ = s₂ := +λ h, function.injective_of_left_inverse to_list_of_list h + +definition nil : hf := +of_list list.nil + +lemma empty_eq_nil : ∅ = nil := +rfl + +definition cons (a l : hf) : hf := +of_list (list.cons a (to_list l)) + +infixr :: := cons + +lemma cons_ne_nil (a l : hf) : a::l ≠ nil := +by contradiction + +lemma head_eq_of_cons_eq {h₁ h₂ t₁ t₂ : hf} : (h₁::t₁) = (h₂::t₂) → h₁ = h₂ := +begin unfold cons, intro h, apply list.head_eq_of_cons_eq (of_list_inj h) end + +lemma tail_eq_of_cons_eq {h₁ h₂ t₁ t₂ : hf} : (h₁::t₁) = (h₂::t₂) → t₁ = t₂ := +begin unfold cons, intro h, apply to_list_inj (list.tail_eq_of_cons_eq (of_list_inj h)) end + +lemma cons_inj {a : hf} : injective (cons a) := +take l₁ l₂, assume Pe, tail_eq_of_cons_eq Pe + +/- append -/ +definition append (l₁ l₂ : hf) : hf := +of_list (list.append (to_list l₁) (to_list l₂)) + +notation l₁ ++ l₂ := append l₁ l₂ + +attribute [simp] +theorem append_nil_left (t : hf) : nil ++ t = t := +begin unfold [nil, append], rewrite [to_list_of_list, list.append_nil_left, of_list_to_list] end + +attribute [simp] +theorem append_cons (x s t : hf) : (x::s) ++ t = x::(s ++ t) := +begin unfold [cons, append], rewrite [*to_list_of_list, list.append_cons] end + +attribute [simp] +theorem append_nil_right (t : hf) : t ++ nil = t := +begin unfold [nil, append], rewrite [to_list_of_list, list.append_nil_right, of_list_to_list] end + +attribute [simp] +theorem append.assoc (s t u : hf) : s ++ t ++ u = s ++ (t ++ u) := +begin unfold append, rewrite [*to_list_of_list, list.append.assoc] end + +/- length -/ +definition length (l : hf) : nat := +list.length (to_list l) + +attribute [simp] +theorem length_nil : length nil = 0 := +begin unfold [length, nil] end + +attribute [simp] +theorem length_cons (x t : hf) : length (x::t) = length t + 1 := +begin unfold [length, cons], rewrite to_list_of_list end + +attribute [simp] +theorem length_append (s t : hf) : length (s ++ t) = length s + length t := +begin unfold [length, append], rewrite [to_list_of_list, list.length_append] end + +theorem eq_nil_of_length_eq_zero {l : hf} : length l = 0 → l = nil := +begin unfold [length, nil], intro h, rewrite [-list.eq_nil_of_length_eq_zero h, of_list_to_list] end + +theorem ne_nil_of_length_eq_succ {l : hf} {n : nat} : length l = succ n → l ≠ nil := +begin unfold [length, nil], intro h₁ h₂, subst l, rewrite to_list_of_list at h₁, contradiction end + +/- head and tail -/ +definition head (l : hf) : hf := +list.head (to_list l) + +attribute [simp] +theorem head_cons (a l : hf) : head (a::l) = a := +begin unfold [head, cons], rewrite to_list_of_list end + +private lemma to_list_ne_list_nil {s : hf} : s ≠ nil → to_list s ≠ list.nil := +begin + unfold nil, + intro h, + suppose to_list s = list.nil, + by rewrite [-this at h, of_list_to_list at h]; exact absurd rfl h +end + +attribute [simp] +theorem head_append (t : hf) {s : hf} : s ≠ nil → head (s ++ t) = head s := +begin + unfold [nil, head, append], rewrite to_list_of_list, + suppose s ≠ of_list list.nil, + by rewrite [list.head_append _ (to_list_ne_list_nil this)] +end + +definition tail (l : hf) : hf := +of_list (list.tail (to_list l)) + +attribute [simp] +theorem tail_nil : tail nil = nil := +begin unfold [tail, nil] end + +attribute [simp] +theorem tail_cons (a l : hf) : tail (a::l) = l := +begin unfold [tail, cons], rewrite [to_list_of_list, list.tail_cons, of_list_to_list] end + +theorem cons_head_tail {l : hf} : l ≠ nil → (head l)::(tail l) = l := +begin + unfold [nil, head, tail, cons], + suppose l ≠ of_list list.nil, + by rewrite [to_list_of_list, list.cons_head_tail (to_list_ne_list_nil this), of_list_to_list] +end +end hf diff --git a/old_library/data/hlist.lean b/old_library/data/hlist.lean new file mode 100644 index 0000000000..e200129674 --- /dev/null +++ b/old_library/data/hlist.lean @@ -0,0 +1,93 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Heterogeneous lists +-/ +import data.list logic.cast +open list + +inductive hlist {A : Type} (B : A → Type) : list A → Type := +| nil {} : hlist B [] +| cons : ∀ {a : A}, B a → ∀ {l : list A}, hlist B l → hlist B (a::l) + +namespace hlist +variables {A : Type} {B : A → Type} + +definition head : Π {a l}, hlist B (a :: l) → B a +| a l (cons b h) := b + +lemma head_cons : ∀ {a l} (b : B a) (h : hlist B l), head (cons b h) = b := +sorry -- by intros; reflexivity + +definition tail : Π {a l}, hlist B (a :: l) → hlist B l +| a l (cons b h) := h + +lemma tail_cons : ∀ {a l} (b : B a) (h : hlist B l), tail (cons b h) = h := +sorry -- by intros; reflexivity + +lemma eta_cons : ∀ {a l} (h : hlist B (a::l)), h = cons (head h) (tail h) := +sorry -- begin intros, cases h, esimp end + +lemma eta_nil : ∀ (h : hlist B []), h = nil := +sorry -- begin intros, cases h, esimp end + +definition append : Π {l₁ l₂}, hlist B l₁ → hlist B l₂ → hlist B (l₁++l₂) +| [] l₂ nil h₂ := h₂ +| (a::l) l₂ (cons b h₁) h₂ := cons b (append h₁ h₂) + +lemma append_nil_left : ∀ {l} (h : hlist B l), append nil h = h := +sorry -- by intros; reflexivity + +lemma eq_rec_on_cons : ∀ {a₁ a₂ l₁ l₂} (b : B a₁) (h : hlist B l₁) (e : a₁::l₁ = a₂::l₂), + eq.rec_on e (cons b h) = cons (eq.rec_on (head_eq_of_cons_eq e) b) (eq.rec_on (tail_eq_of_cons_eq e) h) := +sorry +/- +begin + intros, injection e with e₁ e₂, revert e, subst a₂, subst l₂, intro e, esimp +end +-/ + +local attribute list.append [reducible] +lemma append_nil_right : ∀ {l} (h : hlist B l), append h nil = eq.rec_on (eq.symm (list.append_nil_right l)) h +:= sorry +/- +| [] nil := by esimp +| (a::l) (cons b h) := + begin + change (cons b (append h nil)) = (eq.symm (list.append_nil_right (a :: l))) ▹ cons b h, + rewrite [append_nil_right h], xrewrite eq_rec_on_cons + end +-/ + +lemma append_nil_right_heq {l} (h : hlist B l) : append h nil == h := +sorry -- by rewrite append_nil_right; apply eq_rec_heq + +section get +variables [decA : decidable_eq A] +include decA + +definition get {a : A} : ∀ {l : list A}, hlist B l → a ∈ l → B a +| [] nil e := absurd e (not_mem_nil a) +| (t::l) (cons b h) e := + or.by_cases (eq_or_mem_of_mem_cons e) + (suppose a = t, eq.rec_on (eq.symm this) b) + (suppose a ∈ l, get h this) +end get + +section map +variable {C : A → Type} +variable (f : Π ⦃a⦄, B a → C a) + +definition map : ∀ {l}, hlist B l → hlist C l +| [] nil := nil +| (a::l) (cons b h) := cons (f b) (map h) + +lemma map_nil : map f nil = nil := +rfl + +lemma map_cons : ∀ {a l} (b : B a) (h : hlist B l), map f (cons b h) = cons (f b) (map f h) := +sorry -- by intros; reflexivity +end map +end hlist diff --git a/old_library/data/int/basic.lean b/old_library/data/int/basic.lean new file mode 100644 index 0000000000..eb4cde1f58 --- /dev/null +++ b/old_library/data/int/basic.lean @@ -0,0 +1,604 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Floris van Doorn, Jeremy Avigad + +The integers, with addition, multiplication, and subtraction. The representation of the integers is +chosen to compute efficiently. + +To faciliate proving things about these operations, we show that the integers are a quotient of +ℕ × ℕ with the usual equivalence relation, ≡, and functions + + abstr : ℕ × ℕ → ℤ + repr : ℤ → ℕ × ℕ + +satisfying: + + abstr_repr (a : ℤ) : abstr (repr a) = a + repr_abstr (p : ℕ × ℕ) : repr (abstr p) ≡ p + abstr_eq (p q : ℕ × ℕ) : p ≡ q → abstr p = abstr q + +For example, to "lift" statements about add to statements about padd, we need to prove the +following: + + repr_add (a b : ℤ) : repr (a + b) = padd (repr a) (repr b) + padd_congr (p p' q q' : ℕ × ℕ) (H1 : p ≡ p') (H2 : q ≡ q') : padd p q ≡ p' q' + +-/ +import data.nat.sub algebra.relation data.prod +open eq.ops +open prod relation nat +open decidable binary + +/- the type of integers -/ + +inductive int : Type := +| of_nat : nat → int +| neg_succ_of_nat : nat → int + +notation `ℤ` := int +-- [coercion] +attribute [reducible, constructor] +definition int.of_num (n : num) : ℤ := +int.of_nat (nat.of_num n) + +namespace int + +-- attribute int.of_nat [coercion] + +notation `-[1+ ` n `]` := int.neg_succ_of_nat n -- for pretty-printing output + +protected definition prio : num := num.pred nat.prio + +attribute [instance, priority int.prio] +definition int_has_zero : has_zero int := +has_zero.mk (of_nat 0) + +attribute [instance, priority int.prio] +definition int_has_one : has_one int := +has_one.mk (of_nat 1) + +theorem of_nat_zero : of_nat (0:nat) = (0:int) := +rfl + +theorem of_nat_one : of_nat (1:nat) = (1:int) := +rfl + +/- definitions of basic functions -/ + +definition neg_of_nat : ℕ → ℤ +| 0 := 0 +| (succ m) := -[1+ m] + +definition sub_nat_nat (m n : ℕ) : ℤ := +match (n - m : nat) with + | 0 := of_nat (m - n) -- m ≥ n + | (succ k) := -[1+ k] -- m < n, and n - m = succ k +end + +protected definition neg (a : ℤ) : ℤ := +int.cases_on a neg_of_nat succ + +protected definition add : ℤ → ℤ → ℤ +| (of_nat m) (of_nat n) := m + n +| (of_nat m) -[1+ n] := sub_nat_nat m (succ n) +| -[1+ m] (of_nat n) := sub_nat_nat n (succ m) +| -[1+ m] -[1+ n] := neg_of_nat (succ m + succ n) + +protected definition mul : ℤ → ℤ → ℤ +| (of_nat m) (of_nat n) := m * n +| (of_nat m) -[1+ n] := neg_of_nat (m * succ n) +| -[1+ m] (of_nat n) := neg_of_nat (succ m * n) +| -[1+ m] -[1+ n] := succ m * succ n + +/- notation -/ + +attribute [instance, priority int.prio] +definition int_has_add : has_add int := has_add.mk int.add +attribute [instance, priority int.prio] +definition int_has_neg : has_neg int := has_neg.mk int.neg +attribute [instance, priority int.prio] +definition int_has_mul : has_mul int := has_mul.mk int.mul + +lemma mul_of_nat_of_nat (m n : nat) : of_nat m * of_nat n = of_nat (m * n) := +rfl + +lemma mul_of_nat_neg_succ_of_nat (m n : nat) : of_nat m * -[1+ n] = neg_of_nat (m * succ n) := +rfl + +lemma mul_neg_succ_of_nat_of_nat (m n : nat) : -[1+ m] * of_nat n = neg_of_nat (succ m * n) := +rfl + +lemma mul_neg_succ_of_nat_neg_succ_of_nat (m n : nat) : -[1+ m] * -[1+ n] = succ m * succ n := +rfl + +/- some basic functions and properties -/ + +theorem of_nat.inj {m n : ℕ} (H : of_nat m = of_nat n) : m = n := +int.no_confusion H imp.id + +theorem eq_of_of_nat_eq_of_nat {m n : ℕ} (H : of_nat m = of_nat n) : m = n := +of_nat.inj H + +theorem of_nat_eq_of_nat_iff (m n : ℕ) : of_nat m = of_nat n ↔ m = n := +iff.intro of_nat.inj !congr_arg + +theorem neg_succ_of_nat.inj {m n : ℕ} (H : neg_succ_of_nat m = neg_succ_of_nat n) : m = n := +int.no_confusion H imp.id + +theorem neg_succ_of_nat_eq (n : ℕ) : -[1+ n] = -(n + 1) := rfl + +private definition has_decidable_eq₂ : Π (a b : ℤ), decidable (a = b) +| (of_nat m) (of_nat n) := decidable_of_decidable_of_iff + (nat.has_decidable_eq m n) (iff.symm (of_nat_eq_of_nat_iff m n)) +| (of_nat m) -[1+ n] := inr (by contradiction) +| -[1+ m] (of_nat n) := inr (by contradiction) +| -[1+ m] -[1+ n] := if H : m = n then + inl (congr_arg neg_succ_of_nat H) else inr (not.mto neg_succ_of_nat.inj H) + +attribute [instance, priority int.prio] +definition has_decidable_eq : decidable_eq ℤ := has_decidable_eq₂ + +theorem of_nat_add (n m : nat) : of_nat (n + m) = of_nat n + of_nat m := rfl + +theorem of_nat_succ (n : ℕ) : of_nat (succ n) = of_nat n + 1 := rfl + +theorem of_nat_mul (n m : ℕ) : of_nat (n * m) = of_nat n * of_nat m := rfl + +theorem sub_nat_nat_of_ge {m n : ℕ} (H : m ≥ n) : sub_nat_nat m n = of_nat (m - n) := +show sub_nat_nat m n = nat.cases_on 0 (m -[nat] n) _, from (sub_eq_zero_of_le H) ▸ rfl + +section +local attribute sub_nat_nat [reducible] +theorem sub_nat_nat_of_lt {m n : ℕ} (H : m < n) : sub_nat_nat m n = -[1+ pred (n - m)] := +have H1 : n - m = succ (pred (n - m)), from eq.symm (succ_pred_of_pos (nat.sub_pos_of_lt H)), +show sub_nat_nat m n = nat.cases_on (succ (nat.pred (n - m))) (m -[nat] n) _, from H1 ▸ rfl +end + +definition nat_abs (a : ℤ) : ℕ := int.cases_on a id succ + +theorem nat_abs_of_nat (n : ℕ) : nat_abs n = n := rfl + +theorem eq_zero_of_nat_abs_eq_zero : Π {a : ℤ}, nat_abs a = 0 → a = 0 +| (of_nat m) H := congr_arg of_nat H +| -[1+ m'] H := absurd H !succ_ne_zero + +theorem nat_abs_zero : nat_abs (0:int) = (0:nat) := +rfl + +theorem nat_abs_one : nat_abs (1:int) = (1:nat) := +rfl + +/- int is a quotient of ordered pairs of natural numbers -/ + +protected definition equiv (p q : ℕ × ℕ) : Prop := pr1 p + pr2 q = pr2 p + pr1 q + +local infix ≡ := int.equiv + +attribute [refl] +protected theorem equiv.refl {p : ℕ × ℕ} : p ≡ p := !add.comm + +local attribute int.equiv [reducible] + +attribute [symm] +protected theorem equiv.symm {p q : ℕ × ℕ} (H : p ≡ q) : q ≡ p := +by simp + +attribute [trans] +protected theorem equiv.trans {p q r : ℕ × ℕ} (H1 : p ≡ q) (H2 : q ≡ r) : p ≡ r := +add.right_cancel (calc + pr1 p + pr2 r + pr2 q = pr1 p + pr2 q + pr2 r : by simp_nohyps + ... = pr2 p + pr1 r + pr2 q : by simp) + +protected theorem equiv_equiv : is_equivalence int.equiv := +is_equivalence.mk @equiv.refl @equiv.symm @equiv.trans + +protected theorem equiv_cases {p q : ℕ × ℕ} (H : p ≡ q) : + (pr1 p ≥ pr2 p ∧ pr1 q ≥ pr2 q) ∨ (pr1 p < pr2 p ∧ pr1 q < pr2 q) := +or.elim (@le_or_gt _ _ (pr2 p) (pr1 p)) + (suppose pr1 p ≥ pr2 p, + have pr2 p + pr1 q ≥ pr2 p + pr2 q, from H ▸ add_le_add_right this (pr2 q), + or.inl (and.intro `pr1 p ≥ pr2 p` (le_of_add_le_add_left this))) + (suppose H₁ : pr1 p < pr2 p, + have pr2 p + pr1 q < pr2 p + pr2 q, from H ▸ add_lt_add_right H₁ (pr2 q), + or.inr (and.intro H₁ (lt_of_add_lt_add_left this))) + +protected theorem equiv_of_eq {p q : ℕ × ℕ} (H : p = q) : p ≡ q := H ▸ equiv.refl + +/- the representation and abstraction functions -/ + +definition abstr (a : ℕ × ℕ) : ℤ := sub_nat_nat (pr1 a) (pr2 a) + +theorem abstr_of_ge {p : ℕ × ℕ} (H : pr1 p ≥ pr2 p) : abstr p = of_nat (pr1 p - pr2 p) := +sub_nat_nat_of_ge H + +theorem abstr_of_lt {p : ℕ × ℕ} (H : pr1 p < pr2 p) : + abstr p = -[1+ pred (pr2 p - pr1 p)] := +sub_nat_nat_of_lt H + +definition repr : ℤ → ℕ × ℕ +| (of_nat m) := (m, 0) +| -[1+ m] := (0, succ m) + +theorem abstr_repr : Π (a : ℤ), abstr (repr a) = a +| (of_nat m) := (sub_nat_nat_of_ge (zero_le m)) +| -[1+ m] := rfl + +theorem repr_sub_nat_nat (m n : ℕ) : repr (sub_nat_nat m n) ≡ (m, n) := +nat.lt_ge_by_cases + (take H : m < n, + have H1 : repr (sub_nat_nat m n) = (0, n - m), by + rewrite [sub_nat_nat_of_lt H, -(succ_pred_of_pos (nat.sub_pos_of_lt H))], + H1⁻¹ ▸ (!zero_add ⬝ (nat.sub_add_cancel (le_of_lt H))⁻¹)) + (take H : m ≥ n, + have H1 : repr (sub_nat_nat m n) = (m - n, 0), from sub_nat_nat_of_ge H ▸ rfl, + H1⁻¹ ▸ ((nat.sub_add_cancel H) ⬝ !zero_add⁻¹)) + +theorem repr_abstr (p : ℕ × ℕ) : repr (abstr p) ≡ p := +!prod.eta ▸ !repr_sub_nat_nat + +theorem abstr_eq {p q : ℕ × ℕ} (Hequiv : p ≡ q) : abstr p = abstr q := +or.elim (int.equiv_cases Hequiv) + (and.rec (assume (Hp : pr1 p ≥ pr2 p) (Hq : pr1 q ≥ pr2 q), + have H : pr1 p - pr2 p = pr1 q - pr2 q, from + calc pr1 p - pr2 p + = pr1 p + pr2 q - pr2 q - pr2 p : by rewrite nat.add_sub_cancel + ... = pr2 p + pr1 q - pr2 q - pr2 p : Hequiv + ... = pr2 p + (pr1 q - pr2 q) - pr2 p : nat.add_sub_assoc Hq + ... = pr1 q - pr2 q + pr2 p - pr2 p : by simp + ... = pr1 q - pr2 q : by rewrite nat.add_sub_cancel, + abstr_of_ge Hp ⬝ (H ▸ rfl) ⬝ (abstr_of_ge Hq)⁻¹)) + (and.rec (assume (Hp : pr1 p < pr2 p) (Hq : pr1 q < pr2 q), + have H : pr2 p - pr1 p = pr2 q - pr1 q, from + calc pr2 p - pr1 p + = pr2 p + pr1 q - pr1 q - pr1 p : by rewrite nat.add_sub_cancel + ... = pr1 p + pr2 q - pr1 q - pr1 p : Hequiv + ... = pr1 p + (pr2 q - pr1 q) - pr1 p : nat.add_sub_assoc (le_of_lt Hq) + ... = pr2 q - pr1 q + pr1 p - pr1 p : by rewrite add.comm + ... = pr2 q - pr1 q : by rewrite nat.add_sub_cancel, + abstr_of_lt Hp ⬝ (H ▸ rfl) ⬝ (abstr_of_lt Hq)⁻¹)) + +theorem equiv_iff (p q : ℕ × ℕ) : (p ≡ q) ↔ (abstr p = abstr q) := +iff.intro abstr_eq (assume H, equiv.trans (H ▸ equiv.symm (repr_abstr p)) (repr_abstr q)) + +theorem equiv_iff3 (p q : ℕ × ℕ) : (p ≡ q) ↔ ((p ≡ p) ∧ (q ≡ q) ∧ (abstr p = abstr q)) := +iff.trans !equiv_iff (iff.symm + (iff.trans (and_iff_right !equiv.refl) (and_iff_right !equiv.refl))) + +theorem eq_abstr_of_equiv_repr {a : ℤ} {p : ℕ × ℕ} (Hequiv : repr a ≡ p) : a = abstr p := +!abstr_repr⁻¹ ⬝ abstr_eq Hequiv + +theorem eq_of_repr_equiv_repr {a b : ℤ} (H : repr a ≡ repr b) : a = b := +eq_abstr_of_equiv_repr H ⬝ !abstr_repr + +section +local attribute abstr [reducible] +local attribute dist [reducible] +theorem nat_abs_abstr : Π (p : ℕ × ℕ), nat_abs (abstr p) = dist (pr1 p) (pr2 p) +| (m, n) := nat.lt_ge_by_cases + (assume H : m < n, + calc + nat_abs (abstr (m, n)) = nat_abs (-[1+ pred (n - m)]) : int.abstr_of_lt H + ... = n - m : succ_pred_of_pos (nat.sub_pos_of_lt H) + ... = dist m n : dist_eq_sub_of_le (le_of_lt H)) + (assume H : m ≥ n, (abstr_of_ge H)⁻¹ ▸ (dist_eq_sub_of_ge H)⁻¹) +end + +theorem cases_of_nat_succ (a : ℤ) : (∃n : ℕ, a = of_nat n) ∨ (∃n : ℕ, a = - (of_nat (succ n))) := +int.cases_on a (take m, or.inl (exists.intro _ rfl)) (take m, or.inr (exists.intro _ rfl)) + +theorem cases_of_nat (a : ℤ) : (∃n : ℕ, a = of_nat n) ∨ (∃n : ℕ, a = - of_nat n) := +or.imp_right (Exists.rec (take n, (exists.intro _))) !cases_of_nat_succ + +theorem by_cases_of_nat {P : ℤ → Prop} (a : ℤ) + (H1 : ∀n : ℕ, P (of_nat n)) (H2 : ∀n : ℕ, P (- of_nat n)) : + P a := +or.elim (cases_of_nat a) + (assume H, obtain (n : ℕ) (H3 : a = n), from H, H3⁻¹ ▸ H1 n) + (assume H, obtain (n : ℕ) (H3 : a = -n), from H, H3⁻¹ ▸ H2 n) + +theorem by_cases_of_nat_succ {P : ℤ → Prop} (a : ℤ) + (H1 : ∀n : ℕ, P (of_nat n)) (H2 : ∀n : ℕ, P (- of_nat (succ n))) : + P a := +or.elim (cases_of_nat_succ a) + (assume H, obtain (n : ℕ) (H3 : a = n), from H, H3⁻¹ ▸ H1 n) + (assume H, obtain (n : ℕ) (H3 : a = -(succ n)), from H, H3⁻¹ ▸ H2 n) + +/- + int is a ring +-/ + +/- addition -/ + +definition padd (p q : ℕ × ℕ) : ℕ × ℕ := (pr1 p + pr1 q, pr2 p + pr2 q) + +theorem repr_add : Π (a b : ℤ), repr (add a b) ≡ padd (repr a) (repr b) +| (of_nat m) (of_nat n) := !equiv.refl +| (of_nat m) -[1+ n] := + begin + change repr (sub_nat_nat m (succ n)) ≡ (m + 0, 0 + succ n), + rewrite [zero_add, add_zero], + apply repr_sub_nat_nat + end +| -[1+ m] (of_nat n) := + begin + change repr (-[1+ m] + n) ≡ (0 + n, succ m + 0), + rewrite [zero_add, add_zero], + apply repr_sub_nat_nat + end +| -[1+ m] -[1+ n] := !repr_sub_nat_nat + +theorem padd_congr {p p' q q' : ℕ × ℕ} (Ha : p ≡ p') (Hb : q ≡ q') : padd p q ≡ padd p' q' := +calc pr1 p + pr1 q + (pr2 p' + pr2 q') + = pr1 p + pr2 p' + (pr1 q + pr2 q') : by simp_nohyps + ... = pr2 p + pr1 p' + (pr2 q + pr1 q') : by simp + ... = pr2 p + pr2 q + (pr1 p' + pr1 q') : by simp_nohyps + +theorem padd_comm (p q : ℕ × ℕ) : padd p q = padd q p := +calc (pr1 p + pr1 q, pr2 p + pr2 q) = (pr1 q + pr1 p, pr2 q + pr2 p) : by simp + +theorem padd_assoc (p q r : ℕ × ℕ) : padd (padd p q) r = padd p (padd q r) := +calc (pr1 p + pr1 q + pr1 r, pr2 p + pr2 q + pr2 r) + = (pr1 p + (pr1 q + pr1 r), pr2 p + (pr2 q + pr2 r)) : by simp + +protected theorem add_comm (a b : ℤ) : a + b = b + a := +eq_of_repr_equiv_repr (equiv.trans !repr_add + (equiv.symm (!padd_comm ▸ !repr_add))) + +protected theorem add_assoc (a b c : ℤ) : a + b + c = a + (b + c) := +eq_of_repr_equiv_repr (calc + repr (a + b + c) + ≡ padd (repr (a + b)) (repr c) : repr_add + ... ≡ padd (padd (repr a) (repr b)) (repr c) : padd_congr !repr_add !equiv.refl + ... = padd (repr a) (padd (repr b) (repr c)) : !padd_assoc + ... ≡ padd (repr a) (repr (b + c)) : padd_congr !equiv.refl !repr_add + ... ≡ repr (a + (b + c)) : repr_add) + +protected theorem add_zero : Π (a : ℤ), a + 0 = a := int.rec (λm, rfl) (λm, rfl) + +protected theorem zero_add (a : ℤ) : 0 + a = a := !int.add_comm ▸ !int.add_zero + +/- negation -/ + +definition pneg (p : ℕ × ℕ) : ℕ × ℕ := (pr2 p, pr1 p) + +-- note: this is =, not just ≡ +theorem repr_neg : Π (a : ℤ), repr (- a) = pneg (repr a) +| 0 := rfl +| (succ m) := rfl +| -[1+ m] := rfl + +theorem pneg_congr {p p' : ℕ × ℕ} (H : p ≡ p') : pneg p ≡ pneg p' := eq.symm H + +theorem pneg_pneg (p : ℕ × ℕ) : pneg (pneg p) = p := !prod.eta + +theorem nat_abs_neg (a : ℤ) : nat_abs (-a) = nat_abs a := +calc + nat_abs (-a) = nat_abs (abstr (repr (-a))) : abstr_repr + ... = nat_abs (abstr (pneg (repr a))) : repr_neg + ... = dist (pr1 (pneg (repr a))) (pr2 (pneg (repr a))) : nat_abs_abstr + ... = dist (pr2 (pneg (repr a))) (pr1 (pneg (repr a))) : dist.comm + ... = nat_abs (abstr (repr a)) : nat_abs_abstr + ... = nat_abs a : abstr_repr + +theorem padd_pneg (p : ℕ × ℕ) : padd p (pneg p) ≡ (0, 0) := +show pr1 p + pr2 p + 0 = pr2 p + pr1 p + 0, from !nat.add_comm ▸ rfl + +theorem padd_padd_pneg (p q : ℕ × ℕ) : padd (padd p q) (pneg q) ≡ p := +by unfold [padd, pneg]; simp + +protected theorem add_left_inv (a : ℤ) : -a + a = 0 := +have H : repr (-a + a) ≡ repr 0, from + calc + repr (-a + a) ≡ padd (repr (neg a)) (repr a) : repr_add + ... = padd (pneg (repr a)) (repr a) : repr_neg + ... ≡ repr 0 : padd_pneg, +eq_of_repr_equiv_repr H + +/- nat abs -/ + +definition pabs (p : ℕ × ℕ) : ℕ := dist (pr1 p) (pr2 p) + +theorem pabs_congr {p q : ℕ × ℕ} (H : p ≡ q) : pabs p = pabs q := +calc + pabs p = nat_abs (abstr p) : nat_abs_abstr + ... = nat_abs (abstr q) : abstr_eq H + ... = pabs q : nat_abs_abstr + +theorem nat_abs_eq_pabs_repr (a : ℤ) : nat_abs a = pabs (repr a) := +calc + nat_abs a = nat_abs (abstr (repr a)) : abstr_repr + ... = pabs (repr a) : nat_abs_abstr + +theorem nat_abs_add_le (a b : ℤ) : nat_abs (a + b) ≤ nat_abs a + nat_abs b := +calc + nat_abs (a + b) = pabs (repr (a + b)) : nat_abs_eq_pabs_repr + ... = pabs (padd (repr a) (repr b)) : pabs_congr !repr_add + ... ≤ pabs (repr a) + pabs (repr b) : dist_add_add_le_add_dist_dist + ... = pabs (repr a) + nat_abs b : nat_abs_eq_pabs_repr + ... = nat_abs a + nat_abs b : nat_abs_eq_pabs_repr + +theorem nat_abs_neg_of_nat (n : nat) : nat_abs (neg_of_nat n) = n := +begin cases n, reflexivity, reflexivity end + +section +local attribute nat_abs [reducible] +theorem nat_abs_mul : Π (a b : ℤ), nat_abs (a * b) = (nat_abs a) * (nat_abs b) +| (of_nat m) (of_nat n) := rfl +| (of_nat m) -[1+ n] := by rewrite [mul_of_nat_neg_succ_of_nat, nat_abs_neg_of_nat] +| -[1+ m] (of_nat n) := by rewrite [mul_neg_succ_of_nat_of_nat, nat_abs_neg_of_nat] +| -[1+ m] -[1+ n] := rfl +end + +/- multiplication -/ + +definition pmul (p q : ℕ × ℕ) : ℕ × ℕ := + (pr1 p * pr1 q + pr2 p * pr2 q, pr1 p * pr2 q + pr2 p * pr1 q) + +theorem repr_neg_of_nat (m : ℕ) : repr (neg_of_nat m) = (0, m) := +nat.cases_on m rfl (take m', rfl) + +-- note: we have =, not just ≡ +theorem repr_mul : Π (a b : ℤ), repr (a * b) = pmul (repr a) (repr b) +| (of_nat m) (of_nat n) := calc + (m * n + 0 * 0, m * 0 + 0) = (m * n + 0 * 0, m * 0 + 0 * n) : by rewrite *zero_mul +| (of_nat m) -[1+ n] := calc + repr ((m : int) * -[1+ n]) = (m * 0 + 0, m * succ n + 0 * 0) : repr_neg_of_nat + ... = (m * 0 + 0 * succ n, m * succ n + 0 * 0) : by rewrite *zero_mul +| -[1+ m] (of_nat n) := calc + repr (-[1+ m] * (n:int)) = (0 + succ m * 0, succ m * n) : repr_neg_of_nat + ... = (0 + succ m * 0, 0 + succ m * n) : nat.zero_add + ... = (0 * n + succ m * 0, 0 + succ m * n) : by rewrite zero_mul +| -[1+ m] -[1+ n] := calc + (succ m * succ n, 0) = (succ m * succ n, 0 * succ n) : by rewrite zero_mul + ... = (0 + succ m * succ n, 0 * succ n) : nat.zero_add + +local attribute left_distrib right_distrib [simp] +theorem equiv_mul_prep {xa ya xb yb xn yn xm ym : ℕ} + (H1 : xa + yb = ya + xb) (H2 : xn + ym = yn + xm) : xa*xn+ya*yn+(xb*ym+yb*xm) = xa*yn+ya*xn+(xb*xm+yb*ym) := +nat.add_right_cancel ( +calc xa*xn+ya*yn + (xb*ym+yb*xm) + (yb*xn+xb*yn + (xb*xn+yb*yn)) + = (xa + yb)*xn + (ya + xb)*yn + (xb*(xn + ym)) + (yb*(yn + xm)) : by simp_nohyps + ... = (ya + xb)*xn + (xa + yb)*yn + (xb*(yn + xm)) + (yb*(xn + ym)) : by simp + ... = xa*yn+ya*xn + (xb*xm+yb*ym) + (yb*xn+xb*yn + (xb*xn+yb*yn)) : by simp_nohyps) + +theorem pmul_congr {p p' q q' : ℕ × ℕ} : p ≡ p' → q ≡ q' → pmul p q ≡ pmul p' q' := equiv_mul_prep + +theorem pmul_comm (p q : ℕ × ℕ) : pmul p q = pmul q p := +by unfold pmul; simp + +protected theorem mul_comm (a b : ℤ) : a * b = b * a := +eq_of_repr_equiv_repr + ((calc + repr (a * b) = pmul (repr a) (repr b) : repr_mul + ... = pmul (repr b) (repr a) : pmul_comm + ... = repr (b * a) : repr_mul) ▸ !equiv.refl) + +private theorem pmul_assoc_prep {p1 p2 q1 q2 r1 r2 : ℕ} : + ((p1*q1+p2*q2)*r1+(p1*q2+p2*q1)*r2, (p1*q1+p2*q2)*r2+(p1*q2+p2*q1)*r1) = + (p1*(q1*r1+q2*r2)+p2*(q1*r2+q2*r1), p1*(q1*r2+q2*r1)+p2*(q1*r1+q2*r2)) := +by simp + +theorem pmul_assoc (p q r: ℕ × ℕ) : pmul (pmul p q) r = pmul p (pmul q r) := pmul_assoc_prep + +protected theorem mul_assoc (a b c : ℤ) : (a * b) * c = a * (b * c) := +eq_of_repr_equiv_repr + ((calc + repr (a * b * c) = pmul (repr (a * b)) (repr c) : repr_mul + ... = pmul (pmul (repr a) (repr b)) (repr c) : repr_mul + ... = pmul (repr a) (pmul (repr b) (repr c)) : pmul_assoc + ... = pmul (repr a) (repr (b * c)) : repr_mul + ... = repr (a * (b * c)) : repr_mul) ▸ !equiv.refl) + +protected theorem mul_one : Π (a : ℤ), a * 1 = a +| (of_nat m) := !int.zero_add -- zero_add happens to be def. = to this thm +| -[1+ m] := !nat.zero_add ▸ rfl + +protected theorem one_mul (a : ℤ) : 1 * a = a := +int.mul_comm a 1 ▸ int.mul_one a + +private theorem mul_distrib_prep {a1 a2 b1 b2 c1 c2 : ℕ} : + ((a1+b1)*c1+(a2+b2)*c2, (a1+b1)*c2+(a2+b2)*c1) = + (a1*c1+a2*c2+(b1*c1+b2*c2), a1*c2+a2*c1+(b1*c2+b2*c1)) := +by simp + +protected theorem right_distrib (a b c : ℤ) : (a + b) * c = a * c + b * c := +eq_of_repr_equiv_repr + (calc + repr ((a + b) * c) = pmul (repr (a + b)) (repr c) : repr_mul + ... ≡ pmul (padd (repr a) (repr b)) (repr c) : pmul_congr !repr_add equiv.refl + ... = padd (pmul (repr a) (repr c)) (pmul (repr b) (repr c)) : mul_distrib_prep + ... = padd (repr (a * c)) (pmul (repr b) (repr c)) : repr_mul + ... = padd (repr (a * c)) (repr (b * c)) : repr_mul + ... ≡ repr (a * c + b * c) : repr_add) + +protected theorem left_distrib (a b c : ℤ) : a * (b + c) = a * b + a * c := +calc + a * (b + c) = (b + c) * a : int.mul_comm + ... = b * a + c * a : int.right_distrib + ... = a * b + c * a : int.mul_comm + ... = a * b + a * c : int.mul_comm + +protected theorem zero_ne_one : (0 : int) ≠ 1 := +assume H : 0 = 1, !succ_ne_zero (of_nat.inj H)⁻¹ + +protected theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℤ} (H : a * b = 0) : a = 0 ∨ b = 0 := +or.imp eq_zero_of_nat_abs_eq_zero eq_zero_of_nat_abs_eq_zero + (eq_zero_or_eq_zero_of_mul_eq_zero (by rewrite [-nat_abs_mul, H])) + +attribute [trans_instance] +protected definition integral_domain : integral_domain int := +⦃integral_domain, + add := int.add, + add_assoc := int.add_assoc, + zero := 0, + zero_add := int.zero_add, + add_zero := int.add_zero, + neg := int.neg, + add_left_inv := int.add_left_inv, + add_comm := int.add_comm, + mul := int.mul, + mul_assoc := int.mul_assoc, + one := 1, + one_mul := int.one_mul, + mul_one := int.mul_one, + left_distrib := int.left_distrib, + right_distrib := int.right_distrib, + mul_comm := int.mul_comm, + zero_ne_one := int.zero_ne_one, + eq_zero_or_eq_zero_of_mul_eq_zero := @int.eq_zero_or_eq_zero_of_mul_eq_zero⦄ + +attribute [instance, priority int.prio] +definition int_has_sub : has_sub int := +has_sub.mk has_sub.sub + +attribute [instance, priority int.prio] +definition int_has_dvd : has_dvd int := +has_dvd.mk has_dvd.dvd + +/- additional properties -/ +theorem of_nat_sub {m n : ℕ} (H : m ≥ n) : of_nat (m - n) = of_nat m - of_nat n := +have m - n + n = m, from nat.sub_add_cancel H, +begin + symmetry, + apply sub_eq_of_eq_add, + rewrite [-of_nat_add, this] +end + +theorem neg_succ_of_nat_eq' (m : ℕ) : -[1+ m] = -m - 1 := +by rewrite [neg_succ_of_nat_eq, neg_add] + +definition succ (a : ℤ) := a + (succ zero) +definition pred (a : ℤ) := a - (succ zero) +definition nat_succ_eq_int_succ (n : ℕ) : nat.succ n = int.succ n := rfl +theorem pred_succ (a : ℤ) : pred (succ a) = a := !sub_add_cancel +theorem succ_pred (a : ℤ) : succ (pred a) = a := !add_sub_cancel + +theorem neg_succ (a : ℤ) : -succ a = pred (-a) := +by rewrite [↑succ,neg_add] + +theorem succ_neg_succ (a : ℤ) : succ (-succ a) = -a := +by rewrite [neg_succ,succ_pred] + +theorem neg_pred (a : ℤ) : -pred a = succ (-a) := +by rewrite [↑pred,neg_sub,sub_eq_add_neg,add.comm] + +theorem pred_neg_pred (a : ℤ) : pred (-pred a) = -a := +by rewrite [neg_pred,pred_succ] + +theorem pred_nat_succ (n : ℕ) : pred (nat.succ n) = n := pred_succ n +theorem neg_nat_succ (n : ℕ) : -nat.succ n = pred (-n) := !neg_succ +theorem succ_neg_nat_succ (n : ℕ) : succ (-nat.succ n) = -n := !succ_neg_succ + +attribute [unfold 2] +definition rec_nat_on {P : ℤ → Type} (z : ℤ) (H0 : P 0) + (Hsucc : Π⦃n : ℕ⦄, P n → P (succ n)) (Hpred : Π⦃n : ℕ⦄, P (-n) → P (-nat.succ n)) : P z := +int.rec (nat.rec H0 Hsucc) (λn, nat.rec H0 Hpred (nat.succ n)) z + +--the only computation rule of rec_nat_on which is not definitional +theorem rec_nat_on_neg {P : ℤ → Type} (n : nat) (H0 : P zero) + (Hsucc : Π⦃n : nat⦄, P n → P (succ n)) (Hpred : Π⦃n : nat⦄, P (-n) → P (-nat.succ n)) + : rec_nat_on (-nat.succ n) H0 Hsucc Hpred = Hpred (rec_nat_on (-n) H0 Hsucc Hpred) := +nat.rec rfl (λn H, rfl) n + +end int diff --git a/old_library/data/int/countable.lean b/old_library/data/int/countable.lean new file mode 100644 index 0000000000..31fe14d12d --- /dev/null +++ b/old_library/data/int/countable.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +import data.equiv data.int.basic data.encodable data.countable +open equiv bool sum + +namespace int +definition int_equiv_bool_nat : int ≃ (bool × nat) := +equiv.mk + (λ i, match i with of_nat a := (tt, a) | neg_succ_of_nat a := (ff, a) end) + (λ p, match p with (tt, a) := of_nat a | (ff, a) := neg_succ_of_nat a end) + (λ i, begin cases i, repeat reflexivity end) + (λ p, begin cases p with b a, cases b, repeat reflexivity end) + +definition int_equiv_nat : int ≃ nat := +calc int ≃ (bool × nat) : int_equiv_bool_nat + ... ≃ ((unit + unit) × nat) : prod_congr bool_equiv_unit_sum_unit !_root_.equiv.refl + ... ≃ (unit × nat) + (unit × nat) : sum_prod_distrib + ... ≃ nat + nat : sum_congr !prod_unit_left !prod_unit_left + ... ≃ nat : nat_sum_nat_equiv_nat + +attribute [instance] +definition encodable_int : encodable int := +encodable_of_equiv (_root_.equiv.symm int_equiv_nat) + +lemma countable_int : countable int := +countable_of_encodable encodable_int + +end int diff --git a/old_library/data/int/default.lean b/old_library/data/int/default.lean new file mode 100644 index 0000000000..c71c4f767e --- /dev/null +++ b/old_library/data/int/default.lean @@ -0,0 +1,6 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad +-/ +import .basic .order .div .power .gcd diff --git a/old_library/data/int/div.lean b/old_library/data/int/div.lean new file mode 100644 index 0000000000..a7e0f162ed --- /dev/null +++ b/old_library/data/int/div.lean @@ -0,0 +1,710 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Definitions and properties of div and mod, following the SSReflect library. + +Following SSReflect and the SMTlib standard, we define a % b so that 0 ≤ a % b < |b| when b ≠ 0. +-/ +import data.int.order data.nat.div +-- open [coercion] [reducible] nat +-- open [declaration] [class] nat (succ) +open eq.ops + +namespace int + +/- definitions -/ + +protected definition div (a b : ℤ) : ℤ := +sign b * + (match a with + | of_nat m := of_nat (m / (nat_abs b)) + | -[1+m] := -[1+ ((m:nat) / (nat_abs b))] + end) + +attribute [instance, priority int.prio] +definition int_has_div : has_div int := +has_div.mk int.div + +lemma of_nat_div_eq (m : nat) (b : ℤ) : (of_nat m) / b = sign b * of_nat (m / (nat_abs b)) := +rfl + +lemma neg_succ_div_eq (m: nat) (b : ℤ) : -[1+m] / b = sign b * -[1+ (m / (nat_abs b))] := +rfl + +lemma div_def (a b : ℤ) : a / b = + sign b * + (match a with + | of_nat m := of_nat (m / (nat_abs b)) + | -[1+m] := -[1+ ((m:nat) / (nat_abs b))] + end) := +rfl + +protected definition mod (a b : ℤ) : ℤ := a - a / b * b + +attribute [instance, priority int.prio] +definition int_has_mod : has_mod int := +has_mod.mk int.mod + + +lemma mod_def (a b : ℤ) : a % b = a - a / b * b := +rfl + +notation [priority int.prio] a ≡ b `[mod `:0 c:0 `]` := a % c = b % c + +/- / -/ + +theorem of_nat_div (m n : nat) : of_nat (m / n) = (of_nat m) / (of_nat n) := +nat.cases_on n + (begin rewrite [of_nat_div_eq, of_nat_zero, sign_zero, zero_mul, nat.div_zero] end) + (take (n : nat), by rewrite [of_nat_div_eq, sign_of_succ, one_mul]) + +theorem neg_succ_of_nat_div (m : nat) {b : ℤ} (H : b > 0) : + -[1+m] / b = -(m / b + 1) := +calc + -[1+m] / b = sign b * _ : rfl + ... = -[1+(m / (nat_abs b))] : by rewrite [sign_of_pos H, one_mul] + ... = -(m / b + 1) : by rewrite [of_nat_div_eq, sign_of_pos H, one_mul] + +protected theorem div_neg (a b : ℤ) : a / -b = -(a / b) := +begin + induction a, + rewrite [*of_nat_div_eq, sign_neg, neg_mul_eq_neg_mul, nat_abs_neg], + rewrite [*neg_succ_div_eq, sign_neg, neg_mul_eq_neg_mul, nat_abs_neg], +end + +theorem div_of_neg_of_pos {a b : ℤ} (Ha : a < 0) (Hb : b > 0) : a / b = -((-a - 1) / b + 1) := +obtain (m : nat) (H1 : a = -[1+m]), from exists_eq_neg_succ_of_nat Ha, +calc + a / b = -(m / b + 1) : by rewrite [H1, neg_succ_of_nat_div _ Hb] + ... = -((-a -1) / b + 1) : by rewrite [H1, neg_succ_of_nat_eq', neg_sub, sub_neg_eq_add, + add.comm 1, add_sub_cancel] + +protected theorem div_nonneg {a b : ℤ} (Ha : a ≥ 0) (Hb : b ≥ 0) : a / b ≥ 0 := +obtain (m : ℕ) (Hm : a = m), from exists_eq_of_nat Ha, +obtain (n : ℕ) (Hn : b = n), from exists_eq_of_nat Hb, +calc + a / b = m / n : by rewrite [Hm, Hn] + ... ≥ 0 : by rewrite -of_nat_div; apply trivial + +protected theorem div_nonpos {a b : ℤ} (Ha : a ≥ 0) (Hb : b ≤ 0) : a / b ≤ 0 := +calc + a / b = -(a / -b) : by rewrite [int.div_neg, neg_neg] + ... ≤ 0 : neg_nonpos_of_nonneg (int.div_nonneg Ha (neg_nonneg_of_nonpos Hb)) + +theorem div_neg' {a b : ℤ} (Ha : a < 0) (Hb : b > 0) : a / b < 0 := +have -a - 1 ≥ 0, from le_sub_one_of_lt (neg_pos_of_neg Ha), +have (-a - 1) / b + 1 > 0, from lt_add_one_of_le (int.div_nonneg this (le_of_lt Hb)), +calc + a / b = -((-a - 1) / b + 1) : div_of_neg_of_pos Ha Hb + ... < 0 : neg_neg_of_pos this + +protected theorem zero_div (b : ℤ) : 0 / b = 0 := +by krewrite [of_nat_div_eq, nat.zero_div, of_nat_zero, mul_zero] + +protected theorem div_zero (a : ℤ) : a / 0 = 0 := +by rewrite [div_def, sign_zero, zero_mul] + +protected theorem div_one (a : ℤ) : a / 1 = a := +have (1 : int) > 0, from dec_trivial, +int.cases_on a + (take m : nat, by rewrite [-of_nat_one, -of_nat_div, nat.div_one]) + (take m : nat, by rewrite [!neg_succ_of_nat_div this, -of_nat_one, -of_nat_div, nat.div_one]) + +theorem eq_div_mul_add_mod (a b : ℤ) : a = a / b * b + a % b := +!add.comm ▸ eq_add_of_sub_eq rfl + +theorem div_eq_zero_of_lt {a b : ℤ} : 0 ≤ a → a < b → a / b = 0 := +int.cases_on a + (take (m : nat), assume H, + int.cases_on b + (take (n : nat), + assume H : m < n, + show m / n = 0, + by rewrite [-of_nat_div, nat.div_eq_zero_of_lt (lt_of_of_nat_lt_of_nat H)]) + (take (n : nat), + assume H : m < -[1+n], + have H1 : ¬(m < -[1+n]), from dec_trivial, + absurd H H1)) + (take (m : nat), + assume H : 0 ≤ -[1+m], + have ¬ (0 ≤ -[1+m]), from dec_trivial, + absurd H this) + +theorem div_eq_zero_of_lt_abs {a b : ℤ} (H1 : 0 ≤ a) (H2 : a < abs b) : a / b = 0 := +lt.by_cases + (suppose b < 0, + have a < -b, from abs_of_neg this ▸ H2, + calc + a / b = - (a / -b) : by rewrite [int.div_neg, neg_neg] + ... = 0 : by rewrite [div_eq_zero_of_lt H1 this, neg_zero]) + (suppose b = 0, this⁻¹ ▸ !int.div_zero) + (suppose b > 0, + have a < b, from abs_of_pos this ▸ H2, + div_eq_zero_of_lt H1 this) + +private theorem add_mul_div_self_aux1 {a : ℤ} {k : ℕ} (n : ℕ) (H1 : a ≥ 0) (H2 : k > 0) : + (a + n * k) / k = a / k + n := +obtain (m : nat) (Hm : a = of_nat m), from exists_eq_of_nat H1, +begin + subst Hm, + rewrite [-of_nat_mul, -of_nat_add, -*of_nat_div, -of_nat_add, !nat.add_mul_div_self H2] +end + +private theorem add_mul_div_self_aux2 {a : ℤ} {k : ℕ} (n : ℕ) (H1 : a < 0) (H2 : k > 0) : + (a + n * k) / k = a / k + n := +obtain m (Hm : a = -[1+m]), from exists_eq_neg_succ_of_nat H1, +or.elim (nat.lt_or_ge m (n * k)) + (assume m_lt_nk : m < n * k, + have H3 : m + 1 ≤ n * k, from nat.succ_le_of_lt m_lt_nk, + have H4 : m / k + 1 ≤ n, + from nat.succ_le_of_lt (nat.div_lt_of_lt_mul m_lt_nk), + have (-[1+m] + n * k) / k = -[1+m] / k + n, from calc + (-[1+m] + n * k) / k + = of_nat ((k * n - (m + 1)) / k) : + by rewrite [add.comm, neg_succ_of_nat_eq, of_nat_div, mul.comm k n, + of_nat_sub H3] + ... = of_nat (n - m / k - 1) : + nat.mul_sub_div_of_lt (!nat.mul_comm ▸ m_lt_nk) + ... = -[1+m] / k + n : + by rewrite [nat.sub_sub, of_nat_sub H4, int.add_comm, sub_eq_add_neg, + !neg_succ_of_nat_div (of_nat_lt_of_nat_of_lt H2), + of_nat_add, of_nat_div], + Hm⁻¹ ▸ this) + (assume nk_le_m : n * k ≤ m, + have -[1+m] / k + n = (-[1+m] + n * k) / k, from calc + -[1+m] / k + n + = -(of_nat ((m - n * k + n * k) / k) + 1) + n : + by rewrite [neg_succ_of_nat_div m (of_nat_lt_of_nat_of_lt H2), + nat.sub_add_cancel nk_le_m, of_nat_div] + ... = -(of_nat ((m - n * k) / k + n) + 1) + n : nat.add_mul_div_self H2 + ... = -(of_nat (m - n * k) / k + 1) : + by rewrite [of_nat_add, *neg_add, add.right_comm, neg_add_cancel_right, + of_nat_div] + ... = -[1+(m - n * k)] / k : + neg_succ_of_nat_div _ (of_nat_lt_of_nat_of_lt H2) + ... = -(of_nat(m - n * k) + 1) / k : rfl + ... = -(of_nat m - of_nat(n * k) + 1) / k : of_nat_sub nk_le_m + ... = (-(of_nat m + 1) + n * k) / k : + by rewrite [sub_eq_add_neg, -*add.assoc, *neg_add, neg_neg, add.right_comm] + ... = (-[1+m] + n * k) / k : rfl, + Hm⁻¹ ▸ this⁻¹) + +private theorem add_mul_div_self_aux3 (a : ℤ) {b c : ℤ} (H1 : b ≥ 0) (H2 : c > 0) : + (a + b * c) / c = a / c + b := +obtain (n : nat) (Hn : b = of_nat n), from exists_eq_of_nat H1, +obtain (k : nat) (Hk : c = of_nat k), from exists_eq_of_nat (le_of_lt H2), +have knz : k ≠ 0, from assume kz, !lt.irrefl (kz ▸ Hk ▸ H2), +have kgt0 : (#nat k > 0), from nat.pos_of_ne_zero knz, +have H3 : (a + n * k) / k = a / k + n, from + or.elim (lt_or_ge a 0) + (assume Ha : a < 0, add_mul_div_self_aux2 _ Ha kgt0) + (assume Ha : a ≥ 0, add_mul_div_self_aux1 _ Ha kgt0), +Hn⁻¹ ▸ Hk⁻¹ ▸ H3 + +private theorem add_mul_div_self_aux4 (a b : ℤ) {c : ℤ} (H : c > 0) : + (a + b * c) / c = a / c + b := +or.elim (le.total 0 b) + (assume H1 : 0 ≤ b, add_mul_div_self_aux3 _ H1 H) + (assume H1 : 0 ≥ b, + eq.symm (calc + a / c + b = (a + b * c + -b * c) / c + b : + by rewrite [-neg_mul_eq_neg_mul, add_neg_cancel_right] + ... = (a + b * c) / c + - b + b : + add_mul_div_self_aux3 _ (neg_nonneg_of_nonpos H1) H + ... = (a + b * c) / c : neg_add_cancel_right)) + +protected theorem add_mul_div_self (a b : ℤ) {c : ℤ} (H : c ≠ 0) : + (a + b * c) / c = a / c + b := +lt.by_cases + (assume H1 : 0 < c, !add_mul_div_self_aux4 H1) + (assume H1 : 0 = c, absurd H1⁻¹ H) + (assume H1 : 0 > c, + have H2 : -c > 0, from neg_pos_of_neg H1, + calc + (a + b * c) / c = - ((a + -b * -c) / -c) : by rewrite [int.div_neg, neg_mul_neg, neg_neg] + ... = -(a / -c + -b) : !add_mul_div_self_aux4 H2 + ... = a / c + b : by rewrite [int.div_neg, neg_add, *neg_neg]) + +protected theorem add_mul_div_self_left (a : ℤ) {b : ℤ} (c : ℤ) (H : b ≠ 0) : + (a + b * c) / b = a / b + c := +!mul.comm ▸ !int.add_mul_div_self H + +protected theorem mul_div_cancel (a : ℤ) {b : ℤ} (H : b ≠ 0) : a * b / b = a := +calc + a * b / b = (0 + a * b) / b : zero_add + ... = 0 / b + a : !int.add_mul_div_self H + ... = a : by rewrite [int.zero_div, zero_add] + +protected theorem mul_div_cancel_left {a : ℤ} (b : ℤ) (H : a ≠ 0) : a * b / a = b := +!mul.comm ▸ int.mul_div_cancel b H + +protected theorem div_self {a : ℤ} (H : a ≠ 0) : a / a = 1 := +!mul_one ▸ !int.mul_div_cancel_left H + +/- mod -/ + +theorem of_nat_mod (m n : nat) : m % n = of_nat (m % n) := +have H : m = of_nat (m % n) + m / n * n, from calc + m = of_nat (m / n * n + m % n) : nat.eq_div_mul_add_mod + ... = of_nat (m / n) * n + of_nat (m % n) : rfl + ... = m / n * n + of_nat (m % n) : of_nat_div + ... = of_nat (m % n) + m / n * n : add.comm, +calc + m % n = m - m / n * n : rfl + ... = of_nat (m % n) : sub_eq_of_eq_add H + +theorem neg_succ_of_nat_mod (m : ℕ) {b : ℤ} (bpos : b > 0) : + -[1+m] % b = b - 1 - m % b := +calc + -[1+m] % b = -(m + 1) - -[1+m] / b * b : rfl + ... = -(m + 1) - -(m / b + 1) * b : neg_succ_of_nat_div _ bpos + ... = -m + -1 + (b + m / b * b) : + by rewrite [neg_add, -neg_mul_eq_neg_mul, sub_neg_eq_add, right_distrib, + one_mul, (add.comm b)] + ... = b + -1 + (-m + m / b * b) : + by rewrite [-*add.assoc, add.comm (-m), add.right_comm (-1), (add.comm b)] + ... = b - 1 - m % b : + by rewrite [(mod_def), *sub_eq_add_neg, neg_add, neg_neg] + -- it seems the parser has difficulty here, because "mod" is a token? + +theorem mod_neg (a b : ℤ) : a % -b = a % b := +calc + a % -b = a - (a / -b) * -b : rfl + ... = a - -(a / b) * -b : int.div_neg + ... = a - a / b * b : neg_mul_neg + ... = a % b : rfl + +theorem mod_abs (a b : ℤ) : a % (abs b) = a % b := +abs.by_cases rfl !mod_neg + +theorem zero_mod (b : ℤ) : 0 % b = 0 := +by rewrite [(mod_def), int.zero_div, zero_mul, sub_zero] + +theorem mod_zero (a : ℤ) : a % 0 = a := +by rewrite [(mod_def), mul_zero, sub_zero] + +theorem mod_one (a : ℤ) : a % 1 = 0 := +calc + a % 1 = a - a / 1 * 1 : rfl + ... = 0 : by rewrite [mul_one, int.div_one, sub_self] + +private lemma of_nat_mod_abs (m : ℕ) (b : ℤ) : m % (abs b) = of_nat (m % (nat_abs b)) := +calc + m % (abs b) = m % (nat_abs b) : of_nat_nat_abs + ... = of_nat (m % (nat_abs b)) : of_nat_mod + +private lemma of_nat_mod_abs_lt (m : ℕ) {b : ℤ} (H : b ≠ 0) : m % (abs b) < (abs b) := +have H1 : abs b > 0, from abs_pos_of_ne_zero H, +have H2 : (#nat nat_abs b > 0), from lt_of_of_nat_lt_of_nat (!of_nat_nat_abs⁻¹ ▸ H1), +calc + m % (abs b) = of_nat (m % (nat_abs b)) : of_nat_mod_abs m b + ... < nat_abs b : of_nat_lt_of_nat_of_lt (!nat.mod_lt H2) + ... = abs b : of_nat_nat_abs _ + +theorem mod_eq_of_lt {a b : ℤ} (H1 : 0 ≤ a) (H2 : a < b) : a % b = a := +obtain (m : nat) (Hm : a = of_nat m), from exists_eq_of_nat H1, +obtain (n : nat) (Hn : b = of_nat n), from exists_eq_of_nat (le_of_lt (lt_of_le_of_lt H1 H2)), +begin + revert H2, + rewrite [Hm, Hn, of_nat_mod, of_nat_lt_of_nat_iff, of_nat_eq_of_nat_iff], + apply nat.mod_eq_of_lt +end + +theorem mod_nonneg (a : ℤ) {b : ℤ} (H : b ≠ 0) : a % b ≥ 0 := +have H1 : abs b > 0, from abs_pos_of_ne_zero H, +have H2 : a % (abs b) ≥ 0, from + int.cases_on a + (take m : nat, (of_nat_mod_abs m b)⁻¹ ▸ of_nat_nonneg (nat.mod m (nat_abs b))) + (take m : nat, + have H3 : 1 + m % (abs b) ≤ (abs b), + from (!add.comm ▸ add_one_le_of_lt (of_nat_mod_abs_lt m H)), + calc + -[1+m] % (abs b) = abs b - 1 - m % (abs b) : neg_succ_of_nat_mod _ H1 + ... = abs b - (1 + m % (abs b)) : by rewrite [*sub_eq_add_neg, neg_add, add.assoc] + ... ≥ 0 : iff.mpr !sub_nonneg_iff_le H3), +!mod_abs ▸ H2 + +theorem mod_lt (a : ℤ) {b : ℤ} (H : b ≠ 0) : a % b < (abs b) := +have H1 : abs b > 0, from abs_pos_of_ne_zero H, +have H2 : a % (abs b) < abs b, from + int.cases_on a + (take m, of_nat_mod_abs_lt m H) + (take m : nat, + have H3 : abs b ≠ 0, from assume H', H (eq_zero_of_abs_eq_zero H'), + have H4 : 1 + m % (abs b) > 0, + from add_pos_of_pos_of_nonneg dec_trivial (mod_nonneg _ H3), + calc + -[1+m] % (abs b) = abs b - 1 - m % (abs b) : neg_succ_of_nat_mod _ H1 + ... = abs b - (1 + m % (abs b)) : by rewrite [*sub_eq_add_neg, neg_add, add.assoc] + ... < abs b : sub_lt_self _ H4), +!mod_abs ▸ H2 + +theorem add_mul_mod_self {a b c : ℤ} : (a + b * c) % c = a % c := +decidable.by_cases + (assume cz : c = 0, by rewrite [cz, mul_zero, add_zero]) + (assume cnz, by rewrite [(mod_def), !int.add_mul_div_self cnz, right_distrib, + sub_add_eq_sub_sub_swap, add_sub_cancel]) + +theorem add_mul_mod_self_left (a b c : ℤ) : (a + b * c) % b = a % b := +!mul.comm ▸ !add_mul_mod_self + +theorem add_mod_self {a b : ℤ} : (a + b) % b = a % b := +by rewrite -(int.mul_one b) at {1}; apply add_mul_mod_self_left + +theorem add_mod_self_left {a b : ℤ} : (a + b) % a = b % a := +!add.comm ▸ !add_mod_self + +theorem mod_add_mod (m n k : ℤ) : (m % n + k) % n = (m + k) % n := +by rewrite [eq_div_mul_add_mod m n at {2}, add.assoc, add.comm (m / n * n), add_mul_mod_self] + +theorem add_mod_mod (m n k : ℤ) : (m + n % k) % k = (m + n) % k := +by rewrite [add.comm, mod_add_mod, add.comm] + +theorem add_mod_eq_add_mod_right {m n k : ℤ} (i : ℤ) (H : m % n = k % n) : + (m + i) % n = (k + i) % n := +by rewrite [-mod_add_mod, -mod_add_mod k, H] + +theorem add_mod_eq_add_mod_left {m n k : ℤ} (i : ℤ) (H : m % n = k % n) : + (i + m) % n = (i + k) % n := +by rewrite [add.comm, add_mod_eq_add_mod_right _ H, add.comm] + +theorem mod_eq_mod_of_add_mod_eq_add_mod_right {m n k i : ℤ} + (H : (m + i) % n = (k + i) % n) : + m % n = k % n := +have H1 : (m + i + (-i)) % n = (k + i + (-i)) % n, from add_mod_eq_add_mod_right _ H, +by rewrite [*add_neg_cancel_right at H1]; apply H1 + +theorem mod_eq_mod_of_add_mod_eq_add_mod_left {m n k i : ℤ} : + (i + m) % n = (i + k) % n → m % n = k % n := +by rewrite [add.comm i m, add.comm i k]; apply mod_eq_mod_of_add_mod_eq_add_mod_right + +theorem mul_mod_left (a b : ℤ) : (a * b) % b = 0 := +by rewrite [-zero_add (a * b), add_mul_mod_self, zero_mod] + +theorem mul_mod_right (a b : ℤ) : (a * b) % a = 0 := +!mul.comm ▸ !mul_mod_left + +theorem mod_self {a : ℤ} : a % a = 0 := +decidable.by_cases + (assume H : a = 0, H⁻¹ ▸ !mod_zero) + (assume H : a ≠ 0, + calc + a % a = a - a / a * a : rfl + ... = 0 : by rewrite [!int.div_self H, one_mul, sub_self]) + +theorem mod_lt_of_pos (a : ℤ) {b : ℤ} (H : b > 0) : a % b < b := +!abs_of_pos H ▸ !mod_lt (ne.symm (ne_of_lt H)) + +/- properties of / and % -/ + +theorem mul_div_mul_of_pos_aux {a : ℤ} (b : ℤ) {c : ℤ} + (H1 : a > 0) (H2 : c > 0) : a * b / (a * c) = b / c := +have H3 : a * c ≠ 0, from ne.symm (ne_of_lt (mul_pos H1 H2)), +have H4 : a * (b % c) < a * c, from mul_lt_mul_of_pos_left (!mod_lt_of_pos H2) H1, +have H5 : a * (b % c) ≥ 0, from mul_nonneg (le_of_lt H1) (!mod_nonneg (ne.symm (ne_of_lt H2))), +calc + a * b / (a * c) = a * (b / c * c + b % c) / (a * c) : eq_div_mul_add_mod + + ... = (a * (b % c) + a * c * (b / c)) / (a * c) : + by rewrite [!add.comm, int.left_distrib, mul.comm _ c, -!mul.assoc] + ... = a * (b % c) / (a * c) + b / c : !int.add_mul_div_self_left H3 + ... = 0 + b / c : {!div_eq_zero_of_lt H5 H4} + ... = b / c : zero_add + +theorem mul_div_mul_of_pos {a : ℤ} (b c : ℤ) (H : a > 0) : a * b / (a * c) = b / c := +lt.by_cases + (assume H1 : c < 0, + have H2 : -c > 0, from neg_pos_of_neg H1, + calc + a * b / (a * c) = - (a * b / (a * -c)) : + by rewrite [-neg_mul_eq_mul_neg, int.div_neg, neg_neg] + ... = - (b / -c) : mul_div_mul_of_pos_aux _ H H2 + ... = b / c : by rewrite [int.div_neg, neg_neg]) + (assume H1 : c = 0, + calc + a * b / (a * c) = 0 : by rewrite [H1, mul_zero, int.div_zero] + ... = b / c : by rewrite [H1, int.div_zero]) + (assume H1 : c > 0, + mul_div_mul_of_pos_aux _ H H1) + +theorem mul_div_mul_of_pos_left (a : ℤ) {b : ℤ} (c : ℤ) (H : b > 0) : + a * b / (c * b) = a / c := +!mul.comm ▸ !mul.comm ▸ !mul_div_mul_of_pos H + +theorem mul_mod_mul_of_pos {a : ℤ} (b c : ℤ) (H : a > 0) : a * b % (a * c) = a * (b % c) := +by rewrite [(mod_def), mod_def, !mul_div_mul_of_pos H, mul_sub_left_distrib, mul.left_comm] + +theorem lt_div_add_one_mul_self (a : ℤ) {b : ℤ} (H : b > 0) : a < (a / b + 1) * b := +have H : a - a / b * b < b, from !mod_lt_of_pos H, +calc + a < a / b * b + b : iff.mpr !lt_add_iff_sub_lt_left H + ... = (a / b + 1) * b : by rewrite [right_distrib, one_mul] + +theorem div_le_of_nonneg_of_nonneg {a b : ℤ} (Ha : a ≥ 0) (Hb : b ≥ 0) : a / b ≤ a := +obtain (m : ℕ) (Hm : a = m), from exists_eq_of_nat Ha, +obtain (n : ℕ) (Hn : b = n), from exists_eq_of_nat Hb, +calc + a / b = of_nat (m / n) : by rewrite [Hm, Hn, of_nat_div] + ... ≤ m : of_nat_le_of_nat_of_le !nat.div_le_self + ... = a : Hm + +theorem abs_div_le_abs (a b : ℤ) : abs (a / b) ≤ abs a := +have H : ∀a b, b > 0 → abs (a / b) ≤ abs a, from + take a b, + assume H1 : b > 0, + or.elim (le_or_gt 0 a) + (assume H2 : 0 ≤ a, + have H3 : 0 ≤ b, from le_of_lt H1, + calc + abs (a / b) = a / b : abs_of_nonneg (int.div_nonneg H2 H3) + ... ≤ a : div_le_of_nonneg_of_nonneg H2 H3 + ... = abs a : abs_of_nonneg H2) + (assume H2 : a < 0, + have H3 : -a - 1 ≥ 0, from le_sub_one_of_lt (neg_pos_of_neg H2), + have H4 : (-a - 1) / b + 1 ≥ 0, + from add_nonneg (int.div_nonneg H3 (le_of_lt H1)) (of_nat_le_of_nat_of_le !nat.zero_le), + have H5 : (-a - 1) / b ≤ -a - 1, from div_le_of_nonneg_of_nonneg H3 (le_of_lt H1), + calc + abs (a / b) = abs ((-a - 1) / b + 1) : by rewrite [div_of_neg_of_pos H2 H1, abs_neg] + ... = (-a - 1) / b + 1 : abs_of_nonneg H4 + ... ≤ -a - 1 + 1 : add_le_add_right H5 _ + ... = abs a : by rewrite [sub_add_cancel, abs_of_neg H2]), +lt.by_cases + (assume H1 : b < 0, + calc + abs (a / b) = abs (a / -b) : by rewrite [int.div_neg, abs_neg] + ... ≤ abs a : H _ _ (neg_pos_of_neg H1)) + (assume H1 : b = 0, + calc + abs (a / b) = 0 : by rewrite [H1, int.div_zero, abs_zero] + ... ≤ abs a : abs_nonneg) + (assume H1 : b > 0, H _ _ H1) + +theorem div_mul_cancel_of_mod_eq_zero {a b : ℤ} (H : a % b = 0) : a / b * b = a := +by rewrite [eq_div_mul_add_mod a b at {2}, H, add_zero] + +theorem mul_div_cancel_of_mod_eq_zero {a b : ℤ} (H : a % b = 0) : b * (a / b) = a := +!mul.comm ▸ div_mul_cancel_of_mod_eq_zero H + +/- dvd -/ + +theorem dvd_of_of_nat_dvd_of_nat {m n : ℕ} : of_nat m ∣ of_nat n → (#nat m ∣ n) := +nat.by_cases_zero_pos n + (assume H, dvd_zero m) + (take n' : ℕ, + assume H1 : (#nat n' > 0), + have H2 : of_nat n' > 0, from of_nat_pos H1, + assume H3 : of_nat m ∣ of_nat n', + dvd.elim H3 + (take c, + assume H4 : of_nat n' = of_nat m * c, + have H5 : c > 0, from pos_of_mul_pos_left (H4 ▸ H2) !of_nat_nonneg, + obtain k (H6 : c = of_nat k), from exists_eq_of_nat (le_of_lt H5), + have H7 : n' = (#nat m * k), from (of_nat.inj (H6 ▸ H4)), + dvd.intro H7⁻¹)) + +theorem of_nat_dvd_of_nat_of_dvd {m n : ℕ} (H : #nat m ∣ n) : of_nat m ∣ of_nat n := +dvd.elim H + (take k, assume H1 : #nat n = m * k, + dvd.intro (H1⁻¹ ▸ rfl)) + +theorem of_nat_dvd_of_nat_iff (m n : ℕ) : of_nat m ∣ of_nat n ↔ m ∣ n := +iff.intro dvd_of_of_nat_dvd_of_nat of_nat_dvd_of_nat_of_dvd + +theorem dvd.antisymm {a b : ℤ} (H1 : a ≥ 0) (H2 : b ≥ 0) : a ∣ b → b ∣ a → a = b := +begin + rewrite [-abs_of_nonneg H1, -abs_of_nonneg H2, -*of_nat_nat_abs], + rewrite [*of_nat_dvd_of_nat_iff, *of_nat_eq_of_nat_iff], + apply nat.dvd.antisymm +end + +theorem dvd_of_mod_eq_zero {a b : ℤ} (H : b % a = 0) : a ∣ b := +dvd.intro (!mul.comm ▸ div_mul_cancel_of_mod_eq_zero H) + +theorem mod_eq_zero_of_dvd {a b : ℤ} (H : a ∣ b) : b % a = 0 := +dvd.elim H (take z, assume H1 : b = a * z, H1⁻¹ ▸ !mul_mod_right) + +theorem dvd_iff_mod_eq_zero (a b : ℤ) : a ∣ b ↔ b % a = 0 := +iff.intro mod_eq_zero_of_dvd dvd_of_mod_eq_zero + +attribute [instance] +definition dvd.decidable_rel : decidable_rel dvd := +take a n, decidable_of_decidable_of_iff _ (iff.symm !dvd_iff_mod_eq_zero) + +protected theorem div_mul_cancel {a b : ℤ} (H : b ∣ a) : a / b * b = a := +div_mul_cancel_of_mod_eq_zero (mod_eq_zero_of_dvd H) + +protected theorem mul_div_cancel' {a b : ℤ} (H : a ∣ b) : a * (b / a) = b := +!mul.comm ▸ !int.div_mul_cancel H + +protected theorem mul_div_assoc (a : ℤ) {b c : ℤ} (H : c ∣ b) : (a * b) / c = a * (b / c) := +decidable.by_cases + (assume cz : c = 0, by rewrite [cz, *int.div_zero, mul_zero]) + (assume cnz : c ≠ 0, + obtain d (H' : b = d * c), from exists_eq_mul_left_of_dvd H, + by rewrite [H', -mul.assoc, *(!int.mul_div_cancel cnz)]) + +theorem div_dvd_div {a b c : ℤ} (H1 : a ∣ b) (H2 : b ∣ c) : b / a ∣ c / a := +have H3 : b = b / a * a, from (int.div_mul_cancel H1)⁻¹, +have H4 : c = c / a * a, from (int.div_mul_cancel (dvd.trans H1 H2))⁻¹, +decidable.by_cases + (assume H5 : a = 0, + have H6: c / a = 0, from (congr_arg _ H5 ⬝ !int.div_zero), + H6⁻¹ ▸ !dvd_zero) + (assume H5 : a ≠ 0, + dvd_of_mul_dvd_mul_right H5 (H3 ▸ H4 ▸ H2)) + +protected theorem div_eq_iff_eq_mul_right {a b : ℤ} (c : ℤ) (H : b ≠ 0) (H' : b ∣ a) : + a / b = c ↔ a = b * c := +iff.intro + (assume H1, by rewrite [-H1, int.mul_div_cancel' H']) + (assume H1, by rewrite [H1, !int.mul_div_cancel_left H]) + +protected theorem div_eq_iff_eq_mul_left {a b : ℤ} (c : ℤ) (H : b ≠ 0) (H' : b ∣ a) : + a / b = c ↔ a = c * b := +!mul.comm ▸ !int.div_eq_iff_eq_mul_right H H' + +protected theorem eq_mul_of_div_eq_right {a b c : ℤ} (H1 : b ∣ a) (H2 : a / b = c) : + a = b * c := +calc + a = b * (a / b) : int.mul_div_cancel' H1 + ... = b * c : H2 + +protected theorem div_eq_of_eq_mul_right {a b c : ℤ} (H1 : b ≠ 0) (H2 : a = b * c) : + a / b = c := +calc + a / b = b * c / b : H2 + ... = c : !int.mul_div_cancel_left H1 + +protected theorem eq_mul_of_div_eq_left {a b c : ℤ} (H1 : b ∣ a) (H2 : a / b = c) : + a = c * b := +!mul.comm ▸ !int.eq_mul_of_div_eq_right H1 H2 + +protected theorem div_eq_of_eq_mul_left {a b c : ℤ} (H1 : b ≠ 0) (H2 : a = c * b) : + a / b = c := +int.div_eq_of_eq_mul_right H1 (!mul.comm ▸ H2) + +theorem neg_div_of_dvd {a b : ℤ} (H : b ∣ a) : -a / b = -(a / b) := +decidable.by_cases + (assume H1 : b = 0, by rewrite [H1, *int.div_zero, neg_zero]) + (assume H1 : b ≠ 0, + dvd.elim H + (take c, assume H' : a = b * c, + by rewrite [H', neg_mul_eq_mul_neg, *!int.mul_div_cancel_left H1])) + +protected theorem sign_eq_div_abs (a : ℤ) : sign a = a / (abs a) := +decidable.by_cases + (suppose a = 0, by subst a) + (suppose a ≠ 0, + have abs a ≠ 0, from assume H, this (eq_zero_of_abs_eq_zero H), + have abs a ∣ a, from abs_dvd_of_dvd !dvd.refl, + eq.symm (iff.mpr (!int.div_eq_iff_eq_mul_left `abs a ≠ 0` this) !eq_sign_mul_abs)) + +theorem le_of_dvd {a b : ℤ} (bpos : b > 0) (H : a ∣ b) : a ≤ b := +or.elim !le_or_gt + (suppose a ≤ 0, le.trans this (le_of_lt bpos)) + (suppose a > 0, + obtain c (Hc : b = a * c), from exists_eq_mul_right_of_dvd H, + have a * c > 0, by rewrite -Hc; exact bpos, + have c > 0, from pos_of_mul_pos_left this (le_of_lt `a > 0`), + show a ≤ b, from calc + a = a * 1 : mul_one + ... ≤ a * c : mul_le_mul_of_nonneg_left (add_one_le_of_lt `c > 0`) (le_of_lt `a > 0`) + ... = b : Hc) + +/- / and ordering -/ + +protected theorem div_mul_le (a : ℤ) {b : ℤ} (H : b ≠ 0) : a / b * b ≤ a := +calc + a = a / b * b + a % b : eq_div_mul_add_mod + ... ≥ a / b * b : le_add_of_nonneg_right (!mod_nonneg H) + +protected theorem div_le_of_le_mul {a b c : ℤ} (H : c > 0) (H' : a ≤ b * c) : a / c ≤ b := +le_of_mul_le_mul_right (calc + a / c * c = a / c * c + 0 : add_zero + ... ≤ a / c * c + a % c : add_le_add_left (!mod_nonneg (ne_of_gt H)) + ... = a : eq_div_mul_add_mod + ... ≤ b * c : H') H + +protected theorem div_le_self (a : ℤ) {b : ℤ} (H1 : a ≥ 0) (H2 : b ≥ 0) : a / b ≤ a := +or.elim (lt_or_eq_of_le H2) + (assume H3 : b > 0, + have H4 : b ≥ 1, from add_one_le_of_lt H3, + have H5 : a ≤ a * b, from calc + a = a * 1 : mul_one + ... ≤ a * b : !mul_le_mul_of_nonneg_left H4 H1, + int.div_le_of_le_mul H3 H5) + (assume H3 : 0 = b, + by rewrite [-H3, int.div_zero]; apply H1) + +protected theorem mul_le_of_le_div {a b c : ℤ} (H1 : c > 0) (H2 : a ≤ b / c) : a * c ≤ b := +calc + a * c ≤ b / c * c : !mul_le_mul_of_nonneg_right H2 (le_of_lt H1) + ... ≤ b : !int.div_mul_le (ne_of_gt H1) + +protected theorem le_div_of_mul_le {a b c : ℤ} (H1 : c > 0) (H2 : a * c ≤ b) : a ≤ b / c := +have H3 : a * c < (b / c + 1) * c, from + calc + a * c ≤ b : H2 + ... = b / c * c + b % c : eq_div_mul_add_mod + ... < b / c * c + c : add_lt_add_left (!mod_lt_of_pos H1) + ... = (b / c + 1) * c : by rewrite [right_distrib, one_mul], +le_of_lt_add_one (lt_of_mul_lt_mul_right H3 (le_of_lt H1)) + +protected theorem le_div_iff_mul_le {a b c : ℤ} (H : c > 0) : a ≤ b / c ↔ a * c ≤ b := +iff.intro (!int.mul_le_of_le_div H) (!int.le_div_of_mul_le H) + +protected theorem div_le_div {a b c : ℤ} (H : c > 0) (H' : a ≤ b) : a / c ≤ b / c := +int.le_div_of_mul_le H (le.trans (!int.div_mul_le (ne_of_gt H)) H') + +protected theorem div_lt_of_lt_mul {a b c : ℤ} (H : c > 0) (H' : a < b * c) : a / c < b := +lt_of_mul_lt_mul_right + (calc + a / c * c = a / c * c + 0 : add_zero + ... ≤ a / c * c + a % c : add_le_add_left (!mod_nonneg (ne_of_gt H)) + ... = a : eq_div_mul_add_mod + ... < b * c : H') + (le_of_lt H) + +protected theorem lt_mul_of_div_lt {a b c : ℤ} (H1 : c > 0) (H2 : a / c < b) : a < b * c := +have H3 : (a / c + 1) * c ≤ b * c, + from !mul_le_mul_of_nonneg_right (add_one_le_of_lt H2) (le_of_lt H1), +have H4 : a / c * c + c ≤ b * c, by rewrite [right_distrib at H3, one_mul at H3]; apply H3, +calc + a = a / c * c + a % c : eq_div_mul_add_mod + ... < a / c * c + c : add_lt_add_left (!mod_lt_of_pos H1) + ... ≤ b * c : H4 + +protected theorem div_lt_iff_lt_mul {a b c : ℤ} (H : c > 0) : a / c < b ↔ a < b * c := +iff.intro (!int.lt_mul_of_div_lt H) (!int.div_lt_of_lt_mul H) + +protected theorem div_le_iff_le_mul_of_div {a b : ℤ} (c : ℤ) (H : b > 0) (H' : b ∣ a) : + a / b ≤ c ↔ a ≤ c * b := +by rewrite [propext (!le_iff_mul_le_mul_right H), !int.div_mul_cancel H'] + +protected theorem le_mul_of_div_le_of_div {a b c : ℤ} (H1 : b > 0) (H2 : b ∣ a) (H3 : a / b ≤ c) : + a ≤ c * b := +iff.mp (!int.div_le_iff_le_mul_of_div H1 H2) H3 + +theorem div_pos_of_pos_of_dvd {a b : ℤ} (H1 : a > 0) (H2 : b ≥ 0) (H3 : b ∣ a) : a / b > 0 := +have H4 : b ≠ 0, from + (assume H5 : b = 0, + have H6 : a = 0, from eq_zero_of_zero_dvd (H5 ▸ H3), + ne_of_gt H1 H6), +have H6 : (a / b) * b > 0, by rewrite (int.div_mul_cancel H3); apply H1, +pos_of_mul_pos_right H6 H2 + +theorem div_eq_div_of_dvd_of_dvd {a b c d : ℤ} (H1 : b ∣ a) (H2 : d ∣ c) (H3 : b ≠ 0) + (H4 : d ≠ 0) (H5 : a * d = b * c) : + a / b = c / d := +begin + apply int.div_eq_of_eq_mul_right H3, + rewrite [-!int.mul_div_assoc H2], + apply eq.symm, + apply int.div_eq_of_eq_mul_left H4, + apply eq.symm H5 +end + +end int diff --git a/old_library/data/int/gcd.lean b/old_library/data/int/gcd.lean new file mode 100644 index 0000000000..32cd103762 --- /dev/null +++ b/old_library/data/int/gcd.lean @@ -0,0 +1,350 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad, Leonardo de Moura + +Definitions and properties of gcd, lcm, and coprime. +-/ +import .div data.nat.gcd +open eq.ops + +namespace int + +/- gcd -/ + +definition gcd (a b : ℤ) : ℤ := of_nat (nat.gcd (nat_abs a) (nat_abs b)) + +theorem gcd_nonneg (a b : ℤ) : gcd a b ≥ 0 := +of_nat_nonneg (nat.gcd (nat_abs a) (nat_abs b)) + +theorem gcd.comm (a b : ℤ) : gcd a b = gcd b a := +by rewrite [↑gcd, nat.gcd.comm] + +theorem gcd_zero_right (a : ℤ) : gcd a 0 = abs a := +by rewrite [↑gcd, nat_abs_zero, nat.gcd_zero_right, of_nat_nat_abs] + +theorem gcd_zero_left (a : ℤ) : gcd 0 a = abs a := +by rewrite [gcd.comm, gcd_zero_right] + +theorem gcd_one_right (a : ℤ) : gcd a 1 = 1 := +by rewrite [↑gcd, nat_abs_one, nat.gcd_one_right] + +theorem gcd_one_left (a : ℤ) : gcd 1 a = 1 := +by rewrite [gcd.comm, gcd_one_right] + +theorem gcd_abs_left (a b : ℤ) : gcd (abs a) b = gcd a b := +by rewrite [↑gcd, *nat_abs_abs] + +theorem gcd_abs_right (a b : ℤ) : gcd (abs a) b = gcd a b := +by rewrite [↑gcd, *nat_abs_abs] + +theorem gcd_abs_abs (a b : ℤ) : gcd (abs a) (abs b) = gcd a b := +by rewrite [↑gcd, *nat_abs_abs] + +section +open nat +theorem gcd_of_ne_zero (a : ℤ) {b : ℤ} (H : b ≠ 0) : gcd a b = gcd b (abs a % abs b) := +have nat_abs b ≠ 0, from assume H', H (eq_zero_of_nat_abs_eq_zero H'), +have nat_abs b > 0, from pos_of_ne_zero this, +have nat.gcd (nat_abs a) (nat_abs b) = (nat.gcd (nat_abs b) (nat_abs a % nat_abs b)), + from @nat.gcd_of_pos (nat_abs a) (nat_abs b) this, +calc + gcd a b = nat.gcd (nat_abs b) (nat_abs a % nat_abs b) : by rewrite [↑gcd, this] + ... = gcd (abs b) (abs a % abs b) : by rewrite [↑gcd, -*of_nat_nat_abs, of_nat_mod] + ... = gcd b (abs a % abs b) : by rewrite [↑gcd, *nat_abs_abs] +end + +theorem gcd_of_pos (a : ℤ) {b : ℤ} (H : b > 0) : gcd a b = gcd b (abs a % b) := +by rewrite [!gcd_of_ne_zero (ne_of_gt H), abs_of_pos H] + +theorem gcd_of_nonneg_of_pos {a b : ℤ} (H1 : a ≥ 0) (H2 : b > 0) : gcd a b = gcd b (a % b) := +by rewrite [!gcd_of_pos H2, abs_of_nonneg H1] + +theorem gcd_self (a : ℤ) : gcd a a = abs a := +by rewrite [↑gcd, nat.gcd_self, of_nat_nat_abs] + +theorem gcd_dvd_left (a b : ℤ) : gcd a b ∣ a := +have gcd a b ∣ abs a, + by rewrite [↑gcd, -of_nat_nat_abs, of_nat_dvd_of_nat_iff]; apply nat.gcd_dvd_left, +iff.mp !dvd_abs_iff this + +theorem gcd_dvd_right (a b : ℤ) : gcd a b ∣ b := +by rewrite gcd.comm; apply gcd_dvd_left + +theorem dvd_gcd {a b c : ℤ} : a ∣ b → a ∣ c → a ∣ gcd b c := +begin + rewrite [↑gcd, -*(abs_dvd_iff a), -(dvd_abs_iff _ b), -(dvd_abs_iff _ c), -*of_nat_nat_abs], + rewrite [*of_nat_dvd_of_nat_iff] , + apply nat.dvd_gcd +end + +theorem gcd.assoc (a b c : ℤ) : gcd (gcd a b) c = gcd a (gcd b c) := +dvd.antisymm !gcd_nonneg !gcd_nonneg + (dvd_gcd + (dvd.trans !gcd_dvd_left !gcd_dvd_left) + (dvd_gcd (dvd.trans !gcd_dvd_left !gcd_dvd_right) !gcd_dvd_right)) + (dvd_gcd + (dvd_gcd !gcd_dvd_left (dvd.trans !gcd_dvd_right !gcd_dvd_left)) + (dvd.trans !gcd_dvd_right !gcd_dvd_right)) + +theorem gcd_mul_left (a b c : ℤ) : gcd (a * b) (a * c) = abs a * gcd b c := +by rewrite [↑gcd, *nat_abs_mul, nat.gcd_mul_left, of_nat_mul, of_nat_nat_abs] + +theorem gcd_mul_right (a b c : ℤ) : gcd (a * b) (c * b) = gcd a c * abs b := +by rewrite [mul.comm a, mul.comm c, mul.comm (gcd a c), gcd_mul_left] + +theorem gcd_pos_of_ne_zero_left {a : ℤ} (b : ℤ) (H : a ≠ 0) : gcd a b > 0 := +have gcd a b ≠ 0, from + suppose gcd a b = 0, + have 0 ∣ a, from this ▸ gcd_dvd_left a b, + show false, from H (eq_zero_of_zero_dvd this), +lt_of_le_of_ne (gcd_nonneg a b) (ne.symm this) + +theorem gcd_pos_of_ne_zero_right (a : ℤ) {b : ℤ} (H : b ≠ 0) : gcd a b > 0 := +by rewrite gcd.comm; apply !gcd_pos_of_ne_zero_left H + +theorem eq_zero_of_gcd_eq_zero_left {a b : ℤ} (H : gcd a b = 0) : a = 0 := +decidable.by_contradiction + (suppose a ≠ 0, + have gcd a b > 0, from !gcd_pos_of_ne_zero_left this, + ne_of_lt this H⁻¹) + +theorem eq_zero_of_gcd_eq_zero_right {a b : ℤ} (H : gcd a b = 0) : b = 0 := +by rewrite gcd.comm at H; apply !eq_zero_of_gcd_eq_zero_left H + +theorem gcd_div {a b c : ℤ} (H1 : c ∣ a) (H2 : c ∣ b) : + gcd (a / c) (b / c) = gcd a b / (abs c) := +decidable.by_cases + (suppose c = 0, + calc + gcd (a / c) (b / c) = gcd 0 0 : by subst c; rewrite *int.div_zero + ... = 0 : gcd_zero_left + ... = gcd a b / 0 : int.div_zero + ... = gcd a b / (abs c) : by subst c) + (suppose c ≠ 0, + have abs c ≠ 0, from assume H', this (eq_zero_of_abs_eq_zero H'), + eq.symm (int.div_eq_of_eq_mul_left this + (eq.symm (calc + gcd (a / c) (b / c) * abs c = gcd (a / c * c) (b / c * c) : gcd_mul_right + ... = gcd a (b / c * c) : int.div_mul_cancel H1 + ... = gcd a b : int.div_mul_cancel H2)))) + +theorem gcd_dvd_gcd_mul_left (a b c : ℤ) : gcd a b ∣ gcd (c * a) b := +dvd_gcd (dvd.trans !gcd_dvd_left !dvd_mul_left) !gcd_dvd_right + +theorem gcd_dvd_gcd_mul_right (a b c : ℤ) : gcd a b ∣ gcd (a * c) b := +!mul.comm ▸ !gcd_dvd_gcd_mul_left + +theorem div_gcd_eq_div_gcd_of_nonneg {a₁ b₁ a₂ b₂ : ℤ} (H : a₁ * b₂ = a₂ * b₁) + (H1 : b₁ ≠ 0) (H2 : b₂ ≠ 0) (H3 : a₁ ≥ 0) (H4 : a₂ ≥ 0) : + a₁ / (gcd a₁ b₁) = a₂ / (gcd a₂ b₂) := +begin + apply div_eq_div_of_dvd_of_dvd, + repeat (apply gcd_dvd_left), + intro H', apply H1, apply eq_zero_of_gcd_eq_zero_right H', + intro H', apply H2, apply eq_zero_of_gcd_eq_zero_right H', + rewrite [-abs_of_nonneg H3 at {1}, -abs_of_nonneg H4 at {2}], + rewrite [-gcd_mul_left, -gcd_mul_right, H, mul.comm b₁] +end + +theorem div_gcd_eq_div_gcd {a₁ b₁ a₂ b₂ : ℤ} (H : a₁ * b₂ = a₂ * b₁) (H1 : b₁ > 0) (H2 : b₂ > 0) : + a₁ / (gcd a₁ b₁) = a₂ / (gcd a₂ b₂) := +or.elim (le_or_gt 0 a₁) + (assume H3 : a₁ ≥ 0, + have H4 : a₂ * b₁ ≥ 0, by rewrite -H; apply mul_nonneg H3 (le_of_lt H2), + have H5 : a₂ ≥ 0, from nonneg_of_mul_nonneg_right H4 H1, + div_gcd_eq_div_gcd_of_nonneg H (ne_of_gt H1) (ne_of_gt H2) H3 H5) + (assume H3 : a₁ < 0, + have H4 : a₂ * b₁ < 0, by rewrite -H; apply mul_neg_of_neg_of_pos H3 H2, + have H5 : a₂ < 0, from neg_of_mul_neg_right H4 (le_of_lt H1), + have H6 : abs a₁ / (gcd (abs a₁) (abs b₁)) = abs a₂ / (gcd (abs a₂) (abs b₂)), + begin + apply div_gcd_eq_div_gcd_of_nonneg, + rewrite [abs_of_pos H1, abs_of_pos H2, abs_of_neg H3, abs_of_neg H5], + rewrite [-*neg_mul_eq_neg_mul, H], + apply ne_of_gt (abs_pos_of_pos H1), + apply ne_of_gt (abs_pos_of_pos H2), + repeat (apply abs_nonneg) + end, + have H7 : -a₁ / (gcd a₁ b₁) = -a₂ / (gcd a₂ b₂), + begin + rewrite [-abs_of_neg H3, -abs_of_neg H5, -gcd_abs_abs a₁], + rewrite [-gcd_abs_abs a₂ b₂], + exact H6 + end, + calc + a₁ / (gcd a₁ b₁) = -(-a₁ / (gcd a₁ b₁)) : + by rewrite [neg_div_of_dvd !gcd_dvd_left, neg_neg] + ... = -(-a₂ / (gcd a₂ b₂)) : H7 + ... = a₂ / (gcd a₂ b₂) : + by rewrite [neg_div_of_dvd !gcd_dvd_left, neg_neg]) + +/- lcm -/ + +definition lcm (a b : ℤ) : ℤ := of_nat (nat.lcm (nat_abs a) (nat_abs b)) + +theorem lcm_nonneg (a b : ℤ) : lcm a b ≥ 0 := +of_nat_nonneg (nat.lcm (nat_abs a) (nat_abs b)) + +theorem lcm.comm (a b : ℤ) : lcm a b = lcm b a := +by rewrite [↑lcm, nat.lcm.comm] + +theorem lcm_zero_left (a : ℤ) : lcm 0 a = 0 := +by rewrite [↑lcm, nat_abs_zero, nat.lcm_zero_left] + +theorem lcm_zero_right (a : ℤ) : lcm a 0 = 0 := +!lcm.comm ▸ !lcm_zero_left + +theorem lcm_one_left (a : ℤ) : lcm 1 a = abs a := +by rewrite [↑lcm, nat_abs_one, nat.lcm_one_left, of_nat_nat_abs] + +theorem lcm_one_right (a : ℤ) : lcm a 1 = abs a := +!lcm.comm ▸ !lcm_one_left + +theorem lcm_abs_left (a b : ℤ) : lcm (abs a) b = lcm a b := +by rewrite [↑lcm, *nat_abs_abs] + +theorem lcm_abs_right (a b : ℤ) : lcm (abs a) b = lcm a b := +by rewrite [↑lcm, *nat_abs_abs] + +theorem lcm_abs_abs (a b : ℤ) : lcm (abs a) (abs b) = lcm a b := +by rewrite [↑lcm, *nat_abs_abs] + +theorem lcm_self (a : ℤ) : lcm a a = abs a := +by rewrite [↑lcm, nat.lcm_self, of_nat_nat_abs] + +theorem dvd_lcm_left (a b : ℤ) : a ∣ lcm a b := +by rewrite [↑lcm, -abs_dvd_iff, -of_nat_nat_abs, of_nat_dvd_of_nat_iff]; apply nat.dvd_lcm_left + +theorem dvd_lcm_right (a b : ℤ) : b ∣ lcm a b := +!lcm.comm ▸ !dvd_lcm_left + +theorem gcd_mul_lcm (a b : ℤ) : gcd a b * lcm a b = abs (a * b) := +begin + rewrite [↑gcd, ↑lcm, -of_nat_nat_abs, -of_nat_mul, of_nat_eq_of_nat_iff, nat_abs_mul], + apply nat.gcd_mul_lcm +end + +theorem lcm_dvd {a b c : ℤ} : a ∣ c → b ∣ c → lcm a b ∣ c := +begin + rewrite [↑lcm, -(abs_dvd_iff a), -(abs_dvd_iff b), -*(dvd_abs_iff _ c), -*of_nat_nat_abs], + rewrite [*of_nat_dvd_of_nat_iff] , + apply nat.lcm_dvd +end + +theorem lcm_assoc (a b c : ℤ) : lcm (lcm a b) c = lcm a (lcm b c) := +dvd.antisymm !lcm_nonneg !lcm_nonneg + (lcm_dvd + (lcm_dvd !dvd_lcm_left (dvd.trans !dvd_lcm_left !dvd_lcm_right)) + (dvd.trans !dvd_lcm_right !dvd_lcm_right)) + (lcm_dvd + (dvd.trans !dvd_lcm_left !dvd_lcm_left) + (lcm_dvd (dvd.trans !dvd_lcm_right !dvd_lcm_left) !dvd_lcm_right)) + +/- coprime -/ + +abbreviation coprime (a b : ℤ) : Prop := gcd a b = 1 + +theorem coprime_swap {a b : ℤ} (H : coprime b a) : coprime a b := +!gcd.comm ▸ H + +theorem dvd_of_coprime_of_dvd_mul_right {a b c : ℤ} (H1 : coprime c b) (H2 : c ∣ a * b) : c ∣ a := +have H3 : gcd (a * c) (a * b) = abs a, from + calc + gcd (a * c) (a * b) = abs a * gcd c b : gcd_mul_left + ... = abs a * 1 : H1 + ... = abs a : mul_one, +have H4 : (c ∣ gcd (a * c) (a * b)), from dvd_gcd !dvd_mul_left H2, +by rewrite [-dvd_abs_iff, -H3]; apply H4 + +theorem dvd_of_coprime_of_dvd_mul_left {a b c : ℤ} (H1 : coprime c a) (H2 : c ∣ a * b) : c ∣ b := +dvd_of_coprime_of_dvd_mul_right H1 (!mul.comm ▸ H2) + +theorem gcd_mul_left_cancel_of_coprime {c : ℤ} (a : ℤ) {b : ℤ} (H : coprime c b) : + gcd (c * a) b = gcd a b := +begin + revert H, unfold [coprime, gcd], + rewrite [-of_nat_one], + rewrite [+of_nat_eq_of_nat_iff, nat_abs_mul], + apply nat.gcd_mul_left_cancel_of_coprime, +end + +theorem gcd_mul_right_cancel_of_coprime (a : ℤ) {c b : ℤ} (H : coprime c b) : + gcd (a * c) b = gcd a b := +!mul.comm ▸ !gcd_mul_left_cancel_of_coprime H + +theorem gcd_mul_left_cancel_of_coprime_right {c a : ℤ} (b : ℤ) (H : coprime c a) : + gcd a (c * b) = gcd a b := +!gcd.comm ▸ !gcd.comm ▸ !gcd_mul_left_cancel_of_coprime H + +theorem gcd_mul_right_cancel_of_coprime_right {c a : ℤ} (b : ℤ) (H : coprime c a) : + gcd a (b * c) = gcd a b := +!gcd.comm ▸ !gcd.comm ▸ !gcd_mul_right_cancel_of_coprime H + +theorem coprime_div_gcd_div_gcd {a b : ℤ} (H : gcd a b ≠ 0) : + coprime (a / gcd a b) (b / gcd a b) := +calc + gcd (a / gcd a b) (b / gcd a b) + = gcd a b / abs (gcd a b) : gcd_div !gcd_dvd_left !gcd_dvd_right + ... = 1 : by rewrite [abs_of_nonneg !gcd_nonneg, int.div_self H] + +theorem not_coprime_of_dvd_of_dvd {m n d : ℤ} (dgt1 : d > 1) (Hm : d ∣ m) (Hn : d ∣ n) : + ¬ coprime m n := +assume co : coprime m n, +have d ∣ gcd m n, from dvd_gcd Hm Hn, +have d ∣ 1, by rewrite [↑coprime at co, co at this]; apply this, +have d ≤ 1, from le_of_dvd dec_trivial this, +show false, from not_lt_of_ge `d ≤ 1` `d > 1` + +theorem exists_coprime {a b : ℤ} (H : gcd a b ≠ 0) : + exists a' b', coprime a' b' ∧ a = a' * gcd a b ∧ b = b' * gcd a b := +have H1 : a = (a / gcd a b) * gcd a b, from (int.div_mul_cancel !gcd_dvd_left)⁻¹, +have H2 : b = (b / gcd a b) * gcd a b, from (int.div_mul_cancel !gcd_dvd_right)⁻¹, +exists.intro _ (exists.intro _ (and.intro (coprime_div_gcd_div_gcd H) (and.intro H1 H2))) + +theorem coprime_mul {a b c : ℤ} (H1 : coprime a c) (H2 : coprime b c) : coprime (a * b) c := +calc + gcd (a * b) c = gcd b c : !gcd_mul_left_cancel_of_coprime H1 + ... = 1 : H2 + +theorem coprime_mul_right {c a b : ℤ} (H1 : coprime c a) (H2 : coprime c b) : coprime c (a * b) := +coprime_swap (coprime_mul (coprime_swap H1) (coprime_swap H2)) + +theorem coprime_of_coprime_mul_left {c a b : ℤ} (H : coprime (c * a) b) : coprime a b := +have H1 : (gcd a b ∣ gcd (c * a) b), from !gcd_dvd_gcd_mul_left, +eq_one_of_dvd_one !gcd_nonneg (H ▸ H1) + +theorem coprime_of_coprime_mul_right {c a b : ℤ} (H : coprime (a * c) b) : coprime a b := +coprime_of_coprime_mul_left (!mul.comm ▸ H) + +theorem coprime_of_coprime_mul_left_right {c a b : ℤ} (H : coprime a (c * b)) : coprime a b := +coprime_swap (coprime_of_coprime_mul_left (coprime_swap H)) + +theorem coprime_of_coprime_mul_right_right {c a b : ℤ} (H : coprime a (b * c)) : coprime a b := +coprime_of_coprime_mul_left_right (!mul.comm ▸ H) + +theorem exists_eq_prod_and_dvd_and_dvd {a b c : ℤ} (H : c ∣ a * b) : + ∃ a' b', c = a' * b' ∧ a' ∣ a ∧ b' ∣ b := +decidable.by_cases + (suppose gcd c a = 0, + have c = 0, from eq_zero_of_gcd_eq_zero_left `gcd c a = 0`, + have a = 0, from eq_zero_of_gcd_eq_zero_right `gcd c a = 0`, + have c = 0 * b, from `c = 0` ⬝ !zero_mul⁻¹, + have 0 ∣ a, from `a = 0`⁻¹ ▸ !dvd.refl, + have b ∣ b, from !dvd.refl, + exists.intro _ (exists.intro _ (and.intro `c = 0 * b` (and.intro `0 ∣ a` `b ∣ b`)))) + (suppose gcd c a ≠ 0, + have gcd c a ∣ c, from !gcd_dvd_left, + have H3 : c / gcd c a ∣ (a * b) / gcd c a, from div_dvd_div this H, + have H4 : (a * b) / gcd c a = (a / gcd c a) * b, from + calc + a * b / gcd c a = b * a / gcd c a : mul.comm + ... = b * (a / gcd c a) : !int.mul_div_assoc !gcd_dvd_right + ... = a / gcd c a * b : mul.comm, + have H5 : c / gcd c a ∣ (a / gcd c a) * b, from H4 ▸ H3, + have H6 : coprime (c / gcd c a) (a / gcd c a), from coprime_div_gcd_div_gcd `gcd c a ≠ 0`, + have H7 : c / gcd c a ∣ b, from dvd_of_coprime_of_dvd_mul_left H6 H5, + have H8 : c = gcd c a * (c / gcd c a), from (int.mul_div_cancel' `gcd c a ∣ c`)⁻¹, + exists.intro _ (exists.intro _ (and.intro H8 (and.intro !gcd_dvd_right H7)))) + +end int diff --git a/old_library/data/int/int.md b/old_library/data/int/int.md new file mode 100644 index 0000000000..701972b58e --- /dev/null +++ b/old_library/data/int/int.md @@ -0,0 +1,10 @@ +data.int +======== + +The integers. + +* [basic](basic.lean) : the integers, with basic operations +* [order](order.lean) : the order relations and the sign function +* [div](div.lean) : div and mod +* [power](power.lean) +* [gcd](gcd.lean) : gcd, lcm, and coprime diff --git a/old_library/data/int/order.lean b/old_library/data/int/order.lean new file mode 100644 index 0000000000..7a3c1aa9b1 --- /dev/null +++ b/old_library/data/int/order.lean @@ -0,0 +1,447 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Floris van Doorn, Jeremy Avigad + +The order relation on the integers. We show that int is an instance of linear_comm_ordered_ring +and transfer the results. +-/ +import .basic algebra.ordered_ring +open nat +open decidable +open int eq.ops + +namespace int + +private definition nonneg (a : ℤ) : Prop := int.cases_on a (take n, true) (take n, false) +protected definition le (a b : ℤ) : Prop := nonneg (b - a) + +attribute [instance, priority int.prio] +definition int_has_le : has_le int := +has_le.mk int.le + +protected definition lt (a b : ℤ) : Prop := (a + 1) ≤ b + +attribute [instance, priority int.prio] +definition int_has_lt : has_lt int := +has_lt.mk int.lt + +local attribute nonneg [reducible] +attribute [instance] +private definition decidable_nonneg (a : ℤ) : decidable (nonneg a) := int.cases_on a _ _ +attribute [instance] +definition decidable_le (a b : ℤ) : decidable (a ≤ b) := decidable_nonneg _ +attribute [instance] +definition decidable_lt (a b : ℤ) : decidable (a < b) := decidable_nonneg _ + +private theorem nonneg.elim {a : ℤ} : nonneg a → ∃n : ℕ, a = n := +int.cases_on a (take n H, exists.intro n rfl) (take n', false.elim) + +private theorem nonneg_or_nonneg_neg (a : ℤ) : nonneg a ∨ nonneg (-a) := +int.cases_on a (take n, or.inl trivial) (take n, or.inr trivial) + +theorem le.intro {a b : ℤ} {n : ℕ} (H : a + n = b) : a ≤ b := +have n = b - a, from eq_add_neg_of_add_eq (begin rewrite [add.comm, H] end), -- !add.comm ▸ H), +show nonneg (b - a), from this ▸ trivial + +theorem le.elim {a b : ℤ} (H : a ≤ b) : ∃n : ℕ, a + n = b := +obtain (n : ℕ) (H1 : b - a = n), from nonneg.elim H, +exists.intro n (!add.comm ▸ iff.mpr !add_eq_iff_eq_add_neg (H1⁻¹)) + +protected theorem le_total (a b : ℤ) : a ≤ b ∨ b ≤ a := +or.imp_right + (assume H : nonneg (-(b - a)), + have -(b - a) = a - b, from !neg_sub, + show nonneg (a - b), from this ▸ H) + (nonneg_or_nonneg_neg (b - a)) + +theorem of_nat_le_of_nat_of_le {m n : ℕ} (H : #nat m ≤ n) : of_nat m ≤ of_nat n := +obtain (k : ℕ) (Hk : m + k = n), from nat.le.elim H, +le.intro (Hk ▸ (of_nat_add m k)⁻¹) + +theorem le_of_of_nat_le_of_nat {m n : ℕ} (H : of_nat m ≤ of_nat n) : (#nat m ≤ n) := +obtain (k : ℕ) (Hk : of_nat m + of_nat k = of_nat n), from le.elim H, +have m + k = n, from of_nat.inj (of_nat_add m k ⬝ Hk), +nat.le.intro this + +theorem of_nat_le_of_nat_iff (m n : ℕ) : of_nat m ≤ of_nat n ↔ m ≤ n := +iff.intro le_of_of_nat_le_of_nat of_nat_le_of_nat_of_le + +theorem lt_add_succ (a : ℤ) (n : ℕ) : a < a + succ n := +le.intro (show a + 1 + n = a + succ n, from + calc + a + 1 + n = a + (1 + n) : add.assoc + ... = a + (n + 1) : by rewrite (int.add_comm 1 n) + ... = a + succ n : rfl) + +theorem lt.intro {a b : ℤ} {n : ℕ} (H : a + succ n = b) : a < b := +H ▸ lt_add_succ a n + +theorem lt.elim {a b : ℤ} (H : a < b) : ∃n : ℕ, a + succ n = b := +obtain (n : ℕ) (Hn : a + 1 + n = b), from le.elim H, +have a + succ n = b, from + calc + a + succ n = a + 1 + n : by rewrite [add.assoc, int.add_comm 1 n] + ... = b : Hn, +exists.intro n this + +theorem of_nat_lt_of_nat_iff (n m : ℕ) : of_nat n < of_nat m ↔ n < m := +calc + of_nat n < of_nat m ↔ of_nat n + 1 ≤ of_nat m : iff.refl + ... ↔ of_nat (nat.succ n) ≤ of_nat m : of_nat_succ n ▸ !iff.refl + ... ↔ nat.succ n ≤ m : of_nat_le_of_nat_iff + ... ↔ n < m : iff.symm (lt_iff_succ_le _ _) + +theorem lt_of_of_nat_lt_of_nat {m n : ℕ} (H : of_nat m < of_nat n) : #nat m < n := +iff.mp !of_nat_lt_of_nat_iff H + +theorem of_nat_lt_of_nat_of_lt {m n : ℕ} (H : #nat m < n) : of_nat m < of_nat n := +iff.mpr !of_nat_lt_of_nat_iff H + +/- show that the integers form an ordered additive group -/ + +protected theorem le_refl (a : ℤ) : a ≤ a := +le.intro (add_zero a) + +protected theorem le_trans {a b c : ℤ} (H1 : a ≤ b) (H2 : b ≤ c) : a ≤ c := +obtain (n : ℕ) (Hn : a + n = b), from le.elim H1, +obtain (m : ℕ) (Hm : b + m = c), from le.elim H2, +have a + of_nat (n + m) = c, from + calc + a + of_nat (n + m) = a + (of_nat n + m) : {of_nat_add n m} + ... = a + n + m : (add.assoc a n m)⁻¹ + ... = b + m : {Hn} + ... = c : Hm, +le.intro this + +protected theorem le_antisymm : ∀ {a b : ℤ}, a ≤ b → b ≤ a → a = b := +take a b : ℤ, assume (H₁ : a ≤ b) (H₂ : b ≤ a), +obtain (n : ℕ) (Hn : a + n = b), from le.elim H₁, +obtain (m : ℕ) (Hm : b + m = a), from le.elim H₂, +have a + of_nat (n + m) = a + 0, from + calc + a + of_nat (n + m) = a + (of_nat n + m) : by rewrite of_nat_add + ... = a + n + m : by rewrite add.assoc + ... = b + m : by rewrite Hn + ... = a : by rewrite Hm + ... = a + 0 : by rewrite add_zero, +have of_nat (n + m) = of_nat 0, from add.left_cancel this, +have n + m = 0, from of_nat.inj this, +have n = 0, from nat.eq_zero_of_add_eq_zero_right this, +show a = b, from + calc + a = a + 0 : add_zero + ... = a + n : by rewrite this + ... = b : Hn + +protected theorem lt_irrefl (a : ℤ) : ¬ a < a := +(suppose a < a, + obtain (n : ℕ) (Hn : a + succ n = a), from lt.elim this, + have a + succ n = a + 0, from + Hn ⬝ !add_zero⁻¹, + !succ_ne_zero (of_nat.inj (add.left_cancel this))) + +protected theorem ne_of_lt {a b : ℤ} (H : a < b) : a ≠ b := +(suppose a = b, absurd (this ▸ H) (int.lt_irrefl b)) + +theorem le_of_lt {a b : ℤ} (H : a < b) : a ≤ b := +obtain (n : ℕ) (Hn : a + succ n = b), from lt.elim H, +le.intro Hn + +protected theorem lt_iff_le_and_ne (a b : ℤ) : a < b ↔ (a ≤ b ∧ a ≠ b) := +iff.intro + (assume H, and.intro (le_of_lt H) (int.ne_of_lt H)) + (assume H, + have a ≤ b, from and.elim_left H, + have a ≠ b, from and.elim_right H, + obtain (n : ℕ) (Hn : a + n = b), from le.elim `a ≤ b`, + have n ≠ 0, from (assume H' : n = 0, `a ≠ b` (!add_zero ▸ H' ▸ Hn)), + obtain (k : ℕ) (Hk : n = nat.succ k), from nat.exists_eq_succ_of_ne_zero this, + lt.intro (Hk ▸ Hn)) + +protected theorem le_iff_lt_or_eq (a b : ℤ) : a ≤ b ↔ (a < b ∨ a = b) := +iff.intro + (assume H, + by_cases + (suppose a = b, or.inr this) + (suppose a ≠ b, + obtain (n : ℕ) (Hn : a + n = b), from le.elim H, + have n ≠ 0, from (assume H' : n = 0, `a ≠ b` (!add_zero ▸ H' ▸ Hn)), + obtain (k : ℕ) (Hk : n = nat.succ k), from nat.exists_eq_succ_of_ne_zero this, + or.inl (lt.intro (Hk ▸ Hn)))) + (assume H, + or.elim H + (assume H1, le_of_lt H1) + (assume H1, H1 ▸ !int.le_refl)) + +theorem lt_succ (a : ℤ) : a < a + 1 := +int.le_refl (a + 1) + +protected theorem add_le_add_left {a b : ℤ} (H : a ≤ b) (c : ℤ) : c + a ≤ c + b := +obtain (n : ℕ) (Hn : a + n = b), from le.elim H, +have H2 : c + a + n = c + b, from + calc + c + a + n = c + (a + n) : add.assoc c a n + ... = c + b : {Hn}, +le.intro H2 + +protected theorem add_lt_add_left {a b : ℤ} (H : a < b) (c : ℤ) : c + a < c + b := +let H' := le_of_lt H in +(iff.mpr (int.lt_iff_le_and_ne _ _)) (and.intro (int.add_le_add_left H' _) + (take Heq, let Heq' := add_left_cancel Heq in + !int.lt_irrefl (Heq' ▸ H))) + +protected theorem mul_nonneg {a b : ℤ} (Ha : 0 ≤ a) (Hb : 0 ≤ b) : 0 ≤ a * b := +obtain (n : ℕ) (Hn : 0 + n = a), from le.elim Ha, +obtain (m : ℕ) (Hm : 0 + m = b), from le.elim Hb, +le.intro + (eq.symm + (calc + a * b = (0 + n) * b : by rewrite Hn + ... = n * b : by rewrite zero_add + ... = n * (0 + m) : by rewrite Hm + ... = n * m : by rewrite zero_add + ... = 0 + n * m : by rewrite zero_add)) + +protected theorem mul_pos {a b : ℤ} (Ha : 0 < a) (Hb : 0 < b) : 0 < a * b := +obtain (n : ℕ) (Hn : 0 + nat.succ n = a), from lt.elim Ha, +obtain (m : ℕ) (Hm : 0 + nat.succ m = b), from lt.elim Hb, +lt.intro + (eq.symm + (calc + a * b = (0 + nat.succ n) * b : by rewrite Hn + ... = nat.succ n * b : by rewrite zero_add + ... = nat.succ n * (0 + nat.succ m) : by rewrite Hm + ... = nat.succ n * nat.succ m : by rewrite zero_add + ... = of_nat (nat.succ n * nat.succ m) : by rewrite of_nat_mul + ... = of_nat (nat.succ n * m + nat.succ n) : by rewrite nat.mul_succ + ... = of_nat (nat.succ (nat.succ n * m + n)) : by rewrite nat.add_succ + ... = 0 + nat.succ (nat.succ n * m + n) : by rewrite zero_add)) + +protected theorem zero_lt_one : (0 : ℤ) < 1 := trivial + +protected theorem not_le_of_gt {a b : ℤ} (H : a < b) : ¬ b ≤ a := + assume Hba, + let Heq := int.le_antisymm (le_of_lt H) Hba in + !int.lt_irrefl (Heq ▸ H) + +protected theorem lt_of_lt_of_le {a b c : ℤ} (Hab : a < b) (Hbc : b ≤ c) : a < c := + let Hab' := le_of_lt Hab in + let Hac := int.le_trans Hab' Hbc in + (iff.mpr !int.lt_iff_le_and_ne) (and.intro Hac + (assume Heq, int.not_le_of_gt (Heq ▸ Hab) Hbc)) + +protected theorem lt_of_le_of_lt {a b c : ℤ} (Hab : a ≤ b) (Hbc : b < c) : a < c := + let Hbc' := le_of_lt Hbc in + let Hac := int.le_trans Hab Hbc' in + (iff.mpr !int.lt_iff_le_and_ne) (and.intro Hac + (assume Heq, int.not_le_of_gt (Heq⁻¹ ▸ Hbc) Hab)) + +attribute [trans_instance] +protected definition linear_ordered_comm_ring : + linear_ordered_comm_ring int := +⦃linear_ordered_comm_ring, int.integral_domain, + le := int.le, + le_refl := int.le_refl, + le_trans := @int.le_trans, + le_antisymm := @int.le_antisymm, + lt := int.lt, + le_of_lt := @int.le_of_lt, + lt_irrefl := int.lt_irrefl, + lt_of_lt_of_le := @int.lt_of_lt_of_le, + lt_of_le_of_lt := @int.lt_of_le_of_lt, + add_le_add_left := @int.add_le_add_left, + mul_nonneg := @int.mul_nonneg, + mul_pos := @int.mul_pos, + le_iff_lt_or_eq := int.le_iff_lt_or_eq, + le_total := int.le_total, + zero_ne_one := int.zero_ne_one, + zero_lt_one := int.zero_lt_one, + add_lt_add_left := @int.add_lt_add_left⦄ + +attribute [instance] +protected definition decidable_linear_ordered_comm_ring : + decidable_linear_ordered_comm_ring int := +⦃decidable_linear_ordered_comm_ring, + int.linear_ordered_comm_ring, + decidable_lt := decidable_lt⦄ + +/- more facts specific to int -/ + +theorem of_nat_nonneg (n : ℕ) : 0 ≤ of_nat n := trivial + +theorem of_nat_pos {n : ℕ} (Hpos : #nat n > 0) : of_nat n > 0 := +of_nat_lt_of_nat_of_lt Hpos + +theorem of_nat_succ_pos (n : nat) : of_nat (nat.succ n) > 0 := +of_nat_pos !nat.succ_pos + +theorem exists_eq_of_nat {a : ℤ} (H : 0 ≤ a) : ∃n : ℕ, a = of_nat n := +obtain (n : ℕ) (H1 : 0 + of_nat n = a), from le.elim H, +exists.intro n (!zero_add ▸ (H1⁻¹)) + +theorem exists_eq_neg_of_nat {a : ℤ} (H : a ≤ 0) : ∃n : ℕ, a = -(of_nat n) := +have -a ≥ 0, from iff.mpr !neg_nonneg_iff_nonpos H, +obtain (n : ℕ) (Hn : -a = of_nat n), from exists_eq_of_nat this, +exists.intro n (eq_neg_of_eq_neg (Hn⁻¹)) + +theorem of_nat_nat_abs_of_nonneg {a : ℤ} (H : a ≥ 0) : of_nat (nat_abs a) = a := +obtain (n : ℕ) (Hn : a = of_nat n), from exists_eq_of_nat H, +Hn⁻¹ ▸ congr_arg of_nat (nat_abs_of_nat n) + +theorem of_nat_nat_abs_of_nonpos {a : ℤ} (H : a ≤ 0) : of_nat (nat_abs a) = -a := +have -a ≥ 0, from iff.mpr !neg_nonneg_iff_nonpos H, +calc + of_nat (nat_abs a) = of_nat (nat_abs (-a)) : nat_abs_neg + ... = -a : of_nat_nat_abs_of_nonneg this + +theorem of_nat_nat_abs (b : ℤ) : nat_abs b = abs b := +or.elim (le.total 0 b) + (assume H : b ≥ 0, of_nat_nat_abs_of_nonneg H ⬝ (abs_of_nonneg H)⁻¹) + (assume H : b ≤ 0, of_nat_nat_abs_of_nonpos H ⬝ (abs_of_nonpos H)⁻¹) + +theorem nat_abs_abs (a : ℤ) : nat_abs (abs a) = nat_abs a := +abs.by_cases rfl !nat_abs_neg + +theorem lt_of_add_one_le {a b : ℤ} (H : a + 1 ≤ b) : a < b := +obtain (n : nat) (H1 : a + 1 + n = b), from le.elim H, +have a + succ n = b, by rewrite [-H1, add.assoc, add.comm 1], +lt.intro this + +theorem add_one_le_of_lt {a b : ℤ} (H : a < b) : a + 1 ≤ b := +obtain (n : nat) (H1 : a + succ n = b), from lt.elim H, +have a + 1 + n = b, by rewrite [-H1, add.assoc, add.comm 1], +le.intro this + +theorem lt_add_one_of_le {a b : ℤ} (H : a ≤ b) : a < b + 1 := +lt_add_of_le_of_pos H trivial + +theorem le_of_lt_add_one {a b : ℤ} (H : a < b + 1) : a ≤ b := +have H1 : a + 1 ≤ b + 1, from add_one_le_of_lt H, +le_of_add_le_add_right H1 + +theorem sub_one_le_of_lt {a b : ℤ} (H : a ≤ b) : a - 1 < b := +lt_of_add_one_le (begin rewrite sub_add_cancel, exact H end) + +theorem lt_of_sub_one_le {a b : ℤ} (H : a - 1 < b) : a ≤ b := +!sub_add_cancel ▸ add_one_le_of_lt H + +theorem le_sub_one_of_lt {a b : ℤ} (H : a < b) : a ≤ b - 1 := +le_of_lt_add_one begin rewrite sub_add_cancel, exact H end + +theorem lt_of_le_sub_one {a b : ℤ} (H : a ≤ b - 1) : a < b := +!sub_add_cancel ▸ (lt_add_one_of_le H) + +theorem sign_of_succ (n : nat) : sign (nat.succ n) = 1 := +sign_of_pos (of_nat_pos !nat.succ_pos) + +theorem exists_eq_neg_succ_of_nat {a : ℤ} : a < 0 → ∃m : ℕ, a = -[1+m] := +int.cases_on a + (take (m : nat) H, absurd (of_nat_nonneg m : 0 ≤ m) (not_le_of_gt H)) + (take (m : nat) H, exists.intro m rfl) + +theorem eq_one_of_mul_eq_one_right {a b : ℤ} (H : a ≥ 0) (H' : a * b = 1) : a = 1 := +have a * b > 0, by rewrite H'; apply trivial, +have b > 0, from pos_of_mul_pos_left this H, +have a > 0, from pos_of_mul_pos_right `a * b > 0` (le_of_lt `b > 0`), +or.elim (le_or_gt a 1) + (suppose a ≤ 1, + show a = 1, from le.antisymm this (add_one_le_of_lt `a > 0`)) + (suppose a > 1, + have a * b ≥ 2 * 1, + from mul_le_mul (add_one_le_of_lt `a > 1`) (add_one_le_of_lt `b > 0`) trivial H, + have false, by rewrite [H' at this]; exact this, + false.elim this) + +theorem eq_one_of_mul_eq_one_left {a b : ℤ} (H : b ≥ 0) (H' : a * b = 1) : b = 1 := +eq_one_of_mul_eq_one_right H (!mul.comm ▸ H') + +theorem eq_one_of_mul_eq_self_left {a b : ℤ} (Hpos : a ≠ 0) (H : b * a = a) : b = 1 := +eq_of_mul_eq_mul_right Hpos (H ⬝ (one_mul a)⁻¹) + +theorem eq_one_of_mul_eq_self_right {a b : ℤ} (Hpos : b ≠ 0) (H : b * a = b) : a = 1 := +eq_one_of_mul_eq_self_left Hpos (!mul.comm ▸ H) + +theorem eq_one_of_dvd_one {a : ℤ} (H : a ≥ 0) (H' : a ∣ 1) : a = 1 := +dvd.elim H' + (take b, + suppose 1 = a * b, + eq_one_of_mul_eq_one_right H this⁻¹) + +theorem exists_least_of_bdd {P : ℤ → Prop} [HP : decidable_pred P] + (Hbdd : ∃ b : ℤ, ∀ z : ℤ, z ≤ b → ¬ P z) + (Hinh : ∃ z : ℤ, P z) : ∃ lb : ℤ, P lb ∧ (∀ z : ℤ, z < lb → ¬ P z) := + begin + cases Hbdd with [b, Hb], + cases Hinh with [elt, Helt], + existsi b + of_nat (least (λ n, P (b + of_nat n)) (nat.succ (nat_abs (elt - b)))), + have Heltb : elt > b, begin + apply lt_of_not_ge, + intro Hge, + apply (Hb _ Hge) Helt + end, + have H' : P (b + of_nat (nat_abs (elt - b))), begin + rewrite [of_nat_nat_abs_of_nonneg (int.le_of_lt (iff.mpr !sub_pos_iff_lt Heltb)), + add.comm, sub_add_cancel], + apply Helt + end, + apply and.intro, + apply least_of_lt _ !lt_succ_self H', + intros z Hz, + cases em (z ≤ b) with [Hzb, Hzb], + apply Hb _ Hzb, + let Hzb' := lt_of_not_ge Hzb, + let Hpos := iff.mpr !sub_pos_iff_lt Hzb', + have Hzbk : z = b + of_nat (nat_abs (z - b)), + by rewrite [of_nat_nat_abs_of_nonneg (int.le_of_lt Hpos), int.add_comm, sub_add_cancel], + have Hk : nat_abs (z - b) < least (λ n, P (b + of_nat n)) (nat.succ (nat_abs (elt - b))), begin + note Hz' := iff.mp !lt_add_iff_sub_lt_left Hz, + rewrite [-of_nat_nat_abs_of_nonneg (int.le_of_lt Hpos) at Hz'], + apply lt_of_of_nat_lt_of_nat Hz' + end, + let Hk' := not_le_of_gt Hk, + rewrite Hzbk, + apply λ p, mt (ge_least_of_lt _ p) Hk', + apply nat.lt_trans Hk, + apply least_lt _ !lt_succ_self H' + end + +theorem exists_greatest_of_bdd {P : ℤ → Prop} [HP : decidable_pred P] + (Hbdd : ∃ b : ℤ, ∀ z : ℤ, z ≥ b → ¬ P z) + (Hinh : ∃ z : ℤ, P z) : ∃ ub : ℤ, P ub ∧ (∀ z : ℤ, z > ub → ¬ P z) := + begin + cases Hbdd with [b, Hb], + cases Hinh with [elt, Helt], + existsi b - of_nat (least (λ n, P (b - of_nat n)) (nat.succ (nat_abs (b - elt)))), + have Heltb : elt < b, begin + apply lt_of_not_ge, + intro Hge, + apply (Hb _ Hge) Helt + end, + have H' : P (b - of_nat (nat_abs (b - elt))), begin + rewrite [of_nat_nat_abs_of_nonneg (int.le_of_lt (iff.mpr !sub_pos_iff_lt Heltb)), + sub_sub_self], + apply Helt + end, + apply and.intro, + apply least_of_lt _ !lt_succ_self H', + intros z Hz, + cases em (z ≥ b) with [Hzb, Hzb], + apply Hb _ Hzb, + let Hzb' := lt_of_not_ge Hzb, + let Hpos := iff.mpr !sub_pos_iff_lt Hzb', + have Hzbk : z = b - of_nat (nat_abs (b - z)), + by rewrite [of_nat_nat_abs_of_nonneg (int.le_of_lt Hpos), sub_sub_self], + have Hk : nat_abs (b - z) < least (λ n, P (b - of_nat n)) (nat.succ (nat_abs (b - elt))), begin + note Hz' := iff.mp !lt_add_iff_sub_lt_left (iff.mpr !lt_add_iff_sub_lt_right Hz), + rewrite [-of_nat_nat_abs_of_nonneg (int.le_of_lt Hpos) at Hz'], + apply lt_of_of_nat_lt_of_nat Hz' + end, + let Hk' := not_le_of_gt Hk, + rewrite Hzbk, + apply λ p, mt (ge_least_of_lt _ p) Hk', + apply nat.lt_trans Hk, + apply least_lt _ !lt_succ_self H' + end + +end int diff --git a/old_library/data/int/power.lean b/old_library/data/int/power.lean new file mode 100644 index 0000000000..acf6ab4a4a --- /dev/null +++ b/old_library/data/int/power.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +The power function on the integers. +-/ +import data.int.basic data.int.order data.int.div algebra.group_power data.nat.power + +namespace int + +attribute [instance, priority int.prio] +definition int_has_pow_nat : has_pow_nat int := +has_pow_nat.mk has_pow_nat.pow_nat + +/- + definition nmul (n : ℕ) (a : ℤ) : ℤ := algebra.nmul n a + infix [priority int.prio] ⬝ := nmul + definition imul (i : ℤ) (a : ℤ) : ℤ := algebra.imul i a +-/ + +open nat +theorem of_nat_pow (a n : ℕ) : of_nat (a^n) = (of_nat a)^n := +begin + induction n with n ih, + apply eq.refl, + krewrite [pow_succ, pow_succ, of_nat_mul, ih] +end + +end int diff --git a/old_library/data/list/as_type.lean b/old_library/data/list/as_type.lean new file mode 100644 index 0000000000..9fc80f3b1b --- /dev/null +++ b/old_library/data/list/as_type.lean @@ -0,0 +1,18 @@ +/- +Copyright (c) 2015 Leonardo de Moura. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +import data.list.basic + +namespace list +structure as_type {A : Type} (l : list A) : Type := +(value : A) (is_member : value ∈ l) + +namespace as_type +notation `⟪`:max l `⟫`:0 := as_type l + +definition lval {A : Type} (a : A) {l : list A} (m : a ∈ l) : ⟪l⟫ := +mk a m +end as_type +end list diff --git a/old_library/data/list/basic.lean b/old_library/data/list/basic.lean new file mode 100644 index 0000000000..9d0fd8d68d --- /dev/null +++ b/old_library/data/list/basic.lean @@ -0,0 +1,775 @@ +/- +Copyright (c) 2014 Parikshit Khanna. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn + +Basic properties of lists. +-/ +import logic data.nat.order data.nat.sub +open nat function tactic + +namespace list +variable {T : Type} + +attribute [simp] +lemma cons_ne_nil (a : T) (l : list T) : a::l ≠ [] := +sorry -- by contradiction + +lemma head_eq_of_cons_eq {A : Type} {h₁ h₂ : A} {t₁ t₂ : list A} : + (h₁::t₁) = (h₂::t₂) → h₁ = h₂ := +assume Peq, list.no_confusion Peq (assume Pheq Pteq, Pheq) + +lemma tail_eq_of_cons_eq {A : Type} {h₁ h₂ : A} {t₁ t₂ : list A} : + (h₁::t₁) = (h₂::t₂) → t₁ = t₂ := +assume Peq, list.no_confusion Peq (assume Pheq Pteq, Pteq) + +lemma cons_inj {A : Type} {a : A} : injective (cons a) := +take l₁ l₂, assume Pe, tail_eq_of_cons_eq Pe + +/- append -/ + +attribute [simp] +theorem append_nil_left (t : list T) : [] ++ t = t := +rfl + +attribute [simp] +theorem append_cons (x : T) (s t : list T) : (x::s) ++ t = x::(s ++ t) := +rfl + +attribute [simp] +theorem append_nil_right : ∀ (t : list T), t ++ [] = t := +sorry -- by rec_inst_simp + +attribute [simp] +theorem append.assoc : ∀ (s t u : list T), s ++ t ++ u = s ++ (t ++ u) := +sorry -- by rec_inst_simp + +/- length -/ +attribute [simp] +theorem length_nil : length (@nil T) = 0 := +rfl + +attribute [simp] +theorem length_cons (x : T) (t : list T) : length (x::t) = length t + 1 := +rfl + +attribute [simp] +theorem length_append : ∀ (s t : list T), length (s ++ t) = length s + length t := +sorry -- by rec_inst_simp + +theorem eq_nil_of_length_eq_zero : ∀ {l : list T}, length l = 0 → l = [] +| [] H := rfl +| (a::s) H := sorry -- by contradiction + +theorem ne_nil_of_length_eq_succ : ∀ {l : list T} {n : nat}, length l = succ n → l ≠ [] +| [] n h := sorry -- by contradiction +| (a::l) n h := sorry -- by contradiction + +/- concat -/ + +attribute [simp] +theorem concat_nil (x : T) : concat x [] = [x] := +rfl + +attribute [simp] +theorem concat_cons (x y : T) (l : list T) : concat x (y::l) = y::(concat x l) := +rfl + +attribute [simp] +theorem concat_eq_append (a : T) : ∀ (l : list T), concat a l = l ++ [a] := +sorry -- by rec_inst_simp + +attribute [simp] +theorem concat_ne_nil (a : T) : ∀ (l : list T), concat a l ≠ [] := +sorry -- by intro l; induction l; repeat contradiction + +attribute [simp] +theorem length_concat (a : T) : ∀ (l : list T), length (concat a l) = length l + 1 := +sorry -- by rec_inst_simp + +attribute [simp] +theorem concat_append (a : T) : ∀ (l₁ l₂ : list T), concat a l₁ ++ l₂ = l₁ ++ a :: l₂ := +sorry -- by rec_inst_simp + +theorem append_concat (a : T) : ∀(l₁ l₂ : list T), l₁ ++ concat a l₂ = concat a (l₁ ++ l₂) := +sorry -- by rec_inst_simp + +/- last -/ + +definition last : Π l : list T, l ≠ [] → T +| [] h := absurd rfl h +| [a] h := a +| (a₁::a₂::l) h := last (a₂::l) $ cons_ne_nil a₂ l + +attribute [simp] +lemma last_singleton (a : T) (h : [a] ≠ []) : last [a] h = a := +rfl + +attribute [simp] +lemma last_cons_cons (a₁ a₂ : T) (l : list T) (h : a₁::a₂::l ≠ []) : last (a₁::a₂::l) h = last (a₂::l) (cons_ne_nil a₂ l) := +rfl + +theorem last_congr {l₁ l₂ : list T} (h₁ : l₁ ≠ []) (h₂ : l₂ ≠ []) (h₃ : l₁ = l₂) : last l₁ h₁ = last l₂ h₂ := +sorry -- by subst l₁ + +attribute [simp] +theorem last_concat {x : T} : ∀ {l : list T} (h : concat x l ≠ []), last (concat x l) h = x := +sorry -- by rec_simp + +-- add_rewrite append_nil append_cons + +/- reverse -/ + +attribute [simp] +theorem reverse_nil : reverse (@nil T) = [] := +rfl + +attribute [simp] +theorem reverse_cons (x : T) (l : list T) : reverse (x::l) = concat x (reverse l) := +rfl + +attribute [simp] +theorem reverse_singleton (x : T) : reverse [x] = [x] := +rfl + +attribute [simp] +theorem reverse_append : ∀ (s t : list T), reverse (s ++ t) = (reverse t) ++ (reverse s) := +sorry -- by rec_inst_simp + +attribute [simp] +theorem reverse_reverse : ∀ (l : list T), reverse (reverse l) = l := +sorry -- by rec_inst_simp + +theorem concat_eq_reverse_cons (x : T) (l : list T) : concat x l = reverse (x :: reverse l) := +sorry -- by inst_simp + +theorem length_reverse : ∀ (l : list T), length (reverse l) = length l := +sorry -- by rec_inst_simp + +/- head and tail -/ + +attribute [simp] +theorem head_cons [h : inhabited T] (a : T) (l : list T) : head (a::l) = a := +rfl + +attribute [simp] +theorem head_append [h : inhabited T] (t : list T) : ∀ {s : list T}, s ≠ [] → head (s ++ t) = head s := +sorry -- by rec_inst_simp + +attribute [simp] +theorem tail_nil : tail (@nil T) = [] := +rfl + +attribute [simp] +theorem tail_cons (a : T) (l : list T) : tail (a::l) = l := +rfl + +theorem cons_head_tail [h : inhabited T] {l : list T} : l ≠ [] → (head l)::(tail l) = l := +sorry -- by rec_inst_simp + +/- list membership -/ + +definition mem : T → list T → Prop +| a [] := false +| a (b :: l) := a = b ∨ mem a l + +notation e ∈ s := mem e s +notation e ∉ s := ¬ e ∈ s + +theorem mem_nil_iff (x : T) : x ∈ [] ↔ false := +iff.rfl + +theorem not_mem_nil (x : T) : x ∉ [] := +iff.mp $ mem_nil_iff x + +attribute [simp] +theorem mem_cons (x : T) (l : list T) : x ∈ x :: l := +or.inl rfl + +theorem mem_cons_of_mem (y : T) {x : T} {l : list T} : x ∈ l → x ∈ y :: l := +assume H, or.inr H + +theorem mem_cons_iff (x y : T) (l : list T) : x ∈ y::l ↔ (x = y ∨ x ∈ l) := +iff.rfl + +theorem eq_or_mem_of_mem_cons {x y : T} {l : list T} : x ∈ y::l → x = y ∨ x ∈ l := +assume h, h + +theorem mem_singleton {x a : T} : x ∈ [a] → x = a := +suppose x ∈ [a], or.elim (eq_or_mem_of_mem_cons this) + (suppose x = a, this) + (suppose x ∈ [], absurd this (not_mem_nil x)) + +theorem mem_of_mem_cons_of_mem {a b : T} {l : list T} : a ∈ b::l → b ∈ l → a ∈ l := +sorry +/- +assume ainbl binl, or.elim (eq_or_mem_of_mem_cons ainbl) + (suppose a = b, by substvars; exact binl) + (suppose a ∈ l, this) +-/ + +theorem mem_or_mem_of_mem_append {x : T} {s t : list T} : x ∈ s ++ t → x ∈ s ∨ x ∈ t := +list.induction_on s or.inr + (take y s, + assume IH : x ∈ s ++ t → x ∈ s ∨ x ∈ t, + suppose x ∈ y::s ++ t, + have x = y ∨ x ∈ s ++ t, from this, + have x = y ∨ x ∈ s ∨ x ∈ t, from or_of_or_of_imp_right this IH, + iff.elim_right or.assoc this) + +theorem mem_append_of_mem_or_mem {x : T} {s t : list T} : x ∈ s ∨ x ∈ t → x ∈ s ++ t := +list.induction_on s + (take H, or.elim H false.elim (assume H, H)) + (take y s, + assume IH : x ∈ s ∨ x ∈ t → x ∈ s ++ t, + suppose x ∈ y::s ∨ x ∈ t, + or.elim this + (suppose x ∈ y::s, + or.elim (eq_or_mem_of_mem_cons this) + (suppose x = y, or.inl this) + (suppose x ∈ s, or.inr (IH (or.inl this)))) + (suppose x ∈ t, or.inr (IH (or.inr this)))) + +theorem mem_append_iff (x : T) (s t : list T) : x ∈ s ++ t ↔ x ∈ s ∨ x ∈ t := +iff.intro mem_or_mem_of_mem_append mem_append_of_mem_or_mem + +theorem not_mem_of_not_mem_append_left {x : T} {s t : list T} : x ∉ s++t → x ∉ s := +λ nxinst xins, absurd (mem_append_of_mem_or_mem (or.inl xins)) nxinst + +theorem not_mem_of_not_mem_append_right {x : T} {s t : list T} : x ∉ s++t → x ∉ t := +λ nxinst xint, absurd (mem_append_of_mem_or_mem (or.inr xint)) nxinst + +theorem not_mem_append {x : T} {s t : list T} : x ∉ s → x ∉ t → x ∉ s++t := +sorry +/- +λ nxins nxint xinst, or.elim (mem_or_mem_of_mem_append xinst) + (λ xins, by contradiction) + (λ xint, by contradiction) +-/ + +lemma length_pos_of_mem {a : T} : ∀ {l : list T}, a ∈ l → 0 < length l +:= sorry +/- +| [] := assume Pinnil, by contradiction +| (b::l) := assume Pin, !zero_lt_succ +-/ + +section +local attribute mem [reducible] +local attribute append [reducible] +theorem mem_split {x : T} {l : list T} : x ∈ l → ∃s t : list T, l = s ++ (x::t) := +sorry +/- +list.induction_on l + (suppose x ∈ [], false.elim (iff.elim_left !mem_nil_iff this)) + (take y l, + assume IH : x ∈ l → ∃s t : list T, l = s ++ (x::t), + suppose x ∈ y::l, + or.elim (eq_or_mem_of_mem_cons this) + (suppose x = y, + exists.intro [] (!exists.intro (this ▸ rfl))) + (suppose x ∈ l, + obtain s (H2 : ∃t : list T, l = s ++ (x::t)), from IH this, + obtain t (H3 : l = s ++ (x::t)), from H2, + have y :: l = (y::s) ++ (x::t), + from H3 ▸ rfl, + !exists.intro (!exists.intro this))) +-/ +end + +theorem mem_append_left {a : T} {l₁ : list T} (l₂ : list T) : a ∈ l₁ → a ∈ l₁ ++ l₂ := +assume ainl₁, mem_append_of_mem_or_mem (or.inl ainl₁) + +theorem mem_append_right {a : T} (l₁ : list T) {l₂ : list T} : a ∈ l₂ → a ∈ l₁ ++ l₂ := +assume ainl₂, mem_append_of_mem_or_mem (or.inr ainl₂) + +attribute [instance] +definition decidable_mem [H : decidable_eq T] (x : T) (l : list T) : decidable (x ∈ l) := +list.rec_on l + (decidable.ff (not_of_iff_false (mem_nil_iff _))) + (take (h : T) (l : list T) (iH : decidable (x ∈ l)), + show decidable (x ∈ h::l), from + decidable.rec_on iH + (suppose nxinl : ¬x ∈ l, + decidable.rec_on (H x h) + (suppose xneh : x ≠ h, + have ¬(x = h ∨ x ∈ l), from + suppose x = h ∨ x ∈ l, or.elim this + (suppose x = h, absurd this xneh) + (suppose x ∈ l, absurd this nxinl), + have ¬x ∈ h::l, from + iff.elim_right (not_iff_not_of_iff (mem_cons_iff x h l)) this, + decidable.ff this) + (suppose x = h, decidable.tt (or.inl this))) + (assume Hp : x ∈ l, + decidable.rec_on (H x h) + (suppose x ≠ h, + decidable.tt (or.inr Hp)) + (suppose x = h, + decidable.tt (or.inl this)))) + +theorem mem_of_ne_of_mem {x y : T} {l : list T} (H₁ : x ≠ y) (H₂ : x ∈ y :: l) : x ∈ l := +or.elim (eq_or_mem_of_mem_cons H₂) (λe, absurd e H₁) (λr, r) + +theorem ne_of_not_mem_cons {a b : T} {l : list T} : a ∉ b::l → a ≠ b := +assume nin aeqb, absurd (or.inl aeqb) nin + +theorem not_mem_of_not_mem_cons {a b : T} {l : list T} : a ∉ b::l → a ∉ l := +assume nin nainl, absurd (or.inr nainl) nin + +lemma not_mem_cons_of_ne_of_not_mem {x y : T} {l : list T} : x ≠ y → x ∉ l → x ∉ y::l := +assume P1 P2, not.intro (assume Pxin, absurd (eq_or_mem_of_mem_cons Pxin) (not_or P1 P2)) + +lemma ne_and_not_mem_of_not_mem_cons {x y : T} {l : list T} : x ∉ y::l → x ≠ y ∧ x ∉ l := +assume P, and.intro (ne_of_not_mem_cons P) (not_mem_of_not_mem_cons P) + +definition sublist (l₁ l₂ : list T) := ∀ ⦃a : T⦄, a ∈ l₁ → a ∈ l₂ + +infix ⊆ := sublist + +attribute [simp] +theorem nil_sub (l : list T) : [] ⊆ l := +λ b i, false.elim (iff.mp (mem_nil_iff b) i) + +attribute [simp] +theorem sub.refl (l : list T) : l ⊆ l := +λ b i, i + +theorem sub.trans {l₁ l₂ l₃ : list T} (H₁ : l₁ ⊆ l₂) (H₂ : l₂ ⊆ l₃) : l₁ ⊆ l₃ := +λ b i, H₂ (H₁ i) + +attribute [simp] +theorem sub_cons (a : T) (l : list T) : l ⊆ a::l := +λ b i, or.inr i + +theorem sub_of_cons_sub {a : T} {l₁ l₂ : list T} : a::l₁ ⊆ l₂ → l₁ ⊆ l₂ := +λ s b i, s b (mem_cons_of_mem _ i) + +theorem cons_sub_cons {l₁ l₂ : list T} (a : T) (s : l₁ ⊆ l₂) : (a::l₁) ⊆ (a::l₂) := +λ b Hin, or.elim (eq_or_mem_of_mem_cons Hin) + (λ e : b = a, or.inl e) + (λ i : b ∈ l₁, or.inr (s i)) + +attribute [simp] +theorem sub_append_left (l₁ l₂ : list T) : l₁ ⊆ l₁++l₂ := +λ b i, iff.mpr (mem_append_iff b l₁ l₂) (or.inl i) + +attribute [simp] +theorem sub_append_right (l₁ l₂ : list T) : l₂ ⊆ l₁++l₂ := +λ b i, iff.mpr (mem_append_iff b l₁ l₂) (or.inr i) + +theorem sub_cons_of_sub (a : T) {l₁ l₂ : list T} : l₁ ⊆ l₂ → l₁ ⊆ (a::l₂) := +λ (s : l₁ ⊆ l₂) (x : T) (i : x ∈ l₁), or.inr (s i) + +theorem sub_app_of_sub_left (l l₁ l₂ : list T) : l ⊆ l₁ → l ⊆ l₁++l₂ := +λ (s : l ⊆ l₁) (x : T) (xinl : x ∈ l), + have x ∈ l₁, from s xinl, + mem_append_of_mem_or_mem (or.inl this) + +theorem sub_app_of_sub_right (l l₁ l₂ : list T) : l ⊆ l₂ → l ⊆ l₁++l₂ := +λ (s : l ⊆ l₂) (x : T) (xinl : x ∈ l), + have x ∈ l₂, from s xinl, + mem_append_of_mem_or_mem (or.inr this) + +theorem cons_sub_of_sub_of_mem {a : T} {l m : list T} : a ∈ m → l ⊆ m → a::l ⊆ m := +sorry +/- +λ (ainm : a ∈ m) (lsubm : l ⊆ m) (x : T) (xinal : x ∈ a::l), or.elim (eq_or_mem_of_mem_cons xinal) + (suppose x = a, by substvars; exact ainm) + (suppose x ∈ l, lsubm this) +-/ + +theorem app_sub_of_sub_of_sub {l₁ l₂ l : list T} : l₁ ⊆ l → l₂ ⊆ l → l₁++l₂ ⊆ l := +λ (l₁subl : l₁ ⊆ l) (l₂subl : l₂ ⊆ l) (x : T) (xinl₁l₂ : x ∈ l₁++l₂), + or.elim (mem_or_mem_of_mem_append xinl₁l₂) + (suppose x ∈ l₁, l₁subl this) + (suppose x ∈ l₂, l₂subl this) + +/- find -/ +section +variable [H : decidable_eq T] +include H + +definition find : T → list T → nat +| a [] := 0 +| a (b :: l) := if a = b then 0 else succ (find a l) + +attribute [simp] +theorem find_nil (x : T) : find x [] = 0 := +rfl + +theorem find_cons (x y : T) (l : list T) : find x (y::l) = if x = y then 0 else succ (find x l) := +rfl + +theorem find_cons_of_eq {x y : T} (l : list T) : x = y → find x (y::l) = 0 := +assume e, if_pos e + +theorem find_cons_of_ne {x y : T} (l : list T) : x ≠ y → find x (y::l) = succ (find x l) := +assume n, if_neg n + +theorem find_of_not_mem {l : list T} {x : T} : ¬x ∈ l → find x l = length l := +sorry +/- +list.rec_on l + (suppose ¬x ∈ [], rfl) + (take y l, + assume iH : ¬x ∈ l → find x l = length l, + suppose ¬x ∈ y::l, + have ¬(x = y ∨ x ∈ l), from iff.elim_right (not_iff_not_of_iff !mem_cons_iff) this, + have ¬x = y ∧ ¬x ∈ l, from (iff.elim_left !not_or_iff_not_and_not this), + calc + find x (y::l) = if x = y then 0 else succ (find x l) : !find_cons + ... = succ (find x l) : if_neg (and.elim_left this) + ... = succ (length l) : by rewrite (iH (and.elim_right this)) + ... = length (y::l) : !length_cons⁻¹) +-/ + +lemma find_le_length : ∀ {a} {l : list T}, find a l ≤ length l +:= sorry +/- +| a [] := !le.refl +| a (b::l) := decidable.rec_on (H a b) + (assume Peq, by rewrite [find_cons_of_eq l Peq]; exact !zero_le) + (assume Pne, + begin + rewrite [find_cons_of_ne l Pne, length_cons], + apply succ_le_succ, apply find_le_length + end) +-/ + +lemma not_mem_of_find_eq_length : ∀ {a} {l : list T}, find a l = length l → a ∉ l +:= sorry +/- +| a [] := assume Peq, !not_mem_nil +| a (b::l) := decidable.rec_on (H a b) + (assume Peq, by rewrite [find_cons_of_eq l Peq, length_cons]; contradiction) + (assume Pne, + begin + rewrite [find_cons_of_ne l Pne, length_cons, mem_cons_iff], + intro Plen, apply (not_or Pne), + exact not_mem_of_find_eq_length (succ.inj Plen) + end) +-/ + +lemma find_lt_length {a} {l : list T} (Pin : a ∈ l) : find a l < length l := +sorry +/- +begin + apply nat.lt_of_le_and_ne, + apply find_le_length, + apply not.intro, intro Peq, + exact absurd Pin (not_mem_of_find_eq_length Peq) +end +-/ +end + +/- nth element -/ +section nth +attribute [simp] +theorem nth_zero (a : T) (l : list T) : nth (a :: l) 0 = some a := +rfl + +attribute [simp] +theorem nth_succ (a : T) (l : list T) (n : nat) : nth (a::l) (succ n) = nth l n := +rfl + +theorem nth_eq_some : ∀ {l : list T} {n : nat}, n < length l → Σ a : T, nth l n = some a +:= sorry +/- +| [] n h := absurd h !not_lt_zero +| (a::l) 0 h := ⟨a, rfl⟩ +| (a::l) (succ n) h := + have n < length l, from lt_of_succ_lt_succ h, + obtain (r : T) (req : nth l n = some r), from nth_eq_some this, + ⟨r, by rewrite [nth_succ, req]⟩ +-/ + +open decidable +theorem find_nth [decidable_eq T] {a : T} : ∀ {l}, a ∈ l → nth l (find a l) = some a +:= sorry +/- +| [] ain := absurd ain !not_mem_nil +| (b::l) ainbl := by_cases + (λ aeqb : a = b, by rewrite [find_cons_of_eq _ aeqb, nth_zero, aeqb]) + (λ aneb : a ≠ b, or.elim (eq_or_mem_of_mem_cons ainbl) + (λ aeqb : a = b, absurd aeqb aneb) + (λ ainl : a ∈ l, by rewrite [find_cons_of_ne _ aneb, nth_succ, find_nth ainl])) +-/ + +definition inth [h : inhabited T] (l : list T) (n : nat) : T := +match (nth l n) with +| (some a) := a +| none := arbitrary T +end + +theorem inth_zero [inhabited T] (a : T) (l : list T) : inth (a :: l) 0 = a := +rfl + +theorem inth_succ [inhabited T] (a : T) (l : list T) (n : nat) : inth (a::l) (n+1) = inth l n := +rfl + +end nth + +section ith +definition ith : Π (l : list T) (i : nat), i < length l → T +| nil i h := absurd h (not_lt_zero i) +| (x::xs) 0 h := x +| (x::xs) (succ i) h := ith xs i (lt_of_succ_lt_succ h) + +attribute [simp] +lemma ith_zero (a : T) (l : list T) (h : 0 < length (a::l)) : ith (a::l) 0 h = a := +rfl + +attribute [simp] +lemma ith_succ (a : T) (l : list T) (i : nat) (h : succ i < length (a::l)) + : ith (a::l) (succ i) h = ith l i (lt_of_succ_lt_succ h) := +rfl +end ith + +open decidable + +/- quasiequal a l l' means that l' is exactly l, with a added + once somewhere -/ +section qeq +variable {A : Type} +inductive qeq (a : A) : list A → list A → Prop := +| qhead : ∀ l, qeq a l (a::l) +| qcons : ∀ (b : A) {l l' : list A}, qeq a l l' → qeq a (b::l) (b::l') + +open qeq + +notation l' `≈`:50 a `|` l:50 := qeq a l l' + +theorem qeq_app : ∀ (l₁ : list A) (a : A) (l₂ : list A), l₁++(a::l₂) ≈ a|l₁++l₂ +| [] a l₂ := qhead a l₂ +| (x::xs) a l₂ := qcons x (qeq_app xs a l₂) + +theorem mem_head_of_qeq {a : A} {l₁ l₂ : list A} : l₁≈a|l₂ → a ∈ l₁ := +take q, qeq.induction_on q + (λ l, mem_cons a l) + (λ b l l' q r, or.inr r) + +theorem mem_tail_of_qeq {a : A} {l₁ l₂ : list A} : l₁≈a|l₂ → ∀ x, x ∈ l₂ → x ∈ l₁ := +take q, qeq.induction_on q + (λ l x i, or.inr i) + (λ b l l' q r x xinbl, or.elim (eq_or_mem_of_mem_cons xinbl) + (λ xeqb : x = b, xeqb ▸ mem_cons x l') + (λ xinl : x ∈ l, or.inr (r x xinl))) + +theorem mem_cons_of_qeq {a : A} {l₁ l₂ : list A} : l₁≈a|l₂ → ∀ x, x ∈ l₁ → x ∈ a::l₂ := +take q, qeq.induction_on q + (λ l x i, i) + (λ b l l' q r x xinbl', or.elim (eq_or_mem_of_mem_cons xinbl') + (λ xeqb : x = b, xeqb ▸ or.inr (mem_cons x l)) + (λ xinl' : x ∈ l', or.elim (eq_or_mem_of_mem_cons (r x xinl')) + (λ xeqa : x = a, xeqa ▸ mem_cons x (b::l)) + (λ xinl : x ∈ l, or.inr (or.inr xinl)))) + +theorem length_eq_of_qeq {a : A} {l₁ l₂ : list A} : l₁≈a|l₂ → length l₁ = succ (length l₂) := +sorry +/- +take q, qeq.induction_on q + (λ l, rfl) + (λ b l l' q r, by rewrite [*length_cons, r]) +-/ + +theorem qeq_of_mem {a : A} {l : list A} : a ∈ l → (∃l', l≈a|l') := +sorry +/- +list.induction_on l + (λ h : a ∈ nil, absurd h (not_mem_nil a)) + (λ x xs r ainxxs, or.elim (eq_or_mem_of_mem_cons ainxxs) + (λ aeqx : a = x, + have aux : ∃ l, x::xs≈x|l, from + exists.intro xs (qhead x xs), + by rewrite aeqx; exact aux) + (λ ainxs : a ∈ xs, + have ∃l', xs ≈ a|l', from r ainxs, + obtain (l' : list A) (q : xs ≈ a|l'), from this, + have x::xs ≈ a | x::l', from qcons x q, + exists.intro (x::l') this)) +-/ + +theorem qeq_split {a : A} {l l' : list A} : l'≈a|l → ∃l₁ l₂, l = l₁++l₂ ∧ l' = l₁++(a::l₂) := +sorry +/- +take q, qeq.induction_on q + (λ t, + have t = []++t ∧ a::t = []++(a::t), from and.intro rfl rfl, + exists.intro [] (exists.intro t this)) + (λ b t t' q r, + obtain (l₁ l₂ : list A) (h : t = l₁++l₂ ∧ t' = l₁++(a::l₂)), from r, + have b::t = (b::l₁)++l₂ ∧ b::t' = (b::l₁)++(a::l₂), + begin + rewrite [and.elim_right h, and.elim_left h], + constructor, repeat reflexivity + end, + exists.intro (b::l₁) (exists.intro l₂ this)) +-/ + +theorem sub_of_mem_of_sub_of_qeq {a : A} {l : list A} {u v : list A} : a ∉ l → a::l ⊆ v → v≈a|u → l ⊆ u := +sorry +/- +λ (nainl : a ∉ l) (s : a::l ⊆ v) (q : v≈a|u) (x : A) (xinl : x ∈ l), + have x ∈ v, from s (or.inr xinl), + have x ∈ a::u, from mem_cons_of_qeq q x this, + or.elim (eq_or_mem_of_mem_cons this) + (suppose x = a, by substvars; contradiction) + (suppose x ∈ u, this) +-/ + +end qeq + +section firstn +variable {A : Type} + +definition firstn : nat → list A → list A +| 0 l := [] +| (n+1) [] := [] +| (n+1) (a::l) := a :: firstn n l + +attribute [simp] +lemma firstn_zero : ∀ (l : list A), firstn 0 l = [] := +sorry -- by intros; reflexivity + +attribute [simp] +lemma firstn_nil : ∀ n, firstn n [] = ([] : list A) +| 0 := rfl +| (n+1) := rfl + +lemma firstn_cons : ∀ n (a : A) (l : list A), firstn (succ n) (a::l) = a :: firstn n l := +sorry -- by intros; reflexivity + +lemma firstn_all : ∀ (l : list A), firstn (length l) l = l +| [] := rfl +| (a::l) := sorry -- begin change a :: (firstn (length l) l) = a :: l, rewrite firstn_all end + +lemma firstn_all_of_ge : ∀ {n} {l : list A}, n ≥ length l → firstn n l = l +| 0 [] h := rfl +| 0 (a::l) h := absurd h (not_le_of_gt (succ_pos _)) +| (n+1) [] h := rfl +| (n+1) (a::l) h := + sorry + /- + begin + change a :: firstn n l = a :: l, + rewrite [firstn_all_of_ge (le_of_succ_le_succ h)] + end + -/ + +lemma firstn_firstn : ∀ (n m) (l : list A), firstn n (firstn m l) = firstn (min n m) l +| n 0 l := sorry -- by rewrite [min_zero, firstn_zero, firstn_nil] +| 0 m l := sorry -- by rewrite [zero_min] +| (succ n) (succ m) nil := sorry -- by rewrite [*firstn_nil] +| (succ n) (succ m) (a::l) := sorry -- by rewrite [*firstn_cons, firstn_firstn, min_succ_succ] + +lemma length_firstn_le : ∀ (n) (l : list A), length (firstn n l) ≤ n +| 0 l := sorry -- by rewrite [firstn_zero] +| (succ n) (a::l) := sorry -- by rewrite [firstn_cons, length_cons, add_one]; apply succ_le_succ; apply length_firstn_le +| (succ n) [] := sorry -- by rewrite [firstn_nil, length_nil]; apply zero_le + +lemma length_firstn_eq : ∀ (n) (l : list A), length (firstn n l) = min n (length l) +| 0 l := sorry -- by rewrite [firstn_zero, zero_min] +| (succ n) (a::l) := sorry -- by rewrite [firstn_cons, *length_cons, *add_one, min_succ_succ, length_firstn_eq] +| (succ n) [] := sorry -- by rewrite [firstn_nil] +end firstn + +section dropn +variables {A : Type} +-- 'dropn n l' drops the first 'n' elements of 'l' + +theorem length_dropn +: ∀ (i : ℕ) (l : list A), length (dropn i l) = length l - i +| 0 l := rfl +| (succ i) [] := calc + length (dropn (succ i) []) = 0 - succ i : sorry -- by rewrite (nat.zero_sub (succ i)) +| (succ i) (x::l) := calc + length (dropn (succ i) (x::l)) + = length (dropn i l) : by reflexivity + ... = length l - i : length_dropn i l + ... = succ (length l) - succ i : sorry -- by rewrite (succ_sub_succ (length l) i) +end dropn + +section count +variable {A : Type} +variable [decA : decidable_eq A] +include decA + +definition count (a : A) : list A → nat +| [] := 0 +| (x::xs) := if a = x then succ (count xs) else count xs + +lemma count_nil (a : A) : count a [] = 0 := +rfl + +lemma count_cons (a b : A) (l : list A) : count a (b::l) = if a = b then succ (count a l) else count a l := +rfl + +lemma count_cons_eq (a : A) (l : list A) : count a (a::l) = succ (count a l) := +if_pos rfl + +lemma count_cons_of_ne {a b : A} (h : a ≠ b) (l : list A) : count a (b::l) = count a l := +if_neg h + +lemma count_cons_ge_count (a b : A) (l : list A) : count a (b::l) ≥ count a l := +sorry +/- +by_cases + (suppose a = b, begin subst b, rewrite count_cons_eq, apply le_succ end) + (suppose a ≠ b, begin rewrite (count_cons_of_ne this), apply le.refl end) +-/ + +lemma count_singleton (a : A) : count a [a] = 1 := +sorry -- by rewrite count_cons_eq + +lemma count_append (a : A) : ∀ l₁ l₂, count a (l₁++l₂) = count a l₁ + count a l₂ +:= sorry +/- +| [] l₂ := by rewrite [append_nil_left, count_nil, zero_add] +| (b::l₁) l₂ := by_cases + (suppose a = b, by rewrite [-this, append_cons, *count_cons_eq, succ_add, count_append]) + (suppose a ≠ b, by rewrite [append_cons, *count_cons_of_ne this, count_append]) +-/ + +lemma count_concat (a : A) (l : list A) : count a (concat a l) = succ (count a l) := +sorry -- by rewrite [concat_eq_append, count_append, count_singleton] + +lemma mem_of_count_gt_zero : ∀ {a : A} {l : list A}, count a l > 0 → a ∈ l +:= sorry +/- +| a [] h := absurd h !lt.irrefl +| a (b::l) h := by_cases + (suppose a = b, begin subst b, apply mem_cons end) + (suppose a ≠ b, + have count a l > 0, by rewrite [count_cons_of_ne this at h]; exact h, + have a ∈ l, from mem_of_count_gt_zero this, + show a ∈ b::l, from mem_cons_of_mem _ this) +-/ + +lemma count_gt_zero_of_mem : ∀ {a : A} {l : list A}, a ∈ l → count a l > 0 +:= sorry +/- +| a [] h := absurd h !not_mem_nil +| a (b::l) h := or.elim h + (suppose a = b, begin subst b, rewrite count_cons_eq, apply zero_lt_succ end) + (suppose a ∈ l, calc + count a (b::l) ≥ count a l : !count_cons_ge_count + ... > 0 : count_gt_zero_of_mem this) +-/ + +lemma count_eq_zero_of_not_mem {a : A} {l : list A} (h : a ∉ l) : count a l = 0 := +sorry +/- +have ∀ n, count a l = n → count a l = 0, + begin + intro n, cases n, + { intro this, exact this }, + { intro this, exact absurd (mem_of_count_gt_zero (begin rewrite this, exact dec_trivial end)) h } + end, +this (count a l) rfl +-/ + +end count +end list + +attribute list.decidable_mem [instance] diff --git a/old_library/data/list/comb.lean b/old_library/data/list/comb.lean new file mode 100644 index 0000000000..2ead2aa322 --- /dev/null +++ b/old_library/data/list/comb.lean @@ -0,0 +1,712 @@ +/- +Copyright (c) 2015 Leonardo de Moura. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Haitao Zhang, Floris van Doorn + +List combinators. +-/ +-- TODO(Leo): uncomment data.equiv after refactoring +import data.list.basic -- data.equiv +open nat prod decidable function + +namespace list +variables {A B C : Type} + +section replicate + +-- 'replicate i n' returns the list contain i copies of n. +definition replicate : ℕ → A → list A +| 0 a := [] +| (succ n) a := a :: replicate n a + +theorem length_replicate : ∀ (i : ℕ) (a : A), length (replicate i a) = i +| 0 a := rfl +| (succ i) a := calc + length (replicate (succ i) a) = length (replicate i a) + 1 : rfl + ... = i + 1 : sorry -- by rewrite length_replicate +end replicate + +/- map -/ +theorem map_nil (f : A → B) : map f [] = [] := rfl + +theorem map_cons (f : A → B) (a : A) (l : list A) : map f (a :: l) = f a :: map f l := rfl + +lemma map_concat (f : A → B) (a : A) : Πl, map f (concat a l) = concat (f a) (map f l) +| nil := rfl +| (b::l) := sorry -- begin rewrite [concat_cons, +map_cons, concat_cons, map_concat] end + +lemma map_append (f : A → B) : ∀ l₁ l₂, map f (l₁++l₂) = (map f l₁)++(map f l₂) +| nil := take l, rfl +| (a::l) := take l', sorry -- begin rewrite [append_cons, *map_cons, append_cons, map_append] end + +lemma map_reverse (f : A → B) : Πl, map f (reverse l) = reverse (map f l) +| nil := rfl +| (b::l) := sorry -- begin rewrite [reverse_cons, +map_cons, reverse_cons, map_concat, map_reverse] end + +lemma map_singleton (f : A → B) (a : A) : map f [a] = [f a] := rfl + +attribute [simp] +theorem map_id : ∀ l : list A, map id l = l +| [] := rfl +| (x::xs) := sorry -- begin rewrite [map_cons, map_id] end + +theorem map_id' {f : A → A} (H : ∀x, f x = x) : ∀ l : list A, map f l = l +| [] := rfl +| (x::xs) := sorry -- begin rewrite [map_cons, H, map_id'] end + +attribute [simp] +theorem map_map (g : B → C) (f : A → B) : ∀ l, map g (map f l) = map (g ∘ f) l +| [] := rfl +| (a :: l) := + show (g ∘ f) a :: map g (map f l) = map (g ∘ f) (a :: l), + from sorry -- by rewrite (map_map l) + +attribute [simp] +theorem length_map (f : A → B) : ∀ l : list A, length (map f l) = length l +| [] := sorry -- by esimp +| (a :: l) := + show length (map f l) + 1 = length l + 1, + from sorry -- by rewrite (length_map l) + +theorem map_ne_nil_of_ne_nil (f : A → B) {l : list A} (H : l ≠ nil) : map f l ≠ nil := +sorry +/- +suppose h₁ : map f l = nil, +have length (map f l) = length l, from !length_map, +have 0 = length l, from calc + 0 = length (@nil B) : by rewrite length_nil + ... = length (map f l) : by rewrite h₁ + ... = length l : this, +have l = nil, from eq_nil_of_length_eq_zero (eq.symm this), +H this +-/ + +theorem mem_map {A B : Type} (f : A → B) : ∀ {a l}, a ∈ l → f a ∈ map f l +:= sorry +/- +| a [] i := absurd i !not_mem_nil +| a (x::xs) i := or.elim (eq_or_mem_of_mem_cons i) + (suppose a = x, by rewrite [this, map_cons]; apply mem_cons) + (suppose a ∈ xs, or.inr (mem_map this)) +-/ + +theorem exists_of_mem_map {A B : Type} {f : A → B} {b : B} : + ∀{l}, b ∈ map f l → ∃a, a ∈ l ∧ f a = b +:= sorry +/- +| [] H := false.elim H +| (c::l) H := or.elim (iff.mp !mem_cons_iff H) + (suppose b = f c, + exists.intro c (and.intro !mem_cons (eq.symm this))) + (suppose b ∈ map f l, + obtain a (Hl : a ∈ l) (Hr : f a = b), from exists_of_mem_map this, + exists.intro a (and.intro (mem_cons_of_mem _ Hl) Hr)) +-/ + +theorem eq_of_map_const {A B : Type} {b₁ b₂ : B} : ∀ {l : list A}, b₁ ∈ map (const A b₂) l → b₁ = b₂ +| [] h := absurd h (not_mem_nil b₁) +| (a::l) h := + or.elim (eq_or_mem_of_mem_cons h) + (suppose b₁ = b₂, this) + (suppose b₁ ∈ map (const A b₂) l, eq_of_map_const this) + +definition map₂ (f : A → B → C) : list A → list B → list C +| [] _ := [] +| _ [] := [] +| (x::xs) (y::ys) := f x y :: map₂ xs ys + +theorem map₂_nil1 (f : A → B → C) : ∀ (l : list B), map₂ f [] l = [] +| [] := rfl +| (a::y) := rfl + +theorem map₂_nil2 (f : A → B → C) : ∀ (l : list A), map₂ f l [] = [] +| [] := rfl +| (a::y) := rfl + +theorem length_map₂ : ∀(f : A → B → C) x y, length (map₂ f x y) = min (length x) (length y) +| f [] [] := rfl +| f (xh::xr) [] := rfl +| f [] (yh::yr) := rfl +| f (xh::xr) (yh::yr) := calc + length (map₂ f (xh::xr) (yh::yr)) + = length (map₂ f xr yr) + 1 : rfl + ... = min (length xr) (length yr) + 1 : sorry -- by rewrite length_map₂ + ... = min (succ (length xr)) (succ (length yr)) : sorry -- by rewrite min_succ_succ + ... = min (length (xh::xr)) (length (yh::yr)) : rfl + +/- filter -/ +attribute [simp] +theorem filter_nil (p : A → Prop) [h : decidable_pred p] : filter p [] = [] := rfl + +attribute [simp] +theorem filter_cons_of_pos {p : A → Prop} [h : decidable_pred p] {a : A} : ∀ l, p a → filter p (a::l) = a :: filter p l := +λ l pa, if_pos pa + +attribute [simp] +theorem filter_cons_of_neg {p : A → Prop} [h : decidable_pred p] {a : A} : ∀ l, ¬ p a → filter p (a::l) = filter p l := +λ l pa, if_neg pa + +theorem of_mem_filter {p : A → Prop} [h : decidable_pred p] {a : A} : ∀ {l}, a ∈ filter p l → p a +| [] ain := absurd ain (not_mem_nil a) +| (b::l) ain := + sorry + /- + by_cases + (assume pb : p b, + have a ∈ b :: filter p l, by rewrite [filter_cons_of_pos _ pb at ain]; exact ain, + or.elim (eq_or_mem_of_mem_cons this) + (suppose a = b, by rewrite [-this at pb]; exact pb) + (suppose a ∈ filter p l, of_mem_filter this)) + (suppose ¬ p b, by rewrite [filter_cons_of_neg _ this at ain]; exact (of_mem_filter ain)) + -/ + +theorem mem_of_mem_filter {p : A → Prop} [h : decidable_pred p] {a : A} : ∀ {l}, a ∈ filter p l → a ∈ l +| [] ain := absurd ain (not_mem_nil a) +| (b::l) ain := + sorry + /- + by_cases + (λ pb : p b, + have a ∈ b :: filter p l, by rewrite [filter_cons_of_pos _ pb at ain]; exact ain, + or.elim (eq_or_mem_of_mem_cons this) + (suppose a = b, by rewrite this; exact !mem_cons) + (suppose a ∈ filter p l, mem_cons_of_mem _ (mem_of_mem_filter this))) + (suppose ¬ p b, by rewrite [filter_cons_of_neg _ this at ain]; exact (mem_cons_of_mem _ (mem_of_mem_filter ain))) + -/ + +theorem mem_filter_of_mem {p : A → Prop} [h : decidable_pred p] {a : A} : ∀ {l}, a ∈ l → p a → a ∈ filter p l +:= sorry +/- +| [] ain pa := absurd ain !not_mem_nil +| (b::l) ain pa := by_cases + (λ pb : p b, or.elim (eq_or_mem_of_mem_cons ain) + (λ aeqb : a = b, by rewrite [filter_cons_of_pos _ pb, aeqb]; exact !mem_cons) + (λ ainl : a ∈ l, by rewrite [filter_cons_of_pos _ pb]; exact (mem_cons_of_mem _ (mem_filter_of_mem ainl pa)))) + (λ npb : ¬ p b, or.elim (eq_or_mem_of_mem_cons ain) + (λ aeqb : a = b, absurd (eq.rec_on aeqb pa) npb) + (λ ainl : a ∈ l, by rewrite [filter_cons_of_neg _ npb]; exact (mem_filter_of_mem ainl pa))) +-/ + +attribute [simp] +theorem filter_sub {p : A → Prop} [h : decidable_pred p] (l : list A) : filter p l ⊆ l := +λ a ain, mem_of_mem_filter ain + +theorem filter_append {p : A → Prop} [h : decidable_pred p] : ∀ (l₁ l₂ : list A), filter p (l₁++l₂) = filter p l₁ ++ filter p l₂ +:= sorry +/- +| [] l₂ := rfl +| (a::l₁) l₂ := by_cases + (suppose p a, by rewrite [append_cons, *filter_cons_of_pos _ this, filter_append]) + (suppose ¬ p a, by rewrite [append_cons, *filter_cons_of_neg _ this, filter_append]) +-/ + +/- foldl & foldr -/ +definition foldl (f : A → B → A) : A → list B → A +| a [] := a +| a (b :: l) := foldl (f a b) l + +attribute [simp] +theorem foldl_nil (f : A → B → A) (a : A) : foldl f a [] = a := rfl + +attribute [simp] +theorem foldl_cons (f : A → B → A) (a : A) (b : B) (l : list B) : foldl f a (b::l) = foldl f (f a b) l := rfl + +definition foldr (f : A → B → B) : B → list A → B +| b [] := b +| b (a :: l) := f a (foldr b l) + +attribute [simp] +theorem foldr_nil (f : A → B → B) (b : B) : foldr f b [] = b := rfl + +attribute [simp] +theorem foldr_cons (f : A → B → B) (b : B) (a : A) (l : list A) : foldr f b (a::l) = f a (foldr f b l) := rfl + +section foldl_eq_foldr + -- foldl and foldr coincide when f is commutative and associative + parameters {α : Type} {f : α → α → α} + hypothesis (Hcomm : ∀ a b, f a b = f b a) + hypothesis (Hassoc : ∀ a b c, f (f a b) c = f a (f b c)) + include Hcomm Hassoc + + theorem foldl_eq_of_comm_of_assoc : ∀ a b l, foldl f a (b::l) = f b (foldl f a l) + := sorry + /- + | a b nil := Hcomm a b + | a b (c::l) := + begin + change foldl f (f (f a b) c) l = f b (foldl f (f a c) l), + rewrite -foldl_eq_of_comm_of_assoc, + change foldl f (f (f a b) c) l = foldl f (f (f a c) b) l, + have H₁ : f (f a b) c = f (f a c) b, by rewrite [Hassoc, Hassoc, Hcomm b c], + rewrite H₁ + end + -/ + + theorem foldl_eq_foldr : ∀ a l, foldl f a l = foldr f a l + := sorry + /- + | a nil := rfl + | a (b :: l) := + begin + rewrite foldl_eq_of_comm_of_assoc, + esimp, + change f b (foldl f a l) = f b (foldr f a l), + rewrite foldl_eq_foldr + end + -/ + +end foldl_eq_foldr + +attribute [simp] +theorem foldl_append (f : B → A → B) : ∀ (b : B) (l₁ l₂ : list A), foldl f b (l₁++l₂) = foldl f (foldl f b l₁) l₂ +| b [] l₂ := rfl +| b (a::l₁) l₂ := sorry -- by rewrite [append_cons, *foldl_cons, foldl_append] + +attribute [simp] +theorem foldr_append (f : A → B → B) : ∀ (b : B) (l₁ l₂ : list A), foldr f b (l₁++l₂) = foldr f (foldr f b l₂) l₁ +| b [] l₂ := rfl +| b (a::l₁) l₂ := sorry -- by rewrite [append_cons, *foldr_cons, foldr_append] + +/- all & any -/ +definition all (l : list A) (p : A → Prop) : Prop := +foldr (λ a r, p a ∧ r) true l + +definition any (l : list A) (p : A → Prop) : Prop := +foldr (λ a r, p a ∨ r) false l + +attribute [simp] +theorem all_nil_eq (p : A → Prop) : all [] p = true := rfl + +theorem all_nil (p : A → Prop) : all [] p := trivial + +theorem all_cons_eq (p : A → Prop) (a : A) (l : list A) : all (a::l) p = (p a ∧ all l p) := rfl + +theorem all_cons {p : A → Prop} {a : A} {l : list A} (H1 : p a) (H2 : all l p) : all (a::l) p := +and.intro H1 H2 + +theorem all_of_all_cons {p : A → Prop} {a : A} {l : list A} : all (a::l) p → all l p := +sorry -- assume h, by rewrite [all_cons_eq at h]; exact (and.elim_right h) + +theorem of_all_cons {p : A → Prop} {a : A} {l : list A} : all (a::l) p → p a := +sorry -- assume h, by rewrite [all_cons_eq at h]; exact (and.elim_left h) + +theorem all_cons_of_all {p : A → Prop} {a : A} {l : list A} : p a → all l p → all (a::l) p := +assume pa alllp, and.intro pa alllp + +theorem all_implies {p q : A → Prop} : ∀ {l}, all l p → (∀ x, p x → q x) → all l q +| [] h₁ h₂ := trivial +| (a::l) h₁ h₂ := + have h₃ : all l q, from all_implies (all_of_all_cons h₁) h₂, + have q a, from h₂ a (of_all_cons h₁), + all_cons_of_all this h₃ + +theorem of_mem_of_all {p : A → Prop} {a : A} : ∀ {l}, a ∈ l → all l p → p a +:= sorry +/- +| [] h₁ h₂ := absurd h₁ !not_mem_nil +| (b::l) h₁ h₂ := + or.elim (eq_or_mem_of_mem_cons h₁) + (suppose a = b, + by rewrite [all_cons_eq at h₂, -this at h₂]; exact (and.elim_left h₂)) + (suppose a ∈ l, + have all l p, by rewrite [all_cons_eq at h₂]; exact (and.elim_right h₂), + of_mem_of_all `a ∈ l` this) +-/ + +theorem all_of_forall {p : A → Prop} : ∀ {l}, (∀a, a ∈ l → p a) → all l p +| [] H := all_nil p +| (a::l) H := all_cons (H a (mem_cons a l)) + (all_of_forall (λ a' H', H a' (mem_cons_of_mem _ H'))) + +attribute [simp] +theorem any_nil (p : A → Prop) : any [] p = false := rfl + +attribute [simp] +theorem any_cons (p : A → Prop) (a : A) (l : list A) : any (a::l) p = (p a ∨ any l p) := rfl + +theorem any_of_mem {p : A → Prop} {a : A} : ∀ {l}, a ∈ l → p a → any l p +:= sorry +/- +| [] i h := absurd i !not_mem_nil +| (b::l) i h := + or.elim (eq_or_mem_of_mem_cons i) + (suppose a = b, by rewrite [-this]; exact (or.inl h)) + (suppose a ∈ l, + have any l p, from any_of_mem this h, + or.inr this) +-/ + +theorem exists_of_any {p : A → Prop} : ∀{l : list A}, any l p → ∃a, a ∈ l ∧ p a +:= sorry +/- +| [] H := false.elim H +| (b::l) H := or.elim H + (assume H1 : p b, exists.intro b (and.intro !mem_cons H1)) + (assume H1 : any l p, + obtain a (H2l : a ∈ l) (H2r : p a), from exists_of_any H1, + exists.intro a (and.intro (mem_cons_of_mem b H2l) H2r)) +-/ + +definition decidable_all (p : A → Prop) [H : decidable_pred p] : ∀ l, decidable (all l p) +| [] := decidable_true +| (a :: l) := + match (H a) with + | (tt Hp₁) := + match (decidable_all l) with + | (tt Hp₂) := tt (and.intro Hp₁ Hp₂) + | (ff Hn₂) := ff (not_and_of_not_right (p a) Hn₂) + end + | (ff Hn) := ff (not_and_of_not_left (all l p) Hn) + end + +definition decidable_any (p : A → Prop) [H : decidable_pred p] : ∀ l, decidable (any l p) +| [] := decidable_false +| (a :: l) := + match (H a) with + | (tt Hp) := tt (or.inl Hp) + | (ff Hn₁) := + match (decidable_any l) with + | (tt Hp₂) := tt (or.inr Hp₂) + | (ff Hn₂) := ff (not_or Hn₁ Hn₂) + end + end + +/- zip & unzip -/ +definition zip (l₁ : list A) (l₂ : list B) : list (A × B) := +map₂ (λ a b, (a, b)) l₁ l₂ + +definition unzip : list (A × B) → list A × list B +| [] := ([], []) +| ((a, b) :: l) := + match (unzip l) with + | (la, lb) := (a :: la, b :: lb) + end + +attribute [simp] +theorem unzip_nil : unzip (@nil (A × B)) = ([], []) := rfl + +attribute [simp] +theorem unzip_cons (a : A) (b : B) (l : list (A × B)) : + unzip ((a, b) :: l) = match (unzip l) with (la, lb) := (a :: la, b :: lb) end := +rfl + +theorem zip_unzip : ∀ (l : list (A × B)), zip (pr₁ (unzip l)) (pr₂ (unzip l)) = l +| [] := rfl +| ((a, b) :: l) := + sorry + /- + begin + rewrite unzip_cons, + have r : zip (pr₁ (unzip l)) (pr₂ (unzip l)) = l, from zip_unzip l, + revert r, + eapply prod.cases_on (unzip l), + intro la lb r, + rewrite -r + end + -/ + +section mapAccumR +variable {S : Type} + +-- This runs a function over a list returning the intermediate results and a +-- a final result. +definition mapAccumR : (A → S → S × B) → list A → S → (S × list B) +| f [] c := (c, []) +| f (y::yr) c := + let r := mapAccumR f yr c in + let z := f y (pr₁ r) in + (pr₁ z, pr₂ z :: pr₂ r) + +theorem length_mapAccumR +: ∀ (f : A → S → S × B) (x : list A) (s : S), + length (pr₂ (mapAccumR f x s)) = length x +:= sorry +/- +| f (a::x) s := calc + length (pr₂ (mapAccumR f (a::x) s)) + = length x + 1 : by rewrite -(length_mapAccumR f x s) + ... = length (a::x) : rfl +| f [] s := calc length (pr₂ (mapAccumR f [] s)) = 0 : by esimp +-/ +end mapAccumR + +section mapAccumR₂ +variable {S : Type} +-- This runs a function over two lists returning the intermediate results and a +-- a final result. +definition mapAccumR₂ +: (A → B → S → S × C) → list A → list B → S → S × list C +| f [] _ c := (c,[]) +| f _ [] c := (c,[]) +| f (x::xr) (y::yr) c := + let r := mapAccumR₂ f xr yr c in + let q := f x y (pr₁ r) in + (pr₁ q, pr₂ q :: (pr₂ r)) + +theorem length_mapAccumR₂ +: ∀ (f : A → B → S → S × C) (x : list A) (y : list B) (c : S), + length (pr₂ (mapAccumR₂ f x y c)) = min (length x) (length y) +:= sorry +/- +| f (a::x) (b::y) c := calc + length (pr₂ (mapAccumR₂ f (a::x) (b::y) c)) + = length (pr₂ (mapAccumR₂ f x y c)) + 1 : rfl + ... = min (length x) (length y) + 1 : by rewrite (length_mapAccumR₂ f x y c) + ... = min (succ (length x)) (succ (length y)) : by rewrite min_succ_succ + ... = min (length (a::x)) (length (b::y)) : rfl +| f (a::x) [] c := rfl +| f [] (b::y) c := rfl +| f [] [] c := rfl +-/ +end mapAccumR₂ + +/- flat -/ +definition flat (l : list (list A)) : list A := +foldl append nil l + +/- product -/ +section product + +definition product : list A → list B → list (A × B) +| [] l₂ := [] +| (a::l₁) l₂ := map (λ b, (a, b)) l₂ ++ product l₁ l₂ + +theorem nil_product (l : list B) : product (@nil A) l = [] := rfl + +theorem product_cons (a : A) (l₁ : list A) (l₂ : list B) + : product (a::l₁) l₂ = map (λ b, (a, b)) l₂ ++ product l₁ l₂ := rfl + +theorem product_nil : ∀ (l : list A), product l (@nil B) = [] +| [] := rfl +| (a::l) := sorry -- by rewrite [product_cons, map_nil, product_nil] + +theorem eq_of_mem_map_pair₁ {a₁ a : A} {b₁ : B} {l : list B} : (a₁, b₁) ∈ map (λ b, (a, b)) l → a₁ = a := +sorry +/- +assume ain, +have pr1 (a₁, b₁) ∈ map pr1 (map (λ b, (a, b)) l), from mem_map pr1 ain, +have a₁ ∈ map (λb, a) l, by revert this; rewrite [map_map, ↑pr1]; intro this; assumption, +eq_of_map_const this +-/ + +theorem mem_of_mem_map_pair₁ {a₁ a : A} {b₁ : B} {l : list B} : (a₁, b₁) ∈ map (λ b, (a, b)) l → b₁ ∈ l := +sorry +/- +assume ain, +have pr2 (a₁, b₁) ∈ map pr2 (map (λ b, (a, b)) l), from mem_map pr2 ain, +have b₁ ∈ map (λx, x) l, by rewrite [map_map at this, ↑pr2 at this]; exact this, +by rewrite [map_id at this]; exact this +-/ + +theorem mem_product {a : A} {b : B} : ∀ {l₁ l₂}, a ∈ l₁ → b ∈ l₂ → (a, b) ∈ product l₁ l₂ +:= sorry +/- +| [] l₂ h₁ h₂ := absurd h₁ !not_mem_nil +| (x::l₁) l₂ h₁ h₂ := + or.elim (eq_or_mem_of_mem_cons h₁) + (assume aeqx : a = x, + have (a, b) ∈ map (λ b, (a, b)) l₂, from mem_map _ h₂, + begin rewrite [-aeqx, product_cons], exact mem_append_left _ this end) + (assume ainl₁ : a ∈ l₁, + have (a, b) ∈ product l₁ l₂, from mem_product ainl₁ h₂, + begin rewrite [product_cons], exact mem_append_right _ this end) +-/ + +theorem mem_of_mem_product_left {a : A} {b : B} : ∀ {l₁ l₂}, (a, b) ∈ product l₁ l₂ → a ∈ l₁ +:= sorry +/- +| [] l₂ h := absurd h !not_mem_nil +| (x::l₁) l₂ h := + or.elim (mem_or_mem_of_mem_append h) + (suppose (a, b) ∈ map (λ b, (x, b)) l₂, + have a = x, from eq_of_mem_map_pair₁ this, + by rewrite this; exact !mem_cons) + (suppose (a, b) ∈ product l₁ l₂, + have a ∈ l₁, from mem_of_mem_product_left this, + mem_cons_of_mem _ this) +-/ + +theorem mem_of_mem_product_right {a : A} {b : B} : ∀ {l₁ l₂}, (a, b) ∈ product l₁ l₂ → b ∈ l₂ +| [] l₂ h := absurd h (not_mem_nil ((a, b))) +| (x::l₁) l₂ h := + or.elim (mem_or_mem_of_mem_append h) + (suppose (a, b) ∈ map (λ b, (x, b)) l₂, + mem_of_mem_map_pair₁ this) + (suppose (a, b) ∈ product l₁ l₂, + mem_of_mem_product_right this) + +theorem length_product : ∀ (l₁ : list A) (l₂ : list B), length (product l₁ l₂) = length l₁ * length l₂ +:= sorry +/- +| [] l₂ := by rewrite [length_nil, zero_mul] +| (x::l₁) l₂ := + have length (product l₁ l₂) = length l₁ * length l₂, from length_product l₁ l₂, + by rewrite [product_cons, length_append, length_cons, + length_map, this, right_distrib, one_mul, add.comm] +-/ +end product + +-- new for list/comb dependent map theory +definition dinj₁ (p : A → Prop) (f : Π a, p a → B) := ∀ ⦃a1 a2⦄ (h1 : p a1) (h2 : p a2), a1 ≠ a2 → (f a1 h1) ≠ (f a2 h2) +definition dinj (p : A → Prop) (f : Π a, p a → B) := ∀ ⦃a1 a2⦄ (h1 : p a1) (h2 : p a2), (f a1 h1) = (f a2 h2) → a1 = a2 + +definition dmap (p : A → Prop) [h : decidable_pred p] (f : Π a, p a → B) : list A → list B +| [] := [] +| (a::l) := if P : (p a) then cons (f a P) (dmap l) else (dmap l) + +-- properties of dmap +section dmap + +variable {p : A → Prop} +variable [h : decidable_pred p] +include h +variable {f : Π a, p a → B} + +lemma dmap_nil : dmap p f [] = [] := rfl +lemma dmap_cons_of_pos {a : A} (P : p a) : ∀ l, dmap p f (a::l) = (f a P) :: dmap p f l := + λ l, dif_pos P +lemma dmap_cons_of_neg {a : A} (P : ¬ p a) : ∀ l, dmap p f (a::l) = dmap p f l := + λ l, dif_neg P + +lemma mem_dmap : ∀ {l : list A} {a} (Pa : p a), a ∈ l → (f a Pa) ∈ dmap p f l +:= sorry +/- +| [] := take a Pa Pinnil, by contradiction +| (a::l) := take b Pb Pbin, or.elim (eq_or_mem_of_mem_cons Pbin) + (assume Pbeqa, begin + rewrite [eq.symm Pbeqa, dmap_cons_of_pos Pb], + exact !mem_cons + end) + (assume Pbinl, + decidable.rec_on (h a) + (assume Pa, begin + rewrite [dmap_cons_of_pos Pa], + apply mem_cons_of_mem, + exact mem_dmap Pb Pbinl + end) + (assume nPa, begin + rewrite [dmap_cons_of_neg nPa], + exact mem_dmap Pb Pbinl + end)) +-/ + +lemma exists_of_mem_dmap : ∀ {l : list A} {b : B}, b ∈ dmap p f l → ∃ a P, a ∈ l ∧ b = f a P +:= sorry +/- +| [] := take b, by rewrite dmap_nil; contradiction +| (a::l) := take b, decidable.rec_on (h a) + (assume Pa, begin + rewrite [dmap_cons_of_pos Pa, mem_cons_iff], + intro Pb, cases Pb with Peq Pin, + exact exists.intro a (exists.intro Pa (and.intro !mem_cons Peq)), + have Pex : ∃ (a : A) (P : p a), a ∈ l ∧ b = f a P, from exists_of_mem_dmap Pin, + cases Pex with a' Pex', cases Pex' with Pa' P', + exact exists.intro a' (exists.intro Pa' (and.intro (mem_cons_of_mem a (and.left P')) (and.right P'))) + end) + (assume nPa, begin + rewrite [dmap_cons_of_neg nPa], + intro Pin, + have Pex : ∃ (a : A) (P : p a), a ∈ l ∧ b = f a P, from exists_of_mem_dmap Pin, + cases Pex with a' Pex', cases Pex' with Pa' P', + exact exists.intro a' (exists.intro Pa' (and.intro (mem_cons_of_mem a (and.left P')) (and.right P'))) + end) +-/ + +lemma map_dmap_of_inv_of_pos {g : B → A} (Pinv : ∀ a (Pa : p a), g (f a Pa) = a) : + ∀ {l : list A}, (∀ ⦃a⦄, a ∈ l → p a) → map g (dmap p f l) = l +:= sorry +/- +| [] := assume Pl, by rewrite [dmap_nil, map_nil] +| (a::l) := assume Pal, + have Pa : p a, from Pal a !mem_cons, + have Pl : ∀ a, a ∈ l → p a, + from take x Pxin, Pal x (mem_cons_of_mem a Pxin), + by rewrite [dmap_cons_of_pos Pa, map_cons, Pinv, map_dmap_of_inv_of_pos Pl] +-/ + +lemma mem_of_dinj_of_mem_dmap (Pdi : dinj p f) : + ∀ {l : list A} {a} (Pa : p a), (f a Pa) ∈ dmap p f l → a ∈ l +:= sorry +/- +| [] := take a Pa Pinnil, by contradiction +| (b::l) := take a Pa Pmap, + decidable.rec_on (h b) + (λ Pb, begin + rewrite (dmap_cons_of_pos Pb) at Pmap, + rewrite mem_cons_iff at Pmap, + rewrite mem_cons_iff, + apply (or_of_or_of_imp_of_imp Pmap), + apply Pdi, + apply mem_of_dinj_of_mem_dmap Pa + end) + (λ nPb, begin + rewrite (dmap_cons_of_neg nPb) at Pmap, + apply mem_cons_of_mem, + exact mem_of_dinj_of_mem_dmap Pa Pmap + end) +-/ + +lemma not_mem_dmap_of_dinj_of_not_mem (Pdi : dinj p f) {l : list A} {a} (Pa : p a) : + a ∉ l → (f a Pa) ∉ dmap p f l := +not.mto (mem_of_dinj_of_mem_dmap Pdi Pa) + +end dmap + +/- +section +open equiv +definition list_equiv_of_equiv {A B : Type} : A ≃ B → list A ≃ list B +| (mk f g l r) := + mk (map f) (map g) + begin intros, rewrite [map_map, id_of_left_inverse l, map_id], try reflexivity end + begin intros, rewrite [map_map, id_of_right_inverse r, map_id], try reflexivity end + +private definition to_nat : list nat → nat +| [] := 0 +| (x::xs) := succ (mkpair (to_nat xs) x) + +open prod.ops + +private definition of_nat.F : Π (n : nat), (Π m, m < n → list nat) → list nat +| 0 f := [] +| (succ n) f := (unpair n).2 :: f (unpair n).1 (unpair_lt n) + +private definition of_nat : nat → list nat := +well_founded.fix of_nat.F + +private lemma of_nat_zero : of_nat 0 = [] := +well_founded.fix_eq of_nat.F 0 + +private lemma of_nat_succ (n : nat) + : of_nat (succ n) = (unpair n).2 :: of_nat (unpair n).1 := +well_founded.fix_eq of_nat.F (succ n) + +private lemma to_nat_of_nat (n : nat) : to_nat (of_nat n) = n := +nat.case_strong_induction_on n + _ + (λ n ih, + begin + rewrite of_nat_succ, unfold to_nat, + have to_nat (of_nat (unpair n).1) = (unpair n).1, from ih _ (le_of_lt_succ (unpair_lt n)), + rewrite this, rewrite mkpair_unpair + end) + +private lemma of_nat_to_nat : ∀ (l : list nat), of_nat (to_nat l) = l +| [] := rfl +| (x::xs) := begin unfold to_nat, rewrite of_nat_succ, rewrite *unpair_mkpair, esimp, congruence, apply of_nat_to_nat end + +definition list_nat_equiv_nat : list nat ≃ nat := +mk to_nat of_nat of_nat_to_nat to_nat_of_nat + +definition list_equiv_self_of_equiv_nat {A : Type} : A ≃ nat → list A ≃ A := +suppose A ≃ nat, calc + list A ≃ list nat : list_equiv_of_equiv this + ... ≃ nat : list_nat_equiv_nat + ... ≃ A : this +end +-/ + +end list + +attribute list.decidable_any [instance] +attribute list.decidable_all [instance] diff --git a/old_library/data/list/default.lean b/old_library/data/list/default.lean new file mode 100644 index 0000000000..e5116d8323 --- /dev/null +++ b/old_library/data/list/default.lean @@ -0,0 +1,6 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad +-/ +import .basic .comb .set .perm .as_type diff --git a/old_library/data/list/list.md b/old_library/data/list/list.md new file mode 100644 index 0000000000..1326271b40 --- /dev/null +++ b/old_library/data/list/list.md @@ -0,0 +1,10 @@ +data.list +========= + +List of elements of a fixed type. By default, `import list` imports everything here. + +[basic](basic.lean) : basic operations and properties +[comb](comb.lean) : combinators and list constructions +[set](set.lean) : set-like operations (these support the finset construction) +[perm](perm.lean) : equivalence up to permutation (these support the finset construction) +[as_type](as_type.lean) : treats a list as a type \ No newline at end of file diff --git a/old_library/data/list/perm.lean b/old_library/data/list/perm.lean new file mode 100644 index 0000000000..0d13540ac5 --- /dev/null +++ b/old_library/data/list/perm.lean @@ -0,0 +1,931 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +List permutations. +-/ +import data.list.basic data.list.set +open list setoid nat binary + +variables {A B : Type} + +inductive perm : list A → list A → Prop := +| nil : perm [] [] +| skip : Π (x : A) {l₁ l₂ : list A}, perm l₁ l₂ → perm (x::l₁) (x::l₂) +| swap : Π (x y : A) (l : list A), perm (y::x::l) (x::y::l) +| trans : Π {l₁ l₂ l₃ : list A}, perm l₁ l₂ → perm l₂ l₃ → perm l₁ l₃ + +namespace perm +infix ~ := perm +theorem eq_nil_of_perm_nil {l₁ : list A} (p : [] ~ l₁) : l₁ = [] := +sorry +/- +have gen : ∀ (l₂ : list A) (p : l₂ ~ l₁), l₂ = [] → l₁ = [], from + take l₂ p, perm.induction_on p + (λ h, h) + (by contradiction) + (by contradiction) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂ e, r₂ (r₁ e)), +gen [] p rfl +-/ + +theorem not_perm_nil_cons (x : A) (l : list A) : ¬ [] ~ (x::l) := +sorry +/- +have gen : ∀ (l₁ l₂ : list A) (p : l₁ ~ l₂), l₁ = [] → l₂ = (x::l) → false, from + take l₁ l₂ p, perm.induction_on p + (by contradiction) + (by contradiction) + (by contradiction) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂ e₁ e₂, + begin + rewrite [e₂ at *, e₁ at *], + have e₃ : l₂ = [], from eq_nil_of_perm_nil p₁, + exact (r₂ e₃ rfl) + end), +assume p, gen [] (x::l) p rfl rfl +-/ + +attribute [refl] +protected theorem refl : ∀ (l : list A), l ~ l +| [] := nil +| (x::xs) := skip x (refl xs) + +attribute [symm] +protected theorem symm : ∀ {l₁ l₂ : list A}, l₁ ~ l₂ → l₂ ~ l₁ := +take l₁ l₂ p, perm.induction_on p + nil + (λ x l₁ l₂ p₁ r₁, skip x r₁) + (λ x y l, swap y x l) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₂ r₁) + +attribute perm.trans [trans] + +theorem eqv (A : Type) : equivalence (@perm A) := +mk_equivalence (@perm A) (@perm.refl A) (@perm.symm A) (@perm.trans A) + +attribute [instance] +protected definition is_setoid (A : Type) : setoid (list A) := +setoid.mk (@perm A) (perm.eqv A) + +theorem mem_perm {a : A} {l₁ l₂ : list A} : l₁ ~ l₂ → a ∈ l₁ → a ∈ l₂ := +sorry +/- +assume p, perm.induction_on p + (λ h, h) + (λ x l₁ l₂ p₁ r₁ i, or.elim (eq_or_mem_of_mem_cons i) + (suppose a = x, by rewrite this; apply !mem_cons) + (suppose a ∈ l₁, or.inr (r₁ this))) + (λ x y l ainyxl, or.elim (eq_or_mem_of_mem_cons ainyxl) + (suppose a = y, by rewrite this; exact (or.inr !mem_cons)) + (suppose a ∈ x::l, or.elim (eq_or_mem_of_mem_cons this) + (suppose a = x, or.inl this) + (suppose a ∈ l, or.inr (or.inr this)))) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂ ainl₁, r₂ (r₁ ainl₁)) +-/ + +theorem not_mem_perm {a : A} {l₁ l₂ : list A} : l₁ ~ l₂ → a ∉ l₁ → a ∉ l₂ := +assume p nainl₁ ainl₂, absurd (mem_perm (perm.symm p) ainl₂) nainl₁ + +theorem perm_app_left {l₁ l₂ : list A} (t₁ : list A) : l₁ ~ l₂ → (l₁++t₁) ~ (l₂++t₁) := +assume p, perm.induction_on p + (perm.refl (list.nil ++ t₁)) + (λ x l₁ l₂ p₁ r₁, skip x r₁) + (λ x y l, swap x y _) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂) + +theorem perm_app_right (l : list A) {t₁ t₂ : list A} : t₁ ~ t₂ → (l++t₁) ~ (l++t₂) := +list.induction_on l + (λ p, p) + (λ x xs r p, skip x (r p)) + +theorem perm_app {l₁ l₂ t₁ t₂ : list A} : l₁ ~ l₂ → t₁ ~ t₂ → (l₁++t₁) ~ (l₂++t₂) := +assume p₁ p₂, trans (perm_app_left t₁ p₁) (perm_app_right l₂ p₂) + +theorem perm_app_cons (a : A) {h₁ h₂ t₁ t₂ : list A} : h₁ ~ h₂ → t₁ ~ t₂ → (h₁ ++ (a::t₁)) ~ (h₂ ++ (a::t₂)) := +assume p₁ p₂, perm_app p₁ (skip a p₂) + +theorem perm_cons_app (a : A) : ∀ (l : list A), (a::l) ~ (l ++ [a]) +| [] := perm.refl _ +| (x::xs) := calc + a::x::xs ~ x::a::xs : swap x a xs + ... ~ x::(xs++[a]) : skip x (perm_cons_app xs) + +attribute [simp] +theorem perm_cons_app_simp (a : A) : ∀ (l : list A), (l ++ [a]) ~ (a::l) := +take l, perm.symm (perm_cons_app a l) + +attribute [simp] +theorem perm_app_comm {l₁ l₂ : list A} : (l₁++l₂) ~ (l₂++l₁) := +sorry +/- +list.induction_on l₁ + (by rewrite [append_nil_right, append_nil_left]) + (λ a t r, calc + a::(t++l₂) ~ a::(l₂++t) : skip a r + ... ~ l₂++t++[a] : !perm_cons_app + ... = l₂++(t++[a]) : !append.assoc + ... ~ l₂++(a::t) : perm_app_right l₂ (perm.symm (perm_cons_app a t))) +-/ + +theorem length_eq_length_of_perm {l₁ l₂ : list A} : l₁ ~ l₂ → length l₁ = length l₂ := +sorry +/- +assume p, perm.induction_on p + rfl + (λ x l₁ l₂ p r, by rewrite [*length_cons, r]) + (λ x y l, by rewrite *length_cons) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, eq.trans r₁ r₂) +-/ + +theorem eq_singleton_of_perm_inv (a : A) {l : list A} : [a] ~ l → l = [a] := +sorry +/- +have gen : ∀ l₂, perm l₂ l → l₂ = [a] → l = [a], from + take l₂, assume p, perm.induction_on p + (λ e, e) + (λ x l₁ l₂ p r e, + begin + injection e with e₁ e₂, + rewrite [e₁, e₂ at p], + have h₁ : l₂ = [], from eq_nil_of_perm_nil p, + substvars + end) + (λ x y l e, by injection e; contradiction) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂ e, r₂ (r₁ e)), +assume p, gen [a] p rfl +-/ + +theorem eq_singleton_of_perm (a b : A) : [a] ~ [b] → a = b := +sorry +/- +assume p, +begin + injection eq_singleton_of_perm_inv a p with e₁, + rewrite e₁ +end +-/ + +theorem perm_rev : ∀ (l : list A), l ~ (reverse l) +:= sorry +/- +| [] := nil +| (x::xs) := calc + x::xs ~ xs++[x] : perm_cons_app x xs + ... ~ reverse xs ++ [x] : perm_app_left [x] (perm_rev xs) + ... = reverse (x::xs) : by rewrite [reverse_cons, concat_eq_append] +-/ + +attribute [simp] +theorem perm_rev_simp : ∀ (l : list A), (reverse l) ~ l := +take l, perm.symm (perm_rev l) + +theorem perm_middle (a : A) (l₁ l₂ : list A) : (a::l₁)++l₂ ~ l₁++(a::l₂) := +calc + (a::l₁) ++ l₂ = a::(l₁++l₂) : rfl + ... ~ l₁++l₂++[a] : perm_cons_app a (l₁ ++ l₂) + ... = l₁++(l₂++[a]) : append.assoc l₁ l₂ [a] + ... ~ l₁++(a::l₂) : perm_app_right l₁ (perm.symm (perm_cons_app a l₂)) + +attribute [simp] +theorem perm_middle_simp (a : A) (l₁ l₂ : list A) : l₁++(a::l₂) ~ (a::l₁)++l₂ := +perm.symm $ perm_middle a l₁ l₂ + +theorem perm_cons_app_cons {l l₁ l₂ : list A} (a : A) : l ~ l₁++l₂ → a::l ~ l₁++(a::l₂) := +assume p, calc + a::l ~ l++[a] : perm_cons_app a l + ... ~ l₁++l₂++[a] : perm_app_left [a] p + ... = l₁++(l₂++[a]) : append.assoc l₁ l₂ [a] + ... ~ l₁++(a::l₂) : perm_app_right l₁ (perm.symm (perm_cons_app a l₂)) + +open decidable +theorem perm_erase [decidable_eq A] {a : A} : ∀ {l : list A}, a ∈ l → l ~ a::(erase a l) +:= sorry +/- +| [] h := absurd h !not_mem_nil +| (x::t) h := + by_cases + (assume aeqx : a = x, by rewrite [aeqx, erase_cons_head]) + (assume naeqx : a ≠ x, + have aint : a ∈ t, from mem_of_ne_of_mem naeqx h, + have aux : t ~ a :: erase a t, from perm_erase aint, + calc x::t ~ x::a::(erase a t) : skip x aux + ... ~ a::x::(erase a t) : !swap + ... = a::(erase a (x::t)) : by rewrite [!erase_cons_tail naeqx]) +-/ + +attribute [congr] +theorem erase_perm_erase_of_perm [decidable_eq A] (a : A) {l₁ l₂ : list A} : l₁ ~ l₂ → erase a l₁ ~ erase a l₂ := +sorry +/- +assume p, perm.induction_on p + nil + (λ x t₁ t₂ p r, + by_cases + (assume aeqx : a = x, by rewrite [aeqx, *erase_cons_head]; exact p) + (assume naeqx : a ≠ x, by rewrite [*erase_cons_tail _ naeqx]; exact (skip x r))) + (λ x y l, + by_cases + (assume aeqx : a = x, + by_cases + (assume aeqy : a = y, by rewrite [-aeqx, -aeqy]) + (assume naeqy : a ≠ y, by rewrite [-aeqx, erase_cons_tail _ naeqy, *erase_cons_head])) + (assume naeqx : a ≠ x, + by_cases + (assume aeqy : a = y, by rewrite [-aeqy, erase_cons_tail _ naeqx, *erase_cons_head]) + (assume naeqy : a ≠ y, by rewrite[erase_cons_tail _ naeqx, *erase_cons_tail _ naeqy, erase_cons_tail _ naeqx]; + exact !swap))) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂) +-/ + +theorem perm_induction_on {P : list A → list A → Prop} {l₁ l₂ : list A} (p : l₁ ~ l₂) + (h₁ : P [] []) + (h₂ : ∀ x l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (x::l₁) (x::l₂)) + (h₃ : ∀ x y l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (y::x::l₁) (x::y::l₂)) + (h₄ : ∀ l₁ l₂ l₃, l₁ ~ l₂ → l₂ ~ l₃ → P l₁ l₂ → P l₂ l₃ → P l₁ l₃) + : P l₁ l₂ := +have P_refl : ∀ l, P l l + | [] := h₁ + | (x::xs) := h₂ x xs xs (perm.refl xs) (P_refl xs), +perm.induction_on p h₁ h₂ (λ x y l, h₃ x y l l (perm.refl l) (P_refl l)) h₄ + +theorem xswap {l₁ l₂ : list A} (x y : A) : l₁ ~ l₂ → x::y::l₁ ~ y::x::l₂ := +assume p, calc + x::y::l₁ ~ y::x::l₁ : swap y x l₁ + ... ~ y::x::l₂ : skip y (skip x p) + +attribute [congr] +theorem perm_map (f : A → B) {l₁ l₂ : list A} : l₁ ~ l₂ → map f l₁ ~ map f l₂ := +assume p, perm_induction_on p + nil + (λ x l₁ l₂ p r, skip (f x) r) + (λ x y l₁ l₂ p r, xswap (f y) (f x) r) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂) + +lemma perm_of_qeq {a : A} {l₁ l₂ : list A} : l₁≈a|l₂ → l₁~a::l₂ := +assume q, qeq.induction_on q + (λ h, perm.refl (a :: h)) + (λ b t₁ t₂ q₁ r₁, calc + b::t₂ ~ b::a::t₁ : skip b r₁ + ... ~ a::b::t₁ : swap a b t₁) + +/- permutation is decidable if A has decidable equality -/ +section dec +open decidable +variable [Ha : decidable_eq A] +include Ha + +definition decidable_perm_aux : ∀ (n : nat) (l₁ l₂ : list A), length l₁ = n → length l₂ = n → decidable (l₁ ~ l₂) +:= sorry +/- +| 0 l₁ l₂ H₁ H₂ := + have l₁n : l₁ = [], from eq_nil_of_length_eq_zero H₁, + have l₂n : l₂ = [], from eq_nil_of_length_eq_zero H₂, + by rewrite [l₁n, l₂n]; exact (inl perm.nil) +| (n+1) (x::t₁) l₂ H₁ H₂ := + by_cases + (assume xinl₂ : x ∈ l₂, + let t₂ : list A := erase x l₂ in + have len_t₁ : length t₁ = n, begin injection H₁ with e, exact e end, + have length t₂ = pred (length l₂), from length_erase_of_mem xinl₂, + have length t₂ = n, by rewrite [this, H₂], + match decidable_perm_aux n t₁ t₂ len_t₁ this with + | inl p := inl (calc + x::t₁ ~ x::(erase x l₂) : skip x p + ... ~ l₂ : perm.symm (perm_erase xinl₂)) + | inr np := inr (λ p : x::t₁ ~ l₂, + have erase x (x::t₁) ~ erase x l₂, from erase_perm_erase_of_perm x p, + have t₁ ~ erase x l₂, by rewrite [erase_cons_head at this]; exact this, + absurd this np) + end) + (assume nxinl₂ : x ∉ l₂, + inr (λ p : x::t₁ ~ l₂, absurd (mem_perm p !mem_cons) nxinl₂)) +-/ + +attribute [instance] +definition decidable_perm : ∀ (l₁ l₂ : list A), decidable (l₁ ~ l₂) := +λ l₁ l₂, +by_cases + (assume eql : length l₁ = length l₂, + decidable_perm_aux (length l₂) l₁ l₂ eql rfl) + (assume neql : length l₁ ≠ length l₂, + ff (λ p : l₁ ~ l₂, absurd (length_eq_length_of_perm p) neql)) +end dec + +-- Auxiliary theorem for performing cases-analysis on l₂. +-- We use it to prove perm_inv_core. +private theorem discr {P : Prop} {a b : A} {l₁ l₂ l₃ : list A} : + a::l₁ = l₂++(b::l₃) → + (l₂ = [] → a = b → l₁ = l₃ → P) → + (∀ t, l₂ = a::t → l₁ = t++(b::l₃) → P) → P := +sorry +/- +match l₂ with +| [] := λ e h₁ h₂, by injection e with e₁ e₂; exact h₁ rfl e₁ e₂ +| h::t := λ e h₁ h₂, + begin + injection e with e₁ e₂, + rewrite e₁ at h₂, + exact h₂ t rfl e₂ + end +end +-/ +-- Auxiliary theorem for performing cases-analysis on l₂. +-- We use it to prove perm_inv_core. +private theorem discr₂ {P : Prop} {a b c : A} {l₁ l₂ l₃ : list A} : + a::b::l₁ = l₂++(c::l₃) → + (l₂ = [] → l₃ = b::l₁ → a = c → P) → + (l₂ = [a] → b = c → l₁ = l₃ → P) → + (∀ t, l₂ = a::b::t → l₁ = t++(c::l₃) → P) → P := +sorry +/- +match l₂ with +| [] := λ e H₁ H₂ H₃, + begin + injection e with a_eq_c b_l₁_eq_l₃, + exact H₁ rfl (eq.symm b_l₁_eq_l₃) a_eq_c + end +| [h₁] := λ e H₁ H₂ H₃, + begin + rewrite [append_cons at e, append_nil_left at e], + injection e with a_eq_h₁ b_eq_c l₁_eq_l₃, + rewrite [a_eq_h₁ at H₂, b_eq_c at H₂, l₁_eq_l₃ at H₂], + exact H₂ rfl rfl rfl + end +| h₁::h₂::t₂ := λ e H₁ H₂ H₃, + begin + injection e with a_eq_h₁ b_eq_h₂ l₁_eq, + rewrite [a_eq_h₁ at H₃, b_eq_h₂ at H₃], + exact H₃ t₂ rfl l₁_eq + end +end +-/ + +/- permutation inversion -/ +theorem perm_inv_core {l₁ l₂ : list A} (p' : l₁ ~ l₂) : ∀ {a s₁ s₂}, l₁≈a|s₁ → l₂≈a|s₂ → s₁ ~ s₂ := +sorry +/- +perm_induction_on p' + (λ a s₁ s₂ e₁ e₂, + have innil : a ∈ [], from mem_head_of_qeq e₁, + absurd innil !not_mem_nil) + (λ x t₁ t₂ p (r : ∀{a s₁ s₂}, t₁≈a|s₁ → t₂≈a|s₂ → s₁ ~ s₂) a s₁ s₂ e₁ e₂, + obtain (s₁₁ s₁₂ : list A) (C₁₁ : s₁ = s₁₁ ++ s₁₂) (C₁₂ : x::t₁ = s₁₁++(a::s₁₂)), from qeq_split e₁, + obtain (s₂₁ s₂₂ : list A) (C₂₁ : s₂ = s₂₁ ++ s₂₂) (C₂₂ : x::t₂ = s₂₁++(a::s₂₂)), from qeq_split e₂, + discr C₁₂ + (λ (s₁₁_eq : s₁₁ = []) (x_eq_a : x = a) (t₁_eq : t₁ = s₁₂), + have s₁_p : s₁ ~ t₂, from calc + s₁ = s₁₁ ++ s₁₂ : C₁₁ + ... = t₁ : by rewrite [-t₁_eq, s₁₁_eq, append_nil_left] + ... ~ t₂ : p, + discr C₂₂ + (λ (s₂₁_eq : s₂₁ = []) (x_eq_a : x = a) (t₂_eq: t₂ = s₂₂), + proof calc + s₁ ~ t₂ : s₁_p + ... = s₂₁ ++ s₂₂ : by rewrite [-t₂_eq, s₂₁_eq, append_nil_left] + ... = s₂ : by rewrite C₂₁ + qed) + (λ (ts₂₁ : list A) (s₂₁_eq : s₂₁ = x::ts₂₁) (t₂_eq : t₂ = ts₂₁++(a::s₂₂)), + proof calc + s₁ ~ t₂ : s₁_p + ... = ts₂₁++(a::s₂₂) : t₂_eq + ... ~ (a::ts₂₁)++s₂₂ : perm.symm !perm_middle + ... = s₂₁ ++ s₂₂ : by rewrite [-x_eq_a, -s₂₁_eq] + ... = s₂ : by rewrite C₂₁ + qed)) + (λ (ts₁₁ : list A) (s₁₁_eq : s₁₁ = x::ts₁₁) (t₁_eq : t₁ = ts₁₁++(a::s₁₂)), + have t₁_qeq : t₁ ≈ a|(ts₁₁++s₁₂), by rewrite t₁_eq; exact !qeq_app, + have s₁_eq : s₁ = x::(ts₁₁++s₁₂), from calc + s₁ = s₁₁ ++ s₁₂ : C₁₁ + ... = x::(ts₁₁++ s₁₂) : by rewrite s₁₁_eq, + discr C₂₂ + (λ (s₂₁_eq : s₂₁ = []) (x_eq_a : x = a) (t₂_eq: t₂ = s₂₂), + proof calc + s₁ = a::(ts₁₁++s₁₂) : by rewrite [s₁_eq, x_eq_a] + ... ~ ts₁₁++(a::s₁₂) : !perm_middle + ... = t₁ : eq.symm t₁_eq + ... ~ t₂ : p + ... = s₂ : by rewrite [t₂_eq, C₂₁, s₂₁_eq, append_nil_left] + qed) + (λ (ts₂₁ : list A) (s₂₁_eq : s₂₁ = x::ts₂₁) (t₂_eq : t₂ = ts₂₁++(a::s₂₂)), + have t₂_qeq : t₂ ≈ a|(ts₂₁++s₂₂), by rewrite t₂_eq; exact !qeq_app, + proof calc + s₁ = x::(ts₁₁++s₁₂) : s₁_eq + ... ~ x::(ts₂₁++s₂₂) : skip x (r t₁_qeq t₂_qeq) + ... = s₂ : by rewrite [-append_cons, -s₂₁_eq, C₂₁] + qed))) + (λ x y t₁ t₂ p (r : ∀{a s₁ s₂}, t₁≈a|s₁ → t₂≈a|s₂ → s₁ ~ s₂) a s₁ s₂ e₁ e₂, + obtain (s₁₁ s₁₂ : list A) (C₁₁ : s₁ = s₁₁ ++ s₁₂) (C₁₂ : y::x::t₁ = s₁₁++(a::s₁₂)), from qeq_split e₁, + obtain (s₂₁ s₂₂ : list A) (C₂₁ : s₂ = s₂₁ ++ s₂₂) (C₂₂ : x::y::t₂ = s₂₁++(a::s₂₂)), from qeq_split e₂, + discr₂ C₁₂ + (λ (s₁₁_eq : s₁₁ = []) (s₁₂_eq : s₁₂ = x::t₁) (y_eq_a : y = a), + have s₁_p : s₁ ~ x::t₂, from calc + s₁ = s₁₁ ++ s₁₂ : C₁₁ + ... = x::t₁ : by rewrite [s₁₂_eq, s₁₁_eq, append_nil_left] + ... ~ x::t₂ : skip x p, + discr₂ C₂₂ + (λ (s₂₁_eq : s₂₁ = []) (s₂₂_eq : s₂₂ = y::t₂) (x_eq_a : x = a), + proof calc + s₁ ~ x::t₂ : s₁_p + ... = s₂₁ ++ s₂₂ : by rewrite [x_eq_a, -y_eq_a, -s₂₂_eq, s₂₁_eq, append_nil_left] + ... = s₂ : by rewrite C₂₁ + qed) + (λ (s₂₁_eq : s₂₁ = [x]) (y_eq_a : y = a) (t₂_eq : t₂ = s₂₂), + proof calc + s₁ ~ x::t₂ : s₁_p + ... = s₂₁ ++ s₂₂ : by rewrite [t₂_eq, s₂₁_eq, append_cons] + ... = s₂ : by rewrite C₂₁ + qed) + (λ (ts₂₁ : list A) (s₂₁_eq : s₂₁ = x::y::ts₂₁) (t₂_eq : t₂ = ts₂₁++(a::s₂₂)), + proof calc + s₁ ~ x::t₂ : s₁_p + ... = x::(ts₂₁++(y::s₂₂)) : by rewrite [t₂_eq, -y_eq_a] + ... ~ x::y::(ts₂₁++s₂₂) : perm.symm (skip x (perm_middle _ _ _)) -- !perm_middle + ... = s₂₁ ++ s₂₂ : by rewrite [s₂₁_eq, append_cons] + ... = s₂ : by rewrite C₂₁ + qed)) + (λ (s₁₁_eq : s₁₁ = [y]) (x_eq_a : x = a) (t₁_eq : t₁ = s₁₂), + have s₁_p : s₁ ~ y::t₂, from calc + s₁ = y::t₁ : by rewrite [C₁₁, s₁₁_eq, t₁_eq] + ... ~ y::t₂ : skip y p, + discr₂ C₂₂ + (λ (s₂₁_eq : s₂₁ = []) (s₂₂_eq : s₂₂ = y::t₂) (x_eq_a : x = a), + proof calc + s₁ ~ y::t₂ : s₁_p + ... = s₂₁ ++ s₂₂ : by rewrite [s₂₁_eq, s₂₂_eq] + ... = s₂ : by rewrite C₂₁ + qed) + (λ (s₂₁_eq : s₂₁ = [x]) (y_eq_a : y = a) (t₂_eq : t₂ = s₂₂), + proof calc + s₁ ~ y::t₂ : s₁_p + ... = s₂₁ ++ s₂₂ : by rewrite [s₂₁_eq, t₂_eq, y_eq_a, -x_eq_a] + ... = s₂ : by rewrite C₂₁ + qed) + (λ (ts₂₁ : list A) (s₂₁_eq : s₂₁ = x::y::ts₂₁) (t₂_eq : t₂ = ts₂₁++(a::s₂₂)), + proof calc + s₁ ~ y::t₂ : s₁_p + ... = y::(ts₂₁++(x::s₂₂)) : by rewrite [t₂_eq, -x_eq_a] + ... ~ y::x::(ts₂₁++s₂₂) : perm.symm (skip y (perm_middle _ _ _)) + ... ~ x::y::(ts₂₁++s₂₂) : !swap + ... = s₂₁ ++ s₂₂ : by rewrite [s₂₁_eq] + ... = s₂ : by rewrite C₂₁ + qed)) + (λ (ts₁₁ : list A) (s₁₁_eq : s₁₁ = y::x::ts₁₁) (t₁_eq : t₁ = ts₁₁++(a::s₁₂)), + have s₁_eq : s₁ = y::x::(ts₁₁++s₁₂), by rewrite [C₁₁, s₁₁_eq], + discr₂ C₂₂ + (λ (s₂₁_eq : s₂₁ = []) (s₂₂_eq : s₂₂ = y::t₂) (x_eq_a : x = a), + proof calc + s₁ = y::a::(ts₁₁++s₁₂) : by rewrite [s₁_eq, x_eq_a] + ... ~ y::(ts₁₁++(a::s₁₂)) : skip y !perm_middle + ... = y::t₁ : by rewrite t₁_eq + ... ~ y::t₂ : skip y p + ... = s₂₁ ++ s₂₂ : by rewrite [s₂₁_eq, s₂₂_eq] + ... = s₂ : by rewrite C₂₁ + qed) + (λ (s₂₁_eq : s₂₁ = [x]) (y_eq_a : y = a) (t₂_eq : t₂ = s₂₂), + proof calc + s₁ = y::x::(ts₁₁++s₁₂) : by rewrite s₁_eq + ... ~ x::y::(ts₁₁++s₁₂) : !swap + ... = x::a::(ts₁₁++s₁₂) : by rewrite y_eq_a + ... ~ x::(ts₁₁++(a::s₁₂)) : skip x (perm_middle _ _ _) + ... = x::t₁ : by rewrite t₁_eq + ... ~ x::t₂ : skip x p + ... = s₂₁ ++ s₂₂ : by rewrite [t₂_eq, s₂₁_eq] + ... = s₂ : by rewrite C₂₁ + qed) + (λ (ts₂₁ : list A) (s₂₁_eq : s₂₁ = x::y::ts₂₁) (t₂_eq : t₂ = ts₂₁++(a::s₂₂)), + have t₁_qeq : t₁ ≈ a|(ts₁₁++s₁₂), by rewrite t₁_eq; exact !qeq_app, + have t₂_qeq : t₂ ≈ a|(ts₂₁++s₂₂), by rewrite t₂_eq; exact !qeq_app, + have p_aux : ts₁₁++s₁₂ ~ ts₂₁++s₂₂, from r t₁_qeq t₂_qeq, + proof calc + s₁ = y::x::(ts₁₁++s₁₂) : by rewrite s₁_eq + ... ~ y::x::(ts₂₁++s₂₂) : skip y (skip x p_aux) + ... ~ x::y::(ts₂₁++s₂₂) : !swap + ... = s₂₁ ++ s₂₂ : by rewrite s₂₁_eq + ... = s₂ : by rewrite C₂₁ + qed))) + (λ t₁ t₂ t₃ p₁ p₂ + (r₁ : ∀{a s₁ s₂}, t₁ ≈ a|s₁ → t₂≈a|s₂ → s₁ ~ s₂) + (r₂ : ∀{a s₁ s₂}, t₂ ≈ a|s₁ → t₃≈a|s₂ → s₁ ~ s₂) + a s₁ s₂ e₁ e₂, + have a ∈ t₁, from mem_head_of_qeq e₁, + have a ∈ t₂, from mem_perm p₁ this, + obtain (t₂' : list A) (e₂' : t₂≈a|t₂'), from qeq_of_mem this, + calc s₁ ~ t₂' : r₁ e₁ e₂' + ... ~ s₂ : r₂ e₂' e₂) +-/ + +theorem perm_cons_inv {a : A} {l₁ l₂ : list A} : a::l₁ ~ a::l₂ → l₁ ~ l₂ := +assume p, perm_inv_core p (qeq.qhead a l₁) (qeq.qhead a l₂) + +theorem perm_app_inv {a : A} {l₁ l₂ l₃ l₄ : list A} : l₁++(a::l₂) ~ l₃++(a::l₄) → l₁++l₂ ~ l₃++l₄ := +assume p : l₁++(a::l₂) ~ l₃++(a::l₄), + have p' : a::(l₁++l₂) ~ a::(l₃++l₄), from calc + a::(l₁++l₂) ~ l₁++(a::l₂) : perm_middle a l₁ l₂ + ... ~ l₃++(a::l₄) : p + ... ~ a::(l₃++l₄) : perm.symm (perm_middle a l₃ l₄), + perm_cons_inv p' + +section foldl + variables {f : B → A → B} {l₁ l₂ : list A} + variable rcomm : right_commutative f + include rcomm + + theorem foldl_eq_of_perm : l₁ ~ l₂ → ∀ b, foldl f b l₁ = foldl f b l₂ := + sorry + /- + assume p, perm_induction_on p + (λ b, by rewrite *foldl_nil) + (λ x t₁ t₂ p r b, calc + foldl f b (x::t₁) = foldl f (f b x) t₁ : !foldl_cons + ... = foldl f (f b x) t₂ : by rewrite (r (f b x)) + ... = foldl f b (x::t₂) : eq.symm !foldl_cons) + (λ x y t₁ t₂ p r b, calc + foldl f b (y :: x :: t₁) = foldl f (f (f b y) x) t₁ : by rewrite foldl_cons + ... = foldl f (f (f b x) y) t₁ : by rewrite rcomm + ... = foldl f (f (f b x) y) t₂ : r (f (f b x) y) + ... = foldl f b (x :: y :: t₂) : by rewrite foldl_cons) + (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂ b, eq.trans (r₁ b) (r₂ b)) + -/ +end foldl + +section foldr + variables {f : A → B → B} {l₁ l₂ : list A} + variable lcomm : left_commutative f + include lcomm + + theorem foldr_eq_of_perm : l₁ ~ l₂ → ∀ b, foldr f b l₁ = foldr f b l₂ := + sorry + /- + assume p, perm_induction_on p + (λ b, by rewrite *foldl_nil) + (λ x t₁ t₂ p r b, calc + foldr f b (x::t₁) = f x (foldr f b t₁) : !foldr_cons + ... = f x (foldr f b t₂) : by rewrite [r b] + ... = foldr f b (x::t₂) : eq.symm !foldr_cons) + (λ x y t₁ t₂ p r b, calc + foldr f b (y :: x :: t₁) = f y (f x (foldr f b t₁)) : by rewrite foldr_cons + ... = f x (f y (foldr f b t₁)) : by rewrite lcomm + ... = f x (f y (foldr f b t₂)) : by rewrite [r b] + ... = foldr f b (x :: y :: t₂) : by rewrite foldr_cons) + (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂ a, eq.trans (r₁ a) (r₂ a)) + -/ +end foldr + +attribute [congr] +theorem perm_erase_dup_of_perm [H : decidable_eq A] {l₁ l₂ : list A} : l₁ ~ l₂ → erase_dup l₁ ~ erase_dup l₂ := +sorry +/- +assume p, perm_induction_on p + nil + (λ x t₁ t₂ p r, by_cases + (λ xint₁ : x ∈ t₁, + have xint₂ : x ∈ t₂, from mem_of_mem_erase_dup (mem_perm r (mem_erase_dup xint₁)), + by rewrite [erase_dup_cons_of_mem xint₁, erase_dup_cons_of_mem xint₂]; exact r) + (λ nxint₁ : x ∉ t₁, + have nxint₂ : x ∉ t₂, from + assume xint₂ : x ∈ t₂, absurd (mem_of_mem_erase_dup (mem_perm (perm.symm r) (mem_erase_dup xint₂))) nxint₁, + by rewrite [erase_dup_cons_of_not_mem nxint₂, erase_dup_cons_of_not_mem nxint₁]; exact (skip x r))) + (λ y x t₁ t₂ p r, by_cases + (λ xinyt₁ : x ∈ y::t₁, by_cases + (λ yint₁ : y ∈ t₁, + have yint₂ : y ∈ t₂, from mem_of_mem_erase_dup (mem_perm r (mem_erase_dup yint₁)), + have yinxt₂ : y ∈ x::t₂, from or.inr (yint₂), + or.elim (eq_or_mem_of_mem_cons xinyt₁) + (λ xeqy : x = y, + have xint₂ : x ∈ t₂, by rewrite [-xeqy at yint₂]; exact yint₂, + begin + rewrite [erase_dup_cons_of_mem xinyt₁, erase_dup_cons_of_mem yinxt₂, + erase_dup_cons_of_mem yint₁, erase_dup_cons_of_mem xint₂], + exact r + end) + (λ xint₁ : x ∈ t₁, + have xint₂ : x ∈ t₂, from mem_of_mem_erase_dup (mem_perm r (mem_erase_dup xint₁)), + begin + rewrite [erase_dup_cons_of_mem xinyt₁, erase_dup_cons_of_mem yinxt₂, + erase_dup_cons_of_mem yint₁, erase_dup_cons_of_mem xint₂], + exact r + end)) + (λ nyint₁ : y ∉ t₁, + have nyint₂ : y ∉ t₂, from + assume yint₂ : y ∈ t₂, absurd (mem_of_mem_erase_dup (mem_perm (perm.symm r) (mem_erase_dup yint₂))) nyint₁, + by_cases + (λ xeqy : x = y, + have nxint₂ : x ∉ t₂, by rewrite [-xeqy at nyint₂]; exact nyint₂, + have yinxt₂ : y ∈ x::t₂, by rewrite [xeqy]; exact !mem_cons, + begin + rewrite [erase_dup_cons_of_mem xinyt₁, erase_dup_cons_of_mem yinxt₂, + erase_dup_cons_of_not_mem nyint₁, erase_dup_cons_of_not_mem nxint₂, xeqy], + exact skip y r + end) + (λ xney : x ≠ y, + have x ∈ t₁, from or_resolve_right xinyt₁ xney, + have x ∈ t₂, from mem_of_mem_erase_dup (mem_perm r (mem_erase_dup this)), + have y ∉ x::t₂, from + suppose y ∈ x::t₂, or.elim (eq_or_mem_of_mem_cons this) + (λ h, absurd h (ne.symm xney)) + (λ h, absurd h nyint₂), + begin + rewrite [erase_dup_cons_of_mem xinyt₁, erase_dup_cons_of_not_mem `y ∉ x::t₂`, + erase_dup_cons_of_not_mem nyint₁, erase_dup_cons_of_mem `x ∈ t₂`], + exact skip y r + end))) + (λ nxinyt₁ : x ∉ y::t₁, + have xney : x ≠ y, from ne_of_not_mem_cons nxinyt₁, + have nxint₁ : x ∉ t₁, from not_mem_of_not_mem_cons nxinyt₁, + have nxint₂ : x ∉ t₂, from + assume xint₂ : x ∈ t₂, absurd (mem_of_mem_erase_dup (mem_perm (perm.symm r) (mem_erase_dup xint₂))) nxint₁, + by_cases + (λ yint₁ : y ∈ t₁, + have yinxt₂ : y ∈ x::t₂, from or.inr (mem_of_mem_erase_dup (mem_perm r (mem_erase_dup yint₁))), + begin + rewrite [erase_dup_cons_of_not_mem nxinyt₁, erase_dup_cons_of_mem yinxt₂, + erase_dup_cons_of_mem yint₁, erase_dup_cons_of_not_mem nxint₂], + exact skip x r + end) + (λ nyint₁ : y ∉ t₁, + have nyinxt₂ : y ∉ x::t₂, from + assume yinxt₂ : y ∈ x::t₂, or.elim (eq_or_mem_of_mem_cons yinxt₂) + (λ h, absurd h (ne.symm xney)) + (λ h, absurd (mem_of_mem_erase_dup (mem_perm (perm.symm r) (mem_erase_dup h))) nyint₁), + begin + rewrite [erase_dup_cons_of_not_mem nxinyt₁, erase_dup_cons_of_not_mem nyinxt₂, + erase_dup_cons_of_not_mem nyint₁, erase_dup_cons_of_not_mem nxint₂], + exact xswap x y r + end))) + (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂, trans r₁ r₂) +-/ + +section perm_union +variable [H : decidable_eq A] +include H + +theorem perm_union_left {l₁ l₂ : list A} (t₁ : list A) : l₁ ~ l₂ → (union l₁ t₁) ~ (union l₂ t₁) := +sorry +/- +assume p, perm.induction_on p + (by rewrite [nil_union]) + (λ x l₁ l₂ p₁ r₁, by_cases + (λ xint₁ : x ∈ t₁, by rewrite [*union_cons_of_mem _ xint₁]; exact r₁) + (λ nxint₁ : x ∉ t₁, by rewrite [*union_cons_of_not_mem _ nxint₁]; exact (skip _ r₁))) + (λ x y l, by_cases + (λ yint : y ∈ t₁, by_cases + (λ xint : x ∈ t₁, + by rewrite [*union_cons_of_mem _ xint, *union_cons_of_mem _ yint, *union_cons_of_mem _ xint]) + (λ nxint : x ∉ t₁, + by rewrite [*union_cons_of_mem _ yint, *union_cons_of_not_mem _ nxint, union_cons_of_mem _ yint])) + (λ nyint : y ∉ t₁, by_cases + (λ xint : x ∈ t₁, + by rewrite [*union_cons_of_mem _ xint, *union_cons_of_not_mem _ nyint, union_cons_of_mem _ xint]) + (λ nxint : x ∉ t₁, + by rewrite [*union_cons_of_not_mem _ nxint, *union_cons_of_not_mem _ nyint, union_cons_of_not_mem _ nxint]; exact !swap))) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂) +-/ + +theorem perm_union_right (l : list A) {t₁ t₂ : list A} : t₁ ~ t₂ → (union l t₁) ~ (union l t₂) := +sorry +/- +list.induction_on l + (λ p, by rewrite [*union_nil]; exact p) + (λ x xs r p, by_cases + (λ xint₁ : x ∈ t₁, + have xint₂ : x ∈ t₂, from mem_perm p xint₁, + by rewrite [union_cons_of_mem _ xint₁, union_cons_of_mem _ xint₂]; exact (r p)) + (λ nxint₁ : x ∉ t₁, + have nxint₂ : x ∉ t₂, from not_mem_perm p nxint₁, + by rewrite [union_cons_of_not_mem _ nxint₁, union_cons_of_not_mem _ nxint₂]; exact (skip _ (r p)))) +-/ + +attribute [congr] +theorem perm_union {l₁ l₂ t₁ t₂ : list A} : l₁ ~ l₂ → t₁ ~ t₂ → (union l₁ t₁) ~ (union l₂ t₂) := +assume p₁ p₂, trans (perm_union_left t₁ p₁) (perm_union_right l₂ p₂) +end perm_union + +section perm_insert +variable [H : decidable_eq A] +include H + +attribute [congr] +theorem perm_insert (a : A) {l₁ l₂ : list A} : l₁ ~ l₂ → (insert a l₁) ~ (insert a l₂) := +sorry +/- +assume p, by_cases + (λ ainl₁ : a ∈ l₁, + have ainl₂ : a ∈ l₂, from mem_perm p ainl₁, + by rewrite [insert_eq_of_mem ainl₁, insert_eq_of_mem ainl₂]; exact p) + (λ nainl₁ : a ∉ l₁, + have nainl₂ : a ∉ l₂, from not_mem_perm p nainl₁, + by rewrite [insert_eq_of_not_mem nainl₁, insert_eq_of_not_mem nainl₂]; exact (skip _ p)) +-/ +end perm_insert + +section perm_inter +variable [H : decidable_eq A] +include H + +theorem perm_inter_left {l₁ l₂ : list A} (t₁ : list A) : l₁ ~ l₂ → (inter l₁ t₁) ~ (inter l₂ t₁) := +sorry +/- +assume p, perm.induction_on p + !perm.refl + (λ x l₁ l₂ p₁ r₁, by_cases + (λ xint₁ : x ∈ t₁, by rewrite [*inter_cons_of_mem _ xint₁]; exact (skip x r₁)) + (λ nxint₁ : x ∉ t₁, by rewrite [*inter_cons_of_not_mem _ nxint₁]; exact r₁)) + (λ x y l, by_cases + (λ yint : y ∈ t₁, by_cases + (λ xint : x ∈ t₁, + by rewrite [*inter_cons_of_mem _ xint, *inter_cons_of_mem _ yint, *inter_cons_of_mem _ xint]; + exact !swap) + (λ nxint : x ∉ t₁, + by rewrite [*inter_cons_of_mem _ yint, *inter_cons_of_not_mem _ nxint, inter_cons_of_mem _ yint])) + (λ nyint : y ∉ t₁, by_cases + (λ xint : x ∈ t₁, + by rewrite [*inter_cons_of_mem _ xint, *inter_cons_of_not_mem _ nyint, inter_cons_of_mem _ xint]) + (λ nxint : x ∉ t₁, + by rewrite [*inter_cons_of_not_mem _ nxint, *inter_cons_of_not_mem _ nyint, + inter_cons_of_not_mem _ nxint]))) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂) +-/ + +theorem perm_inter_right (l : list A) {t₁ t₂ : list A} : t₁ ~ t₂ → (inter l t₁) ~ (inter l t₂) := +sorry +/- +list.induction_on l + (λ p, by rewrite [*inter_nil]) + (λ x xs r p, by_cases + (λ xint₁ : x ∈ t₁, + have xint₂ : x ∈ t₂, from mem_perm p xint₁, + by rewrite [inter_cons_of_mem _ xint₁, inter_cons_of_mem _ xint₂]; exact (skip _ (r p))) + (λ nxint₁ : x ∉ t₁, + have nxint₂ : x ∉ t₂, from not_mem_perm p nxint₁, + by rewrite [inter_cons_of_not_mem _ nxint₁, inter_cons_of_not_mem _ nxint₂]; exact (r p))) +-/ +attribute [congr] +theorem perm_inter {l₁ l₂ t₁ t₂ : list A} : l₁ ~ l₂ → t₁ ~ t₂ → (inter l₁ t₁) ~ (inter l₂ t₂) := +assume p₁ p₂, trans (perm_inter_left t₁ p₁) (perm_inter_right l₂ p₂) +end perm_inter + +/- extensionality -/ +section ext + +theorem perm_ext : ∀ {l₁ l₂ : list A}, nodup l₁ → nodup l₂ → (∀a, a ∈ l₁ ↔ a ∈ l₂) → l₁ ~ l₂ +:= sorry +/- +| [] [] d₁ d₂ e := !perm.nil +| [] (a₂::t₂) d₁ d₂ e := absurd (iff.mpr (e a₂) !mem_cons) (not_mem_nil a₂) +| (a₁::t₁) [] d₁ d₂ e := absurd (iff.mp (e a₁) !mem_cons) (not_mem_nil a₁) +| (a₁::t₁) (a₂::t₂) d₁ d₂ e := + have a₁ ∈ a₂::t₂, from iff.mp (e a₁) !mem_cons, + have ∃ s₁ s₂, a₂::t₂ = s₁++(a₁::s₂), from mem_split this, + obtain (s₁ s₂ : list A) (t₂_eq : a₂::t₂ = s₁++(a₁::s₂)), from this, + have dt₂' : nodup (a₁::(s₁++s₂)), from nodup_head (by rewrite [t₂_eq at d₂]; exact d₂), + have eqv : ∀a, a ∈ t₁ ↔ a ∈ s₁++s₂, from + take a, iff.intro + (suppose a ∈ t₁, + have a ∈ a₂::t₂, from iff.mp (e a) (mem_cons_of_mem _ this), + have a ∈ s₁++(a₁::s₂), by rewrite [t₂_eq at this]; exact this, + or.elim (mem_or_mem_of_mem_append this) + (suppose a ∈ s₁, mem_append_left s₂ this) + (suppose a ∈ a₁::s₂, or.elim (eq_or_mem_of_mem_cons this) + (suppose a = a₁, + have a₁ ∉ t₁, from not_mem_of_nodup_cons d₁, + by subst a; contradiction) + (suppose a ∈ s₂, mem_append_right s₁ this))) + (suppose a ∈ s₁ ++ s₂, or.elim (mem_or_mem_of_mem_append this) + (suppose a ∈ s₁, + have a ∈ a₂::t₂, from by rewrite [t₂_eq]; exact (mem_append_left _ this), + have a ∈ a₁::t₁, from iff.mpr (e a) this, + or.elim (eq_or_mem_of_mem_cons this) + (suppose a = a₁, + have a₁ ∉ s₁++s₂, from not_mem_of_nodup_cons dt₂', + have a₁ ∉ s₁, from not_mem_of_not_mem_append_left this, + by subst a; contradiction) + (suppose a ∈ t₁, this)) + (suppose a ∈ s₂, + have a ∈ a₂::t₂, from by rewrite [t₂_eq]; exact (mem_append_right _ (mem_cons_of_mem _ this)), + have a ∈ a₁::t₁, from iff.mpr (e a) this, + or.elim (eq_or_mem_of_mem_cons this) + (suppose a = a₁, + have a₁ ∉ s₁++s₂, from not_mem_of_nodup_cons dt₂', + have a₁ ∉ s₂, from not_mem_of_not_mem_append_right this, + by subst a; contradiction) + (suppose a ∈ t₁, this))), + have ds₁s₂ : nodup (s₁++s₂), from nodup_of_nodup_cons dt₂', + have nodup t₁, from nodup_of_nodup_cons d₁, + calc a₁::t₁ ~ a₁::(s₁++s₂) : skip a₁ (perm_ext this ds₁s₂ eqv) + ... ~ s₁++(a₁::s₂) : !perm_middle + ... = a₂::t₂ : by rewrite t₂_eq +-/ +end ext + +theorem nodup_of_perm_of_nodup {l₁ l₂ : list A} : l₁ ~ l₂ → nodup l₁ → nodup l₂ := +sorry +/- +assume h, perm.induction_on h + (λ h, h) + (λ a l₁ l₂ p ih nd, + have nodup l₁, from nodup_of_nodup_cons nd, + have nodup l₂, from ih this, + have a ∉ l₁, from not_mem_of_nodup_cons nd, + have a ∉ l₂, from suppose a ∈ l₂, absurd (mem_perm (perm.symm p) this) `a ∉ l₁`, + nodup_cons `a ∉ l₂` `nodup l₂`) + (λ x y l₁ nd, + have nodup (x::l₁), from nodup_of_nodup_cons nd, + have nodup l₁, from nodup_of_nodup_cons this, + have x ∉ l₁, from not_mem_of_nodup_cons `nodup (x::l₁)`, + have y ∉ x::l₁, from not_mem_of_nodup_cons nd, + have x ≠ y, from suppose x = y, begin subst x, exact absurd !mem_cons `y ∉ y::l₁` end, + have y ∉ l₁, from not_mem_of_not_mem_cons `y ∉ x::l₁`, + have x ∉ y::l₁, from not_mem_cons_of_ne_of_not_mem `x ≠ y` `x ∉ l₁`, + have nodup (y::l₁), from nodup_cons `y ∉ l₁` `nodup l₁`, + show nodup (x::y::l₁), from nodup_cons `x ∉ y::l₁` `nodup (y::l₁)`) + (λ l₁ l₂ l₃ p₁ p₂ ih₁ ih₂ nd, ih₂ (ih₁ nd)) +-/ + +/- product -/ +section product +theorem perm_product_left {l₁ l₂ : list A} (t₁ : list B) : l₁ ~ l₂ → (product l₁ t₁) ~ (product l₂ t₁) := +sorry +/- +assume p : l₁ ~ l₂, perm.induction_on p + !perm.refl + (λ x l₁ l₂ p r, perm_app (perm.refl (map _ t₁)) r) + (λ x y l, + let m₁ := map (λ b, (x, b)) t₁ in + let m₂ := map (λ b, (y, b)) t₁ in + let c := product l t₁ in + calc m₂ ++ (m₁ ++ c) = (m₂ ++ m₁) ++ c : by rewrite append.assoc + ... ~ (m₁ ++ m₂) ++ c : perm_app !perm_app_comm !perm.refl + ... = m₁ ++ (m₂ ++ c) : by rewrite append.assoc) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂) +-/ + +theorem perm_product_right (l : list A) {t₁ t₂ : list B} : t₁ ~ t₂ → (product l t₁) ~ (product l t₂) := +sorry +/- +list.induction_on l + (λ p, by rewrite [*nil_product]) + (λ a t r p, + perm_app (perm_map _ p) (r p)) +-/ + +attribute [congr] +theorem perm_product {l₁ l₂ : list A} {t₁ t₂ : list B} : l₁ ~ l₂ → t₁ ~ t₂ → (product l₁ t₁) ~ (product l₂ t₂) := +assume p₁ p₂, trans (perm_product_left t₁ p₁) (perm_product_right l₂ p₂) +end product + +/- filter -/ +attribute [congr] +theorem perm_filter {l₁ l₂ : list A} {p : A → Prop} [decidable_pred p] : + l₁ ~ l₂ → (filter p l₁) ~ (filter p l₂) := +sorry +/- +assume u, perm.induction_on u + perm.nil + (take x l₁' l₂', + assume u' : l₁' ~ l₂', + assume u'' : filter p l₁' ~ filter p l₂', + decidable.by_cases + (suppose p x, by rewrite [*filter_cons_of_pos _ this]; apply perm.skip; apply u'') + (suppose ¬ p x, by rewrite [*filter_cons_of_neg _ this]; apply u'')) + (take x y l, + decidable.by_cases + (assume H1 : p x, + decidable.by_cases + (assume H2 : p y, + begin + rewrite [filter_cons_of_pos _ H1, *filter_cons_of_pos _ H2, filter_cons_of_pos _ H1], + apply perm.swap + end) + (assume H2 : ¬ p y, + by rewrite [filter_cons_of_pos _ H1, *filter_cons_of_neg _ H2, filter_cons_of_pos _ H1])) + (assume H1 : ¬ p x, + decidable.by_cases + (assume H2 : p y, + by rewrite [filter_cons_of_neg _ H1, *filter_cons_of_pos _ H2, filter_cons_of_neg _ H1]) + (assume H2 : ¬ p y, + by rewrite [filter_cons_of_neg _ H1, *filter_cons_of_neg _ H2, filter_cons_of_neg _ H1]))) + (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂) +-/ +section count +variable [decA : decidable_eq A] +include decA + +theorem count_eq_of_perm {l₁ l₂ : list A} : l₁ ~ l₂ → ∀ a, count a l₁ = count a l₂ := +sorry +/- +suppose l₁ ~ l₂, perm.induction_on this + (λ a, rfl) + (λ x l₁ l₂ p h a, by rewrite [*count_cons, *h a]) + (λ x y l a, by_cases + (suppose a = x, by_cases + (suppose a = y, begin subst x, subst y end) + (suppose a ≠ y, begin subst x, rewrite [count_cons_of_ne this, *count_cons_eq, count_cons_of_ne this] end)) + (suppose a ≠ x, by_cases + (suppose a = y, begin subst y, rewrite [count_cons_of_ne this, *count_cons_eq, count_cons_of_ne this] end) + (suppose a ≠ y, begin rewrite [count_cons_of_ne `a≠x`, *count_cons_of_ne `a≠y`, count_cons_of_ne `a≠x`] end))) + (λ l₁ l₂ l₃ p₁ p₂ h₁ h₂ a, eq.trans (h₁ a) (h₂ a)) +-/ +end count +end perm diff --git a/old_library/data/list/set.lean b/old_library/data/list/set.lean new file mode 100644 index 0000000000..f0755c6612 --- /dev/null +++ b/old_library/data/list/set.lean @@ -0,0 +1,920 @@ +/- +Copyright (c) 2015 Leonardo de Moura. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Set-like operations on lists +-/ +import data.list.basic data.list.comb +open nat function decidable + +namespace list +section erase +variable {A : Type} +variable [H : decidable_eq A] +include H + +definition erase (a : A) : list A → list A +| [] := [] +| (b::l) := + match (H a b) with + | (tt e) := l + | (ff n) := b :: erase l + end + +lemma erase_nil (a : A) : erase a [] = [] := +rfl + +lemma erase_cons_head (a : A) (l : list A) : erase a (a :: l) = l := +sorry +/- +show match H a a with | inl e := l | inr n := a :: erase a l end = l, +by rewrite decidable_eq_inl_refl +-/ + +lemma erase_cons_tail {a b : A} (l : list A) : a ≠ b → erase a (b::l) = b :: erase a l := +sorry +/- +assume h : a ≠ b, +show match H a b with | inl e := l | inr n₁ := b :: erase a l end = b :: erase a l, +by rewrite (decidable_eq_inr_neg h) +-/ + +lemma length_erase_of_mem {a : A} : ∀ {l}, a ∈ l → length (erase a l) = pred (length l) +:= sorry +/- +| [] h := rfl +| [x] h := by rewrite [mem_singleton h, erase_cons_head] +| (x::y::xs) h := + by_cases + (suppose a = x, by rewrite [this, erase_cons_head]) + (suppose a ≠ x, + have ainyxs : a ∈ y::xs, from or_resolve_right h this, + by rewrite [erase_cons_tail _ this, *length_cons, length_erase_of_mem ainyxs]) +-/ + +lemma length_erase_of_not_mem {a : A} : ∀ {l}, a ∉ l → length (erase a l) = length l +:= sorry +/- +| [] h := rfl +| (x::xs) h := + have anex : a ≠ x, from λ aeqx : a = x, absurd (or.inl aeqx) h, + have aninxs : a ∉ xs, from λ ainxs : a ∈ xs, absurd (or.inr ainxs) h, + by rewrite [erase_cons_tail _ anex, length_cons, length_erase_of_not_mem aninxs] +-/ + +lemma erase_append_left {a : A} : ∀ {l₁} (l₂), a ∈ l₁ → erase a (l₁++l₂) = erase a l₁ ++ l₂ +:= sorry +/- +| [] l₂ h := absurd h !not_mem_nil +| (x::xs) l₂ h := + by_cases + (λ aeqx : a = x, by rewrite [aeqx, append_cons, *erase_cons_head]) + (λ anex : a ≠ x, + have ainxs : a ∈ xs, from mem_of_ne_of_mem anex h, + by rewrite [append_cons, *erase_cons_tail _ anex, erase_append_left l₂ ainxs]) +-/ + +lemma erase_append_right {a : A} : ∀ {l₁} (l₂), a ∉ l₁ → erase a (l₁++l₂) = l₁ ++ erase a l₂ +:= sorry +/- +| [] l₂ h := rfl +| (x::xs) l₂ h := + by_cases + (λ aeqx : a = x, by rewrite aeqx at h; exact (absurd !mem_cons h)) + (λ anex : a ≠ x, + have nainxs : a ∉ xs, from not_mem_of_not_mem_cons h, + by rewrite [append_cons, *erase_cons_tail _ anex, erase_append_right l₂ nainxs]) +-/ + +lemma erase_sub (a : A) : ∀ l, erase a l ⊆ l +:= sorry +/- +| [] := λ x xine, xine +| (x::xs) := λ y xine, + by_cases + (λ aeqx : a = x, by rewrite [aeqx at xine, erase_cons_head at xine]; exact (or.inr xine)) + (λ anex : a ≠ x, + have yinxe : y ∈ x :: erase a xs, by rewrite [erase_cons_tail _ anex at xine]; exact xine, + have subxs : erase a xs ⊆ xs, from erase_sub xs, + by_cases + (λ yeqx : y = x, by rewrite yeqx; apply mem_cons) + (λ ynex : y ≠ x, + have yine : y ∈ erase a xs, from mem_of_ne_of_mem ynex yinxe, + have yinxs : y ∈ xs, from subxs yine, + or.inr yinxs)) +-/ + +theorem mem_erase_of_ne_of_mem {a b : A} : ∀ {l : list A}, a ≠ b → a ∈ l → a ∈ erase b l +:= sorry +/- +| [] n i := absurd i !not_mem_nil +| (c::l) n i := by_cases + (λ beqc : b = c, + have ainl : a ∈ l, from or.elim (eq_or_mem_of_mem_cons i) + (λ aeqc : a = c, absurd aeqc (beqc ▸ n)) + (λ ainl : a ∈ l, ainl), + by rewrite [beqc, erase_cons_head]; exact ainl) + (λ bnec : b ≠ c, by_cases + (λ aeqc : a = c, + have aux : a ∈ c :: erase b l, by rewrite [aeqc]; exact !mem_cons, + by rewrite [erase_cons_tail _ bnec]; exact aux) + (λ anec : a ≠ c, + have ainl : a ∈ l, from mem_of_ne_of_mem anec i, + have ainel : a ∈ erase b l, from mem_erase_of_ne_of_mem n ainl, + have aux : a ∈ c :: erase b l, from mem_cons_of_mem _ ainel, + by rewrite [erase_cons_tail _ bnec]; exact aux)) -- +-/ + +theorem mem_of_mem_erase {a b : A} : ∀ {l}, a ∈ erase b l → a ∈ l +:= sorry +/- +| [] i := absurd i !not_mem_nil +| (c::l) i := by_cases + (λ beqc : b = c, by rewrite [beqc at i, erase_cons_head at i]; exact (mem_cons_of_mem _ i)) + (λ bnec : b ≠ c, + have i₁ : a ∈ c :: erase b l, by rewrite [erase_cons_tail _ bnec at i]; exact i, + or.elim (eq_or_mem_of_mem_cons i₁) + (λ aeqc : a = c, by rewrite [aeqc]; exact !mem_cons) + (λ ainel : a ∈ erase b l, + have ainl : a ∈ l, from mem_of_mem_erase ainel, + mem_cons_of_mem _ ainl)) +-/ + +theorem all_erase_of_all {p : A → Prop} (a : A) : ∀ {l}, all l p → all (erase a l) p +:= sorry +/- +| [] h := by rewrite [erase_nil]; exact h +| (b::l) h := + have h₁ : all l p, from all_of_all_cons h, + have h₂ : all (erase a l) p, from all_erase_of_all h₁, + have pb : p b, from of_all_cons h, + have h₃ : all (b :: erase a l) p, from all_cons_of_all pb h₂, + by_cases + (λ aeqb : a = b, by rewrite [aeqb, erase_cons_head]; exact h₁) + (λ aneb : a ≠ b, by rewrite [erase_cons_tail _ aneb]; exact h₃) +-/ +end erase + +/- disjoint -/ +section disjoint +variable {A : Type} + +definition disjoint (l₁ l₂ : list A) : Prop := ∀ ⦃a⦄, (a ∈ l₁ → a ∈ l₂ → false) + +lemma disjoint_left {l₁ l₂ : list A} : disjoint l₁ l₂ → ∀ {a}, a ∈ l₁ → a ∉ l₂ := +λ d a, d a + +lemma disjoint_right {l₁ l₂ : list A} : disjoint l₁ l₂ → ∀ {a}, a ∈ l₂ → a ∉ l₁ := +λ d a i₂ i₁, d a i₁ i₂ + +lemma disjoint.comm {l₁ l₂ : list A} : disjoint l₁ l₂ → disjoint l₂ l₁ := +λ d a i₂ i₁, d a i₁ i₂ + +lemma disjoint_of_disjoint_cons_left {a : A} {l₁ l₂} : disjoint (a::l₁) l₂ → disjoint l₁ l₂ := +λ d x xinl₁, disjoint_left d (or.inr xinl₁) + +lemma disjoint_of_disjoint_cons_right {a : A} {l₁ l₂} : disjoint l₁ (a::l₂) → disjoint l₁ l₂ := +λ d, disjoint.comm (disjoint_of_disjoint_cons_left (disjoint.comm d)) + +lemma disjoint_nil_left (l : list A) : disjoint [] l := +λ a ab, absurd ab (not_mem_nil a) + +lemma disjoint_nil_right (l : list A) : disjoint l [] := +disjoint.comm (disjoint_nil_left l) + +lemma disjoint_cons_of_not_mem_of_disjoint {a : A} {l₁ l₂} : a ∉ l₂ → disjoint l₁ l₂ → disjoint (a::l₁) l₂ := +λ nainl₂ d x (xinal₁ : x ∈ a::l₁), + or.elim (eq_or_mem_of_mem_cons xinal₁) + (λ xeqa : x = a, eq.symm xeqa ▸ nainl₂) + (λ xinl₁ : x ∈ l₁, disjoint_left d xinl₁) + +lemma disjoint_of_disjoint_append_left_left : ∀ {l₁ l₂ l : list A}, disjoint (l₁++l₂) l → disjoint l₁ l +| [] l₂ l d := disjoint_nil_left l +| (x::xs) l₂ l d := + have nxinl : x ∉ l, from disjoint_left d (mem_cons x _), + have d₁ : disjoint (xs++l₂) l, from disjoint_of_disjoint_cons_left d, + have d₂ : disjoint xs l, from disjoint_of_disjoint_append_left_left d₁, + disjoint_cons_of_not_mem_of_disjoint nxinl d₂ + +lemma disjoint_of_disjoint_append_left_right : ∀ {l₁ l₂ l : list A}, disjoint (l₁++l₂) l → disjoint l₂ l +| [] l₂ l d := d +| (x::xs) l₂ l d := + have d₁ : disjoint (xs++l₂) l, from disjoint_of_disjoint_cons_left d, + disjoint_of_disjoint_append_left_right d₁ + +lemma disjoint_of_disjoint_append_right_left : ∀ {l₁ l₂ l : list A}, disjoint l (l₁++l₂) → disjoint l l₁ := +λ l₁ l₂ l d, disjoint.comm (disjoint_of_disjoint_append_left_left (disjoint.comm d)) + +lemma disjoint_of_disjoint_append_right_right : ∀ {l₁ l₂ l : list A}, disjoint l (l₁++l₂) → disjoint l l₂ := +λ l₁ l₂ l d, disjoint.comm (disjoint_of_disjoint_append_left_right (disjoint.comm d)) + +end disjoint + +/- no duplicates predicate -/ + +inductive nodup {A : Type} : list A → Prop := +| ndnil : nodup [] +| ndcons : ∀ {a l}, a ∉ l → nodup l → nodup (a::l) + +section nodup +open nodup +variables {A B : Type} + +theorem nodup_nil : @nodup A [] := +ndnil + +theorem nodup_cons {a : A} {l : list A} : a ∉ l → nodup l → nodup (a::l) := +λ i n, ndcons i n + +theorem nodup_singleton (a : A) : nodup [a] := +nodup_cons (not_mem_nil a) nodup_nil + +theorem nodup_of_nodup_cons : ∀ {a : A} {l : list A}, nodup (a::l) → nodup l +| a xs (ndcons i n) := n + +theorem not_mem_of_nodup_cons : ∀ {a : A} {l : list A}, nodup (a::l) → a ∉ l +| a xs (ndcons i n) := i + +theorem not_nodup_cons_of_mem {a : A} {l : list A} : a ∈ l → ¬ nodup (a :: l) := +λ ainl d, absurd ainl (not_mem_of_nodup_cons d) + +theorem not_nodup_cons_of_not_nodup {a : A} {l : list A} : ¬ nodup l → ¬ nodup (a :: l) := +λ nd d, absurd (nodup_of_nodup_cons d) nd + +theorem nodup_of_nodup_append_left : ∀ {l₁ l₂ : list A}, nodup (l₁++l₂) → nodup l₁ +| [] l₂ n := nodup_nil +| (x::xs) l₂ n := + have ndxs : nodup xs, from nodup_of_nodup_append_left (nodup_of_nodup_cons n), + have nxinxsl₂ : x ∉ xs++l₂, from not_mem_of_nodup_cons n, + have nxinxs : x ∉ xs, from not_mem_of_not_mem_append_left nxinxsl₂, + nodup_cons nxinxs ndxs + +theorem nodup_of_nodup_append_right : ∀ {l₁ l₂ : list A}, nodup (l₁++l₂) → nodup l₂ +| [] l₂ n := n +| (x::xs) l₂ n := nodup_of_nodup_append_right (nodup_of_nodup_cons n) + +theorem disjoint_of_nodup_append : ∀ {l₁ l₂ : list A}, nodup (l₁++l₂) → disjoint l₁ l₂ +| [] l₂ d := disjoint_nil_left l₂ +| (x::xs) l₂ d := + have nodup (x::(xs++l₂)), from d, + have x ∉ xs++l₂, from not_mem_of_nodup_cons this, + have nxinl₂ : x ∉ l₂, from not_mem_of_not_mem_append_right this, + take a, suppose a ∈ x::xs, + or.elim (eq_or_mem_of_mem_cons this) + (suppose a = x, eq.symm this ▸ nxinl₂) + (suppose ainxs : a ∈ xs, + have nodup (x::(xs++l₂)), from d, + have nodup (xs++l₂), from nodup_of_nodup_cons this, + have disjoint xs l₂, from disjoint_of_nodup_append this, + disjoint_left this ainxs) + +theorem nodup_append_of_nodup_of_nodup_of_disjoint : ∀ {l₁ l₂ : list A}, nodup l₁ → nodup l₂ → disjoint l₁ l₂ → nodup (l₁++l₂) +| [] l₂ d₁ d₂ dsj := sorry -- by rewrite [append_nil_left]; exact d₂ +| (x::xs) l₂ d₁ d₂ dsj := + have ndxs : nodup xs, from nodup_of_nodup_cons d₁, + have disjoint xs l₂, from disjoint_of_disjoint_cons_left dsj, + have ndxsl₂ : nodup (xs++l₂), from nodup_append_of_nodup_of_nodup_of_disjoint ndxs d₂ this, + have nxinxs : x ∉ xs, from not_mem_of_nodup_cons d₁, + have x ∉ l₂, from disjoint_left dsj (mem_cons x xs), + have x ∉ xs++l₂, from not_mem_append nxinxs this, + nodup_cons this ndxsl₂ + +theorem nodup_app_comm {l₁ l₂ : list A} (d : nodup (l₁++l₂)) : nodup (l₂++l₁) := +have d₁ : nodup l₁, from nodup_of_nodup_append_left d, +have d₂ : nodup l₂, from nodup_of_nodup_append_right d, +have dsj : disjoint l₁ l₂, from disjoint_of_nodup_append d, +nodup_append_of_nodup_of_nodup_of_disjoint d₂ d₁ (disjoint.comm dsj) + +theorem nodup_head {a : A} {l₁ l₂ : list A} (d : nodup (l₁++(a::l₂))) : nodup (a::(l₁++l₂)) := +have d₁ : nodup (a::(l₂++l₁)), from nodup_app_comm d, +have d₂ : nodup (l₂++l₁), from nodup_of_nodup_cons d₁, +have d₃ : nodup (l₁++l₂), from nodup_app_comm d₂, +have nain : a ∉ l₂++l₁, from not_mem_of_nodup_cons d₁, +have nain₂ : a ∉ l₂, from not_mem_of_not_mem_append_left nain, +have nain₁ : a ∉ l₁, from not_mem_of_not_mem_append_right nain, +nodup_cons (not_mem_append nain₁ nain₂) d₃ + +theorem nodup_middle {a : A} {l₁ l₂ : list A} (d : nodup (a::(l₁++l₂))) : nodup (l₁++(a::l₂)) := +have d₁ : nodup (l₁++l₂), from nodup_of_nodup_cons d, +have nain : a ∉ l₁++l₂, from not_mem_of_nodup_cons d, +have disj : disjoint l₁ l₂, from disjoint_of_nodup_append d₁, +have d₂ : nodup l₁, from nodup_of_nodup_append_left d₁, +have d₃ : nodup l₂, from nodup_of_nodup_append_right d₁, +have nain₂ : a ∉ l₂, from not_mem_of_not_mem_append_right nain, +have nain₁ : a ∉ l₁, from not_mem_of_not_mem_append_left nain, +have d₄ : nodup (a::l₂), from nodup_cons nain₂ d₃, +have disj₂ : disjoint l₁ (a::l₂), from disjoint.comm (disjoint_cons_of_not_mem_of_disjoint nain₁ (disjoint.comm disj)), +nodup_append_of_nodup_of_nodup_of_disjoint d₂ d₄ disj₂ + +theorem nodup_map {f : A → B} (inj : injective f) : ∀ {l : list A}, nodup l → nodup (map f l) +:= sorry +/- +| [] n := begin rewrite [map_nil], apply nodup_nil end +| (x::xs) n := + have nxinxs : x ∉ xs, from not_mem_of_nodup_cons n, + have ndxs : nodup xs, from nodup_of_nodup_cons n, + have ndmfxs : nodup (map f xs), from nodup_map ndxs, + have nfxinm : f x ∉ map f xs, from + λ ab : f x ∈ map f xs, + obtain (y : A) (yinxs : y ∈ xs) (fyfx : f y = f x), from exists_of_mem_map ab, + have yeqx : y = x, from inj fyfx, + by subst y; contradiction, + nodup_cons nfxinm ndmfxs +-/ + +theorem nodup_erase_of_nodup [decidable_eq A] (a : A) : ∀ {l}, nodup l → nodup (erase a l) +:= sorry +/- +| [] n := nodup_nil +| (b::l) n := by_cases + (λ aeqb : a = b, by rewrite [aeqb, erase_cons_head]; exact (nodup_of_nodup_cons n)) + (λ aneb : a ≠ b, + have nbinl : b ∉ l, from not_mem_of_nodup_cons n, + have ndl : nodup l, from nodup_of_nodup_cons n, + have ndeal : nodup (erase a l), from nodup_erase_of_nodup ndl, + have nbineal : b ∉ erase a l, from λ i, absurd (erase_sub _ _ i) nbinl, + have aux : nodup (b :: erase a l), from nodup_cons nbineal ndeal, + by rewrite [erase_cons_tail _ aneb]; exact aux) +-/ + +theorem mem_erase_of_nodup [decidable_eq A] (a : A) : ∀ {l}, nodup l → a ∉ erase a l +:= sorry +/- +| [] n := !not_mem_nil +| (b::l) n := + have ndl : nodup l, from nodup_of_nodup_cons n, + have naineal : a ∉ erase a l, from mem_erase_of_nodup ndl, + have nbinl : b ∉ l, from not_mem_of_nodup_cons n, + by_cases + (λ aeqb : a = b, by rewrite [aeqb, erase_cons_head]; exact nbinl) + (λ aneb : a ≠ b, + have aux : a ∉ b :: erase a l, from + assume ainbeal : a ∈ b :: erase a l, or.elim (eq_or_mem_of_mem_cons ainbeal) + (λ aeqb : a = b, absurd aeqb aneb) + (λ aineal : a ∈ erase a l, absurd aineal naineal), + by rewrite [erase_cons_tail _ aneb]; exact aux) +-/ + +definition erase_dup [decidable_eq A] : list A → list A +| [] := [] +| (x :: xs) := if x ∈ xs then erase_dup xs else x :: erase_dup xs + +theorem erase_dup_nil [decidable_eq A] : erase_dup [] = ([] : list A) := rfl + +theorem erase_dup_cons_of_mem [decidable_eq A] {a : A} {l : list A} : a ∈ l → erase_dup (a::l) = erase_dup l := +assume ainl, calc + erase_dup (a::l) = if a ∈ l then erase_dup l else a :: erase_dup l : rfl + ... = erase_dup l : if_pos ainl + +theorem erase_dup_cons_of_not_mem [decidable_eq A] {a : A} {l : list A} : a ∉ l → erase_dup (a::l) = a :: erase_dup l := +assume nainl, calc + erase_dup (a::l) = if a ∈ l then erase_dup l else a :: erase_dup l : rfl + ... = a :: erase_dup l : if_neg nainl + +theorem mem_erase_dup [decidable_eq A] {a : A} : ∀ {l}, a ∈ l → a ∈ erase_dup l +:= sorry +/- +| [] h := absurd h !not_mem_nil +| (b::l) h := by_cases + (λ binl : b ∈ l, or.elim (eq_or_mem_of_mem_cons h) + (λ aeqb : a = b, by rewrite [erase_dup_cons_of_mem binl, -aeqb at binl]; exact (mem_erase_dup binl)) + (λ ainl : a ∈ l, by rewrite [erase_dup_cons_of_mem binl]; exact (mem_erase_dup ainl))) + (λ nbinl : b ∉ l, or.elim (eq_or_mem_of_mem_cons h) + (λ aeqb : a = b, by rewrite [erase_dup_cons_of_not_mem nbinl, aeqb]; exact !mem_cons) + (λ ainl : a ∈ l, by rewrite [erase_dup_cons_of_not_mem nbinl]; exact (or.inr (mem_erase_dup ainl)))) +-/ + +theorem mem_of_mem_erase_dup [decidable_eq A] {a : A} : ∀ {l}, a ∈ erase_dup l → a ∈ l +:= sorry +/- +| [] h := by rewrite [erase_dup_nil at h]; exact h +| (b::l) h := by_cases + (λ binl : b ∈ l, + have h₁ : a ∈ erase_dup l, by rewrite [erase_dup_cons_of_mem binl at h]; exact h, + or.inr (mem_of_mem_erase_dup h₁)) + (λ nbinl : b ∉ l, + have h₁ : a ∈ b :: erase_dup l, by rewrite [erase_dup_cons_of_not_mem nbinl at h]; exact h, + or.elim (eq_or_mem_of_mem_cons h₁) + (λ aeqb : a = b, by rewrite aeqb; exact !mem_cons) + (λ ainel : a ∈ erase_dup l, or.inr (mem_of_mem_erase_dup ainel))) +-/ + +theorem erase_dup_sub [decidable_eq A] (l : list A) : erase_dup l ⊆ l := +λ a i, mem_of_mem_erase_dup i + +theorem sub_erase_dup [decidable_eq A] (l : list A) : l ⊆ erase_dup l := +λ a i, mem_erase_dup i + +theorem nodup_erase_dup [decidable_eq A] : ∀ l : list A, nodup (erase_dup l) +:= sorry +/- +| [] := by rewrite erase_dup_nil; exact nodup_nil +| (a::l) := by_cases + (λ ainl : a ∈ l, by rewrite [erase_dup_cons_of_mem ainl]; exact (nodup_erase_dup l)) + (λ nainl : a ∉ l, + have r : nodup (erase_dup l), from nodup_erase_dup l, + have nin : a ∉ erase_dup l, from + assume ab : a ∈ erase_dup l, absurd (mem_of_mem_erase_dup ab) nainl, + by rewrite [erase_dup_cons_of_not_mem nainl]; exact (nodup_cons nin r)) +-/ + +theorem erase_dup_eq_of_nodup [decidable_eq A] : ∀ {l : list A}, nodup l → erase_dup l = l +| [] d := rfl +| (a::l) d := + have nainl : a ∉ l, from not_mem_of_nodup_cons d, + have dl : nodup l, from nodup_of_nodup_cons d, + sorry -- by rewrite [erase_dup_cons_of_not_mem nainl, erase_dup_eq_of_nodup dl] + +attribute [instance] +definition decidable_nodup [decidable_eq A] : ∀ (l : list A), decidable (nodup l) +| [] := tt nodup_nil +| (a::l) := + match (decidable_mem a l) with + | (tt p) := ff (not_nodup_cons_of_mem p) + | (ff n) := + match (decidable_nodup l) with + | (tt nd) := tt (nodup_cons n nd) + | (ff d) := ff (not_nodup_cons_of_not_nodup d) + end + end + +theorem nodup_product : ∀ {l₁ : list A} {l₂ : list B}, nodup l₁ → nodup l₂ → nodup (product l₁ l₂) +| [] l₂ n₁ n₂ := nodup_nil +| (a::l₁) l₂ n₁ n₂ := + have nainl₁ : a ∉ l₁, from not_mem_of_nodup_cons n₁, + have n₃ : nodup l₁, from nodup_of_nodup_cons n₁, + have n₄ : nodup (product l₁ l₂), from nodup_product n₃ n₂, + have dgen : ∀ l, nodup l → nodup (map (λ b, (a, b)) l) + | [] h := nodup_nil + | (x::l) h := + have dl : nodup l, from nodup_of_nodup_cons h, + have dm : nodup (map (λ b, (a, b)) l), from dgen l dl, + have nxin : x ∉ l, from not_mem_of_nodup_cons h, + have npin : (a, x) ∉ map (λ b, (a, b)) l, from + assume pin, absurd (mem_of_mem_map_pair₁ pin) nxin, + nodup_cons npin dm, + have dm : nodup (map (λ b, (a, b)) l₂), from dgen l₂ n₂, + have dsj : disjoint (map (λ b, (a, b)) l₂) (product l₁ l₂), from + λ p, match p with + | (a₁, b₁) := + λ (i₁ : (a₁, b₁) ∈ map (λ b, (a, b)) l₂) (i₂ : (a₁, b₁) ∈ product l₁ l₂), + have a₁inl₁ : a₁ ∈ l₁, from mem_of_mem_product_left i₂, + have a₁eqa : a₁ = a, from eq_of_mem_map_pair₁ i₁, + absurd (a₁eqa ▸ a₁inl₁) nainl₁ + end, + nodup_append_of_nodup_of_nodup_of_disjoint dm n₄ dsj + +theorem nodup_filter (p : A → Prop) [decidable_pred p] : ∀ {l : list A}, nodup l → nodup (filter p l) +:= sorry +/- +| [] nd := nodup_nil +| (a::l) nd := + have nainl : a ∉ l, from not_mem_of_nodup_cons nd, + have ndl : nodup l, from nodup_of_nodup_cons nd, + have ndf : nodup (filter p l), from nodup_filter ndl, + have nainf : a ∉ filter p l, from + assume ainf, absurd (mem_of_mem_filter ainf) nainl, + by_cases + (λ pa : p a, by rewrite [filter_cons_of_pos _ pa]; exact (nodup_cons nainf ndf)) + (λ npa : ¬ p a, by rewrite [filter_cons_of_neg _ npa]; exact ndf) +-/ + +lemma dmap_nodup_of_dinj {p : A → Prop} [h : decidable_pred p] {f : Π a, p a → B} (Pdi : dinj p f): + ∀ {l : list A}, nodup l → nodup (dmap p f l) +:= sorry +/- +| [] := take P, nodup.ndnil +| (a::l) := take Pnodup, + decidable.rec_on (h a) + (λ Pa, + begin + rewrite [dmap_cons_of_pos Pa], + apply nodup_cons, + apply (not_mem_dmap_of_dinj_of_not_mem Pdi Pa), + exact not_mem_of_nodup_cons Pnodup, + exact dmap_nodup_of_dinj (nodup_of_nodup_cons Pnodup) + end) + (λ nPa, + begin + rewrite [dmap_cons_of_neg nPa], + exact dmap_nodup_of_dinj (nodup_of_nodup_cons Pnodup) + end) +-/ +end nodup + +/- upto -/ +definition upto : nat → list nat +| 0 := [] +| (n+1) := n :: upto n + +theorem upto_nil : upto 0 = nil := rfl + +theorem upto_succ (n : nat) : upto (succ n) = n :: upto n := rfl + +theorem length_upto : ∀ n, length (upto n) = n +:= sorry +/- +| 0 := rfl +| (succ n) := by rewrite [upto_succ, length_cons, length_upto] +-/ + +theorem upto_ne_nil_of_ne_zero {n : ℕ} (H : n ≠ 0) : upto n ≠ nil := +sorry +/- +suppose upto n = nil, +have upto n = upto 0, from upto_nil ▸ this, +have n = 0, from calc + n = length (upto n) : by rewrite length_upto + ... = length (upto 0) : by rewrite this + ... = 0 : by rewrite length_upto, +H this +-/ + +theorem upto_less : ∀ n, all (upto n) (λ i, i < n) +| 0 := trivial +| (succ n) := + have alln : all (upto n) (λ i, i < n), from upto_less n, + all_cons_of_all (lt.base n) (all_implies alln (λ x h, lt.step h)) + +theorem nodup_upto : ∀ n, nodup (upto n) +| 0 := nodup_nil +| (n+1) := + have d : nodup (upto n), from nodup_upto n, + have n : n ∉ upto n, from + assume i : n ∈ upto n, absurd (of_mem_of_all i (upto_less n)) (nat.lt_irrefl n), + nodup_cons n d + +theorem lt_of_mem_upto {n i : nat} : i ∈ upto n → i < n := +assume i, of_mem_of_all i (upto_less n) + +theorem mem_upto_succ_of_mem_upto {n i : nat} : i ∈ upto n → i ∈ upto (succ n) := +assume i, mem_cons_of_mem _ i + +theorem mem_upto_of_lt : ∀ {n i : nat}, i < n → i ∈ upto n +| 0 i h := absurd h (not_lt_zero i) +| (succ n) i h := +sorry +/- +begin + cases h with m h', + { rewrite upto_succ, apply mem_cons}, + { exact mem_upto_succ_of_mem_upto (mem_upto_of_lt h')} +end +-/ +lemma upto_step : ∀ {n : nat}, upto (succ n) = (map succ (upto n))++[0] +| 0 := rfl +| (succ n) := sorry -- begin rewrite [upto_succ n, map_cons, append_cons, -upto_step] end + +/- union -/ +section union +variable {A : Type} +variable [H : decidable_eq A] +include H + +definition union : list A → list A → list A +| [] l₂ := l₂ +| (a::l₁) l₂ := if a ∈ l₂ then union l₁ l₂ else a :: union l₁ l₂ + +theorem nil_union (l : list A) : union [] l = l := rfl + +theorem union_cons_of_mem {a : A} {l₂} : ∀ (l₁), a ∈ l₂ → union (a::l₁) l₂ = union l₁ l₂ := +take l₁, assume ainl₂, calc + union (a::l₁) l₂ = if a ∈ l₂ then union l₁ l₂ else a :: union l₁ l₂ : rfl + ... = union l₁ l₂ : if_pos ainl₂ + +theorem union_cons_of_not_mem {a : A} {l₂} : ∀ (l₁), a ∉ l₂ → union (a::l₁) l₂ = a :: union l₁ l₂ := +take l₁, assume nainl₂, calc + union (a::l₁) l₂ = if a ∈ l₂ then union l₁ l₂ else a :: union l₁ l₂ : rfl + ... = a :: union l₁ l₂ : if_neg nainl₂ + +theorem union_nil : ∀ (l : list A), union l [] = l +| [] := nil_union nil +| (a::l) := sorry -- by rewrite [union_cons_of_not_mem _ !not_mem_nil, union_nil] + +theorem mem_or_mem_of_mem_union : ∀ {l₁ l₂} {a : A}, a ∈ union l₁ l₂ → a ∈ l₁ ∨ a ∈ l₂ +:= sorry +/- +| [] l₂ a ainl₂ := by rewrite nil_union at ainl₂; exact (or.inr (ainl₂)) +| (b::l₁) l₂ a ainbl₁l₂ := by_cases + (λ binl₂ : b ∈ l₂, + have ainl₁l₂ : a ∈ union l₁ l₂, by rewrite [union_cons_of_mem l₁ binl₂ at ainbl₁l₂]; exact ainbl₁l₂, + or.elim (mem_or_mem_of_mem_union ainl₁l₂) + (λ ainl₁, or.inl (mem_cons_of_mem _ ainl₁)) + (λ ainl₂, or.inr ainl₂)) + (λ nbinl₂ : b ∉ l₂, + have ainb_l₁l₂ : a ∈ b :: union l₁ l₂, by rewrite [union_cons_of_not_mem l₁ nbinl₂ at ainbl₁l₂]; exact ainbl₁l₂, + or.elim (eq_or_mem_of_mem_cons ainb_l₁l₂) + (λ aeqb, by rewrite aeqb; exact (or.inl !mem_cons)) + (λ ainl₁l₂, + or.elim (mem_or_mem_of_mem_union ainl₁l₂) + (λ ainl₁, or.inl (mem_cons_of_mem _ ainl₁)) + (λ ainl₂, or.inr ainl₂))) +-/ + +theorem mem_union_right {a : A} : ∀ (l₁) {l₂}, a ∈ l₂ → a ∈ union l₁ l₂ +:= sorry +/- +| [] l₂ h := by rewrite nil_union; exact h +| (b::l₁) l₂ h := by_cases + (λ binl₂ : b ∈ l₂, by rewrite [union_cons_of_mem _ binl₂]; exact (mem_union_right _ h)) + (λ nbinl₂ : b ∉ l₂, by rewrite [union_cons_of_not_mem _ nbinl₂]; exact (mem_cons_of_mem _ (mem_union_right _ h))) +-/ + +theorem mem_union_left {a : A} : ∀ {l₁} (l₂), a ∈ l₁ → a ∈ union l₁ l₂ +:= sorry +/- +| [] l₂ h := absurd h !not_mem_nil +| (b::l₁) l₂ h := by_cases + (λ binl₂ : b ∈ l₂, or.elim (eq_or_mem_of_mem_cons h) + (λ aeqb : a = b, + by rewrite [union_cons_of_mem l₁ binl₂, -aeqb at binl₂]; exact (mem_union_right _ binl₂)) + (λ ainl₁ : a ∈ l₁, + by rewrite [union_cons_of_mem l₁ binl₂]; exact (mem_union_left _ ainl₁))) + (λ nbinl₂ : b ∉ l₂, or.elim (eq_or_mem_of_mem_cons h) + (λ aeqb : a = b, + by rewrite [union_cons_of_not_mem l₁ nbinl₂, aeqb]; exact !mem_cons) + (λ ainl₁ : a ∈ l₁, + by rewrite [union_cons_of_not_mem l₁ nbinl₂]; exact (mem_cons_of_mem _ (mem_union_left _ ainl₁)))) +-/ + +theorem mem_union_cons (a : A) (l₁ : list A) (l₂ : list A) : a ∈ union (a::l₁) l₂ := +sorry +/- +by_cases + (λ ainl₂ : a ∈ l₂, mem_union_right _ ainl₂) + (λ nainl₂ : a ∉ l₂, by rewrite [union_cons_of_not_mem _ nainl₂]; exact !mem_cons) +-/ + +theorem nodup_union_of_nodup_of_nodup : ∀ {l₁ l₂ : list A}, nodup l₁ → nodup l₂ → nodup (union l₁ l₂) +:= sorry +/- +| [] l₂ n₁ nl₂ := by rewrite nil_union; exact nl₂ +| (a::l₁) l₂ nal₁ nl₂ := + have nl₁ : nodup l₁, from nodup_of_nodup_cons nal₁, + have nl₁l₂ : nodup (union l₁ l₂), from nodup_union_of_nodup_of_nodup nl₁ nl₂, + by_cases + (λ ainl₂ : a ∈ l₂, + by rewrite [union_cons_of_mem l₁ ainl₂]; exact nl₁l₂) + (λ nainl₂ : a ∉ l₂, + have nainl₁ : a ∉ l₁, from not_mem_of_nodup_cons nal₁, + have nainl₁l₂ : a ∉ union l₁ l₂, from + assume ainl₁l₂ : a ∈ union l₁ l₂, or.elim (mem_or_mem_of_mem_union ainl₁l₂) + (λ ainl₁, absurd ainl₁ nainl₁) + (λ ainl₂, absurd ainl₂ nainl₂), + by rewrite [union_cons_of_not_mem l₁ nainl₂]; exact (nodup_cons nainl₁l₂ nl₁l₂)) +-/ + +theorem union_eq_append : ∀ {l₁ l₂ : list A}, disjoint l₁ l₂ → union l₁ l₂ = append l₁ l₂ +:= sorry +/- +| [] l₂ d := rfl +| (a::l₁) l₂ d := + have nainl₂ : a ∉ l₂, from disjoint_left d !mem_cons, + have d₁ : disjoint l₁ l₂, from disjoint_of_disjoint_cons_left d, + by rewrite [union_cons_of_not_mem _ nainl₂, append_cons, union_eq_append d₁] +-/ + +theorem all_union {p : A → Prop} : ∀ {l₁ l₂ : list A}, all l₁ p → all l₂ p → all (union l₁ l₂) p +:= sorry +/- +| [] l₂ h₁ h₂ := h₂ +| (a::l₁) l₂ h₁ h₂ := + have h₁' : all l₁ p, from all_of_all_cons h₁, + have pa : p a, from of_all_cons h₁, + have au : all (union l₁ l₂) p, from all_union h₁' h₂, + have au' : all (a :: union l₁ l₂) p, from all_cons_of_all pa au, + by_cases + (λ ainl₂ : a ∈ l₂, by rewrite [union_cons_of_mem _ ainl₂]; exact au) + (λ nainl₂ : a ∉ l₂, by rewrite [union_cons_of_not_mem _ nainl₂]; exact au') +-/ + +theorem all_of_all_union_left {p : A → Prop} : ∀ {l₁ l₂ : list A}, all (union l₁ l₂) p → all l₁ p +:= sorry +/- +| [] l₂ h := trivial +| (a::l₁) l₂ h := + have ain : a ∈ union (a::l₁) l₂, from !mem_union_cons, + have pa : p a, from of_mem_of_all ain h, + by_cases + (λ ainl₂ : a ∈ l₂, + have al₁l₂ : all (union l₁ l₂) p, by rewrite [union_cons_of_mem _ ainl₂ at h]; exact h, + have al₁ : all l₁ p, from all_of_all_union_left al₁l₂, + all_cons_of_all pa al₁) + (λ nainl₂ : a ∉ l₂, + have aal₁l₂ : all (a::union l₁ l₂) p, by rewrite [union_cons_of_not_mem _ nainl₂ at h]; exact h, + have al₁l₂ : all (union l₁ l₂) p, from all_of_all_cons aal₁l₂, + have al₁ : all l₁ p, from all_of_all_union_left al₁l₂, + all_cons_of_all pa al₁) +-/ + +theorem all_of_all_union_right {p : A → Prop} : ∀ {l₁ l₂ : list A}, all (union l₁ l₂) p → all l₂ p +:= sorry +/- +| [] l₂ h := by rewrite [nil_union at h]; exact h +| (a::l₁) l₂ h := by_cases + (λ ainl₂ : a ∈ l₂, by rewrite [union_cons_of_mem _ ainl₂ at h]; exact (all_of_all_union_right h)) + (λ nainl₂ : a ∉ l₂, + have h₁ : all (a :: union l₁ l₂) p, by rewrite [union_cons_of_not_mem _ nainl₂ at h]; exact h, + all_of_all_union_right (all_of_all_cons h₁)) +-/ + +variable {B : Type} +theorem foldl_union_of_disjoint (f : B → A → B) (b : B) {l₁ l₂ : list A} (d : disjoint l₁ l₂) + : foldl f b (union l₁ l₂) = foldl f (foldl f b l₁) l₂ := +sorry -- by rewrite [union_eq_append d, foldl_append] + +theorem foldr_union_of_dijoint (f : A → B → B) (b : B) {l₁ l₂ : list A} (d : disjoint l₁ l₂) + : foldr f b (union l₁ l₂) = foldr f (foldr f b l₂) l₁ := +sorry -- by rewrite [union_eq_append d, foldr_append] +end union + +/- insert -/ +section insert +variable {A : Type} +variable [H : decidable_eq A] +include H + +definition insert (a : A) (l : list A) : list A := +if a ∈ l then l else a::l + +theorem insert_eq_of_mem {a : A} {l : list A} : a ∈ l → insert a l = l := +assume ainl, if_pos ainl + +theorem insert_eq_of_not_mem {a : A} {l : list A} : a ∉ l → insert a l = a::l := +assume nainl, if_neg nainl + +theorem mem_insert (a : A) (l : list A) : a ∈ insert a l := +sorry +/- +by_cases + (λ ainl : a ∈ l, by rewrite [insert_eq_of_mem ainl]; exact ainl) + (λ nainl : a ∉ l, by rewrite [insert_eq_of_not_mem nainl]; exact !mem_cons) +-/ + +theorem mem_insert_of_mem {a : A} (b : A) {l : list A} : a ∈ l → a ∈ insert b l := +sorry +/- +assume ainl, by_cases + (λ binl : b ∈ l, by rewrite [insert_eq_of_mem binl]; exact ainl) + (λ nbinl : b ∉ l, by rewrite [insert_eq_of_not_mem nbinl]; exact (mem_cons_of_mem _ ainl)) +-/ + +theorem eq_or_mem_of_mem_insert {x a : A} {l : list A} (H : x ∈ insert a l) : x = a ∨ x ∈ l := +decidable.by_cases + (assume H3: a ∈ l, or.inr (insert_eq_of_mem H3 ▸ H)) + (assume H3: a ∉ l, + have H4: x ∈ a :: l, from insert_eq_of_not_mem H3 ▸ H, + iff.mp (mem_cons_iff x a l) H4) + +theorem mem_insert_iff (x a : A) (l : list A) : x ∈ insert a l ↔ x = a ∨ x ∈ l := +iff.intro + eq_or_mem_of_mem_insert + (assume H, or.elim H + (assume H' : x = a, eq.symm H' ▸ mem_insert a l) + (assume H' : x ∈ l, mem_insert_of_mem a H')) + +theorem nodup_insert (a : A) {l : list A} : nodup l → nodup (insert a l) := +sorry +/- +assume n, by_cases + (λ ainl : a ∈ l, by rewrite [insert_eq_of_mem ainl]; exact n) + (λ nainl : a ∉ l, by rewrite [insert_eq_of_not_mem nainl]; exact (nodup_cons nainl n)) +-/ + +theorem length_insert_of_mem {a : A} {l : list A} : a ∈ l → length (insert a l) = length l := +sorry -- assume ainl, by rewrite [insert_eq_of_mem ainl] + +theorem length_insert_of_not_mem {a : A} {l : list A} : a ∉ l → length (insert a l) = length l + 1 := +sorry -- assume nainl, by rewrite [insert_eq_of_not_mem nainl] + +theorem all_insert_of_all {p : A → Prop} {a : A} {l} : p a → all l p → all (insert a l) p := +sorry +/- +assume h₁ h₂, by_cases + (λ ainl : a ∈ l, by rewrite [insert_eq_of_mem ainl]; exact h₂) + (λ nainl : a ∉ l, by rewrite [insert_eq_of_not_mem nainl]; exact (all_cons_of_all h₁ h₂)) +-/ +end insert + +/- inter -/ +section inter +variable {A : Type} +variable [H : decidable_eq A] +include H + +definition inter : list A → list A → list A +| [] l₂ := [] +| (a::l₁) l₂ := if a ∈ l₂ then a :: inter l₁ l₂ else inter l₁ l₂ + +theorem inter_nil (l : list A) : inter [] l = [] := rfl + +theorem inter_cons_of_mem {a : A} (l₁ : list A) {l₂} : a ∈ l₂ → inter (a::l₁) l₂ = a :: inter l₁ l₂ := +assume i, if_pos i + +theorem inter_cons_of_not_mem {a : A} (l₁ : list A) {l₂} : a ∉ l₂ → inter (a::l₁) l₂ = inter l₁ l₂ := +assume i, if_neg i + +theorem mem_of_mem_inter_left : ∀ {l₁ l₂} {a : A}, a ∈ inter l₁ l₂ → a ∈ l₁ +:= sorry +/- +| [] l₂ a i := absurd i !not_mem_nil +| (b::l₁) l₂ a i := by_cases + (λ binl₂ : b ∈ l₂, + have aux : a ∈ b :: inter l₁ l₂, by rewrite [inter_cons_of_mem _ binl₂ at i]; exact i, + or.elim (eq_or_mem_of_mem_cons aux) + (λ aeqb : a = b, by rewrite [aeqb]; exact !mem_cons) + (λ aini, mem_cons_of_mem _ (mem_of_mem_inter_left aini))) + (λ nbinl₂ : b ∉ l₂, + have ainl₁ : a ∈ l₁, by rewrite [inter_cons_of_not_mem _ nbinl₂ at i]; exact (mem_of_mem_inter_left i), + mem_cons_of_mem _ ainl₁) +-/ + +theorem mem_of_mem_inter_right : ∀ {l₁ l₂} {a : A}, a ∈ inter l₁ l₂ → a ∈ l₂ +:= sorry +/- +| [] l₂ a i := absurd i !not_mem_nil +| (b::l₁) l₂ a i := by_cases + (λ binl₂ : b ∈ l₂, + have aux : a ∈ b :: inter l₁ l₂, by rewrite [inter_cons_of_mem _ binl₂ at i]; exact i, + or.elim (eq_or_mem_of_mem_cons aux) + (λ aeqb : a = b, by rewrite [aeqb]; exact binl₂) + (λ aini : a ∈ inter l₁ l₂, mem_of_mem_inter_right aini)) + (λ nbinl₂ : b ∉ l₂, + by rewrite [inter_cons_of_not_mem _ nbinl₂ at i]; exact (mem_of_mem_inter_right i)) +-/ + +theorem mem_inter_of_mem_of_mem : ∀ {l₁ l₂} {a : A}, a ∈ l₁ → a ∈ l₂ → a ∈ inter l₁ l₂ +:= sorry +/- +| [] l₂ a i₁ i₂ := absurd i₁ !not_mem_nil +| (b::l₁) l₂ a i₁ i₂ := by_cases + (λ binl₂ : b ∈ l₂, + or.elim (eq_or_mem_of_mem_cons i₁) + (λ aeqb : a = b, + by rewrite [inter_cons_of_mem _ binl₂, aeqb]; exact !mem_cons) + (λ ainl₁ : a ∈ l₁, + by rewrite [inter_cons_of_mem _ binl₂]; + apply mem_cons_of_mem; + exact (mem_inter_of_mem_of_mem ainl₁ i₂))) + (λ nbinl₂ : b ∉ l₂, + or.elim (eq_or_mem_of_mem_cons i₁) + (λ aeqb : a = b, absurd (aeqb ▸ i₂) nbinl₂) + (λ ainl₁ : a ∈ l₁, + by rewrite [inter_cons_of_not_mem _ nbinl₂]; exact (mem_inter_of_mem_of_mem ainl₁ i₂))) +-/ + +theorem nodup_inter_of_nodup : ∀ {l₁ : list A} (l₂), nodup l₁ → nodup (inter l₁ l₂) +:= sorry +/- +| [] l₂ d := nodup_nil +| (a::l₁) l₂ d := + have d₁ : nodup l₁, from nodup_of_nodup_cons d, + have d₂ : nodup (inter l₁ l₂), from nodup_inter_of_nodup _ d₁, + have nainl₁ : a ∉ l₁, from not_mem_of_nodup_cons d, + have naini : a ∉ inter l₁ l₂, from λ i, absurd (mem_of_mem_inter_left i) nainl₁, + by_cases + (λ ainl₂ : a ∈ l₂, by rewrite [inter_cons_of_mem _ ainl₂]; exact (nodup_cons naini d₂)) + (λ nainl₂ : a ∉ l₂, by rewrite [inter_cons_of_not_mem _ nainl₂]; exact d₂) +-/ + +theorem inter_eq_nil_of_disjoint : ∀ {l₁ l₂ : list A}, disjoint l₁ l₂ → inter l₁ l₂ = [] +:= sorry +/- +| [] l₂ d := rfl +| (a::l₁) l₂ d := + have aux_eq : inter l₁ l₂ = [], from inter_eq_nil_of_disjoint (disjoint_of_disjoint_cons_left d), + have nainl₂ : a ∉ l₂, from disjoint_left d !mem_cons, + by rewrite [inter_cons_of_not_mem _ nainl₂, aux_eq] +-/ + +theorem all_inter_of_all_left {p : A → Prop} : ∀ {l₁} (l₂), all l₁ p → all (inter l₁ l₂) p +:= sorry +/- +| [] l₂ h := trivial +| (a::l₁) l₂ h := + have h₁ : all l₁ p, from all_of_all_cons h, + have h₂ : all (inter l₁ l₂) p, from all_inter_of_all_left _ h₁, + have pa : p a, from of_all_cons h, + have h₃ : all (a :: inter l₁ l₂) p, from all_cons_of_all pa h₂, + by_cases + (λ ainl₂ : a ∈ l₂, by rewrite [inter_cons_of_mem _ ainl₂]; exact h₃) + (λ nainl₂ : a ∉ l₂, by rewrite [inter_cons_of_not_mem _ nainl₂]; exact h₂) +-/ + +theorem all_inter_of_all_right {p : A → Prop} : ∀ (l₁) {l₂}, all l₂ p → all (inter l₁ l₂) p +:= sorry +/- +| [] l₂ h := trivial +| (a::l₁) l₂ h := + have h₁ : all (inter l₁ l₂) p, from all_inter_of_all_right _ h, + by_cases + (λ ainl₂ : a ∈ l₂, + have pa : p a, from of_mem_of_all ainl₂ h, + have h₂ : all (a :: inter l₁ l₂) p, from all_cons_of_all pa h₁, + by rewrite [inter_cons_of_mem _ ainl₂]; exact h₂) + (λ nainl₂ : a ∉ l₂, by rewrite [inter_cons_of_not_mem _ nainl₂]; exact h₁) +-/ + +end inter +end list diff --git a/old_library/data/list/sort.lean b/old_library/data/list/sort.lean new file mode 100644 index 0000000000..7f63a5ea2e --- /dev/null +++ b/old_library/data/list/sort.lean @@ -0,0 +1,227 @@ +/- +Copyright (c) 2015 Leonardo de Moura. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Naive sort for lists +-/ +import data.list.comb data.list.set data.list.perm data.list.sorted logic.connectives algebra.order + +namespace list +open decidable nat + +variables {B A : Type} +variable (R : A → A → Prop) +variable [decR : decidable_rel R] +include decR + +definition min_core : list A → A → A +| [] a := a +| (b::l) a := if R b a then min_core l b else min_core l a + +definition min : Π (l : list A), l ≠ nil → A +| [] h := absurd rfl h +| (a::l) h := min_core R l a + +variable [decA : decidable_eq A] +include decA + +variable {R} +variables (to : total R) (tr : transitive R) (rf : reflexive R) + +section +include to tr rf +lemma min_core_lemma : ∀ {b l} a, b ∈ l ∨ b = a → R (min_core R l a) b +:= sorry +end + +/- +| b [] a h := or.elim h + (suppose b ∈ [], absurd this !not_mem_nil) + (suppose b = a, + have R a a, from rf a, + begin subst b, unfold min_core, assumption end) +| b (c::l) a h := or.elim h + (suppose b ∈ c :: l, or.elim (eq_or_mem_of_mem_cons this) + (suppose b = c, + or.elim (em (R c a)) + (suppose R c a, + have R (min_core R l b) b, from min_core_lemma _ (or.inr rfl), + begin unfold min_core, rewrite [if_pos `R c a`], subst c, eassumption end) + (suppose ¬ R c a, + have R a c, from or_resolve_right (to c a) this, + have R (min_core R l a) a, from min_core_lemma _ (or.inr rfl), + have R (min_core R l a) c, from tr this `R a c`, + begin unfold min_core, rewrite [if_neg `¬ R c a`], subst b, exact `R (min_core R l a) c` end)) + (suppose b ∈ l, + or.elim (em (R c a)) + (suppose R c a, + have R (min_core R l c) b, from min_core_lemma _ (or.inl `b ∈ l`), + begin unfold min_core, rewrite [if_pos `R c a`], eassumption end) + (suppose ¬ R c a, + have R (min_core R l a) b, from min_core_lemma _ (or.inl `b ∈ l`), + begin unfold min_core, rewrite [if_neg `¬ R c a`], eassumption end))) + (suppose b = a, + have R (min_core R l a) b, from min_core_lemma _ (or.inr this), + or.elim (em (R c a)) + (suppose R c a, + have R (min_core R l c) c, from min_core_lemma _ (or.inr rfl), + have R (min_core R l c) a, from tr this `R c a`, + begin unfold min_core, rewrite [if_pos `R c a`], subst b, exact `R (min_core R l c) a` end) + (suppose ¬ R c a, begin unfold min_core, rewrite [if_neg `¬ R c a`], eassumption end)) +-/ + +lemma min_core_le_of_mem {b : A} {l : list A} (a : A) : b ∈ l → R (min_core R l a) b := +assume h : b ∈ l, min_core_lemma to tr rf a (or.inl h) + +lemma min_core_le {l : list A} (a : A) : R (min_core R l a) a := +min_core_lemma to tr rf a (or.inr rfl) + +lemma min_lemma : ∀ {l} (h : l ≠ nil), all l (R (min R l h)) +| [] h := absurd rfl h +| (b::l) h := + all_of_forall (take x, suppose x ∈ b::l, + or.elim (eq_or_mem_of_mem_cons this) + (suppose x = b, + have R (min_core R l b) b, from min_core_le to tr rf b, + sorry) -- begin subst x, unfold min, assumption end) + (suppose x ∈ l, + have R (min_core R l b) x, from min_core_le_of_mem to tr rf _ this, + sorry)) -- begin unfold min, assumption end)) + +variable (R) + +lemma min_core_mem : ∀ l a, min_core R l a ∈ l ∨ min_core R l a = a +| [] a := or.inr rfl +| (b::l) a := + sorry + /- + or.elim (em (R b a)) + (suppose R b a, + begin + change (if R b a then min_core R l b else min_core R l a) ∈ b :: l ∨ (if R b a then min_core R l b else min_core R l a) = a, + rewrite [if_pos `R b a`], + apply or.elim (min_core_mem l b), + suppose min_core R l b ∈ l, or.inl (mem_cons_of_mem _ this), + suppose min_core R l b = b, by rewrite this; exact or.inl !mem_cons + end) + (suppose ¬ R b a, + begin + unfold min_core, rewrite [if_neg `¬ R b a`], + apply or.elim (min_core_mem l a), + suppose min_core R l a ∈ l, or.inl (mem_cons_of_mem _ this), + suppose min_core R l a = a, or.inr this + end) + -/ + +lemma min_mem : ∀ (l : list A) (h : l ≠ nil), min R l h ∈ l +| [] h := absurd rfl h +| (a::l) h := + sorry + /- + begin + unfold min, + apply or.elim (min_core_mem R l a), + suppose min_core R l a ∈ l, mem_cons_of_mem _ this, + suppose min_core R l a = a, by rewrite this; apply mem_cons + end + -/ + +section +include to tr rf +lemma min_map (f : B → A) {l : list B} (h : l ≠ nil) : + all l (λ b, (R (min R (map f l) (map_ne_nil_of_ne_nil _ h))) (f b)):= +sorry +end + /- + begin + apply all_of_forall, + intro b Hb, + have Hfa : all (map f l) (R (min R (map f l) (map_ne_nil_of_ne_nil _ h))), from min_lemma to tr rf _, + have Hfb : f b ∈ map f l, from mem_map _ Hb, + exact of_mem_of_all Hfb Hfa + end + -/ +lemma min_map_all (f : B → A) {l : list B} (h : l ≠ nil) {b : B} (Hb : b ∈ l) : + R (min R (map f l) ((map_ne_nil_of_ne_nil _ h))) (f b) := + of_mem_of_all Hb (min_map _ to tr rf f h) + +omit decR +private lemma ne_nil {l : list A} {n : nat} : length l = succ n → l ≠ nil := +sorry -- assume h₁ h₂, by rewrite h₂ at h₁; contradiction + +include decR +lemma sort_aux_lemma {l n} (h : length l = succ n) : length (erase (min R l (ne_nil h)) l) = n := +have min R l _ ∈ l, from min_mem R l (ne_nil h), +have length (erase (min R l _) l) = pred (length l), from length_erase_of_mem this, +sorry -- by rewrite h at this; exact this + +definition sort_aux : Π (n : nat) (l : list A), length l = n → list A +| 0 l h := [] +| (succ n) l h := + let m := min R l (ne_nil h) in + let l₁ := erase m l in + m :: sort_aux n l₁ (sort_aux_lemma R h) + +definition sort (l : list A) : list A := +sort_aux R (length l) l rfl + +open perm + +lemma sort_aux_perm : ∀ {n : nat} {l : list A} (h : length l = n), sort_aux R n l h ~ l +| 0 l h := + sorry + /- + begin + change [] ~ l, + rewrite [eq_nil_of_length_eq_zero h] + end + -/ +| (succ n) l h := + let m := min R l (ne_nil h) in + have leq : length (erase m l) = n, from sort_aux_lemma R h, + calc m :: sort_aux R n (erase m l) leq + ~ m :: erase m l : perm.skip m (sort_aux_perm leq) + ... ~ l : perm.symm (perm_erase (min_mem _ _ _)) + +lemma sort_perm (l : list A) : sort R l ~ l := +sort_aux_perm R rfl + +lemma strongly_sorted_sort_aux : ∀ {n : nat} {l : list A} (h : length l = n), strongly_sorted R (sort_aux R n l h) +| 0 l h := strongly_sorted.base R +| (succ n) l h := + let m := min R l (ne_nil h) in + have leq : length (erase m l) = n, from sort_aux_lemma R h, + have ss : strongly_sorted R (sort_aux R n (erase m l) leq), from strongly_sorted_sort_aux leq, + have all l (R m), from min_lemma to tr rf (ne_nil h), + have hall : all (sort_aux R n (erase m l) leq) (R m), from + all_of_forall (take x, + suppose x ∈ sort_aux R n (erase m l) leq, + have x ∈ erase m l, from mem_perm (sort_aux_perm R leq) this, + have x ∈ l, from mem_of_mem_erase this, + show R m x, from of_mem_of_all this sorry), -- `all l (R m)`), + strongly_sorted.step hall ss + +variable {R} + +lemma strongly_sorted_sort_core (to : total R) (tr : transitive R) (rf : reflexive R) (l : list A) : strongly_sorted R (sort R l) := +@strongly_sorted_sort_aux _ _ _ _ to tr rf (length l) l rfl + +lemma sort_eq_of_perm_core {l₁ l₂ : list A} (to : total R) (tr : transitive R) (rf : reflexive R) (asy : anti_symmetric R) (h : l₁ ~ l₂) : sort R l₁ = sort R l₂ := +have s₁ : sorted R (sort R l₁), from sorted_of_strongly_sorted (strongly_sorted_sort_core to tr rf l₁), +have s₂ : sorted R (sort R l₂), from sorted_of_strongly_sorted (strongly_sorted_sort_core to tr rf l₂), +have p : sort R l₁ ~ sort R l₂, from calc + sort R l₁ ~ l₁ : sort_perm R l₁ + ... ~ l₂ : h + ... ~ sort R l₂ : perm.symm $ sort_perm R l₂, +eq_of_sorted_of_perm tr asy p s₁ s₂ + +section +omit decR +lemma strongly_sorted_sort [decidable_linear_order A] (l : list A) : strongly_sorted le (sort le l) := +strongly_sorted_sort_core le.total (@le.trans A _) le.refl l + +lemma sort_eq_of_perm {l₁ l₂ : list A} [decidable_linear_order A] (h : l₁ ~ l₂) : sort le l₁ = sort le l₂ := +sort_eq_of_perm_core le.total (@le.trans A _) le.refl (@le.antisymm A _) h +end +end list diff --git a/old_library/data/list/sorted.lean b/old_library/data/list/sorted.lean new file mode 100644 index 0000000000..84eb0d3ed9 --- /dev/null +++ b/old_library/data/list/sorted.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2015 Leonardo de Moura. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +import data.list.comb data.list.perm + +namespace list +variable {A : Type} +variable (R : A → A → Prop) + +inductive locally_sorted : list A → Prop := +| base0 : locally_sorted [] +| base : ∀ a, locally_sorted [a] +| step : ∀ {a b l}, R a b → locally_sorted (b::l) → locally_sorted (a::b::l) + +inductive hd_rel (a : A) : list A → Prop := +| base : hd_rel a [] +| step : ∀ {b} (l), R a b → hd_rel a (b::l) + +inductive sorted : list A → Prop := +| base : sorted [] +| step : ∀ {a : A} {l : list A}, hd_rel R a l → sorted l → sorted (a::l) + +variable {R} + +lemma hd_rel_inv : ∀ {a b l}, hd_rel R a (b::l) → R a b := +sorry -- begin intros a b l h, cases h, assumption end + +lemma sorted_inv : ∀ {a l}, sorted R (a::l) → hd_rel R a l ∧ sorted R l := +sorry -- begin intros a l h, cases h, split, repeat assumption end + +lemma sorted.rect_on {P : list A → Type} : ∀ {l}, sorted R l → P [] → (∀ a l, sorted R l → P l → hd_rel R a l → P (a::l)) → P l +| [] s h₁ h₂ := h₁ +| (a::l) s h₁ h₂ := + have aux₁ : hd_rel R a l, from and.left (sorted_inv s), + have aux₂ : sorted R l, from and.right (sorted_inv s), + have aux₃ : P l, from sorted.rect_on aux₂ h₁ h₂, + h₂ a l aux₂ aux₃ aux₁ + +lemma sorted_singleton (a : A) : sorted R [a] := +sorted.step (hd_rel.base R a) (sorted.base R) + +lemma sorted_of_locally_sorted : ∀ {l}, locally_sorted R l → sorted R l +| [] h := sorted.base R +| [a] h := sorted_singleton a +| (a::b::l) (locally_sorted.step h₁ h₂) := + have sorted R (b::l), from sorted_of_locally_sorted h₂, + sorted.step (hd_rel.step _ h₁) this + +lemma locally_sorted_of_sorted : ∀ {l}, sorted R l → locally_sorted R l +| [] h := locally_sorted.base0 R +| [a] h := locally_sorted.base R a +| (a::b::l) (sorted.step (hd_rel.step _ h₁) h₂) := + have locally_sorted R (b::l), from locally_sorted_of_sorted h₂, + locally_sorted.step h₁ this + +lemma locally_sorted_eq_sorted : @locally_sorted = @sorted := +funext (λ A, funext (λ R, funext (λ l, propext (iff.intro sorted_of_locally_sorted locally_sorted_of_sorted)))) + +variable (R) + +inductive strongly_sorted : list A → Prop := +| base : strongly_sorted [] +| step : ∀ {a : A} {l : list A}, all l (R a) → strongly_sorted l → strongly_sorted (a::l) + +variable {R} + +lemma sorted_of_strongly_sorted : ∀ {l}, strongly_sorted R l → sorted R l +| [] h := sorted.base R +| [a] h := sorted_singleton a +| (a::b::l) (strongly_sorted.step h₁ h₂) := + have aux : hd_rel R a (b::l), from hd_rel.step _ (of_all_cons h₁), + have sorted R (b::l), from sorted_of_strongly_sorted h₂, + sorted.step aux this + +lemma sorted_extends (trans : transitive R) : ∀ {a l}, sorted R (a::l) → all l (R a) +:= sorry +/- +| a [] h := !all_nil +| a (b::l) h := + have hd_rel R a (b::l), from and.left (sorted_inv h), + have R a b, from hd_rel_inv this, + have all l (R b), from sorted_extends (and.right (sorted_inv h)), + all_of_forall (take x, suppose x ∈ b::l, + or.elim (eq_or_mem_of_mem_cons this) + (suppose x = b, by subst x; assumption) + (suppose x ∈ l, + have R b x, from of_mem_of_all this `all l (R b)`, + trans `R a b` `R b x`)) +-/ + +theorem strongly_sorted_of_sorted_of_transitive (trans : transitive R) : ∀ {l}, sorted R l → strongly_sorted R l +| [] h := strongly_sorted.base R +| (a::l) h := + have sorted R l, from and.right (sorted_inv h), + have aux : strongly_sorted R l, from strongly_sorted_of_sorted_of_transitive this, + have all l (R a), from sorted_extends trans h, + strongly_sorted.step this aux + +open perm + +lemma eq_of_sorted_of_perm (tr : transitive R) (anti : anti_symmetric R) : ∀ {l₁ l₂ : list A}, l₁ ~ l₂ → sorted R l₁ → sorted R l₂ → l₁ = l₂ +:= sorry +/- +| [] [] h₁ h₂ h₃ := rfl +| (a₁::l₁) [] h₁ h₂ h₃ := absurd (perm.symm h₁) !not_perm_nil_cons +| [] (a₂::l₂) h₁ h₂ h₃ := absurd h₁ !not_perm_nil_cons +| (a::l₁) l₂ h₁ h₂ h₃ := + have aux : ∀ {t}, l₂ = a::t → a::l₁ = l₂, from + take t, suppose l₂ = a::t, + have l₁ ~ t, by rewrite [this at h₁]; apply perm_cons_inv h₁, + have sorted R l₁, from and.right (sorted_inv h₂), + have sorted R t, by rewrite [`l₂ = a::t` at h₃]; exact and.right (sorted_inv h₃), + have l₁ = t, from eq_of_sorted_of_perm `l₁ ~ t` `sorted R l₁` `sorted R t`, + show a :: l₁ = l₂, by rewrite [`l₂ = a::t`, this], + have a ∈ l₂, from mem_perm h₁ !mem_cons, + obtain s t (e₁ : l₂ = s ++ (a::t)), from mem_split this, + begin + cases s with b s, + { have l₂ = a::t, by exact e₁, + exact aux this }, + { have e₁ : l₂ = b::(s++(a::t)), by exact e₁, + have b ∈ l₂, by rewrite e₁; apply mem_cons, + have hall₂ : all (s++(a::t)) (R b), begin rewrite [e₁ at h₃], apply sorted_extends tr h₃ end, + have a ∈ s++(a::t), from mem_append_right _ !mem_cons, + have R b a, from of_mem_of_all this hall₂, + have b ∈ a::l₁, from mem_perm (perm.symm h₁) `b ∈ l₂`, + have hall₁ : all l₁ (R a), from sorted_extends tr h₂, + apply or.elim (eq_or_mem_of_mem_cons `b ∈ a::l₁`), + suppose b = a, by rewrite this at e₁; exact aux e₁, + suppose b ∈ l₁, + have R a b, from of_mem_of_all this hall₁, + have b = a, from anti `R b a` `R a b`, + by rewrite this at e₁; exact aux e₁ } + end +-/ +end list diff --git a/old_library/data/map.lean b/old_library/data/map.lean new file mode 100644 index 0000000000..72c1715f45 --- /dev/null +++ b/old_library/data/map.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +definition map (A B : Type) := A → option B + +namespace map +variables {A B : Type} +open tactic + +definition empty : map A B := +λ a, none + +definition lookup (k : A) (m : map A B) : option B := +m k + +theorem ext (m₁ m₂ : map A B) : (∀ a, lookup a m₁ = lookup a m₂) → m₁ = m₂ := +funext + +theorem lookup_empty (k : A) : lookup k (empty : map A B) = none := +rfl + +variable [decidable_eq A] + +definition insert (k : A) (v : B) (m : map A B) : map A B := +λ a, if a = k then some v else m a + +theorem lookup_insert (k : A) (v : B) (m : map A B) : lookup k (insert k v m) = some v := +by unfold [`map.insert, `map.lookup] >> dsimp >> rewrite `if_pos >> reflexivity + +theorem lookup_insert_of_ne {k₁ k₂ : A} (v : B) (m : map A B) : k₁ ≠ k₂ → lookup k₁ (insert k₂ v m) = lookup k₁ m := +by intros >> unfold [`map.insert, `map.lookup] >> dsimp >> rewrite `if_neg >> assumption + +definition erase (k : A) (m : map A B) : map A B := +λ a, if a = k then none else m a + +theorem lookup_erase (k : A) (v : B) (m : map A B) : lookup k (erase k m) = none := +by unfold [`map.erase, `map.lookup] >> dsimp >> rewrite `if_pos >> reflexivity + +theorem lookup_erase_of_ne {k₁ k₂ : A} (v : B) (m : map A B) : k₁ ≠ k₂ → lookup k₁ (erase k₂ m) = lookup k₁ m := +by intros >> unfold [`map.erase, `map.lookup] >> dsimp >> rewrite `if_neg >> assumption + +theorem erase_empty (k : A) : erase k empty = (empty : map A B) := +funext (λ a, by unfold [`map.erase, `map.empty] >> rewrite `if_t_t) + +theorem erase_insert {k : A} {m : map A B} (v : B) : lookup k m = none → erase k (insert k v m) = m := +assume h, funext (λ a, decidable.by_cases + (suppose a = k, by get_local `this >>= subst >> unfold [`map.erase, `map.insert] >> rewrite `if_pos >> symmetry >> assumption >> reflexivity) + (suppose a ≠ k, by unfold [`map.erase, `map.insert] >> rewrite `if_neg >> dsimp >> rewrite `if_neg >> repeat assumption)) + +end map diff --git a/old_library/data/matrix.lean b/old_library/data/matrix.lean new file mode 100644 index 0000000000..a24219638e --- /dev/null +++ b/old_library/data/matrix.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Matrices +-/ +import algebra.ring data.fin data.fintype +open fin nat + +attribute [reducible] +definition matrix (A : Type) (m n : nat) := fin m → fin n → A + +namespace matrix +variables {A B C : Type} {m n p : nat} + +attribute [reducible] +definition val (M : matrix A m n) (i : fin m) (j : fin n) : A := +M i j + +namespace ops +notation M `[` i `, ` j `]` := val M i j +end ops + +open ops + +protected lemma ext {M N : matrix A m n} (h : ∀ i j, M[i,j] = N[i, j]) : M = N := +funext (λ i, funext (λ j, h i j)) + +protected lemma has_decidable_eq [h : decidable_eq A] (m n : nat) : decidable_eq (matrix A m n) := +_ + +definition to_matrix (f : fin m → fin n → A) : matrix A m n := +f + +definition map (f : A → B) (M : matrix A m n) : matrix B m n := +λ i j, f (M[i,j]) + +definition map₂ (f : A → B → C) (M : matrix A m n) (N : matrix B m n) : matrix C m n := +λ i j, f (M[i, j]) (N[i,j]) + +definition transpose (M : matrix A m n) : matrix A n m := +λ i j, M[j, i] + +definition symmetric (M : matrix A n n) := +transpose M = M + +section +variable [r : comm_ring A] +include r + +definition identity (n : nat) : matrix A n n := +λ i j, if i = j then 1 else 0 + +definition I {n : nat} : matrix A n n := +identity n + +protected definition zero (m n : nat) : matrix A m n := +λ i j, 0 + +protected definition add (M : matrix A m n) (N : matrix A m n) : matrix A m n := +λ i j, M[i, j] + N[i, j] + +protected definition sub (M : matrix A m n) (N : matrix A m n) : matrix A m n := +λ i j, M[i, j] - N[i, j] + +protected definition mul (M : matrix A m n) (N : matrix A n p) : matrix A m p := +λ i j, fin.foldl has_add.add 0 (λ k : fin n, M[i,k] * N[k,j]) + +definition smul (a : A) (M : matrix A m n) : matrix A m n := +λ i j, a * M[i, j] + +attribute [instance] +definition matrix_has_zero (m n : nat) : has_zero (matrix A m n) := +has_zero.mk (matrix.zero m n) + +attribute [instance] +definition matrix_has_one (n : nat) : has_one (matrix A n n) := +has_one.mk (identity n) + +attribute [instance] +definition matrix_has_add (m n : nat) : has_add (matrix A m n) := +has_add.mk matrix.add + +attribute [instance] +definition matrix_has_mul (n : nat) : has_mul (matrix A n n) := +has_mul.mk matrix.mul + +infix ` × ` := mul +infix `⬝` := smul + +protected lemma add_zero (M : matrix A m n) : M + 0 = M := +matrix.ext (λ i j, !add_zero) + +protected lemma zero_add (M : matrix A m n) : 0 + M = M := +matrix.ext (λ i j, !zero_add) + +protected lemma add.comm (M : matrix A m n) (N : matrix A m n) : M + N = N + M := +matrix.ext (λ i j, !add.comm) + +protected lemma add.assoc (M : matrix A m n) (N : matrix A m n) (P : matrix A m n) : (M + N) + P = M + (N + P) := +matrix.ext (λ i j, !add.assoc) + +definition is_diagonal (M : matrix A n n) := +∀ i j, i = j ∨ M[i, j] = 0 + +definition is_zero (M : matrix A m n) := +∀ i j, M[i, j] = 0 + +definition is_upper_triangular (M : matrix A n n) := +∀ i j : fin n, i > j → M[i, j] = 0 + +definition is_lower_triangular (M : matrix A n n) := +∀ i j : fin n, i < j → M[i, j] = 0 + +definition inverse (M : matrix A n n) (N : matrix A n n) := +M * N = I ∧ N * M = I + +definition invertible (M : matrix A n n) := +∃ N, inverse M N + +end +end matrix diff --git a/old_library/data/nat/basic.lean b/old_library/data/nat/basic.lean new file mode 100644 index 0000000000..7a1621589c --- /dev/null +++ b/old_library/data/nat/basic.lean @@ -0,0 +1,288 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad + +Basic operations on the natural numbers. +-/ +import ..num algebra.ring +open binary + +namespace nat + +/- a variant of add, defined by recursion on the first argument -/ + +definition addl (x y : ℕ) : ℕ := +nat.rec y (λ n r, succ r) x +infix ` ⊕ `:65 := addl + +theorem addl_succ_right (n m : ℕ) : n ⊕ succ m = succ (n ⊕ m) := +nat.induction_on n + rfl + (λ n₁ ih, calc + succ n₁ ⊕ succ m = succ (n₁ ⊕ succ m) : rfl + ... = succ (succ (n₁ ⊕ m)) : sorry -- by rewrite ih + ... = succ (succ n₁ ⊕ m) : rfl) + +theorem add_eq_addl (x : ℕ) : ∀y, x + y = x ⊕ y := +nat.induction_on x + (λ y, nat.induction_on y + rfl + (λ y₁ ih, calc + 0 + succ y₁ = succ (0 + y₁) : rfl + ... = succ (0 ⊕ y₁) : sorry -- by rewrite ih + ... = 0 ⊕ (succ y₁) : rfl)) + (λ x₁ ih₁ y, nat.induction_on y + (calc + succ x₁ + 0 = succ (x₁ + 0) : rfl + ... = succ (x₁ ⊕ 0) : sorry -- by rewrite (ih₁ 0) + ... = succ x₁ ⊕ 0 : rfl) + (λ y₁ ih₂, calc + succ x₁ + succ y₁ = succ (succ x₁ + y₁) : rfl + ... = succ (succ x₁ ⊕ y₁) : sorry -- by rewrite ih₂ + ... = succ x₁ ⊕ succ y₁ : eq.symm $ addl_succ_right (succ x₁) y₁)) + +/- successor and predecessor -/ + +attribute [simp] +theorem succ_ne_zero (n : ℕ) : succ n ≠ 0 := +sorry -- by contradiction + +attribute [simp] +theorem add_one_ne_zero (n : ℕ) : n + 1 ≠ 0 := +sorry -- by contradiction + +-- add_rewrite succ_ne_zero + +attribute [simp] +theorem pred_zero : pred 0 = 0 := +rfl + +attribute [simp] +theorem pred_succ (n : ℕ) : pred (succ n) = n := +rfl + +theorem eq_zero_or_eq_succ_pred (n : ℕ) : n = 0 ∨ n = succ (pred n) := +nat.induction_on n + (or.inl rfl) + (take m IH, or.inr + (show succ m = succ (pred (succ m)), from congr_arg succ (eq.symm $ pred_succ m))) + +theorem exists_eq_succ_of_ne_zero {n : ℕ} (H : n ≠ 0) : ∃k : ℕ, n = succ k := +exists.intro _ (or_resolve_right (eq_zero_or_eq_succ_pred n) H) + +theorem succ.inj {n m : ℕ} (H : succ n = succ m) : n = m := +nat.no_confusion H imp.id + +abbreviation eq_of_succ_eq_succ := @succ.inj + +theorem succ_ne_self {n : ℕ} : succ n ≠ n := +nat.induction_on n + (take H : 1 = 0, + have ne : 1 ≠ 0, from succ_ne_zero 0, + absurd H ne) + (take k IH H, IH (succ.inj H)) + +theorem discriminate {B : Prop} {n : ℕ} (H1: n = 0 → B) (H2 : ∀m, n = succ m → B) : B := +have H : n = n → B, from nat.cases_on n H1 H2, +H rfl + +theorem two_step_induction_on {P : ℕ → Prop} (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.induction_on a + (and.intro H1 H2) + (take k IH, + have IH1 : P k, from and.elim_left IH, + have IH2 : P (succ k), from and.elim_right IH, + and.intro IH2 (H3 k IH1 IH2)), + and.elim_left stronger + +theorem sub_induction {P : ℕ → ℕ → Prop} (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.induction_on n H1 + (take k : ℕ, + assume IH : ∀m, P k m, + take m : ℕ, + nat.cases_on m (H2 k) (take l, (H3 k l (IH l)))), +general m + +/- addition -/ + +protected theorem add_zero (n : ℕ) : n + 0 = n := +rfl + +theorem add_succ (n m : ℕ) : n + succ m = succ (n + m) := +rfl + +/- +Remark: we use 'local attributes' because in the end of the file +we show not is a comm_semiring, and we will automatically inherit +the associated [simp] lemmas from algebra +-/ +local attribute nat.add_zero nat.add_succ [simp] + +protected theorem zero_add (n : ℕ) : 0 + n = n := +sorry -- by rec_simp + +theorem succ_add (n m : ℕ) : (succ n) + m = succ (n + m) := +sorry -- by rec_simp + +local attribute nat.zero_add nat.succ_add [simp] + +protected theorem add_comm (n m : ℕ) : n + m = m + n := +sorry -- by rec_simp + +theorem succ_add_eq_succ_add (n m : ℕ) : succ n + m = n + succ m := +sorry -- by simp + +protected theorem add_assoc (n m k : ℕ) : (n + m) + k = n + (m + k) := +sorry -- by rec_simp + +protected theorem add_left_comm : Π (n m k : ℕ), n + (m + k) = m + (n + k) := +left_comm nat.add_comm nat.add_assoc + +local attribute nat.add_comm nat.add_assoc nat.add_left_comm [simp] + +protected theorem add_right_comm : Π (n m k : ℕ), n + m + k = n + k + m := +right_comm nat.add_comm nat.add_assoc + +protected theorem add_left_cancel {n m k : ℕ} : n + m = n + k → m = k := +sorry +/- +nat.induction_on n + (by simp) + (take a iH, + -- TODO(Leo): replace with forward reasoning after we add strategies for it. + have succ (a + m) = succ (a + k) → a + m = a + k, from !succ.inj, + by inst_simp) +-/ + +protected theorem add_right_cancel {n m k : ℕ} (H : n + m = k + m) : n = k := +sorry +/- +have H2 : m + n = m + k, by simp, +nat.add_left_cancel H2 +-/ + +theorem eq_zero_of_add_eq_zero_right {n m : ℕ} : n + m = 0 → n = 0 := +sorry +/- +nat.induction_on n + (by simp) + (take k iH, assume H : succ k + m = 0, + absurd + (show succ (k + m) = 0, by simp) + !succ_ne_zero) +-/ + +theorem eq_zero_of_add_eq_zero_left {n m : ℕ} (H : n + m = 0) : m = 0 := +eq_zero_of_add_eq_zero_right (eq.trans (nat.add_comm m n) H) + +theorem eq_zero_and_eq_zero_of_add_eq_zero {n m : ℕ} (H : n + m = 0) : n = 0 ∧ m = 0 := +and.intro (eq_zero_of_add_eq_zero_right H) (eq_zero_of_add_eq_zero_left H) + +theorem add_one (n : ℕ) : n + 1 = succ n := rfl + +local attribute add_one [simp] + +theorem one_add (n : ℕ) : 1 + n = succ n := +sorry -- by simp + +theorem succ_eq_add_one (n : ℕ) : succ n = n + 1 := +rfl + +/- multiplication -/ + +protected theorem mul_zero (n : ℕ) : n * 0 = 0 := +rfl + +theorem mul_succ (n m : ℕ) : n * succ m = n * m + n := +rfl + +local attribute nat.mul_zero nat.mul_succ [simp] + +-- commutativity, distributivity, associativity, identity + +protected theorem zero_mul (n : ℕ) : 0 * n = 0 := +sorry -- by rec_simp + +theorem succ_mul (n m : ℕ) : (succ n) * m = (n * m) + m := +sorry -- by rec_simp + +local attribute nat.zero_mul nat.succ_mul [simp] + +protected theorem mul_comm (n m : ℕ) : n * m = m * n := +sorry -- by rec_simp + +protected theorem right_distrib (n m k : ℕ) : (n + m) * k = n * k + m * k := +sorry -- by rec_simp + +protected theorem left_distrib (n m k : ℕ) : n * (m + k) = n * m + n * k := +sorry -- by rec_simp + +local attribute nat.mul_comm nat.right_distrib nat.left_distrib [simp] + +protected theorem mul_assoc (n m k : ℕ) : (n * m) * k = n * (m * k) := +sorry -- by rec_simp + +local attribute nat.mul_assoc [simp] + +protected theorem mul_one (n : ℕ) : n * 1 = n := +sorry +/- +calc + n * 1 = n * 0 + n : !mul_succ + ... = n : by simp +-/ + +local attribute nat.mul_one [simp] + +protected theorem one_mul (n : ℕ) : 1 * n = n := +sorry -- by simp + +local attribute nat.one_mul [simp] + +theorem eq_zero_or_eq_zero_of_mul_eq_zero {n m : ℕ} : n * m = 0 → n = 0 ∨ m = 0 := +sorry +/- +nat.cases_on n (by simp) + (take n', + nat.cases_on m + (by simp) + (take m', assume H, + absurd + (show succ (succ n' * m' + n') = 0, by simp) + !succ_ne_zero)) +-/ + +attribute [instance] +protected definition comm_semiring : 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⦄ + +end nat + +section +open nat +definition iterate {A : Type} (op : A → A) : ℕ → A → A + | 0 := λ a, a + | (succ k) := λ a, op (iterate k a) + +notation f`^[`n`]` := iterate f n +end diff --git a/old_library/data/nat/bigops.lean b/old_library/data/nat/bigops.lean new file mode 100644 index 0000000000..9266b7e175 --- /dev/null +++ b/old_library/data/nat/bigops.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Finite sums and products over intervals of natural numbers. +-/ +-- TODO(Leo): remove after refactoring +exit +import data.nat.order algebra.group_bigops algebra.interval + +namespace nat + +/- sums -/ + +section add_monoid + +variables {A : Type} [add_monoid A] + +definition sum_up_to (n : ℕ) (f : ℕ → A) : A := + nat.rec_on n 0 (λ n a, a + f n) + +notation `∑` binders ` < ` n `, ` r:(scoped f, sum_up_to n f) := r + +proposition sum_up_to_zero (f : ℕ → A) : (∑ i < 0, f i) = 0 := rfl + +proposition sum_up_to_succ (n : ℕ) (f : ℕ → A) : (∑ i < succ n, f i) = (∑ i < n, f i) + f n := rfl + +proposition sum_up_to_one (f : ℕ → A) : (∑ i < 1, f i) = f 0 := zero_add (f 0) + +definition sum_range (m n : ℕ) (f : ℕ → A) : A := sum_up_to (succ n - m) (λ i, f (i + m)) + +notation `∑` binders `=` m `...` n `, ` r:(scoped f, sum_range m n f) := r + +proposition sum_range_def (m n : ℕ) (f : ℕ → A) : + (∑ i = m...n, f i) = (∑ i < (succ n - m), f (i + m)) := rfl + +proposition sum_range_self (m : ℕ) (f : ℕ → A) : + (∑ i = m...m, f i) = f m := + by krewrite [↑sum_range, succ_sub !le.refl, nat.sub_self, sum_up_to_one, zero_add] + +proposition sum_range_succ {m n : ℕ} (f : ℕ → A) (H : m ≤ succ n) : + (∑ i = m...succ n, f i) = (∑ i = m...n, f i) + f (succ n) := + by rewrite [↑sum_range, succ_sub H, sum_up_to_succ, nat.sub_add_cancel H] + +proposition sum_up_to_succ_eq_sum_range_zero (n : ℕ) (f : ℕ → A) : + (∑ i < succ n, f i) = (∑ i = 0...n, f i) := rfl + +end add_monoid + +section finset + variables {A : Type} [add_comm_monoid A] + open finset + +proposition sum_up_to_eq_Sum_upto (n : ℕ) (f : ℕ → A) : + (∑ i < n, f i) = (∑ i ∈ upto n, f i) := +begin + induction n with n ih, + {exact rfl}, + have H : upto n ∩ '{n} = ∅, from + inter_eq_empty + (take x, + suppose x ∈ upto n, + have x < n, from lt_of_mem_upto this, + suppose x ∈ '{n}, + have x = n, by rewrite -mem_singleton_iff; apply this, + have n < n, from eq.subst this `x < n`, + show false, from !lt.irrefl this), + rewrite [sum_up_to_succ, ih, upto_succ, Sum_union _ H, Sum_singleton] +end + +end finset + +section set + variables {A : Type} [add_comm_monoid A] + open set interval + +proposition sum_range_eq_sum_interval_aux (m n : ℕ) (f : ℕ → A) : + (∑ i = m...m+n, f i) = (∑ i ∈ '[m, m + n], f i) := +begin + induction n with n ih, + {krewrite [nat.add_zero, sum_range_self, Icc_self, Sum_singleton]}, + have H : m ≤ succ (m + n), from le_of_lt (lt_of_le_of_lt !le_add_right !lt_succ_self), + have H' : '[m, m + n] ∩ '{succ (m + n)} = ∅, from + eq_empty_of_forall_not_mem (take x, assume H1, + have x = succ (m + n), from eq_of_mem_singleton (and.right H1), + have succ (m + n) ≤ m + n, from eq.subst this (and.right (and.left H1)), + show false, from not_lt_of_ge this !lt_succ_self), + rewrite [add_succ, sum_range_succ f H, Icc_eq_Icc_union_Ioc !le_add_right !le_succ, + nat.Ioc_eq_Icc_succ, Icc_self, Sum_union f H', Sum_singleton, ih] +end + +proposition sum_range_eq_sum_interval {m n : ℕ} (f : ℕ → A) (H : m ≤ n) : + (∑ i = m...n, f i) = (∑ i ∈ '[m, n], f i) := + have n = m + (n - m), by rewrite [add.comm, nat.sub_add_cancel H], + using this, by rewrite this; apply sum_range_eq_sum_interval_aux + +proposition sum_range_offset (m n : ℕ) (f : ℕ → A) : + (∑ i = m...m+n, f i) = (∑ i = 0...n, f (m + i)) := + have bij_on (add m) ('[0, n]) ('[m, m+n]), from !nat.bij_on_add_Icc_zero, + by rewrite [-zero_add n at {2}, *sum_range_eq_sum_interval_aux, Sum_eq_of_bij_on f this, zero_add] + +end set + +/- products -/ + +section monoid + +variables {A : Type} [monoid A] + +definition prod_up_to (n : ℕ) (f : ℕ → A) : A := + nat.rec_on n 1 (λ n a, a * f n) + +notation `∏` binders ` < ` n `, ` r:(scoped f, prod_up_to n f) := r + +proposition prod_up_to_zero (f : ℕ → A) : (∏ i < 0, f i) = 1 := rfl + +proposition prod_up_to_succ (n : ℕ) (f : ℕ → A) : (∏ i < succ n, f i) = (∏ i < n, f i) * f n := rfl + +proposition prod_up_to_one (f : ℕ → A) : (∏ i < 1, f i) = f 0 := one_mul (f 0) + +definition prod_range (m n : ℕ) (f : ℕ → A) : A := prod_up_to (succ n - m) (λ i, f (i + m)) + +notation `∏` binders `=` m `...` n `, ` r:(scoped f, prod_range m n f) := r + +proposition prod_range_def (m n : ℕ) (f : ℕ → A) : + (∏ i = m...n, f i) = (∏ i < (succ n - m), f (i + m)) := rfl + +proposition prod_range_self (m : ℕ) (f : ℕ → A) : + (∏ i = m...m, f i) = f m := +by krewrite [↑prod_range, succ_sub !le.refl, nat.sub_self, prod_up_to_one, zero_add] + +proposition prod_range_succ {m n : ℕ} (f : ℕ → A) (H : m ≤ succ n) : + (∏ i = m...succ n, f i) = (∏ i = m...n, f i) * f (succ n) := +by rewrite [↑prod_range, succ_sub H, prod_up_to_succ, nat.sub_add_cancel H] + +proposition prod_up_to_succ_eq_prod_range_zero (n : ℕ) (f : ℕ → A) : + (∏ i < succ n, f i) = (∏ i = 0...n, f i) := rfl + +end monoid + +section finset + variables {A : Type} [comm_monoid A] + open finset + +proposition prod_up_to_eq_Prod_upto (n : ℕ) (f : ℕ → A) : + (∏ i < n, f i) = (∏ i ∈ upto n, f i) := +begin + induction n with n ih, + {exact rfl}, + have H : upto n ∩ '{n} = ∅, from + inter_eq_empty + (take x, + suppose x ∈ upto n, + have x < n, from lt_of_mem_upto this, + suppose x ∈ '{n}, + have x = n, by rewrite -mem_singleton_iff; apply this, + have n < n, from eq.subst this `x < n`, + show false, from !lt.irrefl this), + rewrite [prod_up_to_succ, ih, upto_succ, Prod_union _ H, Prod_singleton] +end + +end finset + +section set + variables {A : Type} [comm_monoid A] + open set interval + +proposition prod_range_eq_prod_interval_aux (m n : ℕ) (f : ℕ → A) : + (∏ i = m...m+n, f i) = (∏ i ∈ '[m, m + n], f i) := +begin + induction n with n ih, + {krewrite [nat.add_zero, prod_range_self, Icc_self, Prod_singleton]}, + have H : m ≤ succ (m + n), from le_of_lt (lt_of_le_of_lt !le_add_right !lt_succ_self), + have H' : '[m, m + n] ∩ '{succ (m + n)} = ∅, from + eq_empty_of_forall_not_mem (take x, assume H1, + have x = succ (m + n), from eq_of_mem_singleton (and.right H1), + have succ (m + n) ≤ m + n, from eq.subst this (and.right (and.left H1)), + show false, from not_lt_of_ge this !lt_succ_self), + rewrite [add_succ, prod_range_succ f H, Icc_eq_Icc_union_Ioc !le_add_right !le_succ, + nat.Ioc_eq_Icc_succ, Icc_self, Prod_union f H', Prod_singleton, ih] +end + +proposition prod_range_eq_prod_interval {m n : ℕ} (f : ℕ → A) (H : m ≤ n) : + (∏ i = m...n, f i) = (∏ i ∈ '[m, n], f i) := + have n = m + (n - m), by rewrite [add.comm, nat.sub_add_cancel H], + using this, by rewrite this; apply prod_range_eq_prod_interval_aux + +proposition prod_range_offset (m n : ℕ) (f : ℕ → A) : + (∏ i = m...m+n, f i) = (∏ i = 0...n, f (m + i)) := + have bij_on (add m) ('[0, n]) ('[m, m+n]), from !nat.bij_on_add_Icc_zero, + by rewrite [-zero_add n at {2}, *prod_range_eq_prod_interval_aux, Prod_eq_of_bij_on f this, + zero_add] + +end set + +end nat diff --git a/old_library/data/nat/bquant.lean b/old_library/data/nat/bquant.lean new file mode 100644 index 0000000000..a15ffe5d09 --- /dev/null +++ b/old_library/data/nat/bquant.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Show that "bounded" quantifiers: (∃x, x < n ∧ P x) and (∀x, x < n → P x) +are decidable when P is decidable. + +This module allow us to write if-then-else expressions such as + + if (∀ x : nat, x < n → ∃ y : nat, y < n ∧ y * y = x) then t else s + +without assuming classical axioms. + +More importantly, they can be reduced inside of the Lean kernel. +-/ +import data.nat.order data.nat.div + +namespace nat + open subtype + + attribute [reducible] + definition bex (n : nat) (P : nat → Prop) : Prop := + ∃ x, x < n ∧ P x + + attribute [reducible] + definition bsub (n : nat) (P : nat → Prop) : Type₁ := + {x \ x < n ∧ P x} + + attribute [reducible] + definition ball (n : nat) (P : nat → Prop) : Prop := + ∀ x, x < n → P x + + lemma bex_of_bsub {n : nat} {P : nat → Prop} : bsub n P → bex n P := + assume h, exists_of_subtype h + + theorem not_bex_zero (P : nat → Prop) : ¬ bex 0 P := + sorry + /- + λ H, obtain (w : nat) (Hw : w < 0 ∧ P w), from H, + and.rec_on Hw (λ h₁ h₂, absurd h₁ (not_lt_zero w)) + -/ + + theorem not_bsub_zero (P : nat → Prop) : bsub 0 P → false := + λ H, absurd (bex_of_bsub H) (not_bex_zero P) + + definition bsub_succ {P : nat → Prop} {n : nat} (H : bsub n P) : bsub (succ n) P := + subtype.rec_on H (λ w Hw, tag w (and.rec_on Hw (λ hlt hp, and.intro (lt.step hlt) hp))) + + theorem bex_succ {P : nat → Prop} {n : nat} (H : bex n P) : bex (succ n) P := + sorry + /- + obtain (w : nat) (Hw : w < n ∧ P w), from H, + and.rec_on Hw (λ hlt hp, exists.intro w (and.intro (lt.step hlt) hp)) + -/ + + definition bsub_succ_of_pred {P : nat → Prop} {a : nat} (H : P a) : bsub (succ a) P := + tag a (and.intro (lt.base a) H) + + theorem bex_succ_of_pred {P : nat → Prop} {a : nat} (H : P a) : bex (succ a) P := + bex_of_bsub (bsub_succ_of_pred H) + + theorem not_bex_succ {P : nat → Prop} {n : nat} (H₁ : ¬ bex n P) (H₂ : ¬ P n) : ¬ bex (succ n) P := + sorry + /- + λ H, obtain (w : nat) (Hw : w < succ n ∧ P w), from H, + and.rec_on Hw (λ hltsn hp, or.rec_on (nat.eq_or_lt_of_le (le_of_succ_le_succ hltsn)) + (λ heq : w = n, absurd (eq.rec_on heq hp) H₂) + (λ hltn : w < n, absurd (exists.intro w (and.intro hltn hp)) H₁)) + -/ + + theorem not_bsub_succ {P : nat → Prop} {n : nat} (H₁ : ¬ bex n P) (H₂ : ¬ P n) : bsub (succ n) P → false := + λ H, absurd (bex_of_bsub H) (not_bex_succ H₁ H₂) + + theorem ball_zero (P : nat → Prop) : ball zero P := + λ x Hlt, absurd Hlt (not_lt_zero x) + + theorem ball_of_ball_succ {n : nat} {P : nat → Prop} (H : ball (succ n) P) : ball n P := + λ x Hlt, H x (lt.step Hlt) + + theorem ball_succ_of_ball {n : nat} {P : nat → Prop} (H₁ : ball n P) (H₂ : P n) : ball (succ n) P := + λ (x : nat) (Hlt : x < succ n), or.elim (nat.eq_or_lt_of_le (le_of_succ_le_succ Hlt)) + (λ heq : x = n, eq.rec_on (eq.rec_on heq rfl) H₂) + (λ hlt : x < n, H₁ x hlt) + + theorem not_ball_of_not {n : nat} {P : nat → Prop} (H₁ : ¬ P n) : ¬ ball (succ n) P := + λ (H : ball (succ n) P), absurd (H n (lt.base n)) H₁ + + theorem not_ball_succ_of_not_ball {n : nat} {P : nat → Prop} (H₁ : ¬ ball n P) : ¬ ball (succ n) P := + λ (H : ball (succ n) P), absurd (ball_of_ball_succ H) H₁ +end nat + +section + open nat decidable + + attribute [instance] + definition decidable_bex (n : nat) (P : nat → Prop) [H : decidable_pred P] : decidable (bex n P) := + nat.rec_on n + (ff (not_bex_zero P)) + (λ a ih, decidable.rec_on ih + (λ hneg : ¬ bex a P, decidable.rec_on (H a) + (λ hna : ¬ P a, ff (not_bex_succ hneg hna)) + (λ hpa : P a, tt (bex_succ_of_pred hpa))) + (λ hpos : bex a P, tt (bex_succ hpos))) + + attribute [instance] + definition decidable_ball (n : nat) (P : nat → Prop) [H : decidable_pred P] : decidable (ball n P) := + nat.rec_on n + (tt (ball_zero P)) + (λ n₁ ih, decidable.rec_on ih + (λ ih_neg, ff (not_ball_succ_of_not_ball ih_neg)) + (λ ih_pos, decidable.rec_on (H n₁) + (λ p_neg, ff (not_ball_of_not p_neg)) + (λ p_pos, tt (ball_succ_of_ball ih_pos p_pos)))) + + attribute [instance] + definition decidable_bex_le (n : nat) (P : nat → Prop) [decidable_pred P] + : decidable (∃ x, x ≤ n ∧ P x) := + decidable_of_decidable_of_iff + (decidable_bex (succ n) P) + (exists_congr (λn', and_congr (lt_succ_iff_le n' n) (iff.refl (P n')))) + + attribute [instance] + definition decidable_ball_le (n : nat) (P : nat → Prop) [decidable_pred P] + : decidable (∀ x, x ≤ n → P x) := + decidable_of_decidable_of_iff + (decidable_ball (succ n) P) + (forall_congr (λ n', imp_congr (lt_succ_iff_le n' n) (iff.refl (P n')))) +end + +namespace nat + open decidable subtype + variable {P : nat → Prop} + variable [decP : decidable_pred P] + include decP + + definition bsub_not_of_not_ball : ∀ {n : nat}, ¬ ball n P → {i \ i < n ∧ ¬ P i} + | 0 h := absurd (ball_zero P) h + | (succ n) h := decidable.by_cases + (λ hp : P n, + have ¬ ball n P, from + assume b : ball n P, absurd (ball_succ_of_ball b hp) h, + have {i \ i < n ∧ ¬ P i}, from bsub_not_of_not_ball this, + bsub_succ this) + (λ hn : ¬ P n, bsub_succ_of_pred hn) + + theorem bex_not_of_not_ball {n : nat} (H : ¬ ball n P) : bex n (λ n, ¬ P n) := + bex_of_bsub (bsub_not_of_not_ball H) + + theorem ball_not_of_not_bex : ∀ {n : nat}, ¬ bex n P → ball n (λ n, ¬ P n) + | 0 h := ball_zero _ + | (succ n) h := by_cases + (λ hp : P n, absurd (bex_succ_of_pred hp) h) + (λ hn : ¬ P n, + have ¬ bex n P, from + assume b : bex n P, absurd (bex_succ b) h, + have ball n (λ n, ¬ P n), from ball_not_of_not_bex this, + ball_succ_of_ball this hn) +end nat diff --git a/old_library/data/nat/default.lean b/old_library/data/nat/default.lean new file mode 100644 index 0000000000..a7f30c0e41 --- /dev/null +++ b/old_library/data/nat/default.lean @@ -0,0 +1,6 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad +-/ +import .basic .order .sub .div .gcd .bquant .sqrt .pairing .power .find .fact .parity diff --git a/old_library/data/nat/div.lean b/old_library/data/nat/div.lean new file mode 100644 index 0000000000..0730f629c5 --- /dev/null +++ b/old_library/data/nat/div.lean @@ -0,0 +1,730 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad, Leonardo de Moura + +Definitions and properties of div and mod. Much of the development follows Isabelle's library. +-/ +import .sub +open well_founded decidable prod + +namespace nat + +/- div -/ + +-- auxiliary lemma used to justify div +private definition div_rec_lemma {x y : nat} : 0 < y ∧ y ≤ x → x - y < x := +and.rec (λ ypos ylex, sub_lt (lt_of_lt_of_le ypos ylex) ypos) + +private definition div.F (x : nat) (f : Π x₁, x₁ < x → nat → nat) (y : nat) : nat := +if H : 0 < y ∧ y ≤ x then f (x - y) (div_rec_lemma H) y + 1 else zero + +protected definition div := fix lt_wf div.F + +definition nat_has_divide : has_div nat := +has_div.mk nat.div + +local attribute [instance] nat_has_divide + +theorem div_def (x y : nat) : div x y = if 0 < y ∧ y ≤ x then div (x - y) y + 1 else 0 := +congr_fun (fix_eq lt_wf div.F x) y + +attribute [simp] +protected theorem div_zero (a : ℕ) : a / 0 = 0 := +eq.trans (div_def a 0) $ if_neg (not_and_of_not_left (0 ≤ a) (lt.irrefl 0)) + +theorem div_eq_zero_of_lt {a b : ℕ} (h : a < b) : a / b = 0 := +eq.trans (div_def a b) $ if_neg (not_and_of_not_right (0 < b) (not_le_of_gt h)) + +attribute [simp] +protected theorem zero_div (b : ℕ) : 0 / b = 0 := +eq.trans (div_def 0 b) $ if_neg (and.rec not_le_of_gt) + +theorem div_eq_succ_sub_div {a b : ℕ} (h₁ : b > 0) (h₂ : a ≥ b) : a / b = succ ((a - b) / b) := +eq.trans (div_def a b) $ if_pos (and.intro h₁ h₂) + +theorem add_div_self (x : ℕ) {z : ℕ} (H : z > 0) : (x + z) / z = succ (x / z) := +sorry +/- +calc + (x + z) / z = if 0 < z ∧ z ≤ x + z then (x + z - z) / z + 1 else 0 : !div_def + ... = (x + z - z) / z + 1 : if_pos (and.intro H (le_add_left z x)) + ... = succ (x / z) : by rewrite nat.add_sub_cancel +-/ + +theorem add_div_self_left {x : ℕ} (z : ℕ) (H : x > 0) : (x + z) / x = succ (z / x) := +add.comm z x ▸ add_div_self z H + +local attribute succ_mul [simp] + +theorem add_mul_div_self {x y z : ℕ} (H : z > 0) : (x + y * z) / z = x / z + y := +sorry +/- +nat.induction_on y + (by simp) + (take y, + assume IH : (x + y * z) / z = x / z + y, calc + (x + succ y * z) / z = (x + y * z + z) / z : by inst_simp + ... = succ ((x + y * z) / z) : !add_div_self H + ... = succ (x / z + y) : by rewrite IH) +-/ + +theorem add_mul_div_self_left (x z : ℕ) {y : ℕ} (H : y > 0) : (x + y * z) / y = x / y + z := +mul.comm z y ▸ add_mul_div_self H + +protected theorem mul_div_cancel (m : ℕ) {n : ℕ} (H : n > 0) : m * n / n = m := +sorry +/- +calc + m * n / n = (0 + m * n) / n : by simp + ... = 0 / n + m : add_mul_div_self H + ... = m : by simp +-/ + +protected theorem mul_div_cancel_left {m : ℕ} (n : ℕ) (H : m > 0) : m * n / m = n := +mul.comm n m ▸ nat.mul_div_cancel n H + +/- mod -/ + +private definition mod.F (x : nat) (f : Π x₁, x₁ < x → nat → nat) (y : nat) : nat := +if H : 0 < y ∧ y ≤ x then f (x - y) (div_rec_lemma H) y else x + +protected definition mod := fix lt_wf mod.F + +definition nat_has_mod : has_mod nat := +has_mod.mk nat.mod + +local attribute [instance] nat_has_mod + +notation [priority nat.prio] a ≡ b `[mod `:0 c:0 `]` := a % c = b % c + +theorem mod_def (x y : nat) : mod x y = if 0 < y ∧ y ≤ x then mod (x - y) y else x := +congr_fun (fix_eq lt_wf mod.F x) y + +attribute [simp] +theorem mod_zero (a : ℕ) : a % 0 = a := +eq.trans (mod_def a 0) $ if_neg (not_and_of_not_left (0 ≤ a) (lt.irrefl 0)) + +theorem mod_eq_of_lt {a b : ℕ} (h : a < b) : a % b = a := +eq.trans (mod_def a b) $ if_neg (not_and_of_not_right (0 < b) (not_le_of_gt h)) + +attribute [simp] +theorem zero_mod (b : ℕ) : 0 % b = 0 := +eq.trans (mod_def 0 b) $ if_neg (λ h, and.rec_on h (λ l r, absurd (lt_of_lt_of_le l r) (lt.irrefl 0))) + +theorem mod_eq_sub_mod {a b : ℕ} (h₁ : b > 0) (h₂ : a ≥ b) : a % b = (a - b) % b := +eq.trans (mod_def a b) $ if_pos (and.intro h₁ h₂) + +attribute [simp] +theorem add_mod_self (x z : ℕ) : (x + z) % z = x % z := +sorry +/- +by_cases_zero_pos z + (by rewrite add_zero) + (take z, assume H : z > 0, + calc + (x + z) % z = if 0 < z ∧ z ≤ x + z then (x + z - z) % z else _ : !mod_def + ... = (x + z - z) % z : if_pos (and.intro H (le_add_left z x)) + ... = x % z : by rewrite nat.add_sub_cancel) +-/ + +attribute [simp] +theorem add_mod_self_left (x z : ℕ) : (x + z) % x = z % x := +add.comm z x ▸ add_mod_self z x + +local attribute succ_mul [simp] + +attribute [simp] +theorem add_mul_mod_self (x y z : ℕ) : (x + y * z) % z = x % z := +sorry -- nat.induction_on y (by simp) (by inst_simp) + +attribute [simp] +theorem add_mul_mod_self_left (x y z : ℕ) : (x + y * z) % y = x % y := +sorry -- by inst_simp + +attribute [simp] +theorem mul_mod_left (m n : ℕ) : (m * n) % n = 0 := +sorry +/- +calc (m * n) % n = (0 + m * n) % n : by simp + ... = 0 : by inst_simp +-/ + +attribute [simp] +theorem mul_mod_right (m n : ℕ) : (m * n) % m = 0 := +sorry -- by inst_simp + +theorem mod_lt (x : ℕ) {y : ℕ} (H : y > 0) : x % y < y := +nat.case_strong_induction_on x + (show 0 % y < y, from eq.symm (zero_mod y) ▸ H) + (take x, + assume IH : ∀x', x' ≤ x → x' % y < y, + show succ x % y < y, from + by_cases -- (succ x < y) + (assume H1 : succ x < y, + have succ x % y = succ x, from mod_eq_of_lt H1, + show succ x % y < y, from eq.symm this ▸ H1) + (assume H1 : ¬ succ x < y, + have y ≤ succ x, from le_of_not_gt H1, + have h : succ x % y = (succ x - y) % y, from mod_eq_sub_mod H this, + have succ x - y < succ x, from sub_lt (succ_pos x) H, + have succ x - y ≤ x, from le_of_lt_succ this, + show succ x % y < y, from eq.symm h ▸ IH _ this)) + +theorem mod_one (n : ℕ) : n % 1 = 0 := +have H1 : n % 1 < 1, from (mod_lt n) (succ_pos 0), +eq_zero_of_le_zero (le_of_lt_succ H1) + +/- properties of div and mod -/ + +-- the quotient - remainder theorem +theorem eq_div_mul_add_mod (x y : ℕ) : x = x / y * y + x % y := +sorry +/- +begin + eapply by_cases_zero_pos y, + show x = x / 0 * 0 + x % 0, from + (calc + x / 0 * 0 + x % 0 = 0 + x % 0 : by rewrite mul_zero + ... = x % 0 : by rewrite zero_add + ... = x : by rewrite mod_zero)⁻¹, + intro y H, + show x = x / y * y + x % y, + begin + eapply nat.case_strong_induction_on x, + show 0 = (0 / y) * y + 0 % y, by rewrite [zero_mod, add_zero, nat.zero_div, zero_mul], + intro x IH, + show succ x = succ x / y * y + succ x % y, from + if H1 : succ x < y then + have H2 : succ x / y = 0, from div_eq_zero_of_lt H1, + have H3 : succ x % y = succ x, from mod_eq_of_lt H1, + begin rewrite [H2, H3, zero_mul, zero_add] end + else + have H2 : y ≤ succ x, from le_of_not_gt H1, + have H3 : succ x / y = succ ((succ x - y) / y), from div_eq_succ_sub_div H H2, + have H4 : succ x % y = (succ x - y) % y, from mod_eq_sub_mod H H2, + have H5 : succ x - y < succ x, from sub_lt !succ_pos H, + have H6 : succ x - y ≤ x, from le_of_lt_succ H5, + (calc + succ x / y * y + succ x % y = + succ ((succ x - y) / y) * y + succ x % y : by rewrite H3 + ... = ((succ x - y) / y) * y + y + succ x % y : by rewrite succ_mul + ... = ((succ x - y) / y) * y + y + (succ x - y) % y : by rewrite H4 + ... = ((succ x - y) / y) * y + (succ x - y) % y + y : by rewrite add.right_comm + ... = succ x - y + y : by rewrite -(IH _ H6) + ... = succ x : nat.sub_add_cancel H2)⁻¹ + end +end +-/ + +theorem mod_eq_sub_div_mul (x y : ℕ) : x % y = x - x / y * y := +nat.eq_sub_of_add_eq (eq.symm (add.comm (x / y * y) (x % y) ▸ eq_div_mul_add_mod x y)) + +theorem mod_add_mod (m n k : ℕ) : (m % n + k) % n = (m + k) % n := +sorry -- by rewrite [eq_div_mul_add_mod m n at {2}, add.assoc, add.comm (m / n * n), add_mul_mod_self] + +theorem add_mod_mod (m n k : ℕ) : (m + n % k) % k = (m + n) % k := +sorry -- by rewrite [add.comm, mod_add_mod, add.comm] + +theorem add_mod_eq_add_mod_right {m n k : ℕ} (i : ℕ) (H : m % n = k % n) : + (m + i) % n = (k + i) % n := +sorry -- by rewrite [-mod_add_mod, -mod_add_mod k, H] + +theorem add_mod_eq_add_mod_left {m n k : ℕ} (i : ℕ) (H : m % n = k % n) : + (i + m) % n = (i + k) % n := +sorry -- by rewrite [add.comm, add_mod_eq_add_mod_right _ H, add.comm] + +theorem mod_eq_mod_of_add_mod_eq_add_mod_right {m n k i : ℕ} : + (m + i) % n = (k + i) % n → m % n = k % n := +sorry +/- +by_cases_zero_pos n + (by rewrite [*mod_zero]; apply eq_of_add_eq_add_right) + (take n, + assume npos : n > 0, + assume H1 : (m + i) % n = (k + i) % n, + have H2 : (m + i % n) % n = (k + i % n) % n, by rewrite [*add_mod_mod, H1], + have H3 : (m + i % n + (n - i % n)) % n = (k + i % n + (n - i % n)) % n, + from add_mod_eq_add_mod_right _ H2, + begin + revert H3, + rewrite [*add.assoc, add_sub_of_le (le_of_lt (!mod_lt npos)), *add_mod_self], + intros, assumption + end) +-/ + +theorem mod_eq_mod_of_add_mod_eq_add_mod_left {m n k i : ℕ} : + (i + m) % n = (i + k) % n → m % n = k % n := +sorry -- by rewrite [add.comm i m, add.comm i k]; apply mod_eq_mod_of_add_mod_eq_add_mod_right + +theorem mod_le {x y : ℕ} : x % y ≤ x := +eq.symm (eq_div_mul_add_mod x y) ▸ le_add_left (x % y) (x / y * y) + +theorem eq_remainder {q1 r1 q2 r2 y : ℕ} (H1 : r1 < y) (H2 : r2 < y) + (H3 : q1 * y + r1 = q2 * y + r2) : r1 = r2 := +sorry +/- +calc + r1 = r1 % y : eq.symm (mod_eq_of_lt H1) + ... = (r1 + q1 * y) % y : !add_mul_mod_self⁻¹ + ... = (q1 * y + r1) % y : by rewrite add.comm + ... = (r2 + q2 * y) % y : by rewrite [H3, add.comm] + ... = r2 % y : !add_mul_mod_self + ... = r2 : mod_eq_of_lt H2 +-/ + +theorem eq_quotient {q1 r1 q2 r2 y : ℕ} (H1 : r1 < y) (H2 : r2 < y) + (H3 : q1 * y + r1 = q2 * y + r2) : q1 = q2 := +have H4 : q1 * y + r2 = q2 * y + r2, from (eq_remainder H1 H2 H3) ▸ H3, +have H5 : q1 * y = q2 * y, from add.right_cancel H4, +have H6 : y > 0, from lt_of_le_of_lt (zero_le r1) H1, +show q1 = q2, from eq_of_mul_eq_mul_right H6 H5 + +protected theorem mul_div_mul_left {z : ℕ} (x y : ℕ) (zpos : z > 0) : + (z * x) / (z * y) = x / y := +sorry +/- +if H : y = 0 then + by rewrite [H, mul_zero, *nat.div_zero] +else + have ypos : y > 0, from pos_of_ne_zero H, + have zypos : z * y > 0, from mul_pos zpos ypos, + have H1 : (z * x) % (z * y) < z * y, from !mod_lt zypos, + have H2 : z * (x % y) < z * y, from mul_lt_mul_of_pos_left (!mod_lt ypos) zpos, + eq_quotient H1 H2 + (calc + ((z * x) / (z * y)) * (z * y) + (z * x) % (z * y) = z * x : by rewrite -eq_div_mul_add_mod + ... = z * (x / y * y + x % y) : by rewrite -eq_div_mul_add_mod + ... = z * (x / y * y) + z * (x % y) : !left_distrib + ... = (x / y) * (z * y) + z * (x % y) : by rewrite mul.left_comm) +-/ + +protected theorem mul_div_mul_right {x z y : ℕ} (zpos : z > 0) : (x * z) / (y * z) = x / y := +mul.comm z y ▸ mul.comm z x ▸ nat.mul_div_mul_left x y zpos + +theorem mul_mod_mul_left (z x y : ℕ) : (z * x) % (z * y) = z * (x % y) := +sorry +/- +or.elim (eq_zero_or_pos z) + (assume H : z = 0, H⁻¹ ▸ calc + (0 * x) % (z * y) = 0 % (z * y) : by rewrite zero_mul + ... = 0 : by rewrite zero_mod + ... = 0 * (x % y) : by rewrite zero_mul) + (assume zpos : z > 0, + or.elim (eq_zero_or_pos y) + (assume H : y = 0, by rewrite [H, mul_zero, *mod_zero]) + (assume ypos : y > 0, + have zypos : z * y > 0, from mul_pos zpos ypos, + have H1 : (z * x) % (z * y) < z * y, from !mod_lt zypos, + have H2 : z * (x % y) < z * y, from mul_lt_mul_of_pos_left (!mod_lt ypos) zpos, + eq_remainder H1 H2 + (calc + ((z * x) / (z * y)) * (z * y) + (z * x) % (z * y) = z * x : by rewrite -eq_div_mul_add_mod + ... = z * (x / y * y + x % y) : by rewrite -eq_div_mul_add_mod + ... = z * (x / y * y) + z * (x % y) : by rewrite left_distrib + ... = (x / y) * (z * y) + z * (x % y) : by rewrite mul.left_comm))) +-/ + +theorem mul_mod_mul_right (x z y : ℕ) : (x * z) % (y * z) = (x % y) * z := +mul.comm z x ▸ mul.comm z y ▸ mul.comm z (x % y) ▸ mul_mod_mul_left z x y + +theorem mod_self (n : ℕ) : n % n = 0 := +sorry +/- +nat.cases_on n (by rewrite zero_mod) + (take n, by rewrite [-zero_add (succ n) at {1}, add_mod_self]) +-/ + +theorem mul_mod_eq_mod_mul_mod (m n k : nat) : (m * n) % k = ((m % k) * n) % k := +sorry +/- +calc + (m * n) % k = (((m / k) * k + m % k) * n) % k : by rewrite -eq_div_mul_add_mod + ... = ((m % k) * n) % k : + by rewrite [right_distrib, mul.right_comm, add.comm, add_mul_mod_self] +-/ + +theorem mul_mod_eq_mul_mod_mod (m n k : nat) : (m * n) % k = (m * (n % k)) % k := +mul.comm (n % k) m ▸ mul.comm n m ▸ mul_mod_eq_mod_mul_mod n m k + +protected theorem div_one (n : ℕ) : n / 1 = n := +sorry +/- +have n / 1 * 1 + n % 1 = n, from !eq_div_mul_add_mod⁻¹, +begin rewrite [-this at {2}, mul_one, mod_one] end +-/ + +protected theorem div_self {n : ℕ} (H : n > 0) : n / n = 1 := +sorry +/- +have (n * 1) / (n * 1) = 1 / 1, from !nat.mul_div_mul_left H, +by rewrite [nat.div_one at this, -this, *mul_one] +-/ + +theorem div_mul_cancel_of_mod_eq_zero {m n : ℕ} (H : m % n = 0) : m / n * n = m := +sorry -- by rewrite [eq_div_mul_add_mod m n at {2}, H, add_zero] + +theorem mul_div_cancel_of_mod_eq_zero {m n : ℕ} (H : m % n = 0) : n * (m / n) = m := +mul.comm (m / n) n ▸ div_mul_cancel_of_mod_eq_zero H + +/- dvd -/ + +theorem dvd_of_mod_eq_zero {m n : ℕ} (H : n % m = 0) : m ∣ n := +dvd.intro (mul.comm (n / m) m ▸ div_mul_cancel_of_mod_eq_zero H) + +theorem mod_eq_zero_of_dvd {m n : ℕ} (H : m ∣ n) : n % m = 0 := +dvd.elim H (take z, assume H1 : n = m * z, eq.symm H1 ▸ mul_mod_right m z) + +theorem dvd_iff_mod_eq_zero (m n : ℕ) : m ∣ n ↔ n % m = 0 := +iff.intro mod_eq_zero_of_dvd dvd_of_mod_eq_zero + +definition dvd.decidable_rel : decidable_rel dvd := +take m n, decidable_of_decidable_of_iff _ (iff.symm $ dvd_iff_mod_eq_zero m n) + +protected theorem div_mul_cancel {m n : ℕ} (H : n ∣ m) : m / n * n = m := +div_mul_cancel_of_mod_eq_zero (mod_eq_zero_of_dvd H) + +protected theorem mul_div_cancel' {m n : ℕ} (H : n ∣ m) : n * (m / n) = m := +mul.comm (m / n) n ▸ nat.div_mul_cancel H + +theorem dvd_of_dvd_add_left {m n₁ n₂ : ℕ} (H₁ : m ∣ n₁ + n₂) (H₂ : m ∣ n₁) : m ∣ n₂ := +sorry +/- +obtain (c₁ : nat) (Hc₁ : n₁ + n₂ = m * c₁), from H₁, +obtain (c₂ : nat) (Hc₂ : n₁ = m * c₂), from H₂, +have aux : m * (c₁ - c₂) = n₂, from calc + m * (c₁ - c₂) = m * c₁ - m * c₂ : !nat.mul_sub_left_distrib + ... = n₁ + n₂ - m * c₂ : by rewrite Hc₁ + ... = n₁ + n₂ - n₁ : by rewrite Hc₂ + ... = n₂ : !nat.add_sub_cancel_left, +dvd.intro aux +-/ + +theorem dvd_of_dvd_add_right {m n₁ n₂ : ℕ} (H : m ∣ n₁ + n₂) : m ∣ n₂ → m ∣ n₁ := +nat.dvd_of_dvd_add_left (add.comm n₁ n₂ ▸ H) + +theorem dvd_sub {m n₁ n₂ : ℕ} (H1 : m ∣ n₁) (H2 : m ∣ n₂) : m ∣ n₁ - n₂ := +by_cases + (assume H3 : n₁ ≥ n₂, + have H4 : n₁ = n₁ - n₂ + n₂, from eq.symm (nat.sub_add_cancel H3), + show m ∣ n₁ - n₂, from nat.dvd_of_dvd_add_right (H4 ▸ H1) H2) + (assume H3 : ¬ (n₁ ≥ n₂), + have H4 : n₁ - n₂ = 0, from sub_eq_zero_of_le (le_of_lt (lt_of_not_ge H3)), + show m ∣ n₁ - n₂, from eq.symm H4 ▸ dvd_zero _) + +theorem dvd.antisymm {m n : ℕ} : m ∣ n → n ∣ m → m = n := +sorry +/- +by_cases_zero_pos n + (assume H1, assume H2 : 0 ∣ m, eq_zero_of_zero_dvd H2) + (take n, + assume Hpos : n > 0, + assume H1 : m ∣ n, + assume H2 : n ∣ m, + obtain k (Hk : n = m * k), from exists_eq_mul_right_of_dvd H1, + obtain l (Hl : m = n * l), from exists_eq_mul_right_of_dvd H2, + have n * (l * k) = n, from !mul.assoc ▸ Hl ▸ Hk⁻¹, + have l * k = 1, from eq_one_of_mul_eq_self_right Hpos this, + have k = 1, from eq_one_of_mul_eq_one_left this, + show m = n, from (mul_one m)⁻¹ ⬝ (this ▸ Hk⁻¹)) +-/ + +protected theorem mul_div_assoc (m : ℕ) {n k : ℕ} (H : k ∣ n) : m * n / k = m * (n / k) := +sorry +/- +or.elim (eq_zero_or_pos k) + (assume H1 : k = 0, + calc + m * n / k = m * n / 0 : by rewrite H1 + ... = 0 : by rewrite nat.div_zero + ... = m * 0 : mul_zero m + ... = m * (n / 0) : by rewrite nat.div_zero + ... = m * (n / k) : by rewrite H1) + (assume H1 : k > 0, + have H2 : n = n / k * k, from (nat.div_mul_cancel H)⁻¹, + calc + m * n / k = m * (n / k * k) / k : by rewrite -H2 + ... = m * (n / k) * k / k : by rewrite mul.assoc + ... = m * (n / k) : nat.mul_div_cancel _ H1) +-/ + +theorem dvd_of_mul_dvd_mul_left {m n k : ℕ} (kpos : k > 0) (H : k * m ∣ k * n) : m ∣ n := +dvd.elim H + (take l, + assume H1 : k * n = k * m * l, + have H2 : n = m * l, from eq_of_mul_eq_mul_left kpos (eq.trans H1 $ mul.assoc k m l), + dvd.intro (eq.symm H2)) + +theorem dvd_of_mul_dvd_mul_right {m n k : ℕ} (kpos : k > 0) (H : m * k ∣ n * k) : m ∣ n := +nat.dvd_of_mul_dvd_mul_left kpos (mul.comm n k ▸ mul.comm m k ▸ H) + +lemma dvd_of_eq_mul (i j n : nat) : n = j*i → j ∣ n := +sorry -- begin intros, subst n, apply dvd_mul_right end + +theorem div_dvd_div {k m n : ℕ} (H1 : k ∣ m) (H2 : m ∣ n) : m / k ∣ n / k := +have H3 : m = m / k * k, from eq.symm (nat.div_mul_cancel H1), +have H4 : n = n / k * k, from eq.symm (nat.div_mul_cancel (dvd.trans H1 H2)), +or.elim (eq_zero_or_pos k) + (assume H5 : k = 0, + have H6: n / k = 0, from (eq.trans (congr_arg _ H5) $ nat.div_zero n), + eq.symm H6 ▸ dvd_zero (m / k)) + (assume H5 : k > 0, + nat.dvd_of_mul_dvd_mul_right H5 (H3 ▸ H4 ▸ H2)) + +protected theorem div_eq_iff_eq_mul_right {m n : ℕ} (k : ℕ) (H : n > 0) (H' : n ∣ m) : + m / n = k ↔ m = n * k := +sorry +/- +iff.intro + (assume H1, by rewrite [-H1, nat.mul_div_cancel' H']) + (assume H1, by rewrite [H1, !nat.mul_div_cancel_left H]) +-/ + +protected theorem div_eq_iff_eq_mul_left {m n : ℕ} (k : ℕ) (H : n > 0) (H' : n ∣ m) : + m / n = k ↔ m = k * n := +mul.comm n k ▸ nat.div_eq_iff_eq_mul_right k H H' + +protected theorem eq_mul_of_div_eq_right {m n k : ℕ} (H1 : n ∣ m) (H2 : m / n = k) : + m = n * k := +sorry +/- +calc + m = n * (m / n) : by rewrite (nat.mul_div_cancel' H1) + ... = n * k : by rewrite H2 +-/ + +protected theorem div_eq_of_eq_mul_right {m n k : ℕ} (H1 : n > 0) (H2 : m = n * k) : + m / n = k := +sorry +/- +calc + m / n = n * k / n : by rewrite -H2 + ... = k : by rewrite (!nat.mul_div_cancel_left H1) +-/ + +protected theorem eq_mul_of_div_eq_left {m n k : ℕ} (H1 : n ∣ m) (H2 : m / n = k) : + m = k * n := +mul.comm n k ▸ nat.eq_mul_of_div_eq_right H1 H2 + +protected theorem div_eq_of_eq_mul_left {m n k : ℕ} (H1 : n > 0) (H2 : m = k * n) : + m / n = k := +nat.div_eq_of_eq_mul_right H1 (mul.comm k n ▸ H2) + +lemma add_mod_eq_of_dvd (i j n : nat) : n ∣ j → (i + j) % n = i % n := +sorry +/- +assume h, +obtain k (hk : j = n * k), from exists_eq_mul_right_of_dvd h, +begin + subst j, rewrite mul.comm, + apply add_mul_mod_self +end +-/ + +/- / and ordering -/ + +lemma le_of_dvd {m n : nat} : n > 0 → m ∣ n → m ≤ n := +sorry +/- +assume (h₁ : n > 0) (h₂ : m ∣ n), +have h₃ : n % m = 0, from mod_eq_zero_of_dvd h₂, +by_contradiction + (λ nle : ¬ m ≤ n, + have h₄ : m > n, from lt_of_not_ge nle, + have h₅ : n % m = n, from mod_eq_of_lt h₄, + begin + rewrite h₃ at h₅, subst n, + exact absurd h₁ (lt.irrefl 0) + end) +-/ + +theorem div_mul_le (m n : ℕ) : m / n * n ≤ m := +sorry +/- +calc + m = m / n * n + m % n : by rewrite -eq_div_mul_add_mod + ... ≥ m / n * n : !le_add_right +-/ + +protected theorem div_le_of_le_mul {m n k : ℕ} (H : m ≤ n * k) : m / k ≤ n := +sorry +/- +or.elim (eq_zero_or_pos k) + (assume H1 : k = 0, + calc + m / k = m / 0 : by rewrite H1 + ... = 0 : by rewrite nat.div_zero + ... ≤ n : !zero_le) + (assume H1 : k > 0, + le_of_mul_le_mul_right (calc + m / k * k ≤ m / k * k + m % k : !le_add_right + ... = m : by rewrite -eq_div_mul_add_mod + ... ≤ n * k : H) H1) +-/ + +protected theorem div_le_self (m n : ℕ) : m / n ≤ m := +sorry +/- +nat.cases_on n (!nat.div_zero⁻¹ ▸ !zero_le) + take n, + have H : m ≤ m * succ n, from calc + m = m * 1 : by rewrite mul_one + ... ≤ m * succ n : !mul_le_mul_left (succ_le_succ !zero_le), + nat.div_le_of_le_mul H +-/ + +protected theorem mul_le_of_le_div {m n k : ℕ} (H : m ≤ n / k) : m * k ≤ n := +calc + m * k ≤ n / k * k : mul_le_mul_right k H + ... ≤ n : div_mul_le n k + +protected theorem le_div_of_mul_le {m n k : ℕ} (H1 : k > 0) (H2 : m * k ≤ n) : m ≤ n / k := +sorry +/- +have H3 : m * k < (succ (n / k)) * k, from + calc + m * k ≤ n : H2 + ... = n / k * k + n % k : by rewrite -eq_div_mul_add_mod + ... < n / k * k + k : add_lt_add_left (!mod_lt H1) _ + ... = (succ (n / k)) * k : by rewrite succ_mul, +le_of_lt_succ (lt_of_mul_lt_mul_right H3) +-/ + +protected theorem le_div_iff_mul_le {m n k : ℕ} (H : k > 0) : m ≤ n / k ↔ m * k ≤ n := +iff.intro nat.mul_le_of_le_div (nat.le_div_of_mul_le H) + +protected theorem div_le_div {m n : ℕ} (k : ℕ) (H : m ≤ n) : m / k ≤ n / k := +sorry +/- +by_cases_zero_pos k + (by rewrite [*nat.div_zero]) + (take k, assume H1 : k > 0, nat.le_div_of_mul_le H1 (le.trans !div_mul_le H)) +-/ + +protected theorem div_lt_of_lt_mul {m n k : ℕ} (H : m < n * k) : m / k < n := +sorry +/- +lt_of_mul_lt_mul_right (calc + m / k * k ≤ m / k * k + m % k : !le_add_right + ... = m : by rewrite -eq_div_mul_add_mod + ... < n * k : H) +-/ + +protected theorem lt_mul_of_div_lt {m n k : ℕ} (H1 : k > 0) (H2 : m / k < n) : m < n * k := +sorry +/- +have H3 : succ (m / k) * k ≤ n * k, from !mul_le_mul_right (succ_le_of_lt H2), +have H4 : m / k * k + k ≤ n * k, by rewrite [succ_mul at H3]; apply H3, +calc + m = m / k * k + m % k : by rewrite -eq_div_mul_add_mod + ... < m / k * k + k : add_lt_add_left (!mod_lt H1) _ + ... ≤ n * k : H4 +-/ + +protected theorem div_lt_iff_lt_mul {m n k : ℕ} (H : k > 0) : m / k < n ↔ m < n * k := +iff.intro (nat.lt_mul_of_div_lt H) nat.div_lt_of_lt_mul + +protected theorem div_le_iff_le_mul_of_div {m n : ℕ} (k : ℕ) (H : n > 0) (H' : n ∣ m) : + m / n ≤ k ↔ m ≤ k * n := +sorry -- by refine iff.trans (!le_iff_mul_le_mul_right H) _; rewrite [!nat.div_mul_cancel H'] + +protected theorem le_mul_of_div_le_of_div {m n k : ℕ} (H1 : n > 0) (H2 : n ∣ m) (H3 : m / n ≤ k) : + m ≤ k * n := +iff.mp (nat.div_le_iff_le_mul_of_div k H1 H2) H3 + +-- needed for integer division +theorem mul_sub_div_of_lt {m n k : ℕ} (H : k < m * n) : + (m * n - (k + 1)) / m = n - k / m - 1 := +sorry +/- +begin + have H1 : k / m < n, from nat.div_lt_of_lt_mul (!mul.comm ▸ H), + have H2 : n - k / m ≥ 1, from + nat.le_sub_of_add_le (calc + 1 + k / m = succ (k / m) : by rewrite add.comm + ... ≤ n : succ_le_of_lt H1), + have H3 : n - k / m = n - k / m - 1 + 1, from (nat.sub_add_cancel H2)⁻¹, + have H4 : m > 0, from pos_of_ne_zero (assume H': m = 0, not_lt_zero k (begin rewrite [H' at H, zero_mul at H], exact H end)), + have H5 : k % m + 1 ≤ m, from succ_le_of_lt (!mod_lt H4), + have H6 : m - (k % m + 1) < m, from nat.sub_lt_self H4 !succ_pos, +calc + (m * n - (k + 1)) / m = (m * n - (k / m * m + k % m + 1)) / m : by rewrite -eq_div_mul_add_mod + ... = (m * n - k / m * m - (k % m + 1)) / m : by rewrite [*nat.sub_sub] + ... = ((n - k / m) * m - (k % m + 1)) / m : + by rewrite [mul.comm m, nat.mul_sub_right_distrib] + ... = ((n - k / m - 1) * m + m - (k % m + 1)) / m : + by rewrite [H3 at {1}, right_distrib, nat.one_mul] + ... = ((n - k / m - 1) * m + (m - (k % m + 1))) / m : by rewrite (nat.add_sub_assoc H5 _) + ... = (m - (k % m + 1)) / m + (n - k / m - 1) : + by rewrite [add.comm, (add_mul_div_self H4)] + ... = n - k / m - 1 : + by rewrite [div_eq_zero_of_lt H6, zero_add] +end +-/ + +private lemma div_div_aux (a b c : nat) : b > 0 → c > 0 → (a / b) / c = a / (b * c) := +sorry +/- +suppose b > 0, suppose c > 0, +nat.strong_induction_on a +(λ a ih, + let k₁ := a / (b*c) in + let k₂ := a %(b*c) in + have bc_pos : b*c > 0, from mul_pos `b > 0` `c > 0`, + have k₂ < b * c, from mod_lt _ bc_pos, + have k₂ ≤ a, from !mod_le, + or.elim (eq_or_lt_of_le this) + (suppose k₂ = a, + have i₁ : a < b * c, by rewrite -this; assumption, + have k₁ = 0, from div_eq_zero_of_lt i₁, + have a / b < c, by rewrite [mul.comm at i₁]; exact nat.div_lt_of_lt_mul i₁, + begin + rewrite [`k₁ = 0`], + show (a / b) / c = 0, from div_eq_zero_of_lt `a / b < c` + end) + (suppose k₂ < a, + have a = k₁*(b*c) + k₂, from eq_div_mul_add_mod a (b*c), + have a / b = k₁*c + k₂ / b, by + rewrite [this at {1}, mul.comm b c at {2}, -mul.assoc, + add.comm, add_mul_div_self `b > 0`, add.comm], + have e₁ : (a / b) / c = k₁ + (k₂ / b) / c, by + rewrite [this, add.comm, add_mul_div_self `c > 0`, add.comm], + have e₂ : (k₂ / b) / c = k₂ / (b * c), from ih k₂ `k₂ < a`, + have e₃ : k₂ / (b * c) = 0, from div_eq_zero_of_lt `k₂ < b * c`, + have (k₂ / b) / c = 0, by rewrite [e₂, e₃], + show (a / b) / c = k₁, by rewrite [e₁, this])) +-/ + +protected lemma div_div_eq_div_mul (a b c : nat) : (a / b) / c = a / (b * c) := +sorry +/- +begin + cases b with b, + rewrite [zero_mul, *nat.div_zero, nat.zero_div], + cases c with c, + rewrite [mul_zero, *nat.div_zero], + apply div_div_aux a (succ b) (succ c) dec_trivial dec_trivial +end +-/ + +lemma div_lt_of_ne_zero : ∀ {n : nat}, n ≠ 0 → n / 2 < n +:= sorry +/- +| 0 h := absurd rfl h +| (succ n) h := + begin + apply nat.div_lt_of_lt_mul, + rewrite [-add_one, right_distrib], + change n + 1 < (n * 1 + n) + (1 + 1), + rewrite [mul_one, -add.assoc], + apply add_lt_add_right, + show n < n + n + 1, + begin + rewrite [add.assoc, -add_zero n at {1}], + apply add_lt_add_left, + apply zero_lt_succ + end + end +-/ +end nat +attribute [instance, priority nat.prio] nat.nat_has_divide nat.nat_has_mod nat.dvd.decidable_rel diff --git a/old_library/data/nat/examples/fib.lean b/old_library/data/nat/examples/fib.lean new file mode 100644 index 0000000000..eaee98a1ef --- /dev/null +++ b/old_library/data/nat/examples/fib.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +import data.nat +open nat + +definition fib : nat → nat +| 0 := 1 +| 1 := 1 +| (n+2) := fib (n+1) + fib n + +private definition fib_fast_aux : nat → (nat × nat) +| 0 := (0, 1) +| 1 := (1, 1) +| (n+2) := + match (fib_fast_aux (n+1)) with + | (fn, fn1) := (fn1, fn1 + fn) + end + +open prod -- Get .1 .2 notation for pairs + +definition fib_fast (n : nat) := (fib_fast_aux n).2 + +-- We now prove that fib_fast and fib are equal + +lemma fib_fast_aux_lemma : ∀ n, (fib_fast_aux (succ n)).1 = (fib_fast_aux n).2 +| 0 := rfl +| 1 := rfl +| (succ (succ n)) := + sorry + /- + begin + -- TODO(Leo): fix unfold + -- unfold fib_fast_aux at {1}, esimp, + -- rewrite [-prod.eta (fib_fast_aux _)], + apply sorry + end + -/ + +theorem fib_eq_fib_fast : ∀ n, fib_fast n = fib n +| 0 := rfl +| 1 := rfl +| (succ (succ n)) := + sorry + /- + begin + have feq : fib_fast n = fib n, from fib_eq_fib_fast n, + have f1eq : fib_fast (succ n) = fib (succ n), from fib_eq_fib_fast (succ n), + -- TODO(Leo): fix unfold + apply sorry + /- + unfold [fib, fib_fast, fib_fast_aux], + rewrite [-prod.eta (fib_fast_aux _)], + fold fib_fast (succ n), rewrite f1eq, + rewrite fib_fast_aux_lemma, + fold fib_fast n, rewrite feq, + -/ + end + -/ diff --git a/old_library/data/nat/examples/fib2.lean b/old_library/data/nat/examples/fib2.lean new file mode 100644 index 0000000000..50b20c4d22 --- /dev/null +++ b/old_library/data/nat/examples/fib2.lean @@ -0,0 +1,46 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Show that tail recursive fib is equal to standard one. +-/ +import data.nat +open nat + +definition fib : nat → nat +| 0 := 1 +| 1 := 1 +| (n+2) := fib (n+1) + fib n + +private definition fib_fast_aux : nat → nat → nat → nat +| 0 i j := j +| (n+1) i j := fib_fast_aux n j (j+i) + +lemma fib_fast_aux_lemma : ∀ n m, fib_fast_aux n (fib m) (fib (succ m)) = fib (succ (n + m)) +| 0 m := sorry -- by rewrite zero_add +| (succ n) m := + sorry + /- + begin + have ih : fib_fast_aux n (fib (succ m)) (fib (succ (succ m))) = fib (succ (n + succ m)), from fib_fast_aux_lemma n (succ m), + have h₁ : fib (succ m) + fib m = fib (succ (succ m)), from rfl, + change fib_fast_aux n (fib (succ m)) (fib (succ m) + fib m) = fib (succ (succ n + m)), + rewrite [h₁, ih, succ_add, add_succ] + end + -/ + +definition fib_fast (n: nat) := +fib_fast_aux n 0 1 + +lemma fib_fast_eq_fib : ∀ n, fib_fast n = fib n +| 0 := rfl +| (succ n) := + sorry + /- + begin + have h₁ : fib_fast_aux n (fib 0) (fib 1) = fib (succ n), from !fib_fast_aux_lemma, + change fib_fast_aux n 1 (1+0) = fib (succ n), + krewrite h₁ + end + -/ diff --git a/old_library/data/nat/examples/partial_sum.lean b/old_library/data/nat/examples/partial_sum.lean new file mode 100644 index 0000000000..e5b20f3b73 --- /dev/null +++ b/old_library/data/nat/examples/partial_sum.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +import data.nat +open nat + +definition partial_sum : nat → nat +| 0 := 0 +| (succ n) := succ n + partial_sum n + +example : partial_sum 5 = 15 := +rfl + +example : partial_sum 6 = 21 := +rfl + +lemma two_mul_partial_sum_eq : ∀ n, 2 * partial_sum n = (succ n) * n +| 0 := sorry -- by reflexivity +| (succ n) := +sorry +/- +calc + 2 * (succ n + partial_sum n) = 2 * succ n + 2 * partial_sum n : by rewrite left_distrib + ... = 2 * succ n + succ n * n : by rewrite two_mul_partial_sum_eq + ... = 2 * succ n + n * succ n : by rewrite (mul.comm n (succ n)) + ... = (2 + n) * succ n : by rewrite right_distrib + ... = (n + 2) * succ n : by rewrite add.comm + ... = (succ (succ n)) * succ n : rfl +-/ + +theorem partial_sum_eq : ∀ n, partial_sum n = ((n + 1) * n) / 2 := +sorry +/- +take n, +have h₁ : (2 * partial_sum n) / 2 = ((succ n) * n) / 2, by rewrite two_mul_partial_sum_eq, +have h₂ : (2:nat) > 0, from dec_trivial, +by rewrite [nat.mul_div_cancel_left _ h₂ at h₁]; exact h₁ +-/ diff --git a/old_library/data/nat/fact.lean b/old_library/data/nat/fact.lean new file mode 100644 index 0000000000..b3b91b713f --- /dev/null +++ b/old_library/data/nat/fact.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Factorial +-/ +import data.nat.div + +namespace nat +definition fact : nat → nat +| 0 := 1 +| (succ n) := (succ n) * fact n + +lemma fact_zero : fact 0 = 1 := +rfl + +lemma fact_one : fact 1 = 1 := +rfl + +lemma fact_succ (n) : fact (succ n) = succ n * fact n := +rfl + +lemma fact_pos : ∀ n, fact n > 0 +| 0 := zero_lt_one +| (succ n) := mul_pos (succ_pos n) (fact_pos n) + +lemma fact_ne_zero (n : ℕ) : fact n ≠ 0 := ne_of_gt (fact_pos n) + +lemma dvd_fact : ∀ {m n}, m > 0 → m ≤ n → m ∣ fact n +| m 0 h₁ h₂ := absurd h₁ (not_lt_of_ge h₂) +| m (succ n) h₁ h₂ := + sorry +/- + begin + rewrite fact_succ, + cases (eq_or_lt_of_le h₂) with he hl, + {subst m, apply dvd_mul_right}, + {have aux : m ∣ fact n, from dvd_fact h₁ (le_of_lt_succ hl), + apply dvd_mul_of_dvd_right aux} + end +-/ + +lemma fact_le {m n} : m ≤ n → fact m ≤ fact n := +sorry +/- +begin + induction n with n ih, + {intro h, + have meq0 : m = 0, from eq_zero_of_le_zero h, + subst m}, + {intro m_le_succ_n, + cases (eq_or_lt_of_le m_le_succ_n) with h₁ h₂, + {subst m}, + {transitivity (fact n), + exact ih (le_of_lt_succ h₂), + rewrite [fact_succ, -one_mul at {1}], + exact nat.mul_le_mul (succ_le_succ (zero_le n)) !le.refl}} +end +-/ +end nat diff --git a/old_library/data/nat/find.lean b/old_library/data/nat/find.lean new file mode 100644 index 0000000000..c4d6f2a557 --- /dev/null +++ b/old_library/data/nat/find.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Choice function for decidable predicates on natural numbers. + +This module provides the following two declarations: + +choose {p : nat → Prop} [d : decidable_pred p] : (∃ x, p x) → nat +choose_spec {p : nat → Prop} [d : decidable_pred p] (ex : ∃ x, p x) : p (choose ex) +-/ +import data.nat.basic data.nat.order +open nat subtype decidable well_founded + +namespace nat +section find_x +parameter {p : nat → Prop} + +private definition lbp (x : nat) : Prop := ∀ y, y < x → ¬ p y + +private lemma lbp_zero : lbp 0 := +λ y h, absurd h (not_lt_zero y) + +private lemma lbp_succ {x : nat} : lbp x → ¬ p x → lbp (succ x) := +sorry +/- +λ lx npx y yltsx, + or.elim (eq_or_lt_of_le (le_of_succ_le_succ yltsx)) + (suppose y = x, by substvars; assumption) + (suppose y < x, lx y this) +-/ + +private definition gtb (a b : nat) : Prop := +a > b ∧ lbp a + +local infix ` ≺ `:50 := gtb + +private lemma acc_of_px {x : nat} : p x → acc gtb x := +sorry +/- +assume h, +acc.intro x (λ (y : nat) (l : y ≺ x), + obtain (h₁ : y > x) (h₂ : ∀ a, a < y → ¬ p a), from l, + absurd h (h₂ x h₁)) +-/ + +private lemma acc_of_acc_succ {x : nat} : acc gtb (succ x) → acc gtb x := +sorry +/- +assume h, +acc.intro x (λ (y : nat) (l : y ≺ x), + by_cases + (suppose y = succ x, by substvars; assumption) + (suppose y ≠ succ x, + have x < y, from and.elim_left l, + have succ x < y, from lt_of_le_of_ne this (ne.symm `y ≠ succ x`), + acc.inv h (and.intro this (and.elim_right l)))) +-/ + +private lemma acc_of_px_of_gt {x y : nat} : p x → y > x → acc gtb y := +sorry +/- +assume px ygtx, +acc.intro y (λ (z : nat) (l : z ≺ y), + obtain (zgty : z > y) (h : ∀ a, a < z → ¬ p a), from l, + absurd px (h x (lt.trans ygtx zgty))) +-/ + +private lemma acc_of_acc_of_lt : ∀ {x y : nat}, acc gtb x → y < x → acc gtb y +:= sorry +/- +| 0 y a0 ylt0 := absurd ylt0 !not_lt_zero +| (succ x) y asx yltsx := + have acc gtb x, from acc_of_acc_succ asx, + by_cases + (suppose y = x, by substvars; assumption) + (suppose y ≠ x, acc_of_acc_of_lt `acc gtb x` (lt_of_le_of_ne (le_of_lt_succ yltsx) this)) +-/ + +parameter (ex : ∃ a, p a) +parameter [dp : decidable_pred p] +include dp + +private lemma acc_of_ex (x : nat) : acc gtb x := +sorry +/- +using ex, +obtain (w : nat) (pw : p w), from ex, +lt.by_cases + (suppose x < w, acc_of_acc_of_lt (acc_of_px pw) this) + (suppose x = w, by subst x; exact (acc_of_px pw)) + (suppose x > w, acc_of_px_of_gt pw this) +-/ +private lemma wf_gtb : well_founded gtb := +well_founded.intro acc_of_ex + +private definition find.F (x : nat) : (Π x₁, x₁ ≺ x → lbp x₁ → {a : nat \ p a}) → lbp x → {a : nat \ p a} := +match x with +| 0 := λ f l0, by_cases + (λ p0 : p 0, tag 0 p0) + (suppose ¬ p 0, + have h₁ : lbp 1, from lbp_succ l0 this, + have 1 ≺ 0, from and.intro (lt.base 0) h₁, + f 1 this h₁) +| (succ n) := λ f lsn, by_cases + (suppose p (succ n), tag (succ n) this) + (suppose ¬ p (succ n), + have lss : lbp (succ (succ n)), from lbp_succ lsn this, + have succ (succ n) ≺ succ n, from and.intro (lt.base (succ n)) lss, + f (succ (succ n)) this lss) +end +include ex -- todo remove +private definition find_x : {x : nat \ p x} := +@fix _ _ _ wf_gtb find.F 0 lbp_zero +end find_x + +protected definition find {p : nat → Prop} [d : decidable_pred p] : (∃ x, p x) → nat := +assume h, elt_of (find_x h) + +protected theorem find_spec {p : nat → Prop} [d : decidable_pred p] (ex : ∃ x, p x) : p (nat.find ex) := +has_property (find_x ex) +end nat diff --git a/old_library/data/nat/gcd.lean b/old_library/data/nat/gcd.lean new file mode 100644 index 0000000000..c7e10c5a0d --- /dev/null +++ b/old_library/data/nat/gcd.lean @@ -0,0 +1,412 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad, Leonardo de Moura + +Definitions and properties of gcd, lcm, and coprime. +-/ +import .div +open well_founded decidable prod + +namespace nat + +/- gcd -/ + +private definition pair_nat.lt : nat × nat → nat × nat → Prop := measure pr₂ +private definition pair_nat.lt.wf : well_founded pair_nat.lt := +intro_k (measure_wf pr₂) 20 -- we use intro_k to be able to execute gcd efficiently in the kernel + +local infixl ` ≺ `:50 := pair_nat.lt + +private definition gcd.lt.dec (x y₁ : nat) : (succ y₁, x % succ y₁) ≺ (x, succ y₁) := +mod_lt x (succ_pos y₁) + +definition gcd.F : Π (p₁ : nat × nat), (Π p₂ : nat × nat, p₂ ≺ p₁ → nat) → nat +| (x, 0) f := x +| (x, succ y) f := f (succ y, x % succ y) (gcd.lt.dec x y) + +definition gcd (x y : nat) := fix pair_nat.lt.wf gcd.F (x, y) + +attribute [simp] +theorem gcd_zero_right (x : nat) : gcd x 0 = x := rfl + +attribute [simp] +theorem gcd_succ (x y : nat) : gcd x (succ y) = gcd (succ y) (x % succ y) := +well_founded.fix_eq pair_nat.lt.wf gcd.F (x, succ y) + +theorem gcd_one_right (n : ℕ) : gcd n 1 = 1 := +calc gcd n 1 = gcd 1 (n % 1) : gcd_succ n 0 + ... = gcd 1 0 : sorry -- by rewrite mod_one + +theorem gcd_def (x : ℕ) : Π (y : ℕ), gcd x y = if y = 0 then x else gcd y (x % y) +| 0 := gcd_zero_right _ +| (succ y) := eq.trans (gcd_succ x y) $ eq.symm (if_neg (succ_ne_zero y)) + + +theorem gcd_self : Π (n : ℕ), gcd n n = n +| 0 := rfl +| (succ n₁) := calc + gcd (succ n₁) (succ n₁) = gcd (succ n₁) (succ n₁ % succ n₁) : gcd_succ (succ n₁) n₁ + ... = gcd (succ n₁) 0 : sorry -- by rewrite mod_self + +theorem gcd_zero_left : Π (n : ℕ), gcd 0 n = n +| 0 := rfl +| (succ n₁) := calc + gcd 0 (succ n₁) = gcd (succ n₁) (0 % succ n₁) : gcd_succ 0 n₁ + ... = gcd (succ n₁) 0 : sorry -- by rewrite zero_mod + +theorem gcd_of_pos (m : ℕ) {n : ℕ} (H : n > 0) : gcd m n = gcd n (m % n) := +eq.trans (gcd_def m n) $ if_neg (ne_zero_of_pos H) + +theorem gcd_rec (m n : ℕ) : gcd m n = gcd n (m % n) := +sorry +/- +by_cases_zero_pos n + (calc + m = gcd 0 m : by rewrite gcd_zero_left + ... = gcd 0 (m % 0) : by rewrite mod_zero) + (take n, assume H : 0 < n, gcd_of_pos m H) +-/ + +theorem gcd.induction {P : ℕ → ℕ → Prop} + (m n : ℕ) + (H0 : ∀m, P m 0) + (H1 : ∀m n, 0 < n → P n (m % n) → P m n) : + P m n := +induction pair_nat.lt.wf (m, n) (prod.rec (λm, nat.rec (λ IH, H0 m) + (λ n₁ v (IH : ∀p₂, p₂ ≺ (m, succ n₁) → P (pr₁ p₂) (pr₂ p₂)), + H1 m (succ n₁) (succ_pos n₁) (IH _ (gcd.lt.dec m n₁))))) + +theorem gcd_dvd (m n : ℕ) : (gcd m n ∣ m) ∧ (gcd m n ∣ n) := +gcd.induction m n + (take m, and.intro (one_mul m ▸ dvd_mul_left m 1) (dvd_zero (gcd m 0))) + (take m n (npos : 0 < n), and.rec + (assume (IH₁ : gcd n (m % n) ∣ n) (IH₂ : gcd n (m % n) ∣ (m % n)), + have H : (gcd n (m % n) ∣ (m / n * n + m % n)), from + dvd_add (dvd.trans IH₁ (dvd_mul_left n (m / n))) IH₂, + have H1 : (gcd n (m % n) ∣ m), from eq.symm (eq_div_mul_add_mod m n) ▸ H, + show (gcd m n ∣ m) ∧ (gcd m n ∣ n), from eq.symm (gcd_rec m n) ▸ (and.intro H1 IH₁))) + +theorem gcd_dvd_left (m n : ℕ) : gcd m n ∣ m := and.left $ gcd_dvd m n + +theorem gcd_dvd_right (m n : ℕ) : gcd m n ∣ n := and.right $ gcd_dvd m n + +theorem dvd_gcd {m n k : ℕ} : k ∣ m → k ∣ n → k ∣ gcd m n := +gcd.induction m n (take m, imp.intro) + (take m n (npos : n > 0) + (IH : k ∣ n → k ∣ m % n → k ∣ gcd n (m % n)) + (H1 : k ∣ m) (H2 : k ∣ n), + have H3 : k ∣ m / n * n + m % n, from eq_div_mul_add_mod m n ▸ H1, + have H4 : k ∣ m % n, from nat.dvd_of_dvd_add_left H3 (dvd.trans H2 (dvd_mul_left n (m / n))), + eq.symm (gcd_rec m n) ▸ IH H2 H4) + +theorem gcd.comm (m n : ℕ) : gcd m n = gcd n m := +dvd.antisymm + (dvd_gcd (gcd_dvd_right m n) (gcd_dvd_left m n)) + (dvd_gcd (gcd_dvd_right n m) (gcd_dvd_left n m)) + +theorem gcd.assoc (m n k : ℕ) : gcd (gcd m n) k = gcd m (gcd n k) := +dvd.antisymm + (dvd_gcd + (dvd.trans (gcd_dvd_left (gcd m n) k) (gcd_dvd_left m n)) + (dvd_gcd (dvd.trans (gcd_dvd_left (gcd m n) k) (gcd_dvd_right m n)) (gcd_dvd_right (gcd m n) k))) + (dvd_gcd + (dvd_gcd (gcd_dvd_left m (gcd n k)) (dvd.trans (gcd_dvd_right m (gcd n k)) (gcd_dvd_left n k))) + (dvd.trans (gcd_dvd_right m (gcd n k)) (gcd_dvd_right n k))) + +theorem gcd_one_left (m : ℕ) : gcd 1 m = 1 := +eq.trans (gcd.comm 1 m) $ gcd_one_right m + +theorem gcd_mul_left (m n k : ℕ) : gcd (m * n) (m * k) = m * gcd n k := +sorry +/- +gcd.induction n k + (take n, calc gcd (m * n) (m * 0) = gcd (m * n) 0 : by rewrite mul_zero) + (take n k, + assume H : 0 < k, + assume IH : gcd (m * k) (m * (n % k)) = m * gcd k (n % k), + calc + gcd (m * n) (m * k) = gcd (m * k) (m * n % (m * k)) : !gcd_rec + ... = gcd (m * k) (m * (n % k)) : by rewrite mul_mod_mul_left + ... = m * gcd k (n % k) : by rewrite IH + ... = m * gcd n k : by rewrite -gcd_rec) +-/ + +theorem gcd_mul_right (m n k : ℕ) : gcd (m * n) (k * n) = gcd m k * n := +sorry +/- +calc + gcd (m * n) (k * n) = gcd (n * m) (k * n) : by rewrite (mul.comm m n) + ... = gcd (n * m) (n * k) : by rewrite (mul.comm n k) + ... = n * gcd m k : by rewrite gcd_mul_left + ... = gcd m k * n : by rewrite mul.comm +-/ + +theorem gcd_pos_of_pos_left {m : ℕ} (n : ℕ) (mpos : m > 0) : gcd m n > 0 := +pos_of_dvd_of_pos (gcd_dvd_left m n) mpos + +theorem gcd_pos_of_pos_right (m : ℕ) {n : ℕ} (npos : n > 0) : gcd m n > 0 := +pos_of_dvd_of_pos (gcd_dvd_right m n) npos + +theorem eq_zero_of_gcd_eq_zero_left {m n : ℕ} (H : gcd m n = 0) : m = 0 := +or.elim (eq_zero_or_pos m) + (assume H1, H1) + (assume H1 : m > 0, absurd (eq.symm H) (ne_of_lt (gcd_pos_of_pos_left _ H1))) + +theorem eq_zero_of_gcd_eq_zero_right {m n : ℕ} (H : gcd m n = 0) : n = 0 := +eq_zero_of_gcd_eq_zero_left (gcd.comm m n ▸ H) + +theorem gcd_div {m n k : ℕ} (H1 : k ∣ m) (H2 : k ∣ n) : + gcd (m / k) (n / k) = gcd m n / k := +sorry +/- +or.elim (eq_zero_or_pos k) + (assume H3 : k = 0, by subst k; rewrite *nat.div_zero) + (assume H3 : k > 0, (nat.div_eq_of_eq_mul_left H3 (calc + gcd m n = gcd m (n / k * k) : by rewrite (nat.div_mul_cancel H2) + ... = gcd (m / k * k) (n / k * k) : by rewrite (nat.div_mul_cancel H1) + ... = gcd (m / k) (n / k) * k : by rewrite gcd_mul_right))⁻¹) +-/ + +theorem gcd_dvd_gcd_mul_left (m n k : ℕ) : gcd m n ∣ gcd (k * m) n := +dvd_gcd (dvd.trans (gcd_dvd_left m n) (dvd_mul_left m k)) (gcd_dvd_right m n) + +theorem gcd_dvd_gcd_mul_right (m n k : ℕ) : gcd m n ∣ gcd (m * k) n := +mul.comm k m ▸ gcd_dvd_gcd_mul_left m n k + +theorem gcd_dvd_gcd_mul_left_right (m n k : ℕ) : gcd m n ∣ gcd m (k * n) := +dvd_gcd (gcd_dvd_left m n) (dvd.trans (gcd_dvd_right m n) (dvd_mul_left n k)) + +theorem gcd_dvd_gcd_mul_right_right (m n k : ℕ) : gcd m n ∣ gcd m (n * k) := +mul.comm k n ▸ gcd_dvd_gcd_mul_left_right m n k + +/- lcm -/ + +definition lcm (m n : ℕ) : ℕ := m * n / (gcd m n) + +theorem lcm.comm (m n : ℕ) : lcm m n = lcm n m := +sorry +/- +calc + lcm m n = m * n / gcd m n : rfl + ... = n * m / gcd m n : by rewrite mul.comm + ... = n * m / gcd n m : by rewrite gcd.comm + ... = lcm n m : rfl +-/ + +theorem lcm_zero_left (m : ℕ) : lcm 0 m = 0 := +sorry +/- +calc + lcm 0 m = 0 * m / gcd 0 m : rfl + ... = 0 / gcd 0 m : by rewrite zero_mul + ... = 0 : by rewrite nat.zero_div +-/ + +theorem lcm_zero_right (m : ℕ) : lcm m 0 = 0 := lcm.comm 0 m ▸ lcm_zero_left m + +theorem lcm_one_left (m : ℕ) : lcm 1 m = m := +sorry +/- +calc + lcm 1 m = 1 * m / gcd 1 m : rfl + ... = m / gcd 1 m : by rewrite one_mul + ... = m / 1 : by rewrite gcd_one_left + ... = m : by rewrite nat.div_one +-/ + +theorem lcm_one_right (m : ℕ) : lcm m 1 = m := lcm.comm 1 m ▸ lcm_one_left m + +theorem lcm_self (m : ℕ) : lcm m m = m := +sorry +/- +have H : m * m / m = m, from + by_cases_zero_pos m !nat.div_zero (take m, assume H1 : m > 0, !nat.mul_div_cancel H1), +calc + lcm m m = m * m / gcd m m : rfl + ... = m * m / m : by rewrite gcd_self + ... = m : H +-/ + +theorem dvd_lcm_left (m n : ℕ) : m ∣ lcm m n := +have H : lcm m n = m * (n / gcd m n), from nat.mul_div_assoc _ $ gcd_dvd_right m n, +dvd.intro (eq.symm H) + +theorem dvd_lcm_right (m n : ℕ) : n ∣ lcm m n := +lcm.comm n m ▸ dvd_lcm_left n m + +theorem gcd_mul_lcm (m n : ℕ) : gcd m n * lcm m n = m * n := +eq.symm (nat.eq_mul_of_div_eq_right (dvd.trans (gcd_dvd_left m n) (dvd_mul_right m n)) rfl) + +theorem lcm_dvd {m n k : ℕ} (H1 : m ∣ k) (H2 : n ∣ k) : lcm m n ∣ k := +sorry +/- +or.elim (eq_zero_or_pos k) + (assume kzero : k = 0, !kzero⁻¹ ▸ !dvd_zero) + (assume kpos : k > 0, + have mpos : m > 0, from pos_of_dvd_of_pos H1 kpos, + have npos : n > 0, from pos_of_dvd_of_pos H2 kpos, + have gcd_pos : gcd m n > 0, from !gcd_pos_of_pos_left mpos, + obtain p (km : k = m * p), from exists_eq_mul_right_of_dvd H1, + obtain q (kn : k = n * q), from exists_eq_mul_right_of_dvd H2, + have ppos : p > 0, from pos_of_mul_pos_left (km ▸ kpos), + have qpos : q > 0, from pos_of_mul_pos_left (kn ▸ kpos), + have H3 : p * q * (m * n * gcd p q) = p * q * (gcd m n * k), from + calc + p * q * (m * n * gcd p q) + = m * p * (n * q * gcd p q) : by rewrite [*mul.assoc, *mul.left_comm q, + mul.left_comm p] + ... = k * (k * gcd p q) : by rewrite [-kn, -km] + ... = k * gcd (k * p) (k * q) : by rewrite gcd_mul_left + ... = k * gcd (n * q * p) (m * p * q) : by rewrite [-kn, -km] + ... = k * (gcd n m * (p * q)) : by rewrite [*mul.assoc, mul.comm q, gcd_mul_right] + ... = p * q * (gcd m n * k) : by rewrite [mul.comm, mul.comm (gcd n m), gcd.comm, + *mul.assoc], + have H4 : m * n * gcd p q = gcd m n * k, + from !eq_of_mul_eq_mul_left (mul_pos ppos qpos) H3, + have H5 : gcd m n * (lcm m n * gcd p q) = gcd m n * k, + from !mul.assoc ▸ !gcd_mul_lcm⁻¹ ▸ H4, + have H6 : lcm m n * gcd p q = k, + from !eq_of_mul_eq_mul_left gcd_pos H5, + dvd.intro H6) +-/ + +theorem lcm.assoc (m n k : ℕ) : lcm (lcm m n) k = lcm m (lcm n k) := +dvd.antisymm + (lcm_dvd + (lcm_dvd (dvd_lcm_left m (lcm n k)) (dvd.trans (dvd_lcm_left n k) (dvd_lcm_right m (lcm n k)))) + (dvd.trans (dvd_lcm_right n k) (dvd_lcm_right m (lcm n k)))) + (lcm_dvd + (dvd.trans (dvd_lcm_left m n) (dvd_lcm_left (lcm m n) k)) + (lcm_dvd (dvd.trans (dvd_lcm_right m n) (dvd_lcm_left (lcm m n) k)) (dvd_lcm_right (lcm m n) k))) + +/- coprime -/ + +attribute [reducible] +definition coprime (m n : ℕ) : Prop := gcd m n = 1 + +lemma gcd_eq_one_of_coprime {m n : ℕ} : coprime m n → gcd m n = 1 := +λ h, h + +theorem coprime_swap {m n : ℕ} (H : coprime n m) : coprime m n := +gcd.comm n m ▸ H + +theorem dvd_of_coprime_of_dvd_mul_right {m n k : ℕ} (H1 : coprime k n) (H2 : k ∣ m * n) : k ∣ m := +sorry +/- +have H3 : gcd (m * k) (m * n) = m, from + calc + gcd (m * k) (m * n) = m * gcd k n : by rewrite gcd_mul_left + ... = m * 1 : begin unfold coprime at H1, rewrite H1 end + ... = m : by rewrite mul_one, +have H4 : (k ∣ gcd (m * k) (m * n)), from dvd_gcd !dvd_mul_left H2, +H3 ▸ H4 +-/ + +theorem dvd_of_coprime_of_dvd_mul_left {m n k : ℕ} (H1 : coprime k m) (H2 : k ∣ m * n) : k ∣ n := +dvd_of_coprime_of_dvd_mul_right H1 (mul.comm m n ▸ H2) + +theorem gcd_mul_left_cancel_of_coprime {k : ℕ} (m : ℕ) {n : ℕ} (H : coprime k n) : + gcd (k * m) n = gcd m n := +sorry +/- +have H1 : coprime (gcd (k * m) n) k, from + calc + gcd (gcd (k * m) n) k + = gcd (k * gcd 1 m) n : by rewrite [-gcd_mul_left, mul_one, gcd.comm, gcd.assoc] + ... = 1 : by rewrite [gcd_one_left, mul_one, ↑coprime at H, H], +dvd.antisymm + (dvd_gcd (dvd_of_coprime_of_dvd_mul_left H1 !gcd_dvd_left) !gcd_dvd_right) + (dvd_gcd (dvd.trans !gcd_dvd_left !dvd_mul_left) !gcd_dvd_right) +-/ + +theorem gcd_mul_right_cancel_of_coprime (m : ℕ) {k n : ℕ} (H : coprime k n) : + gcd (m * k) n = gcd m n := +mul.comm k m ▸ gcd_mul_left_cancel_of_coprime m H + +theorem gcd_mul_left_cancel_of_coprime_right {k m : ℕ} (n : ℕ) (H : coprime k m) : + gcd m (k * n) = gcd m n := +gcd.comm n m ▸ gcd.comm (k * n) m ▸ gcd_mul_left_cancel_of_coprime n H + +theorem gcd_mul_right_cancel_of_coprime_right {k m : ℕ} (n : ℕ) (H : coprime k m) : + gcd m (n * k) = gcd m n := +gcd.comm n m ▸ gcd.comm (n * k) m ▸ gcd_mul_right_cancel_of_coprime n H + +theorem coprime_div_gcd_div_gcd {m n : ℕ} (H : gcd m n > 0) : + coprime (m / gcd m n) (n / gcd m n) := +calc + gcd (m / gcd m n) (n / gcd m n) = gcd m n / gcd m n : gcd_div (gcd_dvd_left m n) (gcd_dvd_right m n) + ... = 1 : nat.div_self H + +theorem not_coprime_of_dvd_of_dvd {m n d : ℕ} (dgt1 : d > 1) (Hm : d ∣ m) (Hn : d ∣ n) : + ¬ coprime m n := +sorry +/- +assume co : coprime m n, +have d ∣ gcd m n, from dvd_gcd Hm Hn, +have d ∣ 1, by rewrite [↑coprime at co, co at this]; apply this, +have d ≤ 1, from le_of_dvd dec_trivial this, +show false, from not_lt_of_ge `d ≤ 1` `d > 1` +-/ + +theorem exists_coprime {m n : ℕ} (H : gcd m n > 0) : + exists m' n', coprime m' n' ∧ m = m' * gcd m n ∧ n = n' * gcd m n := +have H1 : m = (m / gcd m n) * gcd m n, from eq.symm (nat.div_mul_cancel (gcd_dvd_left m n)), +have H2 : n = (n / gcd m n) * gcd m n, from eq.symm (nat.div_mul_cancel (gcd_dvd_right m n)), +exists.intro _ (exists.intro _ (and.intro (coprime_div_gcd_div_gcd H) (and.intro H1 H2))) + +theorem coprime_mul {m n k : ℕ} (H1 : coprime m k) (H2 : coprime n k) : coprime (m * n) k := +calc + gcd (m * n) k = gcd n k : gcd_mul_left_cancel_of_coprime n H1 + ... = 1 : H2 + +theorem coprime_mul_right {k m n : ℕ} (H1 : coprime k m) (H2 : coprime k n) : coprime k (m * n) := +coprime_swap (coprime_mul (coprime_swap H1) (coprime_swap H2)) + +theorem coprime_of_coprime_mul_left {k m n : ℕ} (H : coprime (k * m) n) : coprime m n := +have H1 : (gcd m n ∣ gcd (k * m) n), from gcd_dvd_gcd_mul_left m n k, +eq_one_of_dvd_one (H ▸ H1) + +theorem coprime_of_coprime_mul_right {k m n : ℕ} (H : coprime (m * k) n) : coprime m n := +coprime_of_coprime_mul_left (mul.comm m k ▸ H) + +theorem coprime_of_coprime_mul_left_right {k m n : ℕ} (H : coprime m (k * n)) : coprime m n := +coprime_swap (coprime_of_coprime_mul_left (coprime_swap H)) + +theorem coprime_of_coprime_mul_right_right {k m n : ℕ} (H : coprime m (n * k)) : coprime m n := +coprime_of_coprime_mul_left_right (mul.comm n k ▸ H) + +theorem comprime_one_left : ∀ n, coprime 1 n := +λ n, gcd_one_left n + +theorem comprime_one_right : ∀ n, coprime n 1 := +λ n, gcd_one_right n + +theorem exists_eq_prod_and_dvd_and_dvd {m n k : nat} (H : k ∣ m * n) : + ∃ m' n', k = m' * n' ∧ m' ∣ m ∧ n' ∣ n := +sorry +/- +or.elim (eq_zero_or_pos (gcd k m)) + (assume H1 : gcd k m = 0, + have H2 : k = 0, from eq_zero_of_gcd_eq_zero_left H1, + have H3 : m = 0, from eq_zero_of_gcd_eq_zero_right H1, + have H4 : k = 0 * n, from H2 ⬝ !zero_mul⁻¹, + have H5 : 0 ∣ m, from H3⁻¹ ▸ !dvd.refl, + have H6 : n ∣ n, from !dvd.refl, + exists.intro _ (exists.intro _ (and.intro H4 (and.intro H5 H6)))) + (assume H1 : gcd k m > 0, + have H2 : gcd k m ∣ k, from !gcd_dvd_left, + have H3 : k / gcd k m ∣ (m * n) / gcd k m, from nat.div_dvd_div H2 H, + have H4 : (m * n) / gcd k m = (m / gcd k m) * n, from + calc + m * n / gcd k m = n * m / gcd k m : by rewrite mul.comm + ... = n * (m / gcd k m) : !nat.mul_div_assoc !gcd_dvd_right + ... = m / gcd k m * n : by rewrite mul.comm, + have H5 : k / gcd k m ∣ (m / gcd k m) * n, from H4 ▸ H3, + have H6 : coprime (k / gcd k m) (m / gcd k m), from coprime_div_gcd_div_gcd H1, + have H7 : k / gcd k m ∣ n, from dvd_of_coprime_of_dvd_mul_left H6 H5, + have H8 : k = gcd k m * (k / gcd k m), from (nat.mul_div_cancel' H2)⁻¹, + exists.intro _ (exists.intro _ (and.intro H8 (and.intro !gcd_dvd_right H7)))) +-/ + +end nat diff --git a/old_library/data/nat/nat.md b/old_library/data/nat/nat.md new file mode 100644 index 0000000000..1f9c2ad0f5 --- /dev/null +++ b/old_library/data/nat/nat.md @@ -0,0 +1,14 @@ +data.nat +======== + +The natural numbers. + +* [basic](basic.lean) : the natural numbers, with succ, pred, addition, and multiplication +* [order](order.lean) : less-than, less-then-or-equal, etc. +* [bquant](bquant.lean) : bounded quantifiers +* [sub](sub.lean) : subtraction, and distance +* [div](div.lean) : div and mod +* [gcd](gcd.lean) : gcd, lcm, and coprime +* [power](power.lean) +* [bigops](bigops.lean) : finite sums and products +* [find](find.lean) : search for a witness to an existence statement \ No newline at end of file diff --git a/old_library/data/nat/order.lean b/old_library/data/nat/order.lean new file mode 100644 index 0000000000..ae41769d30 --- /dev/null +++ b/old_library/data/nat/order.lean @@ -0,0 +1,616 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Floris van Doorn, Leonardo de Moura, Jeremy Avigad + +The order relation on the natural numbers. +-/ +import .basic algebra.ordered_ring + +namespace nat + +/- lt and le -/ + +protected theorem le_of_lt_or_eq {m n : ℕ} (H : m < n ∨ m = n) : m ≤ n := +nat.le_of_eq_or_lt (or.swap H) + +protected theorem lt_or_eq_of_le {m n : ℕ} (H : m ≤ n) : m < n ∨ m = n := +or.swap (nat.eq_or_lt_of_le H) + +protected theorem le_iff_lt_or_eq (m n : ℕ) : m ≤ n ↔ m < n ∨ m = n := +iff.intro nat.lt_or_eq_of_le nat.le_of_lt_or_eq + +protected theorem lt_of_le_and_ne {m n : ℕ} (H1 : m ≤ n) : m ≠ n → m < n := +or_resolve_right (nat.eq_or_lt_of_le H1) + +protected theorem lt_iff_le_and_ne (m n : ℕ) : m < n ↔ m ≤ n ∧ m ≠ n := +iff.intro + (take H, and.intro (nat.le_of_lt H) (take H1, nat.lt_irrefl n (H1 ▸ H))) + (and.rec nat.lt_of_le_and_ne) + +theorem le_add_right (n k : ℕ) : n ≤ n + k := +nat.rec (nat.le_refl n) (λ k, le_succ_of_le) k + +theorem le_add_left (n m : ℕ): n ≤ m + n := +add.comm n m ▸ le_add_right n m + +theorem le.intro {n m k : ℕ} (h : n + k = m) : n ≤ m := +h ▸ le_add_right n k + +theorem le.elim {n m : ℕ} : n ≤ m → ∃ k, n + k = m := +le.rec (exists.intro 0 rfl) (λm h, Exists.rec + (λ k H, exists.intro (succ k) (H ▸ rfl))) + +protected theorem le_total {m n : ℕ} : m ≤ n ∨ n ≤ m := +or.imp_left nat.le_of_lt (nat.lt_or_ge m n) + +/- addition -/ + +protected theorem add_le_add_left {n m : ℕ} (H : n ≤ m) (k : ℕ) : k + n ≤ k + m := +sorry -- obtain l Hl, from le.elim H, le.intro (Hl ▸ !add.assoc) + +protected theorem add_le_add_right {n m : ℕ} (H : n ≤ m) (k : ℕ) : n + k ≤ m + k := +add.comm k m ▸ add.comm k n ▸ nat.add_le_add_left H k + +protected theorem le_of_add_le_add_left {k n m : ℕ} (H : k + n ≤ k + m) : n ≤ m := +sorry -- obtain l Hl, from le.elim H, le.intro (nat.add_left_cancel (!add.assoc⁻¹ ⬝ Hl)) + +protected theorem lt_of_add_lt_add_left {k n m : ℕ} (H : k + n < k + m) : n < m := +let H' := nat.le_of_lt H in +nat.lt_of_le_and_ne (nat.le_of_add_le_add_left H') (assume Heq, nat.lt_irrefl (k + m) (Heq ▸ H)) + +protected theorem add_lt_add_left {n m : ℕ} (H : n < m) (k : ℕ) : k + n < k + m := +lt_of_succ_le (add_succ k n ▸ nat.add_le_add_left (succ_le_of_lt H) k) + +protected theorem add_lt_add_right {n m : ℕ} (H : n < m) (k : ℕ) : n + k < m + k := +add.comm k m ▸ add.comm k n ▸ nat.add_lt_add_left H k + +protected theorem lt_add_of_pos_right {n k : ℕ} (H : k > 0) : n < n + k := +add_zero (n + k) ▸ nat.add_lt_add_left H n + +/- multiplication -/ + +theorem mul_le_mul_left {n m : ℕ} (k : ℕ) (H : n ≤ m) : k * n ≤ k * m := +sorry +/- +obtain (l : ℕ) (Hl : n + l = m), from le.elim H, +have k * n + k * l = k * m, by rewrite [-left_distrib, Hl], +le.intro this +-/ + +theorem mul_le_mul_right {n m : ℕ} (k : ℕ) (H : n ≤ m) : n * k ≤ m * k := +mul.comm k m ▸ mul.comm k n ▸ mul_le_mul_left k H + +protected theorem mul_le_mul {n m k l : ℕ} (H1 : n ≤ k) (H2 : m ≤ l) : n * m ≤ k * l := +nat.le_trans (nat.mul_le_mul_right m H1) (nat.mul_le_mul_left k H2) + +protected theorem mul_lt_mul_of_pos_left {n m k : ℕ} (H : n < m) (Hk : k > 0) : k * n < k * m := +nat.lt_of_lt_of_le (nat.lt_add_of_pos_right Hk) (mul_succ k n ▸ nat.mul_le_mul_left k (succ_le_of_lt H)) + +protected theorem mul_lt_mul_of_pos_right {n m k : ℕ} (H : n < m) (Hk : k > 0) : n * k < m * k := +mul.comm k m ▸ mul.comm k n ▸ nat.mul_lt_mul_of_pos_left H Hk + +/- nat is an instance of a linearly ordered semiring and a lattice -/ + +attribute [instance] +protected definition decidable_linear_ordered_semiring : +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_or_eq := @nat.le_iff_lt_or_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 ⦄ + +attribute [instance, priority nat.prio] +definition nat_has_dvd : has_dvd nat := +has_dvd.mk has_dvd.dvd + +theorem add_pos_left {a : ℕ} (H : 0 < a) (b : ℕ) : 0 < a + b := +@add_pos_of_pos_of_nonneg _ _ a b H (zero_le b) + +theorem add_pos_right {a : ℕ} (H : 0 < a) (b : ℕ) : 0 < b + a := +sorry -- by rewrite add.comm; apply add_pos_left H b + +theorem add_eq_zero_iff_eq_zero_and_eq_zero {a b : ℕ} : +a + b = 0 ↔ a = 0 ∧ b = 0 := +@add_eq_zero_iff_eq_zero_and_eq_zero_of_nonneg_of_nonneg _ _ a b (zero_le a) (zero_le b) + +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 a) 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 a) + +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 a) 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 a) + +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 c) + +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 c) + +theorem pos_of_mul_pos_left {a b : ℕ} (H : 0 < a * b) : 0 < b := +@pos_of_mul_pos_left _ _ a b H (zero_le a) + +theorem pos_of_mul_pos_right {a b : ℕ} (H : 0 < a * b) : 0 < a := +@pos_of_mul_pos_right _ _ a b H (zero_le b) + +theorem zero_le_one : (0:nat) ≤ 1 := +dec_trivial + +/- properties specific to nat -/ + +theorem lt_intro {n m k : ℕ} (H : succ n + k = m) : n < m := +lt_of_succ_le (le.intro H) + +theorem lt_elim {n m : ℕ} (H : n < m) : ∃k, succ n + k = m := +le.elim (succ_le_of_lt H) + +theorem lt_add_succ (n m : ℕ) : n < n + succ m := +lt_intro (succ_add_eq_succ_add n m) + +theorem eq_zero_of_le_zero {n : ℕ} (H : n ≤ 0) : n = 0 := +sorry +/- +obtain (k : ℕ) (Hk : n + k = 0), from le.elim H, +eq_zero_of_add_eq_zero_right Hk +-/ + +/- succ and pred -/ + +theorem le_of_lt_succ {m n : nat} : m < succ n → m ≤ n := +le_of_succ_le_succ + +theorem lt_iff_succ_le (m n : nat) : m < n ↔ succ m ≤ n := +iff.rfl + +theorem lt_succ_iff_le (m n : nat) : m < succ n ↔ m ≤ n := +iff.intro le_of_lt_succ lt_succ_of_le + +theorem self_le_succ (n : ℕ) : n ≤ succ n := +le.intro (add_one n) + +theorem succ_le_or_eq_of_le {n m : ℕ} : n ≤ m → succ n ≤ m ∨ n = m := +lt_or_eq_of_le + +theorem pred_le_of_le_succ {n m : ℕ} : n ≤ succ m → pred n ≤ m := +pred_le_pred + +theorem succ_le_of_le_pred {n m : ℕ} : succ n ≤ m → n ≤ pred m := +pred_le_pred + +theorem pred_le_pred_of_le {n m : ℕ} : n ≤ m → pred n ≤ pred m := +pred_le_pred + +theorem pre_lt_of_lt {n m : ℕ} : n < m → pred n < m := +lt_of_le_of_lt (pred_le n) + +theorem lt_of_pred_lt_pred {n m : ℕ} (H : pred n < pred m) : n < m := +lt_of_not_ge + (suppose m ≤ n, + not_lt_of_ge (pred_le_pred_of_le this) H) + +theorem le_or_eq_succ_of_le_succ {n m : ℕ} (H : n ≤ succ m) : n ≤ m ∨ n = succ m := +or.imp_left le_of_succ_le_succ (succ_le_or_eq_of_le H) + +theorem le_pred_self (n : ℕ) : pred n ≤ n := +pred_le n + +theorem succ_pos (n : ℕ) : 0 < succ n := +zero_lt_succ n + +theorem succ_pred_of_pos {n : ℕ} (H : n > 0) : succ (pred n) = n := +eq.symm (or_resolve_right (eq_zero_or_eq_succ_pred n) (ne.symm (ne_of_lt H))) + +theorem exists_eq_succ_of_lt {n : ℕ} : Π {m : ℕ}, n < m → ∃k, m = succ k +| 0 H := absurd H $ not_lt_zero n +| (succ k) H := exists.intro k rfl + +theorem lt_succ_self (n : ℕ) : n < succ n := +lt.base n + +lemma lt_succ_of_lt {i j : nat} : i < j → i < succ j := +assume Plt, lt.trans Plt (self_lt_succ j) + +/- increasing and decreasing functions -/ + +section + variables {A : Type} [strict_order A] {f : ℕ → A} + + theorem strictly_increasing_of_forall_lt_succ (H : ∀ i, f i < f (succ i)) : strictly_increasing f := + sorry + /- + take i j, + nat.induction_on j + (suppose i < 0, absurd this !not_lt_zero) + (take j', assume ih, suppose i < succ j', + or.elim (lt_or_eq_of_le (le_of_lt_succ this)) + (suppose i < j', lt.trans (ih this) (H j')) + (suppose i = j', by rewrite this; apply H)) + -/ + + theorem strictly_decreasing_of_forall_gt_succ (H : ∀ i, f i > f (succ i)) : strictly_decreasing f := + sorry + /- + take i j, + nat.induction_on j + (suppose i < 0, absurd this !not_lt_zero) + (take j', assume ih, suppose i < succ j', + or.elim (lt_or_eq_of_le (le_of_lt_succ this)) + (suppose i < j', lt.trans (H j') (ih this)) + (suppose i = j', by rewrite this; apply H)) + -/ +end + +section + variables {A : Type} [weak_order A] {f : ℕ → A} + + theorem nondecreasing_of_forall_le_succ (H : ∀ i, f i ≤ f (succ i)) : nondecreasing f := + sorry + /- + take i j, + nat.induction_on j + (suppose i ≤ 0, have i = 0, from eq_zero_of_le_zero this, by rewrite this; apply le.refl) + (take j', assume ih, suppose i ≤ succ j', + or.elim (le_or_eq_succ_of_le_succ this) + (suppose i ≤ j', le.trans (ih this) (H j')) + (suppose i = succ j', by rewrite this; apply le.refl)) + -/ + + theorem nonincreasing_of_forall_ge_succ (H : ∀ i, f i ≥ f (succ i)) : nonincreasing f := + sorry + /- + take i j, + nat.induction_on j + (suppose i ≤ 0, have i = 0, from eq_zero_of_le_zero this, by rewrite this; apply le.refl) + (take j', assume ih, suppose i ≤ succ j', + or.elim (le_or_eq_succ_of_le_succ this) + (suppose i ≤ j', le.trans (H j') (ih this)) + (suppose i = succ j', by rewrite this; apply le.refl)) + -/ +end + +/- other forms of induction -/ + +protected definition strong_rec_on {P : nat → Type} (n : ℕ) (H : ∀n, (∀m, m < n → P m) → P n) : P n := +nat.rec (λm h, absurd h $ not_lt_zero _) + (λn' (IH : ∀ {m : ℕ}, m < n' → P m) m l, + or.by_cases (lt_or_eq_of_le (le_of_lt_succ l)) + IH (λ e, eq.rec (H n' @IH) (eq.symm e))) (succ n) n $ lt_succ_self n + +protected theorem strong_induction_on {P : nat → Prop} (n : ℕ) (H : ∀n, (∀m, m < n → P m) → P n) : + P n := +nat.strong_rec_on n H + +protected theorem case_strong_induction_on {P : nat → Prop} (a : nat) (H0 : P 0) + (Hind : ∀(n : nat), (∀m, m ≤ n → P m) → P (succ n)) : P a := +nat.strong_induction_on a + (take n, + show (∀ m, m < n → P m) → P n, from + nat.cases_on n + (suppose (∀ m, m < 0 → P m), show P 0, from H0) + (take n, + suppose (∀ m, m < succ n → P m), + show P (succ n), from + Hind n (take m, assume H1 : m ≤ n, this _ (lt_succ_of_le H1)))) + +/- pos -/ + +theorem by_cases_zero_pos {P : ℕ → Prop} (y : ℕ) (H0 : P 0) (H1 : ∀ {y : nat}, y > 0 → P y) : + P y := +nat.cases_on y H0 (take y, H1 (succ_pos y)) + +theorem eq_zero_or_pos (n : ℕ) : n = 0 ∨ n > 0 := +sorry +/- +or_of_or_of_imp_left + (or.swap (lt_or_eq_of_le !zero_le)) + (suppose 0 = n, by subst n) +-/ + +theorem pos_of_ne_zero {n : ℕ} (H : n ≠ 0) : n > 0 := +sorry -- 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) : ∃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 := +sorry +/- +pos_of_ne_zero + (suppose m = 0, + have n = 0, from eq_zero_of_zero_dvd (this ▸ H1), + ne_of_lt H2 (by subst n)) +-/ + +/- multiplication -/ + +theorem mul_lt_mul_of_le_of_lt {n m k l : ℕ} (Hk : k > 0) (H1 : n ≤ k) (H2 : m < l) : + n * m < k * l := +lt_of_le_of_lt (mul_le_mul_right m H1) (mul_lt_mul_of_pos_left H2 Hk) + +theorem mul_lt_mul_of_lt_of_le {n m k l : ℕ} (Hl : l > 0) (H1 : n < k) (H2 : m ≤ l) : + n * m < k * l := +lt_of_le_of_lt (mul_le_mul_left n H2) (mul_lt_mul_of_pos_right H1 Hl) + +theorem mul_lt_mul_of_le_of_le {n m k l : ℕ} (H1 : n < k) (H2 : m < l) : n * m < k * l := +have H3 : n * m ≤ k * m, from mul_le_mul_right m (le_of_lt H1), +have H4 : k * m < k * l, from mul_lt_mul_of_pos_left H2 (lt_of_le_of_lt (zero_le n) 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 := +sorry +/- +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 k m ▸ mul.comm n m ▸ H) + +theorem eq_zero_or_eq_of_mul_eq_mul_left {n m k : ℕ} (H : n * m = n * k) : n = 0 ∨ m = k := +or_of_or_of_imp_right (eq_zero_or_pos n) + (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 k m ▸ mul.comm n m ▸ H) + +theorem eq_one_of_mul_eq_one_right {n m : ℕ} (H : n * m = 1) : n = 1 := +sorry +/- +have H2 : n * m > 0, by rewrite H; apply succ_pos, +or.elim (le_or_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 n m ▸ H) + +theorem eq_one_of_mul_eq_self_left {n m : ℕ} (Hpos : n > 0) (H : m * n = n) : m = 1 := +eq_of_mul_eq_mul_right Hpos (eq.trans H (eq.symm (one_mul n))) + +theorem eq_one_of_mul_eq_self_right {n m : ℕ} (Hpos : m > 0) (H : m * n = m) : n = 1 := +eq_one_of_mul_eq_self_left Hpos (mul.comm m n ▸ H) + +theorem eq_one_of_dvd_one {n : ℕ} (H : n ∣ 1) : n = 1 := +dvd.elim H + (take m, suppose 1 = n * m, + eq_one_of_mul_eq_one_right (eq.symm this)) + +/- min and max -/ +open decidable + +attribute [simp] +theorem min_zero (a : ℕ) : min a 0 = 0 := +sorry -- by rewrite [min_eq_right !zero_le] + +attribute [simp] +theorem zero_min (a : ℕ) : min 0 a = 0 := +sorry -- by rewrite [min_eq_left !zero_le] + +attribute [simp] +theorem max_zero (a : ℕ) : max a 0 = a := +sorry -- by rewrite [max_eq_left !zero_le] + +attribute [simp] +theorem zero_max (a : ℕ) : max 0 a = a := +sorry -- by rewrite [max_eq_right !zero_le] + +attribute [simp] +theorem min_succ_succ (a b : ℕ) : min (succ a) (succ b) = succ (min a b) := +sorry +/- +or.elim !lt_or_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)]) +-/ + +attribute [simp] +theorem max_succ_succ (a b : ℕ) : max (succ a) (succ b) = succ (max a b) := +sorry +/- +or.elim !lt_or_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 := +sorry +/- +decidable.by_cases + (suppose b ≤ c, + have a + b ≤ a + c, from add_le_add_left this _, + by rewrite [min_eq_left `b ≤ c`, min_eq_left this]) + (suppose ¬ b ≤ c, + have c ≤ b, from le_of_lt (lt_of_not_ge this), + have a + c ≤ a + b, from add_le_add_left this _, + by rewrite [min_eq_right `c ≤ b`, min_eq_right this]) +-/ + +protected theorem min_add_add_right (a b c : ℕ) : min (a + c) (b + c) = min a b + c := +sorry -- 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 := +sorry +/- +decidable.by_cases + (suppose b ≤ c, + have a + b ≤ a + c, from add_le_add_left this _, + by rewrite [max_eq_right `b ≤ c`, max_eq_right this]) + (suppose ¬ b ≤ c, + have c ≤ b, from le_of_lt (lt_of_not_ge this), + have a + c ≤ a + b, from add_le_add_left this _, + by rewrite [max_eq_left `c ≤ b`, max_eq_left this]) +-/ + +protected theorem max_add_add_right (a b c : ℕ) : max (a + c) (b + c) = max a b + c := +sorry -- by rewrite [add.comm a c, add.comm b c, add.comm _ c]; apply nat.max_add_add_left + +/- least and greatest -/ + +section least_and_greatest + variable (P : ℕ → Prop) + variable [decP : ∀ n, decidable (P n)] + include decP + + -- returns the least i < n satisfying P, or 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) := + sorry + /- + begin + induction n with [m, ih], + rewrite ↑least, + apply H, + rewrite ↑least, + cases decidable.em (P (least P m)) with [Hlp, Hlp], + fold (least P m), + rewrite [if_pos Hlp], + apply Hlp, + fold (least P m), + rewrite [if_neg Hlp], + apply H + end + -/ + + theorem least_le (n : ℕ) : least P n ≤ n:= + sorry + /- + begin + induction n with [m, ih], + {rewrite ↑least}, + rewrite ↑least, + cases decidable.em (P (least P m)) with [Psm, Pnsm], + fold (least P m), + rewrite [if_pos Psm], + apply le.trans ih !le_succ, + fold (least P m), + rewrite [if_neg Pnsm] + end + -/ + + theorem least_of_lt {i n : ℕ} (ltin : i < n) (H : P i) : P (least P n) := + sorry + /- + begin + induction n with [m, ih], + exact absurd ltin !not_lt_zero, + rewrite ↑least, + cases decidable.em (P (least P m)) with [Psm, Pnsm], + fold (least P m), + rewrite [if_pos Psm], + apply Psm, + fold (least P m), + rewrite [if_neg Pnsm], + cases (lt_or_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 := + sorry + /- + begin + induction n with [m, ih], + exact absurd ltin !not_lt_zero, + rewrite ↑least, + cases decidable.em (P (least P m)) with [Psm, Pnsm], + fold (least P m), + rewrite [if_pos Psm], + cases (lt_or_eq_of_le (le_of_lt_succ ltin)) with [Hlt, Heq], + apply ih Hlt, + rewrite Heq, + apply least_le, + fold (least P m), + rewrite [if_neg Pnsm], + cases (lt_or_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, or 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) := + sorry + /- + 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 := + sorry + /- + 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_and_greatest + +end nat diff --git a/old_library/data/nat/pairing.lean b/old_library/data/nat/pairing.lean new file mode 100644 index 0000000000..bba3e45d9b --- /dev/null +++ b/old_library/data/nat/pairing.lean @@ -0,0 +1,104 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Elegant pairing function. +-/ +import data.nat.sqrt data.nat.div +open prod decidable + +namespace nat +definition mkpair (a b : nat) : nat := +if a < b then b*b + a else a*a + a + b + +definition unpair (n : nat) : nat × nat := +let s := sqrt n in +if n - s*s < s then (n - s*s, s) else (s, n - s*s - s) + +theorem mkpair_unpair (n : nat) : mkpair (pr1 (unpair n)) (pr2 (unpair n)) = n := +sorry +/- +let s := sqrt n in +by_cases + (suppose n - s*s < s, + begin + esimp [unpair], + rewrite [if_pos this], + esimp [mkpair], + rewrite [if_pos this, add_sub_of_le (sqrt_lower n)] + end) + (suppose h₁ : ¬ n - s*s < s, + have s ≤ n - s*s, from le_of_not_gt h₁, + have s + s*s ≤ n - s*s + s*s, from add_le_add_right this (s*s), + have s*s + s ≤ n, by rewrite [nat.sub_add_cancel (sqrt_lower n) at this, + add.comm at this]; assumption, + have n ≤ s*s + s + s, from sqrt_upper n, + have n - s*s ≤ s + s, from calc + n - s*s ≤ (s*s + s + s) - s*s : nat.sub_le_sub_right this (s*s) + ... = (s*s + (s+s)) - s*s : by rewrite add.assoc + ... = s + s : by rewrite nat.add_sub_cancel_left, + have n - s*s - s ≤ s, from calc + n - s*s - s ≤ (s + s) - s : nat.sub_le_sub_right this s + ... = s : by rewrite nat.add_sub_cancel_left, + have h₂ : ¬ s < n - s*s - s, from not_lt_of_ge this, + begin + esimp [unpair], + rewrite [if_neg h₁], esimp, + esimp [mkpair], + rewrite [if_neg h₂, nat.sub_sub, add_sub_of_le `s*s + s ≤ n`], + end) +-/ + +theorem unpair_mkpair (a b : nat) : unpair (mkpair a b) = (a, b) := +sorry +/- +by_cases + (suppose a < b, + have a ≤ b + b, from calc + a ≤ b : le_of_lt this + ... ≤ b+b : !le_add_right, + begin + esimp [mkpair], + rewrite [if_pos `a < b`], + esimp [unpair], + rewrite [sqrt_offset_eq `a ≤ b + b`, nat.add_sub_cancel_left, if_pos `a < b`] + end) + (suppose ¬ a < b, + have b ≤ a, from le_of_not_gt this, + have a + b ≤ a + a, from add_le_add_left this a, + have a + b ≥ a, from !le_add_right, + have ¬ a + b < a, from not_lt_of_ge this, + begin + esimp [mkpair], + rewrite [if_neg `¬ a < b`], + esimp [unpair], + rewrite [add.assoc (a * a) a b, sqrt_offset_eq `a + b ≤ a + a`, *nat.add_sub_cancel_left, + if_neg `¬ a + b < a`] + end) +-/ +open prod + +theorem unpair_lt_aux {n : nat} : n ≥ 1 → (unpair n).1 < n := +sorry +/- +suppose n ≥ 1, +or.elim (eq_or_lt_of_le this) + (suppose 1 = n, by subst n; exact dec_trivial) + (suppose n > 1, + let s := sqrt n in + by_cases + (suppose h : n - s*s < s, + have n > 0, from lt_of_succ_lt `n > 1`, + have sqrt n > 0, from sqrt_pos_of_pos this, + have sqrt n * sqrt n > 0, from mul_pos this this, + begin unfold unpair, rewrite [if_pos h], esimp, exact sub_lt `n > 0` `sqrt n * sqrt n > 0` end) + (suppose ¬ n - s*s < s, begin unfold unpair, rewrite [if_neg this], esimp, apply sqrt_lt `n > 1` end)) +-/ + +theorem unpair_lt : ∀ (n : nat), (unpair n).1 < succ n +| 0 := dec_trivial +| (succ n) := + have (unpair (succ n)).1 < succ n, from unpair_lt_aux dec_trivial, + lt.step this +end nat diff --git a/old_library/data/nat/parity.lean b/old_library/data/nat/parity.lean new file mode 100644 index 0000000000..2e4b6c6557 --- /dev/null +++ b/old_library/data/nat/parity.lean @@ -0,0 +1,292 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Parity. +-/ +-- TODO(Leo): remove after refactoring +exit +import data.nat.power logic.identities + +namespace nat +open decidable + +definition even (n : nat) := n % 2 = 0 + +attribute [instance] +definition decidable_even : ∀ n, decidable (even n) := +take n, !nat.has_decidable_eq + +definition odd (n : nat) := ¬even n + +attribute [instance] +definition decidable_odd : ∀ n, decidable (odd n) := +take n, decidable_not + +lemma even_of_dvd {n} : 2 ∣ n → even n := +mod_eq_zero_of_dvd + +lemma dvd_of_even {n} : even n → 2 ∣ n := +dvd_of_mod_eq_zero + +lemma not_odd_zero : ¬ odd 0 := +dec_trivial + +lemma even_zero : even 0 := +dec_trivial + +lemma odd_one : odd 1 := +dec_trivial + +lemma not_even_one : ¬ even 1 := +dec_trivial + +lemma odd_eq_not_even (n : nat) : odd n = ¬ even n := +rfl + +lemma odd_iff_not_even (n : nat) : odd n ↔ ¬ even n := +!iff.refl + +lemma odd_of_not_even {n} : ¬ even n → odd n := +suppose ¬ even n, +iff.mpr !odd_iff_not_even this + +lemma even_of_not_odd {n} : ¬ odd n → even n := +suppose ¬ odd n, +not_not_elim (iff.mp (not_iff_not_of_iff !odd_iff_not_even) this) + +lemma not_odd_of_even {n} : even n → ¬ odd n := +suppose even n, +iff.mpr (not_iff_not_of_iff !odd_iff_not_even) (not_not_intro this) + +lemma not_even_of_odd {n} : odd n → ¬ even n := +suppose odd n, +iff.mp !odd_iff_not_even this + +lemma odd_succ_of_even {n} : even n → odd (succ n) := +suppose even n, +have n ≡ 0 [mod 2], from this, +have n+1 ≡ 0+1 [mod 2], from add_mod_eq_add_mod_right 1 this, +have h : n+1 ≡ 1 [mod 2], from this, +by_contradiction (suppose ¬ odd (succ n), + have n+1 ≡ 0 [mod 2], from even_of_not_odd this, + have 1 ≡ 0 [mod 2], from eq.trans (eq.symm h) this, + have 1 = 0, from this, + by contradiction) + +lemma eq_1_of_ne_0_lt_2 : ∀ {n : nat}, n ≠ 0 → n < 2 → n = 1 +| 0 h₁ h₂ := absurd rfl h₁ +| 1 h₁ h₂ := rfl +| (n+2) h₁ h₂ := absurd (lt_of_succ_lt_succ (lt_of_succ_lt_succ h₂)) !not_lt_zero + +lemma mod_eq_of_odd {n} : odd n → n % 2 = 1 := +suppose odd n, + have ¬ n % 2 = 0, from this, + have n % 2 < 2, from mod_lt n dec_trivial, + eq_1_of_ne_0_lt_2 `¬ n % 2 = 0` `n % 2 < 2` + +lemma odd_of_mod_eq {n} : n % 2 = 1 → odd n := +suppose n % 2 = 1, +by_contradiction (suppose ¬ odd n, + have n % 2 = 0, from even_of_not_odd this, + by rewrite this at *; contradiction) + +lemma even_succ_of_odd {n} : odd n → even (succ n) := +suppose odd n, + have n % 2 = 1 % 2, from mod_eq_of_odd this, + have (n+1) % 2 = 2 % 2, from add_mod_eq_add_mod_right 1 this, + by rewrite mod_self at this; exact this + +lemma odd_succ_succ_of_odd {n} : odd n → odd (succ (succ n)) := +suppose odd n, +odd_succ_of_even (even_succ_of_odd this) + +lemma even_succ_succ_of_even {n} : even n → even (succ (succ n)) := +suppose even n, +even_succ_of_odd (odd_succ_of_even this) + +lemma even_of_odd_succ {n} : odd (succ n) → even n := +suppose odd (succ n), +by_contradiction (suppose ¬ even n, + have odd n, from odd_of_not_even this, + have even (succ n), from even_succ_of_odd this, + absurd this (not_even_of_odd `odd (succ n)`)) + +lemma odd_of_even_succ {n} : even (succ n) → odd n := +suppose even (succ n), +by_contradiction (suppose ¬ odd n, + have even n, from even_of_not_odd this, + have odd (succ n), from odd_succ_of_even this, + absurd `even (succ n)` (not_even_of_odd this)) + +lemma even_of_even_succ_succ {n} : even (succ (succ n)) → even n := +suppose even (n+2), +even_of_odd_succ (odd_of_even_succ this) + +lemma odd_of_odd_succ_succ {n} : odd (succ (succ n)) → odd n := +suppose odd (n+2), +odd_of_even_succ (even_of_odd_succ this) + +lemma dvd_of_odd {n} : odd n → 2 ∣ n+1 := +suppose odd n, +dvd_of_even (even_succ_of_odd this) + +lemma odd_of_dvd {n} : 2 ∣ n+1 → odd n := +suppose 2 ∣ n+1, +odd_of_even_succ (even_of_dvd this) + +lemma even_two_mul : ∀ n, even (2 * n) := +take n, even_of_dvd (dvd_mul_right 2 n) + +lemma odd_two_mul_plus_one : ∀ n, odd (2 * n + 1) := +take n, odd_succ_of_even (even_two_mul n) + +lemma not_even_two_mul_plus_one : ∀ n, ¬ even (2 * n + 1) := +take n, not_even_of_odd (odd_two_mul_plus_one n) + +lemma not_odd_two_mul : ∀ n, ¬ odd (2 * n) := +take n, not_odd_of_even (even_two_mul n) + +lemma even_pred_of_odd : ∀ {n}, odd n → even (pred n) +| 0 h := absurd h not_odd_zero +| (n+1) h := even_of_odd_succ h + +lemma even_or_odd : ∀ n, even n ∨ odd n := +λ n, by_cases + (λ h : even n, or.inl h) + (λ h : ¬ even n, or.inr (odd_of_not_even h)) + +lemma exists_of_even {n} : even n → ∃ k, n = 2*k := +λ h, exists_eq_mul_right_of_dvd (dvd_of_even h) + +lemma exists_of_odd : ∀ {n}, odd n → ∃ k, n = 2*k + 1 +| 0 h := absurd h not_odd_zero +| (n+1) h := + obtain k (hk : n = 2*k), from exists_of_even (even_of_odd_succ h), + exists.intro k (by subst n) + +lemma even_of_exists {n} : (∃ k, n = 2 * k) → even n := +suppose ∃ k, n = 2 * k, +obtain k (hk : n = 2 * k), from this, +have 2 ∣ n, by subst n; apply dvd_mul_right, +even_of_dvd this + +lemma odd_of_exists {n} : (∃ k, n = 2 * k + 1) → odd n := +assume h, by_contradiction (λ hn, + have even n, from even_of_not_odd hn, + have ∃ k, n = 2 * k, from exists_of_even this, + obtain k₁ (hk₁ : n = 2 * k₁ + 1), from h, + obtain k₂ (hk₂ : n = 2 * k₂), from this, + have (2 * k₁ + 1) % 2 = (2 * k₂) % 2, by rewrite [-hk₁, -hk₂], + begin + rewrite [mul_mod_right at this, add.comm at this, add_mul_mod_self_left at this], + contradiction + end) + +lemma even_add_of_even_of_even {n m} : even n → even m → even (n+m) := +suppose even n, suppose even m, +obtain k₁ (hk₁ : n = 2 * k₁), from exists_of_even `even n`, +obtain k₂ (hk₂ : m = 2 * k₂), from exists_of_even `even m`, +even_of_exists (exists.intro (k₁+k₂) (by rewrite [hk₁, hk₂, left_distrib])) + +lemma even_add_of_odd_of_odd {n m} : odd n → odd m → even (n+m) := +suppose odd n, suppose odd m, +have even (succ n + succ m), + from even_add_of_even_of_even (even_succ_of_odd `odd n`) (even_succ_of_odd `odd m`), +have even(succ (succ (n + m))), by rewrite [add_succ at this, succ_add at this]; exact this, +even_of_even_succ_succ this + +lemma odd_add_of_even_of_odd {n m} : even n → odd m → odd (n+m) := +suppose even n, suppose odd m, +have even (n + succ m), from even_add_of_even_of_even `even n` (even_succ_of_odd `odd m`), +odd_of_even_succ this + +lemma odd_add_of_odd_of_even {n m} : odd n → even m → odd (n+m) := +suppose odd n, suppose even m, +have odd (m+n), from odd_add_of_even_of_odd `even m` `odd n`, +by rewrite add.comm at this; exact this + +lemma even_mul_of_even_left {n} (m) : even n → even (n*m) := +suppose even n, +obtain k (hk : n = 2*k), from exists_of_even this, +even_of_exists (exists.intro (k*m) (by rewrite [hk, mul.assoc])) + +lemma even_mul_of_even_right {n} (m) : even n → even (m*n) := +suppose even n, +have even (n*m), from even_mul_of_even_left _ this, +by rewrite mul.comm at this; exact this + +lemma odd_mul_of_odd_of_odd {n m} : odd n → odd m → odd (n*m) := +suppose odd n, suppose odd m, +have even (n * succ m), from even_mul_of_even_right _ (even_succ_of_odd `odd m`), +have even (n * m + n), by rewrite mul_succ at this; exact this, +by_contradiction (suppose ¬ odd (n*m), + have even (n*m), from even_of_not_odd this, + absurd `even (n * m + n)` (not_even_of_odd (odd_add_of_even_of_odd this `odd n`))) + +lemma even_of_even_mul_self {n} : even (n * n) → even n := +suppose even (n * n), +by_contradiction (suppose odd n, + have odd (n * n), from odd_mul_of_odd_of_odd this this, + show false, from this `even (n * n)`) + +lemma odd_of_odd_mul_self {n} : odd (n * n) → odd n := +suppose odd (n * n), + suppose even n, + have even (n * n), from !even_mul_of_even_left this, + show false, from `odd (n * n)` this + +lemma odd_pow {n m} (h : odd n) : odd (n^m) := +nat.induction_on m + (show odd (n^0), from dec_trivial) + (take m, suppose odd (n^m), + show odd (n^(m+1)), from odd_mul_of_odd_of_odd h this) + +lemma even_pow {n m} (mpos : m > 0) (h : even n) : even (n^m) := +have h₁ : ∀ m, even (n^succ m), + from take m, nat.induction_on m + (show even (n^1), by rewrite pow_one; apply h) + (take m, suppose even (n^succ m), + show even (n^(succ (succ m))), from !even_mul_of_even_left h), +obtain m' (h₂ : m = succ m'), from exists_eq_succ_of_pos mpos, +show even (n^m), by rewrite h₂; apply h₁ + +lemma odd_of_odd_pow {n m} (mpos : m > 0) (h : odd (n^m)) : odd n := +suppose even n, +have even (n^m), from even_pow mpos this, +show false, from `odd (n^m)` this + +lemma even_of_even_pow {n m} (h : even (n^m)) : even n := +by_contradiction + (suppose odd n, + have odd (n^m), from odd_pow this, + show false, from this `even (n^m)`) + +lemma eq_of_div2_of_even {n m : nat} : n / 2 = m / 2 → (even n ↔ even m) → n = m := +assume h₁ h₂, + or.elim (em (even n)) + (suppose even n, or.elim (em (even m)) + (suppose even m, + obtain w₁ (hw₁ : n = 2*w₁), from exists_of_even `even n`, + obtain w₂ (hw₂ : m = 2*w₂), from exists_of_even `even m`, + begin + substvars, rewrite [mul.comm 2 w₁ at h₁, mul.comm 2 w₂ at h₁, + *nat.mul_div_cancel _ (dec_trivial : 2 > 0) at h₁, h₁] + end) + (suppose odd m, absurd `odd m` (not_odd_of_even (iff.mp h₂ `even n`)))) + (suppose odd n, or.elim (em (even m)) + (suppose even m, absurd `odd n` (not_odd_of_even (iff.mpr h₂ `even m`))) + (suppose odd m, + have d : 1 / 2 = (0:nat), from dec_trivial, + obtain w₁ (hw₁ : n = 2*w₁ + 1), from exists_of_odd `odd n`, + obtain w₂ (hw₂ : m = 2*w₂ + 1), from exists_of_odd `odd m`, + begin + substvars, + rewrite [add.comm at h₁, add_mul_div_self_left _ _ (dec_trivial : 2 > 0) at h₁, d at h₁, + zero_add at h₁], + rewrite [add.comm at h₁, add_mul_div_self_left _ _ (dec_trivial : 2 > 0) at h₁, d at h₁, + zero_add at h₁], + rewrite h₁ + end)) +end nat diff --git a/old_library/data/nat/power.lean b/old_library/data/nat/power.lean new file mode 100644 index 0000000000..9f91d6ee62 --- /dev/null +++ b/old_library/data/nat/power.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad + +The power function on the natural numbers. +-/ + +-- TODO(Leo): remove after refactoring +exit + +import data.nat.basic data.nat.order data.nat.div data.nat.gcd algebra.ring_power + +namespace nat + +attribute [instance, priority nat.prio] +definition nat_has_pow_nat : has_pow_nat nat := +has_pow_nat.mk has_pow_nat.pow_nat + +theorem pow_le_pow_of_le {x y : ℕ} (i : ℕ) (H : x ≤ y) : x^i ≤ y^i := +pow_le_pow_of_le i !zero_le H + +theorem eq_zero_of_pow_eq_zero {a m : ℕ} (H : a^m = 0) : a = 0 := +or.elim (eq_zero_or_pos m) + (suppose m = 0, + by rewrite [`m = 0` at H, pow_zero at H]; contradiction) + (suppose m > 0, + have h₁ : ∀ m, a^succ m = 0 → a = 0, + begin + intro m, + induction m with m ih, + {krewrite pow_one; intros; assumption}, + rewrite pow_succ, + intro H, + cases eq_zero_or_eq_zero_of_mul_eq_zero H with h₃ h₄, + assumption, + exact ih h₄ + end, + obtain m' (h₂ : m = succ m'), from exists_eq_succ_of_pos `m > 0`, + show a = 0, by rewrite h₂ at H; apply h₁ m' H) + +-- generalize to semirings? +theorem le_pow_self {x : ℕ} (H : x > 1) : ∀ i, i ≤ x^i +| 0 := !zero_le +| (succ j) := have x > 0, from lt.trans zero_lt_one H, + have h₁ : x^j ≥ 1, from succ_le_of_lt (pow_pos_of_pos _ this), + have x ≥ 2, from succ_le_of_lt H, + calc + succ j = j + 1 : rfl + ... ≤ x^j + 1 : add_le_add_right (le_pow_self j) + ... ≤ x^j + x^j : add_le_add_left h₁ + ... = x^j * (1 + 1) : by rewrite [left_distrib, *mul_one] + ... = x^j * 2 : rfl + ... ≤ x^j * x : mul_le_mul_left _ `x ≥ 2` + ... = x^(succ j) : pow_succ' + +-- TODO: eventually this will be subsumed under the algebraic theorems + +theorem mul_self_eq_pow_2 (a : nat) : a * a = a ^ 2 := +show a * a = a ^ (succ (succ zero)), from +by krewrite [*pow_succ, *pow_zero, mul_one] + +theorem pow_cancel_left : ∀ {a b c : nat}, a > 1 → a ^ b = a ^ c → b = c +| a 0 0 h₁ h₂ := rfl +| a (succ b) 0 h₁ h₂ := + have a = 1, by rewrite [pow_succ at h₂, pow_zero at h₂]; exact (eq_one_of_mul_eq_one_right h₂), + have (1:nat) < 1, by rewrite [this at h₁]; exact h₁, + absurd `1 <[nat] 1` !lt.irrefl +| a 0 (succ c) h₁ h₂ := + have a = 1, by rewrite [pow_succ at h₂, pow_zero at h₂]; exact (eq_one_of_mul_eq_one_right (eq.symm h₂)), + have (1:nat) < 1, by rewrite [this at h₁]; exact h₁, + absurd `1 <[nat] 1` !lt.irrefl +| a (succ b) (succ c) h₁ h₂ := + have a ≠ 0, from assume aeq0, by rewrite [aeq0 at h₁]; exact (absurd h₁ dec_trivial), + have a^b = a^c, by rewrite [*pow_succ at h₂]; exact (eq_of_mul_eq_mul_left (pos_of_ne_zero this) h₂), + by rewrite [pow_cancel_left h₁ this] + +theorem pow_div_cancel : ∀ {a b : nat}, a ≠ 0 → (a ^ succ b) / a = a ^ b +| a 0 h := by rewrite [pow_succ, pow_zero, mul_one, nat.div_self (pos_of_ne_zero h)] +| a (succ b) h := by rewrite [pow_succ, nat.mul_div_cancel_left _ (pos_of_ne_zero h)] + +lemma dvd_pow : ∀ (i : nat) {n : nat}, n > 0 → i ∣ i^n +| i 0 h := absurd h !lt.irrefl +| i (succ n) h := by rewrite [pow_succ']; apply dvd_mul_left + +lemma dvd_pow_of_dvd_of_pos : ∀ {i j n : nat}, i ∣ j → n > 0 → i ∣ j^n +| i j 0 h₁ h₂ := absurd h₂ !lt.irrefl +| i j (succ n) h₁ h₂ := by rewrite [pow_succ']; apply dvd_mul_of_dvd_right h₁ + +lemma pow_mod_eq_zero (i : nat) {n : nat} (h : n > 0) : (i ^ n) % i = 0 := +iff.mp !dvd_iff_mod_eq_zero (dvd_pow i h) + +lemma pow_dvd_of_pow_succ_dvd {p i n : nat} : p^(succ i) ∣ n → p^i ∣ n := +suppose p^(succ i) ∣ n, +have p^i ∣ p^(succ i), + by rewrite [pow_succ']; apply nat.dvd_of_eq_mul; apply rfl, +dvd.trans `p^i ∣ p^(succ i)` `p^(succ i) ∣ n` + +lemma dvd_of_pow_succ_dvd_mul_pow {p i n : nat} (Ppos : p > 0) : + p^(succ i) ∣ (n * p^i) → p ∣ n := +by rewrite [pow_succ]; apply nat.dvd_of_mul_dvd_mul_right; apply pow_pos_of_pos _ Ppos + +lemma coprime_pow_right {a b} : ∀ n, coprime b a → coprime b (a^n) +| 0 h := !comprime_one_right +| (succ n) h := + begin + rewrite [pow_succ'], + apply coprime_mul_right, + exact coprime_pow_right n h, + exact h + end + +lemma coprime_pow_left {a b} : ∀ n, coprime b a → coprime (b^n) a := +take n, suppose coprime b a, +coprime_swap (coprime_pow_right n (coprime_swap this)) +end nat diff --git a/old_library/data/nat/sqrt.lean b/old_library/data/nat/sqrt.lean new file mode 100644 index 0000000000..98ca8aa923 --- /dev/null +++ b/old_library/data/nat/sqrt.lean @@ -0,0 +1,202 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Very simple (sqrt n) function that returns s s.t. + s*s ≤ n ≤ s*s + s + s +-/ +import data.nat.order data.nat.sub + +namespace nat +open decidable + +-- This is the simplest possible function that just performs a linear search +definition sqrt_aux : nat → nat → nat +| 0 n := 0 +| (succ s) n := if (succ s)*(succ s) ≤ n then succ s else sqrt_aux s n + +theorem sqrt_aux_succ_of_pos {s n} : (succ s)*(succ s) ≤ n → sqrt_aux (succ s) n = (succ s) := +assume h, if_pos h + +theorem sqrt_aux_succ_of_neg {s n} : ¬ (succ s)*(succ s) ≤ n → sqrt_aux (succ s) n = sqrt_aux s n := +assume h, if_neg h + +theorem sqrt_aux_of_le : ∀ {s n : nat}, s * s ≤ n → sqrt_aux s n = s +:= sorry +/- +| 0 n h := rfl +| (succ s) n h := by rewrite [sqrt_aux_succ_of_pos h] +-/ + +theorem sqrt_aux_le : ∀ (s n), sqrt_aux s n ≤ s +:= sorry +/- +| 0 n := !zero_le +| (succ s) n := or.elim (em ((succ s)*(succ s) ≤ n)) + (λ h, begin unfold sqrt_aux, rewrite [if_pos h] end) + (λ h, + have sqrt_aux s n ≤ succ s, from le.step (sqrt_aux_le s n), + begin unfold sqrt_aux, rewrite [if_neg h], eassumption end) +-/ + +definition sqrt (n : nat) : nat := +sqrt_aux n n + +theorem sqrt_aux_lower : ∀ {s n : nat}, s ≤ n → sqrt_aux s n * sqrt_aux s n ≤ n +:= sorry +/- +| 0 n h := h +| (succ s) n h := by_cases + (λ h₁ : (succ s)*(succ s) ≤ n, by rewrite [sqrt_aux_succ_of_pos h₁]; exact h₁) + (λ h₂ : ¬ (succ s)*(succ s) ≤ n, + have aux : s ≤ n, from le_of_succ_le h, + by rewrite [sqrt_aux_succ_of_neg h₂]; exact (sqrt_aux_lower aux)) +-/ + +theorem sqrt_lower (n : nat) : sqrt n * sqrt n ≤ n := +sqrt_aux_lower (le.refl n) + +theorem sqrt_aux_upper : ∀ {s n : nat}, n ≤ s*s + s + s → n ≤ sqrt_aux s n * sqrt_aux s n + sqrt_aux s n + sqrt_aux s n +:= sorry +/- +| 0 n h := h +| (succ s) n h := by_cases + (λ h₁ : (succ s)*(succ s) ≤ n, + by rewrite [sqrt_aux_succ_of_pos h₁]; exact h) + (λ h₂ : ¬ (succ s)*(succ s) ≤ n, + have h₃ : n < (succ s) * (succ s), from lt_of_not_ge h₂, + have h₄ : n ≤ s * s + s + s, by rewrite [succ_mul_succ_eq at h₃]; exact le_of_lt_succ h₃, + by rewrite [sqrt_aux_succ_of_neg h₂]; exact (sqrt_aux_upper h₄)) +-/ + +theorem sqrt_upper (n : nat) : n ≤ sqrt n * sqrt n + sqrt n + sqrt n := +have aux : n ≤ n*n + n + n, from le_add_of_le_right (le_add_of_le_left (le.refl n)), +sqrt_aux_upper aux + +private theorem le_squared : ∀ (n : nat), n ≤ n*n +:= sorry +/- +| 0 := !le.refl +| (succ n) := + have aux₁ : 1 ≤ succ n, from succ_le_succ !zero_le, + have aux₂ : 1 * succ n ≤ succ n * succ n, from nat.mul_le_mul aux₁ !le.refl, + by rewrite [one_mul at aux₂]; exact aux₂ +-/ + +private theorem lt_squared : ∀ {n : nat}, n > 1 → n < n * n +:= sorry +/- +| 0 h := absurd h dec_trivial +| 1 h := absurd h dec_trivial +| (succ (succ n)) h := + have 1 < succ (succ n), from dec_trivial, + have succ (succ n) * 1 < succ (succ n) * succ (succ n), from mul_lt_mul_of_pos_left this dec_trivial, + by rewrite [mul_one at this]; exact this +-/ + +theorem sqrt_le (n : nat) : sqrt n ≤ n := +calc sqrt n ≤ sqrt n * sqrt n : le_squared (sqrt n) + ... ≤ n : sqrt_lower n + +theorem eq_zero_of_sqrt_eq_zero {n : nat} : sqrt n = 0 → n = 0 := +sorry +/- +suppose sqrt n = 0, +have n ≤ sqrt n * sqrt n + sqrt n + sqrt n, from !sqrt_upper, +have n ≤ 0, by rewrite [*`sqrt n = 0` at this]; exact this, +eq_zero_of_le_zero this +-/ + +theorem le_three_of_sqrt_eq_one {n : nat} : sqrt n = 1 → n ≤ 3 := +sorry +/- +suppose sqrt n = 1, +have n ≤ sqrt n * sqrt n + sqrt n + sqrt n, from !sqrt_upper, +show n ≤ 3, by rewrite [*`sqrt n = 1` at this]; exact this +-/ + +theorem sqrt_lt : ∀ {n : nat}, n > 1 → sqrt n < n +:= sorry +/- +| 0 h := absurd h dec_trivial +| 1 h := absurd h dec_trivial +| 2 h := dec_trivial +| 3 h := dec_trivial +| (n+4) h := + have sqrt (n+4) > 1, from by_contradiction + (suppose ¬ sqrt (n+4) > 1, + have sqrt (n+4) ≤ 1, from le_of_not_gt this, + or.elim (eq_or_lt_of_le this) + (suppose sqrt (n+4) = 1, + have n+4 ≤ 3, from le_three_of_sqrt_eq_one this, + absurd this dec_trivial) + (suppose sqrt (n+4) < 1, + have sqrt (n+4) = 0, from eq_zero_of_le_zero (le_of_lt_succ this), + have n + 4 = 0, from eq_zero_of_sqrt_eq_zero this, + absurd this dec_trivial)), + calc sqrt (n+4) < sqrt (n+4) * sqrt (n+4) : lt_squared this + ... ≤ n+4 : !sqrt_lower +-/ + +theorem sqrt_pos_of_pos {n : nat} : n > 0 → sqrt n > 0 := +sorry +/- +suppose n > 0, +have sqrt n ≠ 0, from + suppose sqrt n = 0, + have n = 0, from eq_zero_of_sqrt_eq_zero this, + by subst n; exact absurd `0 > 0` !lt.irrefl, +pos_of_ne_zero this +-/ + +theorem sqrt_aux_offset_eq {n k : nat} (h₁ : k ≤ n + n) : ∀ {s}, s ≥ n → sqrt_aux s (n*n + k) = n +:= sorry +/- +| 0 h₂ := + have neqz : n = 0, from eq_zero_of_le_zero h₂, + by rewrite neqz +| (succ s) h₂ := by_cases + (λ hl : (succ s)*(succ s) ≤ n*n + k, + have l₁ : n*n + k ≤ n*n + n + n, from by rewrite [add.assoc]; exact (add_le_add_left h₁ (n*n)), + have l₂ : n*n + k < n*n + n + n + 1, from lt_succ_of_le l₁, + have l₃ : n*n + k < (succ n)*(succ n), by rewrite [-succ_mul_succ_eq at l₂]; exact l₂, + have l₄ : (succ s)*(succ s) < (succ n)*(succ n), from lt_of_le_of_lt hl l₃, + have ng : ¬ succ s > (succ n), from + assume g : succ s > succ n, + have g₁ : (succ s)*(succ s) > (succ n)*(succ n), from mul_lt_mul_of_le_of_le g g, + absurd (lt.trans g₁ l₄) !lt.irrefl, + have sslesn : succ s ≤ succ n, from le_of_not_gt ng, + have ssnesn : succ s ≠ succ n, from + assume sseqsn : succ s = succ n, + by rewrite [sseqsn at l₄]; exact (absurd l₄ !lt.irrefl), + have sslen : s < n, from lt_of_succ_lt_succ (lt_of_le_of_ne sslesn ssnesn), + have sseqn : succ s = n, from le.antisymm sslen h₂, + by rewrite [sqrt_aux_succ_of_pos hl]; exact sseqn) + (λ hg : ¬ (succ s)*(succ s) ≤ n*n + k, + or.elim (eq_or_lt_of_le h₂) + (λ neqss : n = succ s, + have p : n*n ≤ n*n + k, from !le_add_right, + have n : ¬ n*n ≤ n*n + k, by rewrite [-neqss at hg]; exact hg, + absurd p n) + (λ sgen : succ s > n, + by rewrite [sqrt_aux_succ_of_neg hg]; exact (sqrt_aux_offset_eq (le_of_lt_succ sgen)))) +-/ + +theorem sqrt_offset_eq {n k : nat} : k ≤ n + n → sqrt (n*n + k) = n := +assume h, +have h₁ : n ≤ n*n + k, from le.trans (le_squared n) (le_add_right (n * n) k), +sqrt_aux_offset_eq h h₁ + +theorem sqrt_eq (n : nat) : sqrt (n*n) = n := +sqrt_offset_eq (zero_le (n + n)) + +theorem mul_square_cancel {a b : nat} : a*a = b*b → a = b := +sorry +/- +assume h, +have aux : sqrt (a*a) = sqrt (b*b), by rewrite h, +by rewrite [*sqrt_eq at aux]; exact aux +-/ + +end nat diff --git a/old_library/data/nat/sub.lean b/old_library/data/nat/sub.lean new file mode 100644 index 0000000000..4ded20aa69 --- /dev/null +++ b/old_library/data/nat/sub.lean @@ -0,0 +1,503 @@ +/- +Copyright (c) 2014 Floris van Doorn. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Authors: Floris van Doorn, Jeremy Avigad +Subtraction on the natural numbers, as well as min, max, and distance. +-/ +import .order + +namespace nat + +/- subtraction -/ + +attribute [simp] +protected theorem sub_zero (n : ℕ) : n - 0 = n := +rfl + +attribute [simp] +theorem sub_succ (n m : ℕ) : n - succ m = pred (n - m) := +rfl + +attribute [simp] +protected theorem zero_sub (n : ℕ) : 0 - n = 0 := +sorry -- nat.induction_on n (by simp) (by simp) + +attribute [simp] +theorem succ_sub_succ (n m : ℕ) : succ n - succ m = n - m := +succ_sub_succ_eq_sub n m + +attribute [simp] +protected theorem sub_self (n : ℕ) : n - n = 0 := +sorry -- nat.induction_on n (by simp) (by simp) + +local attribute nat.add_succ [simp] + +attribute [simp] +protected theorem add_sub_add_right (n k m : ℕ) : (n + k) - (m + k) = n - m := +sorry -- nat.induction_on k (by simp) (by simp) + +attribute [simp] +protected theorem add_sub_add_left (k n m : ℕ) : (k + n) - (k + m) = n - m := +sorry -- nat.induction_on k (by simp) (by simp) + +attribute [simp] +protected theorem add_sub_cancel (n m : ℕ) : n + m - m = n := +sorry -- nat.induction_on m (by simp) (by simp) + +attribute [simp] +protected theorem add_sub_cancel_left (n m : ℕ) : n + m - n = m := +sorry -- nat.induction_on n (by simp) (by simp) + +attribute [simp] +protected theorem sub_sub (n m k : ℕ) : n - m - k = n - (m + k) := +sorry -- nat.induction_on k (by simp) (by simp) + +attribute [simp] +theorem succ_sub_sub_succ (n m k : ℕ) : succ n - m - succ k = n - m - k := +sorry -- by simp + +attribute [simp] +theorem sub_self_add (n m : ℕ) : n - (n + m) = 0 := +sorry -- by inst_simp + +protected theorem sub.right_comm (m n k : ℕ) : m - n - k = m - k - n := +sorry -- by simp + +theorem sub_one (n : ℕ) : n - 1 = pred n := +rfl + +attribute [simp] +theorem succ_sub_one (n : ℕ) : succ n - 1 = n := +rfl + +local attribute nat.succ_mul nat.mul_succ [simp] + +/- interaction with multiplication -/ + +attribute [simp] +theorem mul_pred_left (n m : ℕ) : pred n * m = n * m - m := +sorry -- nat.induction_on n (by simp) (by simp) + +attribute [simp] +theorem mul_pred_right (n m : ℕ) : n * pred m = n * m - n := +sorry -- by inst_simp + +attribute [simp] +protected theorem mul_sub_right_distrib (n m k : ℕ) : (n - m) * k = n * k - m * k := +sorry -- nat.induction_on m (by simp) (by simp) + +attribute [simp] +protected theorem mul_sub_left_distrib (n m k : ℕ) : n * (m - k) = n * m - n * k := +sorry -- by inst_simp + +protected theorem mul_self_sub_mul_self_eq (a b : nat) : a * a - b * b = (a + b) * (a - b) := +sorry +/- +by rewrite [nat.mul_sub_left_distrib, *right_distrib, mul.comm b a, add.comm (a*a) (a*b), + nat.add_sub_add_left] +-/ + +local attribute succ_eq_add_one right_distrib left_distrib [simp] + +theorem succ_mul_succ_eq (a : nat) : succ a * succ a = a*a + a + a + 1 := +sorry -- by simp + +/- interaction with inequalities -/ + +theorem succ_sub {m n : ℕ} : m ≥ n → succ m - n = succ (m - n) := +sorry +/- +sub_induction n m + (take k, assume H : 0 ≤ k, rfl) + (take k, + assume H : succ k ≤ 0, + absurd H !not_succ_le_zero) + (take k l, + assume IH : k ≤ l → succ l - k = succ (l - k), + take H : succ k ≤ succ l, + calc + succ (succ l) - succ k = succ l - k : !succ_sub_succ + ... = succ (l - k) : IH (le_of_succ_le_succ H) + ... = succ (succ l - succ k) : by rewrite succ_sub_succ) +-/ + +theorem sub_eq_zero_of_le {n m : ℕ} (H : n ≤ m) : n - m = 0 := +sorry -- obtain (k : ℕ) (Hk : n + k = m), from le.elim H, Hk ▸ !sub_self_add + +theorem add_sub_of_le {n m : ℕ} : n ≤ m → n + (m - n) = m := +sorry +/- +sub_induction n m + (take k, + assume H : 0 ≤ k, + calc + 0 + (k - 0) = k - 0 : by rewrite zero_add + ... = k : by rewrite nat.sub_zero) + (take k, assume H : succ k ≤ 0, absurd H !not_succ_le_zero) + (take k l, + assume IH : k ≤ l → k + (l - k) = l, + take H : succ k ≤ succ l, + calc + succ k + (succ l - succ k) = succ k + (l - k) : by rewrite succ_sub_succ + ... = succ (k + (l - k)) : by rewrite succ_add + ... = succ l : by rewrite (IH (le_of_succ_le_succ H))) +-/ + +theorem add_sub_of_ge {n m : ℕ} (H : n ≥ m) : n + (m - n) = n := +sorry +/- +calc + n + (m - n) = n + 0 : by rewrite (sub_eq_zero_of_le H) + ... = n : by rewrite add_zero +-/ + +protected theorem sub_add_cancel {n m : ℕ} : n ≥ m → n - m + m = n := +add.comm m (n - m) ▸ add_sub_of_le + +theorem sub_add_of_le {n m : ℕ} : n ≤ m → n - m + m = m := +add.comm m (n - m) ▸ add_sub_of_ge + +theorem sub.cases {P : ℕ → Prop} {n m : ℕ} (H1 : n ≤ m → P 0) (H2 : ∀k, m + k = n -> P k) + : P (n - m) := +or.elim (le.total n m) + (assume H3 : n ≤ m, eq.symm (sub_eq_zero_of_le H3) ▸ (H1 H3)) + (assume H3 : m ≤ n, H2 (n - m) (add_sub_of_le H3)) + +theorem exists_sub_eq_of_le {n m : ℕ} (H : n ≤ m) : ∃k, m - k = n := +sorry +/- +obtain (k : ℕ) (Hk : n + k = m), from le.elim H, +exists.intro k + (calc + m - k = n + k - k : by rewrite Hk + ... = n : by rewrite nat.add_sub_cancel) +-/ + +protected theorem add_sub_assoc {m k : ℕ} (H : k ≤ m) (n : ℕ) : n + m - k = n + (m - k) := +sorry +/- +have l1 : k ≤ m → n + m - k = n + (m - k), from + sub_induction k m + (by simp) + (take k : ℕ, assume H : succ k ≤ 0, absurd H !not_succ_le_zero) + (take k m, + assume IH : k ≤ m → n + m - k = n + (m - k), + take H : succ k ≤ succ m, + calc + n + succ m - succ k = succ (n + m) - succ k : by rewrite add_succ + ... = n + m - k : by rewrite succ_sub_succ + ... = n + (m - k) : by rewrite (IH (le_of_succ_le_succ H)) + ... = n + (succ m - succ k) : by rewrite succ_sub_succ), +l1 H +-/ + +theorem le_of_sub_eq_zero {n m : ℕ} : n - m = 0 → n ≤ m := +sub.cases + (assume H1 : n ≤ m, assume H2 : 0 = 0, H1) + (take k : ℕ, + assume H1 : m + k = n, + assume H2 : k = 0, + have H3 : n = m, from add_zero m ▸ H2 ▸ eq.symm H1, + H3 ▸ le.refl n) + +theorem sub_sub.cases {P : ℕ → ℕ → Prop} {n m : ℕ} (H1 : ∀k, n = m + k -> P k 0) + (H2 : ∀k, m = n + k → P 0 k) : P (n - m) (m - n) := +or.elim (le.total n m) + (assume H3 : n ≤ m, + eq.symm (sub_eq_zero_of_le H3) ▸ H2 (m - n) (eq.symm (add_sub_of_le H3))) + (assume H3 : m ≤ n, + eq.symm (sub_eq_zero_of_le H3) ▸ (H1 (n - m) (eq.symm (add_sub_of_le H3)))) + +protected theorem sub_eq_of_add_eq {n m k : ℕ} (H : n + m = k) : k - n = m := +have H2 : k - n + n = m + n, from + calc + k - n + n = k : nat.sub_add_cancel (le.intro H) + ... = n + m : eq.symm H + ... = m + n : add.comm n m, +add.right_cancel H2 + +protected theorem eq_sub_of_add_eq {a b c : ℕ} (H : a + c = b) : a = b - c := +eq.symm (nat.sub_eq_of_add_eq (add.comm a c ▸ 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 c b ▸ eq.symm H) + +protected theorem sub_le_sub_right {n m : ℕ} (H : n ≤ m) (k : ℕ) : n - k ≤ m - k := +sorry +/- +obtain (l : ℕ) (Hl : n + l = m), from le.elim H, +or.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) : by simp + ... = l + n - k : by rewrite (nat.add_sub_assoc H2 l) + ... = m - k : by simp, + le.intro H3) +-/ + +protected theorem sub_le_sub_left {n m : ℕ} (H : n ≤ m) (k : ℕ) : k - m ≤ k - n := +sorry +/- +obtain (l : ℕ) (Hl : n + l = m), from le.elim H, +sub.cases + (assume H2 : k ≤ m, !zero_le) + (take m' : ℕ, + assume Hm : m + m' = k, + have H3 : n ≤ k, from le.trans H (le.intro Hm), + have H4 : m' + l + n = k - n + n, by simp, + le.intro (add.right_cancel H4)) +-/ + +protected theorem sub_pos_of_lt {m n : ℕ} (H : m < n) : n - m > 0 := +sorry +/- +have H1 : n = n - m + m, from (nat.sub_add_cancel (le_of_lt H))⁻¹, +have H2 : 0 + m < n - m + m, begin rewrite [zero_add, -H1], exact H end, +!lt_of_add_lt_add_right H2 +-/ + +protected theorem lt_of_sub_pos {m n : ℕ} (H : n - m > 0) : m < n := +lt_of_not_ge + (take H1 : m ≥ n, + have H2 : n - m = 0, from sub_eq_zero_of_le H1, + lt.irrefl 0 (H2 ▸ H)) + +protected theorem lt_of_sub_lt_sub_right {n m k : ℕ} (H : n - k < m - k) : n < m := +lt_of_not_ge + (assume H1 : m ≤ n, + have H2 : m - k ≤ n - k, from nat.sub_le_sub_right H1 _, + not_le_of_gt H H2) + +protected theorem lt_of_sub_lt_sub_left {n m k : ℕ} (H : n - m < n - k) : k < m := +lt_of_not_ge + (assume H1 : m ≤ k, + have H2 : n - k ≤ n - m, from nat.sub_le_sub_left H1 _, + not_le_of_gt H H2) + +protected theorem sub_lt_sub_add_sub (n m k : ℕ) : n - k ≤ (n - m) + (m - k) := +sorry +/- +sub.cases + (assume H : n ≤ m, (zero_add (m - k))⁻¹ ▸ nat.sub_le_sub_right H k) + (take mn : ℕ, + assume Hmn : m + mn = n, + sub.cases + (assume H : m ≤ k, + have H2 : n - k ≤ n - m, from nat.sub_le_sub_left H n, + have H3 : n - k ≤ mn, from nat.sub_eq_of_add_eq Hmn ▸ H2, + show n - k ≤ mn + 0, begin rewrite add_zero, assumption end) + (take km : ℕ, + assume Hkm : k + km = m, + have H : k + (mn + km) = n, from + calc + k + (mn + km) = k + km + mn : by simp + ... = m + mn : by rewrite Hkm + ... = n : Hmn, + have H2 : n - k = mn + km, from nat.sub_eq_of_add_eq H, + H2 ▸ !le.refl)) +-/ + +protected theorem sub_lt_self {m n : ℕ} (H1 : m > 0) (H2 : n > 0) : m - n < m := +sorry +/- +calc + m - n = succ (pred m) - n : by rewrite (succ_pred_of_pos H1) + ... = succ (pred m) - succ (pred n) : by rewrite (succ_pred_of_pos H2) + ... = pred m - pred n : by rewrite succ_sub_succ + ... ≤ pred m : !sub_le + ... < succ (pred m) : !lt_succ_self + ... = m : succ_pred_of_pos H1 +-/ + +protected theorem le_sub_of_add_le {m n k : ℕ} (H : m + k ≤ n) : m ≤ n - k := +sorry +/- +calc + m = m + k - k : by rewrite nat.add_sub_cancel + ... ≤ n - k : nat.sub_le_sub_right H k +-/ + +protected theorem lt_sub_of_add_lt {m n k : ℕ} (H : m + k < n) (H2 : k ≤ n) : m < n - k := +sorry +/- +lt_of_succ_le (nat.le_sub_of_add_le (calc + succ m + k = succ (m + k) : by rewrite 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 := +sorry +/- +have succ v ≤ n + m, from succ_le_of_lt h₁, +have succ (v - n) ≤ m, from + calc succ (v - n) = succ v - n : by rewrite (succ_sub h₂) + ... ≤ n + m - n : nat.sub_le_sub_right this n + ... = m : by rewrite nat.add_sub_cancel_left, +lt_of_succ_le this +-/ + +/- distance -/ + +attribute [reducible] +definition dist (n m : ℕ) := (n - m) + (m - n) + +theorem dist.comm (n m : ℕ) : dist n m = dist m n := +sorry -- by simp + +theorem dist_self (n : ℕ) : dist n n = 0 := +sorry -- by simp + +theorem eq_of_dist_eq_zero {n m : ℕ} (H : dist n m = 0) : n = m := +have H2 : n - m = 0, from eq_zero_of_add_eq_zero_right H, +have H3 : n ≤ m, from le_of_sub_eq_zero H2, +have H4 : m - n = 0, from eq_zero_of_add_eq_zero_left H, +have H5 : m ≤ n, from le_of_sub_eq_zero H4, +le.antisymm H3 H5 + +theorem dist_eq_zero {n m : ℕ} (H : n = m) : dist n m = 0 := +sorry -- 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 := +sorry +/- +calc + dist n m = 0 + (m - n) : by rewrite -(sub_eq_zero_of_le H) + ... = m - n : by rewrite zero_add +-/ + +theorem dist_eq_sub_of_lt {n m : ℕ} (H : n < m) : dist n m = m - n := +dist_eq_sub_of_le (le_of_lt H) + +theorem dist_eq_sub_of_ge {n m : ℕ} (H : n ≥ m) : dist n m = n - m := +dist.comm m n ▸ dist_eq_sub_of_le H + +theorem dist_eq_sub_of_gt {n m : ℕ} (H : n > m) : dist n m = n - m := +dist_eq_sub_of_ge (le_of_lt H) + +theorem dist_zero_right (n : ℕ) : dist n 0 = n := +eq.trans (dist_eq_sub_of_ge (zero_le n)) (nat.sub_zero n) + +theorem dist_zero_left (n : ℕ) : dist 0 n = n := +eq.trans (dist_eq_sub_of_le (zero_le n)) (nat.sub_zero n) + +theorem dist.intro {n m k : ℕ} (H : n + m = k) : dist k n = m := +calc + dist k n = k - n : dist_eq_sub_of_ge (le.intro H) + ... = m : nat.sub_eq_of_add_eq H + +theorem dist_add_add_right (n k m : ℕ) : dist (n + k) (m + k) = dist n m := +calc + dist (n + k) (m + k) = ((n+k) - (m+k)) + ((m+k)-(n+k)) : rfl + ... = (n - m) + ((m + k) - (n + k)) : sorry -- by rewrite nat.add_sub_add_right + ... = (n - m) + (m - n) : sorry -- by rewrite nat.add_sub_add_right + +theorem dist_add_add_left (k n m : ℕ) : dist (k + n) (k + m) = dist n m := +sorry -- begin rewrite [add.comm k n, add.comm k m]; apply dist_add_add_right end + +theorem dist_add_eq_of_ge {n m : ℕ} (H : n ≥ m) : dist n m + m = n := +sorry +/- +calc + dist n m + m = n - m + m : by rewrite (dist_eq_sub_of_ge H) + ... = n : nat.sub_add_cancel H +-/ + +theorem dist_eq_intro {n m k l : ℕ} (H : n + m = k + l) : dist n k = dist l m := +sorry +/- +calc + dist n k = dist (n + m) (k + m) : by rewrite dist_add_add_right + ... = dist (k + l) (k + m) : by rewrite H + ... = dist l m : by rewrite dist_add_add_left +-/ + +theorem dist_sub_eq_dist_add_left {n m : ℕ} (H : n ≥ m) (k : ℕ) : + dist (n - m) k = dist n (k + m) := +sorry +/- +have H2 : n - m + (k + m) = k + n, from + calc + n - m + (k + m) = n - m + m + k : by simp + ... = n + k : by rewrite (nat.sub_add_cancel H) + ... = k + n : by simp, +dist_eq_intro H2 +-/ + +theorem dist_sub_eq_dist_add_right {k m : ℕ} (H : k ≥ m) (n : ℕ) : + dist n (k - m) = dist (n + m) k := +dist.comm (k - m) n ▸ dist.comm k (n + m) ▸ dist_sub_eq_dist_add_left H n + +theorem dist.triangle_inequality (n m k : ℕ) : dist n k ≤ dist n m + dist m k := +sorry +/- +have (n - m) + (m - k) + ((k - m) + (m - n)) = (n - m) + (m - n) + ((m - k) + (k - m)), by simp, +this ▸ add_le_add !nat.sub_lt_sub_add_sub !nat.sub_lt_sub_add_sub +-/ + +theorem dist_add_add_le_add_dist_dist (n m k l : ℕ) : dist (n + m) (k + l) ≤ dist n k + dist m l := +sorry +/- +have H : dist (n + m) (k + m) + dist (k + m) (k + l) = dist n k + dist m l, + by rewrite [dist_add_add_left, dist_add_add_right], +by rewrite -H; apply dist.triangle_inequality +-/ + +theorem dist_mul_right (n k m : ℕ) : dist (n * k) (m * k) = dist n m * k := +sorry +/- +have ∀ n m, dist n m = n - m + (m - n), from take n m, rfl, +by rewrite [this, this n m, right_distrib, *nat.mul_sub_right_distrib] +-/ + +theorem dist_mul_left (k n m : ℕ) : dist (k * n) (k * m) = k * dist n m := +sorry -- begin rewrite [mul.comm k n, mul.comm k m, dist_mul_right, mul.comm] end + +theorem dist_mul_dist (n m k l : ℕ) : dist n m * dist k l = dist (n * k + m * l) (n * l + m * k) := +sorry +/- +have aux : ∀k l, k ≥ l → dist n m * dist k l = dist (n * k + m * l) (n * l + m * k), from + take k l : ℕ, + assume H : k ≥ l, + have H2 : m * k ≥ m * l, from !mul_le_mul_left H, + have H3 : n * l + m * k ≥ m * l, from le.trans H2 !le_add_left, + calc + dist n m * dist k l = dist n m * (k - l) : by rewrite (dist_eq_sub_of_ge H) + ... = dist (n * (k - l)) (m * (k - l)) : by rewrite dist_mul_right + ... = dist (n * k - n * l) (m * k - m * l) : by rewrite [*nat.mul_sub_left_distrib] + ... = dist (n * k) (m * k - m * l + n * l) : by rewrite (dist_sub_eq_dist_add_left (!mul_le_mul_left H)) + ... = dist (n * k) (n * l + (m * k - m * l)) : by rewrite (add.comm (n * l)) + ... = dist (n * k) (n * l + m * k - m * l) : by rewrite (nat.add_sub_assoc H2 (n * l)) + ... = dist (n * k + m * l) (n * l + m * k) : dist_sub_eq_dist_add_right H3 _, +or.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 := +sorry +/- +or.elim (lt_or_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 := +sorry -- by rewrite [↑dist, *succ_sub_succ] + +lemma dist_le_max {i j : nat} : dist i j ≤ max i j := +sorry -- 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 := +sorry +/- +assume Pne, lt.by_cases + (suppose i < j, begin rewrite [dist_eq_sub_of_lt this], apply nat.sub_pos_of_lt this end) + (suppose i = j, by contradiction) + (suppose i > j, begin rewrite [dist_eq_sub_of_gt this], apply nat.sub_pos_of_lt this end) +-/ +end nat diff --git a/old_library/data/num.lean b/old_library/data/num.lean new file mode 100644 index 0000000000..83a966747f --- /dev/null +++ b/old_library/data/num.lean @@ -0,0 +1,548 @@ +/- +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 data.bool +open bool tactic + +attribute [instance] +definition pos_num_decidable_eq : decidable_eq pos_num := +by mk_dec_eq_instance + +attribute [instance] +definition num_decidable_eq : decidable_eq num := +by mk_dec_eq_instance + +namespace pos_num + theorem succ_not_is_one (a : pos_num) : is_one (succ a) = ff := + pos_num.induction_on a rfl (take n iH, rfl) (take n iH, rfl) + + theorem succ_one : succ one = bit0 one := rfl + theorem succ_bit1 (a : pos_num) : succ (bit1 a) = bit0 (succ a) := rfl + theorem succ_bit0 (a : pos_num) : succ (bit0 a) = bit1 a := rfl + + 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) := sorry -- 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))) : sorry -- by rewrite succ_not_is_one + ... = bit1 (pred (succ a)) : rfl + ... = bit1 a : sorry -- by rewrite pred_succ + + section + variables (a b : pos_num) + + theorem one_add_one : one + one = bit0 one := rfl + theorem one_add_bit0 : one + (bit0 a) = bit1 a := rfl + theorem one_add_bit1 : one + (bit1 a) = succ (bit1 a) := rfl + theorem bit0_add_one : (bit0 a) + one = bit1 a := rfl + theorem bit1_add_one : (bit1 a) + one = succ (bit1 a) := rfl + theorem bit0_add_bit0 : (bit0 a) + (bit0 b) = bit0 (a + b) := rfl + theorem bit0_add_bit1 : (bit0 a) + (bit1 b) = bit1 (a + b) := rfl + theorem bit1_add_bit0 : (bit1 a) + (bit0 b) = bit1 (a + b) := rfl + theorem bit1_add_bit1 : (bit1 a) + (bit1 b) = succ (bit1 (a + b)) := rfl + theorem one_mul : one * a = a := rfl + end + + theorem mul_one : ∀ a, a * one = a + | one := rfl + | (bit1 n) := + calc bit1 n * one = bit0 (n * one) + one : rfl + ... = bit0 n + one : sorry -- by rewrite mul_one + ... = bit1 n : bit0_add_one _ + | (bit0 n) := + calc bit0 n * one = bit0 (n * one) : rfl + ... = bit0 n : sorry -- by rewrite mul_one + + 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) := + sorry + /- + begin + rewrite lt_bit0_bit0_eq_lt, apply lt_irrefl + end + -/ + | (bit1 a) := + sorry + /- + 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 → false + | one ⌞one⌟ H₁ (eq.refl one) := absurd H₁ ff_ne_tt + | (bit0 a) ⌞(bit0 a)⌟ H₁ (eq.refl (bit0 a)) := + sorry + /- + 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)) := + sorry + /- + 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) := + sorry + /- + begin + rewrite [succ_bit0, lt_bit0_bit1_eq_lt_succ], + apply lt_base + end + -/ + | (bit1 a) := + sorry + /- + 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 + := sorry + /- + | 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 + := sorry + /- + | 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 + := sorry + /- + | 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 + := sorry + /- + | 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 + := sorry + /- + | 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 + := sorry + /- + | 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 + := sorry + /- + | 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 → false, + 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 → false, + 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 → false, + begin + intro Hp, + rewrite -Hp at H, + apply absurd_of_eq_ff_of_eq_tt (lt_irrefl b) H + end, + show b ≠ a → false, + 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 → false + := sorry + /- + | 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 + := sorry + /- + | 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 false.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 false.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 := + sorry + /- + 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 diff --git a/old_library/data/old_fin.lean b/old_library/data/old_fin.lean new file mode 100644 index 0000000000..52361b4d1b --- /dev/null +++ b/old_library/data/old_fin.lean @@ -0,0 +1,496 @@ +/- +Copyright (c) 2015 Haitao Zhang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Haitao Zhang, Leonardo de Moura + +Finite ordinal types. +-/ +import data.list.basic data.finset.basic data.fintype.card algebra.group data.equiv +open eq.ops nat function list finset fintype + +structure fin (n : nat) := (val : nat) (is_lt : val < n) + +attribute [reducible] +definition less_than := fin + +namespace fin + +-- attribute fin.val [coercion] + +section def_equal +variable {n : nat} + +lemma eq_of_veq : ∀ {i j : fin n}, (val i) = j → i = j +| (mk iv ilt) (mk jv jlt) := assume (veq : iv = jv), begin congruence, assumption end + +lemma veq_of_eq : ∀ {i j : fin n}, i = j → (val i) = j +| (mk iv ilt) (mk jv jlt) := assume Peq, + show iv = jv, from fin.no_confusion Peq (λ Pe Pqe, Pe) + +lemma eq_iff_veq {i j : fin n} : (val i) = j ↔ i = j := +iff.intro eq_of_veq veq_of_eq + +definition val_inj := @eq_of_veq n + +end def_equal + +section +open decidable +attribute [instance] +protected definition has_decidable_eq (n : nat) : ∀ (i j : fin n), decidable (i = j) +| (mk ival ilt) (mk jval jlt) := + decidable_of_decidable_of_iff (nat.has_decidable_eq ival jval) eq_iff_veq +end + +lemma dinj_lt (n : nat) : dinj (λ i, i < n) fin.mk := +take a1 a2 Pa1 Pa2 Pmkeq, fin.no_confusion Pmkeq (λ Pe Pqe, Pe) + +lemma val_mk (n i : nat) (Plt : i < n) : fin.val (fin.mk i Plt) = i := rfl + +attribute [reducible] +definition upto (n : nat) : list (fin n) := +dmap (λ i, i < n) fin.mk (list.upto n) + +lemma nodup_upto (n : nat) : nodup (upto n) := +dmap_nodup_of_dinj (dinj_lt n) (list.nodup_upto n) + +lemma mem_upto (n : nat) : ∀ (i : fin n), i ∈ upto n := +take i, fin.destruct i + (take ival Piltn, + have ival ∈ list.upto n, from mem_upto_of_lt Piltn, + mem_dmap Piltn this) + +lemma upto_zero : upto 0 = [] := +by rewrite [↑upto, list.upto_nil, dmap_nil] + +lemma map_val_upto (n : nat) : map fin.val (upto n) = list.upto n := +map_dmap_of_inv_of_pos (val_mk n) (@lt_of_mem_upto n) + +lemma length_upto (n : nat) : length (upto n) = n := +calc + length (upto n) = length (list.upto n) : (map_val_upto n ▸ length_map fin.val (upto n))⁻¹ + ... = n : list.length_upto n + +attribute [instance] +definition is_fintype (n : nat) : fintype (fin n) := +fintype.mk (upto n) (nodup_upto n) (mem_upto n) + +section pigeonhole +open fintype + +lemma card_fin (n : nat) : card (fin n) = n := length_upto n + +theorem pigeonhole {n m : nat} (Pmltn : m < n) : ¬∃ f : fin n → fin m, injective f := +assume Pex, absurd Pmltn (not_lt_of_ge + (calc + n = card (fin n) : card_fin + ... ≤ card (fin m) : card_le_of_inj (fin n) (fin m) Pex + ... = m : card_fin)) + +end pigeonhole + +protected definition zero (n : nat) : fin (succ n) := +mk 0 !zero_lt_succ + +attribute [instance] +definition fin_has_zero (n : nat) : has_zero (fin (succ n)) := +has_zero.mk (fin.zero n) + +theorem val_zero (n : nat) : val (0 : fin (succ n)) = 0 := rfl + +attribute [reducible] +definition mk_mod (n i : nat) : fin (succ n) := +mk (i % (succ n)) (mod_lt _ !zero_lt_succ) + +theorem mk_mod_zero_eq (n : nat) : mk_mod n 0 = 0 := +rfl + +variable {n : nat} + +theorem val_lt : ∀ i : fin n, val i < n +| (mk v h) := h + +lemma max_lt (i j : fin n) : max i j < n := +max_lt (is_lt i) (is_lt j) + +definition lift : fin n → Π m : nat, fin (n + m) +| (mk v h) m := mk v (lt_add_of_lt_right h m) + +definition lift_succ (i : fin n) : fin (nat.succ n) := +have r : fin (n+1), from lift i 1, +r + +attribute [reducible] +definition maxi : fin (succ n) := +mk n !lt_succ_self + +theorem val_lift : ∀ (i : fin n) (m : nat), val i = val (lift i m) +| (mk v h) m := rfl + +lemma mk_succ_ne_zero {i : nat} : ∀ {P}, mk (succ i) P ≠ (0 : fin (succ n)) := +assume P Pe, absurd (veq_of_eq Pe) !succ_ne_zero + +lemma mk_mod_eq {i : fin (succ n)} : i = mk_mod n i := +eq_of_veq begin rewrite [↑mk_mod, mod_eq_of_lt !is_lt] end + +lemma mk_mod_of_lt {i : nat} (Plt : i < succ n) : mk_mod n i = mk i Plt := +begin esimp [mk_mod], congruence, exact mod_eq_of_lt Plt end + +section lift_lower + +lemma lift_zero : lift_succ (0 : fin (succ n)) = (0 : fin (succ (succ n))) := rfl + +lemma ne_max_of_lt_max {i : fin (succ n)} : i < n → i ≠ maxi := +by intro hlt he; substvars; exact absurd hlt (lt.irrefl n) + +lemma lt_max_of_ne_max {i : fin (succ n)} : i ≠ maxi → i < n := +assume hne : i ≠ maxi, +have vne : val i ≠ n, from + assume he, + have val (@maxi n) = n, from rfl, + have val i = val (@maxi n), from he ⬝ this⁻¹, + absurd (eq_of_veq this) hne, +have val i < nat.succ n, from val_lt i, +lt_of_le_of_ne (le_of_lt_succ this) vne + +lemma lift_succ_ne_max {i : fin n} : lift_succ i ≠ maxi := +begin + cases i with v hlt, esimp [lift_succ, lift, max], intro he, + injection he, substvars, + exact absurd hlt (lt.irrefl v) +end + +lemma lift_succ_inj : injective (@lift_succ n) := +take i j, destruct i (destruct j (take iv ilt jv jlt Pmkeq, + begin congruence, apply fin.no_confusion Pmkeq, intros, assumption end)) + +lemma lt_of_inj_of_max (f : fin (succ n) → fin (succ n)) : + injective f → (f maxi = maxi) → ∀ i : fin (succ n), i < n → f i < n := +assume Pinj Peq, take i, assume Pilt, +have P1 : f i = f maxi → i = maxi, from assume Peq, Pinj i maxi Peq, +have f i ≠ maxi, from + begin rewrite -Peq, intro P2, apply absurd (P1 P2) (ne_max_of_lt_max Pilt) end, +lt_max_of_ne_max this + +definition lift_fun : (fin n → fin n) → (fin (succ n) → fin (succ n)) := +λ f i, dite (i = maxi) (λ Pe, maxi) (λ Pne, lift_succ (f (mk i (lt_max_of_ne_max Pne)))) + +definition lower_inj (f : fin (succ n) → fin (succ n)) (inj : injective f) : + f maxi = maxi → fin n → fin n := +assume Peq, take i, mk (f (lift_succ i)) (lt_of_inj_of_max f inj Peq (lift_succ i) (lt_max_of_ne_max lift_succ_ne_max)) + +lemma lift_fun_max {f : fin n → fin n} : lift_fun f maxi = maxi := +begin rewrite [↑lift_fun, dif_pos rfl] end + +lemma lift_fun_of_ne_max {f : fin n → fin n} {i} (Pne : i ≠ maxi) : + lift_fun f i = lift_succ (f (mk i (lt_max_of_ne_max Pne))) := +begin rewrite [↑lift_fun, dif_neg Pne] end + +lemma lift_fun_eq {f : fin n → fin n} {i : fin n} : + lift_fun f (lift_succ i) = lift_succ (f i) := +begin +rewrite [lift_fun_of_ne_max lift_succ_ne_max], congruence, congruence, +rewrite [-eq_iff_veq], esimp, rewrite [↑lift_succ, -val_lift] +end + +lemma lift_fun_of_inj {f : fin n → fin n} : injective f → injective (lift_fun f) := +assume Pinj, take i j, +have Pdi : decidable (i = maxi), from _, have Pdj : decidable (j = maxi), from _, +begin + cases Pdi with Pimax Pinmax, + cases Pdj with Pjmax Pjnmax, + substvars, intros, exact rfl, + substvars, rewrite [lift_fun_max, lift_fun_of_ne_max Pjnmax], + intro Plmax, apply absurd Plmax⁻¹ lift_succ_ne_max, + cases Pdj with Pjmax Pjnmax, + substvars, rewrite [lift_fun_max, lift_fun_of_ne_max Pinmax], + intro Plmax, apply absurd Plmax lift_succ_ne_max, + rewrite [lift_fun_of_ne_max Pinmax, lift_fun_of_ne_max Pjnmax], + intro Peq, rewrite [-eq_iff_veq], + exact veq_of_eq (Pinj (lift_succ_inj Peq)) +end + +lemma lift_fun_inj : injective (@lift_fun n) := +take f₁ f₂ Peq, funext (λ i, +have lift_fun f₁ (lift_succ i) = lift_fun f₂ (lift_succ i), from congr_fun Peq _, +begin revert this, rewrite [*lift_fun_eq], apply lift_succ_inj end) + +lemma lower_inj_apply {f Pinj Pmax} (i : fin n) : + val (lower_inj f Pinj Pmax i) = val (f (lift_succ i)) := +by rewrite [↑lower_inj] + +end lift_lower + +section madd + +definition madd (i j : fin (succ n)) : fin (succ n) := +mk ((i + j) % (succ n)) (mod_lt _ !zero_lt_succ) + +definition minv : ∀ i : fin (succ n), fin (succ n) +| (mk iv ilt) := mk ((succ n - iv) % succ n) (mod_lt _ !zero_lt_succ) + +lemma val_madd : ∀ i j : fin (succ n), val (madd i j) = (i + j) % (succ n) +| (mk iv ilt) (mk jv jlt) := by esimp + +lemma madd_inj : ∀ {i : fin (succ n)}, injective (madd i) +| (mk iv ilt) := +take j₁ j₂, fin.destruct j₁ (fin.destruct j₂ (λ jv₁ jlt₁ jv₂ jlt₂, begin + rewrite [↑madd, -eq_iff_veq], + intro Peq, congruence, + rewrite [-(mod_eq_of_lt jlt₁), -(mod_eq_of_lt jlt₂)], + apply mod_eq_mod_of_add_mod_eq_add_mod_left Peq +end)) + +lemma madd_mk_mod {i j : nat} : madd (mk_mod n i) (mk_mod n j) = mk_mod n (i+j) := +eq_of_veq begin esimp [madd, mk_mod], rewrite [ mod_add_mod, add_mod_mod ] end + +lemma val_mod : ∀ i : fin (succ n), (val i) % (succ n) = val i +| (mk iv ilt) := by esimp; rewrite [(mod_eq_of_lt ilt)] + +lemma madd_comm (i j : fin (succ n)) : madd i j = madd j i := +by apply eq_of_veq; rewrite [*val_madd, add.comm (val i)] + +lemma zero_madd (i : fin (succ n)) : madd 0 i = i := +have H : madd (fin.zero n) i = i, + by apply eq_of_veq; rewrite [val_madd, ↑fin.zero, nat.zero_add, mod_eq_of_lt (is_lt i)], +H + +lemma madd_zero (i : fin (succ n)) : madd i (fin.zero n) = i := +!madd_comm ▸ zero_madd i + +lemma madd_assoc (i j k : fin (succ n)) : madd (madd i j) k = madd i (madd j k) := +by apply eq_of_veq; rewrite [*val_madd, mod_add_mod, add_mod_mod, add.assoc (val i)] + +lemma madd_left_inv : ∀ i : fin (succ n), madd (minv i) i = fin.zero n +| (mk iv ilt) := eq_of_veq (by + rewrite [val_madd, ↑minv, ↑fin.zero, mod_add_mod, nat.sub_add_cancel (le_of_lt ilt), mod_self]) + +attribute [instance] +definition madd_is_comm_group : add_comm_group (fin (succ n)) := +add_comm_group.mk madd madd_assoc (fin.zero n) zero_madd madd_zero minv madd_left_inv madd_comm + +end madd + +definition pred : fin n → fin n +| (mk v h) := mk (nat.pred v) (pre_lt_of_lt h) + +lemma val_pred : ∀ (i : fin n), val (pred i) = nat.pred (val i) +| (mk v h) := rfl + +lemma pred_zero : pred (fin.zero n) = fin.zero n := +rfl + +definition mk_pred (i : nat) (h : succ i < succ n) : fin n := +mk i (lt_of_succ_lt_succ h) + +definition succ : fin n → fin (succ n) +| (mk v h) := mk (nat.succ v) (succ_lt_succ h) + +lemma val_succ : ∀ (i : fin n), val (succ i) = nat.succ (val i) +| (mk v h) := rfl + +lemma succ_max : fin.succ maxi = (@maxi (nat.succ n)) := rfl + +lemma lift_succ.comm : lift_succ ∘ (@succ n) = succ ∘ lift_succ := +funext take i, eq_of_veq (begin rewrite [↑lift_succ, -val_lift, *val_succ, -val_lift] end) + +definition elim0 {C : fin 0 → Type} : Π i : fin 0, C i +| (mk v h) := absurd h !not_lt_zero + +definition zero_succ_cases {C : fin (nat.succ n) → Type} : + C (fin.zero n) → (Π j : fin n, C (succ j)) → (Π k : fin (nat.succ n), C k) := +begin + intros CO CS k, + induction k with [vk, pk], + induction (nat.decidable_lt 0 vk) with [HT, HF], + { show C (mk vk pk), from + let vj := nat.pred vk in + have vk = vj+1, from + eq.symm (succ_pred_of_pos HT), + have vj < n, from + lt_of_succ_lt_succ (eq.subst `vk = vj+1` pk), + have succ (mk vj `vj < n`) = mk vk pk, from + val_inj (eq.symm `vk = vj+1`), + eq.rec_on this (CS (mk vj `vj < n`)) }, + { show C (mk vk pk), from + have vk = 0, from + eq_zero_of_le_zero (le_of_not_gt HF), + have fin.zero n = mk vk pk, from + val_inj (eq.symm this), + eq.rec_on this CO } +end + +definition succ_maxi_cases {C : fin (nat.succ n) → Type} : + (Π j : fin n, C (lift_succ j)) → C maxi → (Π k : fin (nat.succ n), C k) := +begin + intros CL CM k, + induction k with [vk, pk], + induction (nat.decidable_lt vk n) with [HT, HF], + { show C (mk vk pk), from + have HL : lift_succ (mk vk HT) = mk vk pk, from + val_inj rfl, + eq.rec_on HL (CL (mk vk HT)) }, + { show C (mk vk pk), from + have HMv : vk = n, from + le.antisymm (le_of_lt_succ pk) (le_of_not_gt HF), + have HM : maxi = mk vk pk, from + val_inj (eq.symm HMv), + eq.rec_on HM CM } +end + +definition foldr {A B : Type} (m : A → B → B) (b : B) : ∀ {n : nat}, (fin n → A) → B := + nat.rec (λ f, b) (λ n IH f, m (f (fin.zero n)) (IH (λ i : fin n, f (succ i)))) + +definition foldl {A B : Type} (m : B → A → B) (b : B) : ∀ {n : nat}, (fin n → A) → B := + nat.rec (λ f, b) (λ n IH f, m (IH (λ i : fin n, f (lift_succ i))) (f maxi)) + +theorem choice {C : fin n → Type} : + (∀ i : fin n, nonempty (C i)) → nonempty (Π i : fin n, C i) := +begin + revert C, + induction n with [n, IH], + { intros C H, + apply nonempty.intro, + exact elim0 }, + { intros C H, + fapply nonempty.elim (H (fin.zero n)), + intro CO, + fapply nonempty.elim (IH (λ i, C (succ i)) (λ i, H (succ i))), + intro CS, + apply nonempty.intro, + exact zero_succ_cases CO CS } +end + +section +open list +local postfix `+1`:100 := nat.succ + +lemma dmap_map_lift {n : nat} : ∀ l : list nat, (∀ i, i ∈ l → i < n) → dmap (λ i, i < n +1) mk l = map lift_succ (dmap (λ i, i < n) mk l) +| [] := assume Plt, rfl +| (i::l) := assume Plt, begin + rewrite [@dmap_cons_of_pos _ _ (λ i, i < n +1) _ _ _ (lt_succ_of_lt (Plt i !mem_cons)), @dmap_cons_of_pos _ _ (λ i, i < n) _ _ _ (Plt i !mem_cons), map_cons], + congruence, + apply dmap_map_lift, + intro j Pjinl, apply Plt, apply mem_cons_of_mem, assumption end + +lemma upto_succ (n : nat) : upto (n +1) = maxi :: map lift_succ (upto n) := +begin + rewrite [↑fin.upto, list.upto_succ, @dmap_cons_of_pos _ _ (λ i, i < n +1) _ _ _ (nat.self_lt_succ n)], + congruence, + apply dmap_map_lift, apply @list.lt_of_mem_upto +end + +definition upto_step : ∀ {n : nat}, fin.upto (n +1) = (map succ (upto n))++[0] +| 0 := rfl +| (i +1) := begin rewrite [upto_succ i, map_cons, append_cons, succ_max, upto_succ, -lift_zero], + congruence, rewrite [map_map, -lift_succ.comm, -map_map, -(map_singleton _ 0), -map_append, -upto_step] end +end + +open sum equiv decidable + +definition fin_zero_equiv_empty : fin 0 ≃ empty := +⦃ equiv, + to_fun := λ f : (fin 0), elim0 f, + inv_fun := λ e : empty, empty.rec _ e, + left_inv := λ f : (fin 0), elim0 f, + right_inv := λ e : empty, empty.rec _ e +⦄ + +definition fin_one_equiv_unit : fin 1 ≃ unit := +⦃ equiv, + to_fun := λ f : (fin 1), unit.star, + inv_fun := λ u : unit, fin.zero 0, + left_inv := begin + intro f, change mk 0 !zero_lt_succ = f, cases f with v h, congruence, + have v +1 ≤ 1, from succ_le_of_lt h, + have v ≤ 0, from le_of_succ_le_succ this, + have v = 0, from eq_zero_of_le_zero this, + subst v + end, + right_inv := begin + intro u, cases u, reflexivity + end +⦄ + +definition fin_sum_equiv (n m : nat) : (fin n + fin m) ≃ fin (n+m) := +have aux₁ : ∀ {v}, v < m → (v + n) < (n + m), from + take v, suppose v < m, calc + v + n < m + n : add_lt_add_of_lt_of_le this !le.refl + ... = n + m : add.comm, +⦃ equiv, + to_fun := λ s : sum (fin n) (fin m), + match s with + | sum.inl (mk v hlt) := mk v (lt_add_of_lt_right hlt m) + | sum.inr (mk v hlt) := mk (v+n) (aux₁ hlt) + end, + inv_fun := λ f : fin (n + m), + match f with + | mk v hlt := if h : v < n then sum.inl (mk v h) else sum.inr (mk (v-n) (nat.sub_lt_of_lt_add hlt (le_of_not_gt h))) + end, + left_inv := begin + intro s, cases s with f₁ f₂, + { cases f₁ with v hlt, esimp, rewrite [dif_pos hlt] }, + { cases f₂ with v hlt, esimp, + have ¬ v + n < n, from + suppose v + n < n, + have v < n - n, from nat.lt_sub_of_add_lt this !le.refl, + have v < 0, by rewrite [nat.sub_self at this]; exact this, + absurd this !not_lt_zero, + rewrite [dif_neg this], congruence, congruence, rewrite [nat.add_sub_cancel] } + end, + right_inv := begin + intro f, cases f with v hlt, esimp, apply @by_cases (v < n), + { intro h₁, rewrite [dif_pos h₁] }, + { intro h₁, rewrite [dif_neg h₁], esimp, congruence, rewrite [nat.sub_add_cancel (le_of_not_gt h₁)] } + end +⦄ + +definition fin_prod_equiv_of_pos (n m : nat) : n > 0 → (fin n × fin m) ≃ fin (n*m) := +suppose n > 0, +have aux₁ : ∀ {v₁ v₂}, v₁ < n → v₂ < m → v₁ + v₂ * n < n*m, from + take v₁ v₂, assume h₁ h₂, + have nat.succ v₂ ≤ m, from succ_le_of_lt h₂, + have nat.succ v₂ * n ≤ m * n, from mul_le_mul_right _ this, + have v₂ * n + n ≤ n * m, by rewrite [-add_one at this, right_distrib at this, one_mul at this, mul.comm m n at this]; exact this, + have v₁ + (v₂ * n + n) < n + n * m, from add_lt_add_of_lt_of_le h₁ this, + have v₁ + v₂ * n + n < n * m + n, by rewrite [add.assoc, add.comm (n*m) n]; exact this, + lt_of_add_lt_add_right this, +have aux₂ : ∀ v, v % n < n, from + take v, mod_lt _ `n > 0`, +have aux₃ : ∀ {v}, v < n * m → v / n < m, from + take v, assume h, by rewrite mul.comm at h; exact nat.div_lt_of_lt_mul h, +⦃ equiv, + to_fun := λ p : (fin n × fin m), match p with (mk v₁ hlt₁, mk v₂ hlt₂) := mk (v₁ + v₂ * n) (aux₁ hlt₁ hlt₂) end, + inv_fun := λ f : fin (n*m), match f with (mk v hlt) := (mk (v % n) (aux₂ v), mk (v / n) (aux₃ hlt)) end, + left_inv := begin + intro p, cases p with f₁ f₂, cases f₁ with v₁ hlt₁, cases f₂ with v₂ hlt₂, esimp, + congruence, + {congruence, rewrite [add_mul_mod_self, mod_eq_of_lt hlt₁] }, + {congruence, rewrite [add_mul_div_self `n > 0`, div_eq_zero_of_lt hlt₁, zero_add]} + end, + right_inv := begin + intro f, cases f with v hlt, esimp, congruence, + rewrite [add.comm, -eq_div_mul_add_mod] + end +⦄ + +definition fin_prod_equiv : Π (n m : nat), (fin n × fin m) ≃ fin (n*m) +| 0 b := calc + (fin 0 × fin b) ≃ (empty × fin b) : prod_congr fin_zero_equiv_empty !equiv.refl + ... ≃ empty : prod_empty_left + ... ≃ fin 0 : fin_zero_equiv_empty + ... ≃ fin (0 * b) : by rewrite zero_mul +| (a+1) b := fin_prod_equiv_of_pos (a+1) b dec_trivial + +definition fin_two_equiv_bool : fin 2 ≃ bool := +calc + fin 2 ≃ fin (1 + 1) : equiv.refl + ... ≃ fin 1 + fin 1 : fin_sum_equiv + ... ≃ unit + unit : sum_congr fin_one_equiv_unit fin_one_equiv_unit + ... ≃ bool : bool_equiv_unit_sum_unit + +definition fin_sum_unit_equiv (n : nat) : fin n + unit ≃ fin (n+1) := +calc + fin n + unit ≃ fin n + fin 1 : sum_congr !equiv.refl (equiv.symm fin_one_equiv_unit) + ... ≃ fin (n+1) : fin_sum_equiv +end fin diff --git a/old_library/data/old_string.lean b/old_library/data/old_string.lean new file mode 100644 index 0000000000..b3f8484149 --- /dev/null +++ b/old_library/data/old_string.lean @@ -0,0 +1,52 @@ +/- +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 data.bool +open bool + +attribute [instance] +protected definition char.is_inhabited : inhabited char := +inhabited.mk (char.mk ff ff ff ff ff ff ff ff) + +attribute [instance] +protected definition string.is_inhabited : inhabited string := +inhabited.mk string.empty + +open decidable + +attribute [instance] +definition decidable_eq_char : ∀ c₁ c₂ : char, decidable (c₁ = c₂) := +begin + intro c₁ c₂, + cases c₁ with a₁ a₂ a₃ a₄ a₅ a₆ a₇ a₈, + cases c₂ with b₁ b₂ b₃ b₄ b₅ b₆ b₇ b₈, + apply (@by_cases (a₁ = b₁)), intros, + apply (@by_cases (a₂ = b₂)), intros, + apply (@by_cases (a₃ = b₃)), intros, + apply (@by_cases (a₄ = b₄)), intros, + apply (@by_cases (a₅ = b₅)), intros, + apply (@by_cases (a₆ = b₆)), intros, + apply (@by_cases (a₇ = b₇)), intros, + apply (@by_cases (a₈ = b₈)), intros, + left, congruence, repeat assumption, + repeat (intro n; right; intro h; injection h; contradiction) +end + +open string + +attribute [instance] +definition decidable_eq_string : ∀ s₁ s₂ : string, decidable (s₁ = s₂) +| empty empty := by left; reflexivity +| empty (str c₂ r₂) := by right; contradiction +| (str c₁ r₁) empty := by right; contradiction +| (str c₁ r₁) (str c₂ r₂) := + match decidable_eq_char c₁ c₂ with + | inl e₁ := + match decidable_eq_string r₁ r₂ with + | inl e₂ := by left; congruence; repeat assumption + | inr n₂ := by right; intro h; injection h; contradiction + end + | inr n₁ := by right; intro h; injection h; contradiction + end diff --git a/old_library/data/pnat.lean b/old_library/data/pnat.lean new file mode 100644 index 0000000000..2132696db7 --- /dev/null +++ b/old_library/data/pnat.lean @@ -0,0 +1,404 @@ +/- +Copyright (c) 2015 Robert Y. Lewis. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Robert Y. Lewis + +Basic facts about the positive natural numbers. + +Developed primarily for use in the construction of ℝ. For the most part, the only theorems here +are those needed for that construction. +-/ +import data.rat.order data.nat +open nat rat subtype eq.ops + +namespace pnat + +definition pnat := { n : ℕ | n > 0 } + +notation `ℕ+` := pnat + +definition pos (n : ℕ) (H : n > 0) : ℕ+ := tag n H + +definition nat_of_pnat (p : ℕ+) : ℕ := elt_of p +reserve postfix `~`:std.prec.max_plus +local postfix ~ := nat_of_pnat + +theorem pnat_pos (p : ℕ+) : p~ > 0 := has_property p + +protected definition add (p q : ℕ+) : ℕ+ := +tag (p~ + q~) (add_pos (pnat_pos p) (pnat_pos q)) + +protected definition mul (p q : ℕ+) : ℕ+ := +tag (p~ * q~) (mul_pos (pnat_pos p) (pnat_pos q)) + +protected definition le (p q : ℕ+) := p~ ≤ q~ + +protected definition lt (p q : ℕ+) := p~ < q~ + +attribute [instance] +definition pnat_has_add : has_add pnat := +has_add.mk pnat.add + +attribute [instance] +definition pnat_has_mul : has_mul pnat := +has_mul.mk pnat.mul + +attribute [instance] +definition pnat_has_le : has_le pnat := +has_le.mk pnat.le + +attribute [instance] +definition pnat_has_lt : has_lt pnat := +has_lt.mk pnat.lt + +attribute [instance] +definition pnat_has_one : has_one pnat := +has_one.mk (pos (1:nat) dec_trivial) + +protected lemma mul_def (p q : ℕ+) : p * q = tag (p~ * q~) (mul_pos (pnat_pos p) (pnat_pos q)) := +rfl + +protected lemma le_def (p q : ℕ+) : (p ≤ q) = (p~ ≤ q~) := +rfl + +protected lemma lt_def (p q : ℕ+) : (p < q) = (p~ < q~) := +rfl + +protected theorem pnat.eq {p q : ℕ+} : p~ = q~ → p = q := +subtype.eq + +attribute [instance] +definition pnat_le_decidable (p q : ℕ+) : decidable (p ≤ q) := +begin rewrite pnat.le_def, exact nat.decidable_le p~ q~ end + +attribute [instance] +definition pnat_lt_decidable {p q : ℕ+} : decidable (p < q) := +begin rewrite pnat.lt_def, exact nat.decidable_lt p~ q~ end + +protected theorem le_trans {p q r : ℕ+} : p ≤ q → q ≤ r → p ≤ r := +begin rewrite *pnat.le_def, apply nat.le_trans end + +definition max (p q : ℕ+) : ℕ+ := +tag (max p~ q~) (lt_of_lt_of_le (!pnat_pos) (!le_max_right)) + +protected theorem max_right (a b : ℕ+) : max a b ≥ b := +begin change b ≤ max a b, rewrite pnat.le_def, apply le_max_right end + +protected theorem max_left (a b : ℕ+) : max a b ≥ a := +begin change a ≤ max a b, rewrite pnat.le_def, apply le_max_left end + +protected theorem max_eq_right {a b : ℕ+} (H : a < b) : max a b = b := +begin rewrite pnat.lt_def at H, exact pnat.eq (max_eq_right_of_lt H) end + +protected theorem max_eq_left {a b : ℕ+} (H : ¬ a < b) : max a b = a := +begin rewrite pnat.lt_def at H, exact pnat.eq (max_eq_left (le_of_not_gt H)) end + +protected theorem le_of_lt {a b : ℕ+} : a < b → a ≤ b := +begin rewrite [pnat.lt_def, pnat.le_def], apply nat.le_of_lt end + +protected theorem not_lt_of_ge {a b : ℕ+} : a ≤ b → ¬ (b < a) := +begin rewrite [pnat.lt_def, pnat.le_def], apply not_lt_of_ge end + +protected theorem le_of_not_gt {a b : ℕ+} : ¬ a < b → b ≤ a := +begin rewrite [pnat.lt_def, pnat.le_def], apply le_of_not_gt end + +protected theorem eq_of_le_of_ge {a b : ℕ+} : a ≤ b → b ≤ a → a = b := +begin rewrite [+pnat.le_def], intros H1 H2, exact pnat.eq (eq_of_le_of_ge H1 H2) end + +protected theorem le_refl (a : ℕ+) : a ≤ a := +begin rewrite pnat.le_def end + +notation 2 := (tag 2 dec_trivial : ℕ+) +notation 3 := (tag 3 dec_trivial : ℕ+) +definition pone : ℕ+ := tag 1 dec_trivial + +attribute [reducible] +definition rat_of_pnat (n : ℕ+) : ℚ := +n~ + +theorem pnat.to_rat_of_nat (n : ℕ+) : rat_of_pnat n = of_nat n~ := +rfl + +-- these will come in rat + +theorem rat_of_nat_nonneg (n : ℕ) : 0 ≤ of_nat n := +trivial + +theorem rat_of_pnat_ge_one (n : ℕ+) : rat_of_pnat n ≥ 1 := +of_nat_le_of_nat_of_le (pnat_pos n) + +theorem rat_of_pnat_is_pos (n : ℕ+) : rat_of_pnat n > 0 := +of_nat_lt_of_nat_of_lt (pnat_pos n) + +theorem of_nat_le_of_nat_of_le {m n : ℕ} (H : m ≤ n) : of_nat m ≤ of_nat n := +of_nat_le_of_nat_of_le H + +theorem of_nat_lt_of_nat_of_lt {m n : ℕ} (H : m < n) : of_nat m < of_nat n := +of_nat_lt_of_nat_of_lt H + +theorem rat_of_pnat_le_of_pnat_le {m n : ℕ+} (H : m ≤ n) : rat_of_pnat m ≤ rat_of_pnat n := +begin rewrite pnat.le_def at H, exact of_nat_le_of_nat_of_le H end + +theorem rat_of_pnat_lt_of_pnat_lt {m n : ℕ+} (H : m < n) : rat_of_pnat m < rat_of_pnat n := +begin rewrite pnat.lt_def at H, exact of_nat_lt_of_nat_of_lt H end + +theorem pnat_le_of_rat_of_pnat_le {m n : ℕ+} (H : rat_of_pnat m ≤ rat_of_pnat n) : m ≤ n := +begin rewrite pnat.le_def, exact le_of_of_nat_le_of_nat H end + +definition inv (n : ℕ+) : ℚ := +(1 : ℚ) / rat_of_pnat n + +local postfix `⁻¹` := inv + +protected theorem inv_pos (n : ℕ+) : n⁻¹ > 0 := one_div_pos_of_pos !rat_of_pnat_is_pos + +theorem inv_le_one (n : ℕ+) : n⁻¹ ≤ (1 : ℚ) := +begin + unfold inv, + change 1 / rat_of_pnat n ≤ 1 / 1, + apply one_div_le_one_div_of_le, + apply zero_lt_one, + apply rat_of_pnat_ge_one +end + +theorem inv_lt_one_of_gt {n : ℕ+} (H : n~ > 1) : n⁻¹ < (1 : ℚ) := +begin + unfold inv, + change 1 / rat_of_pnat n < 1 / 1, + apply one_div_lt_one_div_of_lt, + apply zero_lt_one, + rewrite pnat.to_rat_of_nat, + apply (of_nat_lt_of_nat_of_lt H) +end + +theorem pone_inv : pone⁻¹ = 1 := rfl + +theorem add_invs_nonneg (m n : ℕ+) : 0 ≤ m⁻¹ + n⁻¹ := +begin + apply le_of_lt, + apply add_pos, + repeat apply pnat.inv_pos +end + +protected theorem one_mul (n : ℕ+) : pone * n = n := +begin + apply pnat.eq, + unfold pone, + rewrite [pnat.mul_def, ↑nat_of_pnat, one_mul] +end + +theorem pone_le (n : ℕ+) : pone ≤ n := +begin rewrite pnat.le_def, exact succ_le_of_lt (pnat_pos n) end + +theorem pnat_to_rat_mul (a b : ℕ+) : rat_of_pnat (a * b) = rat_of_pnat a * rat_of_pnat b := rfl + +theorem mul_lt_mul_left {a b c : ℕ+} (H : a < b) : a * c < b * c := +begin rewrite [pnat.lt_def at *], exact mul_lt_mul_of_pos_right H !pnat_pos end + +theorem one_lt_two : pone < 2 := +!nat.le_refl + +theorem inv_two_mul_lt_inv (n : ℕ+) : (2 * n)⁻¹ < n⁻¹ := +begin + rewrite ↑inv, + apply one_div_lt_one_div_of_lt, + apply rat_of_pnat_is_pos, + have H : n~ < (2 * n)~, begin + rewrite -pnat.one_mul at {1}, + rewrite -pnat.lt_def, + apply mul_lt_mul_left, + apply one_lt_two + end, + apply of_nat_lt_of_nat_of_lt, + apply H +end + +theorem inv_two_mul_le_inv (n : ℕ+) : (2 * n)⁻¹ ≤ n⁻¹ := rat.le_of_lt !inv_two_mul_lt_inv + +theorem inv_ge_of_le {p q : ℕ+} (H : p ≤ q) : q⁻¹ ≤ p⁻¹ := +one_div_le_one_div_of_le !rat_of_pnat_is_pos (rat_of_pnat_le_of_pnat_le H) + +theorem inv_gt_of_lt {p q : ℕ+} (H : p < q) : q⁻¹ < p⁻¹ := +one_div_lt_one_div_of_lt !rat_of_pnat_is_pos (rat_of_pnat_lt_of_pnat_lt H) + +theorem ge_of_inv_le {p q : ℕ+} (H : p⁻¹ ≤ q⁻¹) : q ≤ p := +pnat_le_of_rat_of_pnat_le (le_of_one_div_le_one_div !rat_of_pnat_is_pos H) + +theorem two_mul (p : ℕ+) : rat_of_pnat (2 * p) = (1 + 1) * rat_of_pnat p := +by rewrite pnat_to_rat_mul + +protected theorem add_halves (p : ℕ+) : (2 * p)⁻¹ + (2 * p)⁻¹ = p⁻¹ := +begin + rewrite [↑inv, -(add_halves (1 / (rat_of_pnat p))), div_div_eq_div_mul], + have H : rat_of_pnat (2 * p) = rat_of_pnat p * (1 + 1), by rewrite [rat.mul_comm, two_mul], + rewrite *H +end + +theorem add_halves_double (m n : ℕ+) : + m⁻¹ + n⁻¹ = ((2 * m)⁻¹ + (2 * n)⁻¹) + ((2 * m)⁻¹ + (2 * n)⁻¹) := +have hsimp : ∀ a b : ℚ, (a + a) + (b + b) = (a + b) + (a + b), + by intros; rewrite [rat.add_assoc, -(rat.add_assoc a b b), {_+b}rat.add_comm, -*rat.add_assoc], +by rewrite [-pnat.add_halves m, -pnat.add_halves n, hsimp] + +protected theorem inv_mul_eq_mul_inv {p q : ℕ+} : (p * q)⁻¹ = p⁻¹ * q⁻¹ := +begin rewrite [↑inv, pnat_to_rat_mul, one_div_mul_one_div] end + +protected theorem inv_mul_le_inv (p q : ℕ+) : (p * q)⁻¹ ≤ q⁻¹ := +begin + rewrite [pnat.inv_mul_eq_mul_inv, -{q⁻¹}rat.one_mul at {2}], + apply mul_le_mul, + apply inv_le_one, + apply le.refl, + apply le_of_lt, + apply pnat.inv_pos, + apply rat.le_of_lt rat.zero_lt_one +end + +theorem pnat_mul_le_mul_left' (a b c : ℕ+) : a ≤ b → c * a ≤ c * b := +begin + rewrite +pnat.le_def, intro H, + apply mul_le_mul_of_nonneg_left H, + apply le_of_lt, + apply pnat_pos +end + +protected theorem mul_assoc (a b c : ℕ+) : a * b * c = a * (b * c) := +pnat.eq !mul.assoc + +protected theorem mul_comm (a b : ℕ+) : a * b = b * a := +pnat.eq !mul.comm + +protected theorem add_assoc (a b c : ℕ+) : a + b + c = a + (b + c) := +pnat.eq !add.assoc + +protected theorem mul_le_mul_left (p q : ℕ+) : q ≤ p * q := +begin + rewrite [-pnat.one_mul at {1}, pnat.mul_comm, pnat.mul_comm p], + apply pnat_mul_le_mul_left', + apply pone_le +end + +protected theorem mul_le_mul_right (p q : ℕ+) : p ≤ p * q := +by rewrite pnat.mul_comm; apply pnat.mul_le_mul_left + +theorem pnat.lt_of_not_le {p q : ℕ+} : ¬ p ≤ q → q < p := +begin rewrite [pnat.le_def, pnat.lt_def], apply lt_of_not_ge end + +protected theorem inv_cancel_left (p : ℕ+) : rat_of_pnat p * p⁻¹ = (1 : ℚ) := +mul_one_div_cancel (ne.symm (ne_of_lt !rat_of_pnat_is_pos)) + +protected theorem inv_cancel_right (p : ℕ+) : p⁻¹ * rat_of_pnat p = (1 : ℚ) := +by rewrite rat.mul_comm; apply pnat.inv_cancel_left + +theorem lt_add_left (p q : ℕ+) : p < p + q := +begin + have H : p~ < p~ + q~, begin + rewrite -nat.add_zero at {1}, + apply nat.add_lt_add_left, + apply pnat_pos + end, + apply H +end + +theorem inv_add_lt_left (p q : ℕ+) : (p + q)⁻¹ < p⁻¹ := +by apply inv_gt_of_lt; apply lt_add_left + +theorem div_le_pnat (q : ℚ) (n : ℕ+) (H : q ≥ n⁻¹) : 1 / q ≤ rat_of_pnat n := +begin + apply div_le_of_le_mul, + apply lt_of_lt_of_le, + apply pnat.inv_pos, + rotate 1, + apply H, + apply le_mul_of_div_le, + apply rat_of_pnat_is_pos, + apply H +end + +theorem pnat_cancel' (n m : ℕ+) : (n * n * m)⁻¹ * (rat_of_pnat n * rat_of_pnat n) = m⁻¹ := +have hsimp : ∀ a b c : ℚ, (a * a * (b * b * c)) = (a * b) * (a * b) * c, + begin + intro a b c, + rewrite[-*rat.mul_assoc], + exact (!mul.right_comm ▸ rfl), + end, +by rewrite [rat.mul_comm, *pnat.inv_mul_eq_mul_inv, hsimp, *pnat.inv_cancel_left, *rat.one_mul] + +definition pceil (a : ℚ) : ℕ+ := tag (ubound a) !ubound_pos + +theorem pceil_helper {a : ℚ} {n : ℕ+} (H : pceil a ≤ n) (Ha : a > 0) : n⁻¹ ≤ 1 / a := +le.trans (inv_ge_of_le H) (one_div_le_one_div_of_le Ha (ubound_ge a)) + +theorem inv_pceil_div (a b : ℚ) (Ha : a > 0) (Hb : b > 0) : (pceil (a / b))⁻¹ ≤ b / a := +have (pceil (a / b))⁻¹ ≤ 1 / (1 / (b / a)), + begin + apply one_div_le_one_div_of_le, + show 0 < 1 / (b / a), from + one_div_pos_of_pos (div_pos_of_pos_of_pos Hb Ha), + show 1 / (b / a) ≤ rat_of_pnat (pceil (a / b)), + begin + rewrite div_div_eq_mul_div, + rewrite one_mul, + apply ubound_ge + end + end, +begin + rewrite one_div_one_div at this, + exact this +end + +theorem sep_by_inv {a b : ℚ} : a > b → ∃ N : ℕ+, a > (b + N⁻¹ + N⁻¹) := +begin + change b < a → ∃ N : ℕ+, (b + N⁻¹ + N⁻¹) < a, + intro H, + apply exists.elim (exists_add_lt_and_pos_of_lt H), + intro c Hc, + existsi (pceil ((1 + 1 + 1) / c)), + apply lt.trans, + rotate 1, + apply and.left Hc, + rewrite rat.add_assoc, + apply rat.add_lt_add_left, + rewrite -(add_halves c) at {3}, + apply add_lt_add, + repeat (apply lt_of_le_of_lt; + apply inv_pceil_div; + apply dec_trivial; + apply and.right Hc; + apply div_lt_div_of_pos_of_lt_of_pos; + apply two_pos; + exact dec_trivial; + apply and.right Hc) +end + +theorem nonneg_of_ge_neg_invs (a : ℚ) : (∀ n : ℕ+, -n⁻¹ ≤ a) → 0 ≤ a := +begin + intro H, + apply le_of_not_gt, + suppose a < 0, + have H2 : 0 < -a, from neg_pos_of_neg this, + (not_lt_of_ge !H) (iff.mp !lt_neg_iff_lt_neg (calc + (pceil (of_num 2 / -a))⁻¹ ≤ -a / of_num 2 + : !inv_pceil_div dec_trivial H2 + ... < -a / 1 + : div_lt_div_of_pos_of_lt_of_pos dec_trivial dec_trivial H2 + ... = -a : !div_one)) +end + +theorem pnat_bound {ε : ℚ} (Hε : ε > 0) : ∃ p : ℕ+, p⁻¹ ≤ ε := +begin + existsi (pceil (1 / ε)), + rewrite -(one_div_one_div ε) at {2}, + apply pceil_helper, + apply pnat.le_refl, + apply one_div_pos_of_pos Hε +end + +theorem p_add_fractions (n : ℕ+) : (2 * n)⁻¹ + (2 * 3 * n)⁻¹ + (3 * n)⁻¹ = n⁻¹ := +have T : 2⁻¹ + 2⁻¹ * 3⁻¹ + 3⁻¹ = 1, from dec_trivial, +by rewrite[*pnat.inv_mul_eq_mul_inv,-*right_distrib,T,rat.one_mul] + +theorem rat_power_two_le (k : ℕ+) : rat_of_pnat k ≤ 2^k~ := +!binary_nat_bound + +end pnat diff --git a/old_library/data/prod.lean b/old_library/data/prod.lean new file mode 100644 index 0000000000..f30944a812 --- /dev/null +++ b/old_library/data/prod.lean @@ -0,0 +1,28 @@ +/- +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 +-/ +import logic.eq +open inhabited decidable + +namespace prod + variables {A B : Type} {a₁ a₂ : A} {b₁ b₂ : B} {u : A × B} + + theorem pair_eq : a₁ = a₂ → b₁ = b₂ → (a₁, b₁) = (a₂, b₂) := + assume H1 H2, H1 ▸ H2 ▸ rfl + + protected theorem eq {p₁ p₂ : prod A B} : pr₁ p₁ = pr₁ p₂ → pr₂ p₁ = pr₂ p₂ → p₁ = p₂ := + destruct p₁ (take a₁ b₁, destruct p₂ (take a₂ b₂ H₁ H₂, pair_eq H₁ H₂)) + + definition swap {A : Type} : A × A → A × A + | (a, b) := (b, a) + + theorem swap_swap {A : Type} : ∀ p : A × A, swap (swap p) = p + | (a, b) := rfl + + theorem eq_of_swap_eq {A : Type} : ∀ p₁ p₂ : A × A, swap p₁ = swap p₂ → p₁ = p₂ := + take p₁ p₂, assume seqs, + have swap (swap p₁) = swap (swap p₂), from congr_arg swap seqs, + sorry -- by rewrite *swap_swap at this; exact this +end prod diff --git a/old_library/data/rat/basic.lean b/old_library/data/rat/basic.lean new file mode 100644 index 0000000000..517de29ba6 --- /dev/null +++ b/old_library/data/rat/basic.lean @@ -0,0 +1,628 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +The rational numbers as a field generated by the integers, defined as the usual quotient. +-/ +import data.int algebra.field +open int quot eq.ops + +record prerat : Type := +(num : ℤ) (denom : ℤ) (denom_pos : denom > 0) + +/- + prerat: the representations of the rationals as integers num, denom, with denom > 0. + note: names are not protected, because it is not expected that users will open prerat. +-/ + +namespace prerat + +/- the equivalence relation -/ + +definition equiv (a b : prerat) : Prop := num a * denom b = num b * denom a + +infix ≡ := equiv + +attribute [refl] +theorem equiv.refl (a : prerat) : a ≡ a := rfl + +attribute [symm] +theorem equiv.symm {a b : prerat} (H : a ≡ b) : b ≡ a := !eq.symm H + +theorem num_eq_zero_of_equiv {a b : prerat} (H : a ≡ b) (na_zero : num a = 0) : num b = 0 := +have num a * denom b = 0, from !zero_mul ▸ na_zero ▸ rfl, +have num b * denom a = 0, from H ▸ this, +show num b = 0, from or_resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero this) (ne_of_gt (denom_pos a)) + +theorem num_pos_of_equiv {a b : prerat} (H : a ≡ b) (na_pos : num a > 0) : num b > 0 := +have num a * denom b > 0, from mul_pos na_pos (denom_pos b), +have num b * denom a > 0, from H ▸ this, +show num b > 0, from pos_of_mul_pos_right this (le_of_lt (denom_pos a)) + +theorem num_neg_of_equiv {a b : prerat} (H : a ≡ b) (na_neg : num a < 0) : num b < 0 := +have H₁ : num a * denom b = num b * denom a, from H, +have num a * denom b < 0, from mul_neg_of_neg_of_pos na_neg (denom_pos b), +have -(-num b * denom a) < 0, begin rewrite [neg_mul_eq_neg_mul, neg_neg, -H₁], exact this end, +have -num b > 0, from pos_of_mul_pos_right (pos_of_neg_neg this) (le_of_lt (denom_pos a)), +neg_of_neg_pos this + +theorem equiv_of_num_eq_zero {a b : prerat} (H1 : num a = 0) (H2 : num b = 0) : a ≡ b := +by rewrite [↑equiv, H1, H2, *zero_mul] + +attribute [trans] +theorem equiv.trans {a b c : prerat} (H1 : a ≡ b) (H2 : b ≡ c) : a ≡ c := +decidable.by_cases + (suppose num b = 0, + have num a = 0, from num_eq_zero_of_equiv (equiv.symm H1) `num b = 0`, + have num c = 0, from num_eq_zero_of_equiv H2 `num b = 0`, + equiv_of_num_eq_zero `num a = 0` `num c = 0`) + (suppose num b ≠ 0, + have H3 : num b * denom b ≠ 0, from mul_ne_zero this (ne_of_gt (denom_pos b)), + have H4 : (num b * denom b) * (num a * denom c) = (num b * denom b) * (num c * denom a), + from calc + (num b * denom b) * (num a * denom c) = (num a * denom b) * (num b * denom c) : + by rewrite [*mul.assoc, *mul.left_comm (num a), *mul.left_comm (num b)] + ... = (num b * denom a) * (num b * denom c) : {H1} + ... = (num b * denom a) * (num c * denom b) : {H2} + ... = (num b * denom b) * (num c * denom a) : + by rewrite [*mul.assoc, *mul.left_comm (denom a), + *mul.left_comm (denom b), mul.comm (denom a)], + eq_of_mul_eq_mul_left H3 H4) + +theorem equiv.is_equivalence : equivalence equiv := + mk_equivalence equiv equiv.refl @equiv.symm @equiv.trans + +definition setoid : setoid prerat := +setoid.mk equiv equiv.is_equivalence + +/- field operations -/ + +definition of_int (i : int) : prerat := prerat.mk i 1 !of_nat_succ_pos + +definition zero : prerat := of_int 0 + +definition one : prerat := of_int 1 + +private theorem mul_denom_pos (a b : prerat) : denom a * denom b > 0 := +mul_pos (denom_pos a) (denom_pos b) + +definition add (a b : prerat) : prerat := +prerat.mk (num a * denom b + num b * denom a) (denom a * denom b) (mul_denom_pos a b) + +definition mul (a b : prerat) : prerat := +prerat.mk (num a * num b) (denom a * denom b) (mul_denom_pos a b) + +definition neg (a : prerat) : prerat := +prerat.mk (- num a) (denom a) (denom_pos a) + +definition smul (a : ℤ) (b : prerat) (H : a > 0) : prerat := +prerat.mk (a * num b) (a * denom b) (mul_pos H (denom_pos b)) + +theorem of_int_add (a b : ℤ) : of_int (a + b) ≡ add (of_int a) (of_int b) := +by esimp [equiv, num, denom, one, add, of_int]; rewrite [*int.mul_one] + +theorem of_int_mul (a b : ℤ) : of_int (a * b) ≡ mul (of_int a) (of_int b) := +!equiv.refl + +theorem of_int_neg (a : ℤ) : of_int (-a) ≡ neg (of_int a) := +!equiv.refl + +theorem of_int.inj {a b : ℤ} : of_int a ≡ of_int b → a = b := +by rewrite [↑of_int, ↑equiv, *mul_one]; intros; assumption + +definition inv : prerat → prerat +| inv (prerat.mk nat.zero d dp) := zero +| inv (prerat.mk (nat.succ n) d dp) := prerat.mk d (nat.succ n) !of_nat_succ_pos +| inv (prerat.mk -[1+n] d dp) := prerat.mk (-d) (nat.succ n) !of_nat_succ_pos + +theorem equiv_zero_of_num_eq_zero {a : prerat} (H : num a = 0) : a ≡ zero := +by rewrite [↑equiv, H, ↑zero, ↑num, ↑of_int, *zero_mul] + +theorem num_eq_zero_of_equiv_zero {a : prerat} : a ≡ zero → num a = 0 := +by rewrite [↑equiv, ↑zero, ↑of_int, mul_one, zero_mul]; intro H; exact H + +theorem inv_zero {d : int} (dp : d > 0) : inv (mk nat.zero d dp) = zero := +begin rewrite [↑inv, ▸*] end + +theorem inv_zero' : inv zero = zero := inv_zero (of_nat_succ_pos nat.zero) + +open nat + +theorem inv_of_pos {n d : int} (np : n > 0) (dp : d > 0) : inv (mk n d dp) ≡ mk d n np := +obtain (n' : nat) (Hn' : n = of_nat n'), from exists_eq_of_nat (le_of_lt np), +have (n' > nat.zero), from lt_of_of_nat_lt_of_nat (Hn' ▸ np), +obtain (k : nat) (Hk : n' = nat.succ k), from nat.exists_eq_succ_of_lt this, +have d * n = d * nat.succ k, by rewrite [Hn', Hk], +Hn'⁻¹ ▸ (Hk⁻¹ ▸ this) + +theorem inv_neg {n d : int} (np : n > 0) (dp : d > 0) : inv (mk (-n) d dp) ≡ mk (-d) n np := +obtain (n' : nat) (Hn' : n = of_nat n'), from exists_eq_of_nat (le_of_lt np), +have (n' > nat.zero), from lt_of_of_nat_lt_of_nat (Hn' ▸ np), +obtain (k : nat) (Hk : n' = nat.succ k), from nat.exists_eq_succ_of_lt this, +have -d * n = -d * nat.succ k, by rewrite [Hn', Hk], +have H3 : inv (mk -[1+k] d dp) ≡ mk (-d) n np, from this, +have H4 : -[1+k] = -n, from calc + -[1+k] = -(nat.succ k) : rfl + ... = -n : by rewrite [Hk⁻¹, Hn'], +H4 ▸ H3 + +theorem inv_of_neg {n d : int} (nn : n < 0) (dp : d > 0) : + inv (mk n d dp) ≡ mk (-d) (-n) (neg_pos_of_neg nn) := +have inv (mk (-(-n)) d dp) ≡ mk (-d) (-n) (neg_pos_of_neg nn), + from inv_neg (neg_pos_of_neg nn) dp, +!neg_neg ▸ this + +/- operations respect equiv -/ + +theorem add_equiv_add {a1 b1 a2 b2 : prerat} (eqv1 : a1 ≡ a2) (eqv2 : b1 ≡ b2) : + add a1 b1 ≡ add a2 b2 := +calc + (num a1 * denom b1 + num b1 * denom a1) * (denom a2 * denom b2) + = num a1 * denom a2 * denom b1 * denom b2 + num b1 * denom b2 * denom a1 * denom a2 : + by rewrite [right_distrib, *mul.assoc, mul.left_comm (denom b1), + mul.comm (denom b2), *mul.assoc] + ... = num a2 * denom a1 * denom b1 * denom b2 + num b2 * denom b1 * denom a1 * denom a2 : + by rewrite [↑equiv at *, eqv1, eqv2] + ... = (num a2 * denom b2 + num b2 * denom a2) * (denom a1 * denom b1) : + by rewrite [right_distrib, *mul.assoc, *mul.left_comm (denom b2), + *mul.comm (denom b1), *mul.assoc, mul.left_comm (denom a2)] + +theorem mul_equiv_mul {a1 b1 a2 b2 : prerat} (eqv1 : a1 ≡ a2) (eqv2 : b1 ≡ b2) : + mul a1 b1 ≡ mul a2 b2 := +calc + (num a1 * num b1) * (denom a2 * denom b2) + = (num a1 * denom a2) * (num b1 * denom b2) : by rewrite [*mul.assoc, mul.left_comm (num b1)] + ... = (num a2 * denom a1) * (num b2 * denom b1) : by rewrite [↑equiv at *, eqv1, eqv2] + ... = (num a2 * num b2) * (denom a1 * denom b1) : by rewrite [*mul.assoc, mul.left_comm (num b2)] + +theorem neg_equiv_neg {a b : prerat} (eqv : a ≡ b) : neg a ≡ neg b := +calc + -num a * denom b = -(num a * denom b) : neg_mul_eq_neg_mul + ... = -(num b * denom a) : {eqv} + ... = -num b * denom a : neg_mul_eq_neg_mul + +theorem inv_equiv_inv : ∀{a b : prerat}, a ≡ b → inv a ≡ inv b +| (mk an ad adp) (mk bn bd bdp) := + assume H, + lt.by_cases + (assume an_neg : an < 0, + have bn_neg : bn < 0, from num_neg_of_equiv H an_neg, + calc + inv (mk an ad adp) ≡ mk (-ad) (-an) (neg_pos_of_neg an_neg) : inv_of_neg an_neg adp + ... ≡ mk (-bd) (-bn) (neg_pos_of_neg bn_neg) : + by rewrite [↑equiv at *, ▸*, *neg_mul_neg, mul.comm ad, mul.comm bd, H] + ... ≡ inv (mk bn bd bdp) : (inv_of_neg bn_neg bdp)⁻¹) + (assume an_zero : an = 0, + have bn_zero : bn = 0, from num_eq_zero_of_equiv H an_zero, + eq.subst (calc + inv (mk an ad adp) = inv (mk 0 ad adp) : {an_zero} + ... = zero : inv_zero adp + ... = inv (mk 0 bd bdp) : inv_zero bdp + ... = inv (mk bn bd bdp) : bn_zero) !equiv.refl) + (assume an_pos : an > 0, + have bn_pos : bn > 0, from num_pos_of_equiv H an_pos, + calc + inv (mk an ad adp) ≡ mk ad an an_pos : inv_of_pos an_pos adp + ... ≡ mk bd bn bn_pos : + by rewrite [↑equiv at *, ▸*, mul.comm ad, mul.comm bd, H] + ... ≡ inv (mk bn bd bdp) : (inv_of_pos bn_pos bdp)⁻¹) + +theorem smul_equiv {a : ℤ} {b : prerat} (H : a > 0) : smul a b H ≡ b := +by esimp[equiv, smul]; rewrite[mul.assoc, mul.left_comm] + +/- properties -/ + +protected theorem add.comm (a b : prerat) : add a b ≡ add b a := +by rewrite [↑add, ↑equiv, ▸*, add.comm, mul.comm (denom a)] + +protected theorem add.assoc (a b c : prerat) : add (add a b) c ≡ add a (add b c) := +by rewrite [↑add, ↑equiv, ▸*, *(mul.comm (num c)), *(λy, mul.comm y (denom a)), *left_distrib, + *right_distrib, *mul.assoc, *add.assoc] + +protected theorem add_zero (a : prerat) : add a zero ≡ a := +by rewrite [↑add, ↑equiv, ↑zero, ↑of_int, ▸*, *mul_one, zero_mul, add_zero] + +protected theorem add_left_inv (a : prerat) : add (neg a) a ≡ zero := +by rewrite [↑add, ↑equiv, ↑neg, ↑zero, ↑of_int, ▸*, -neg_mul_eq_neg_mul, add.left_inv, *zero_mul] + +protected theorem mul_comm (a b : prerat) : mul a b ≡ mul b a := +by rewrite [↑mul, ↑equiv, mul.comm (num a), mul.comm (denom a)] + +protected theorem mul_assoc (a b c : prerat) : mul (mul a b) c ≡ mul a (mul b c) := +by rewrite [↑mul, ↑equiv, *mul.assoc] + +protected theorem mul_one (a : prerat) : mul a one ≡ a := +by rewrite [↑mul, ↑one, ↑of_int, ↑equiv, ▸*, *mul_one] + +protected theorem mul_left_distrib (a b c : prerat) : mul a (add b c) ≡ add (mul a b) (mul a c) := +have H : smul (denom a) (mul a (add b c)) (denom_pos a) = + add (mul a b) (mul a c), from begin + rewrite[↑smul, ↑mul, ↑add], + congruence, + rewrite[*left_distrib, *right_distrib, -+(int.mul_assoc)], + have T : ∀ {x y z w : ℤ}, x*y*z*w=y*z*x*w, from + λx y z w, (!int.mul_assoc ⬝ !int.mul_comm) ▸ rfl, + exact !congr_arg2 T T, + rewrite [mul.left_comm (denom a) (denom b) (denom c)], + rewrite int.mul_assoc +end, +equiv.symm (H ▸ smul_equiv (denom_pos a)) + +theorem mul_inv_cancel : ∀{a : prerat}, ¬ a ≡ zero → mul a (inv a) ≡ one +| (mk an ad adp) := + assume H, + let a := mk an ad adp in + lt.by_cases + (assume an_neg : an < 0, + let ia := mk (-ad) (-an) (neg_pos_of_neg an_neg) in + calc + mul a (inv a) ≡ mul a ia : mul_equiv_mul !equiv.refl (inv_of_neg an_neg adp) + ... ≡ one : begin + esimp [equiv, num, denom, one, mul, of_int], + rewrite [*int.mul_one, *int.one_mul, mul.comm, + neg_mul_comm] + end) + (assume an_zero : an = 0, absurd (equiv_zero_of_num_eq_zero an_zero) H) + (assume an_pos : an > 0, + let ia := mk ad an an_pos in + calc + mul a (inv a) ≡ mul a ia : mul_equiv_mul !equiv.refl (inv_of_pos an_pos adp) + ... ≡ one : begin + esimp [equiv, num, denom, one, mul, of_int], + rewrite [*int.mul_one, *int.one_mul, mul.comm] + end) + +theorem zero_not_equiv_one : ¬ zero ≡ one := +begin + esimp [equiv, zero, one, of_int], + rewrite [zero_mul, int.mul_one], + exact zero_ne_one +end + +theorem mul_denom_equiv (a : prerat) : mul a (of_int (denom a)) ≡ of_int (num a) := +by esimp [mul, of_int, equiv]; rewrite [*int.mul_one] + +/- Reducing a fraction to lowest terms. Needed to choose a canonical representative of rat, and + define numerator and denominator. -/ + +definition reduce : prerat → prerat +| (mk an ad adpos) := + have pos : ad / gcd an ad > 0, from div_pos_of_pos_of_dvd adpos !gcd_nonneg !gcd_dvd_right, + if an = 0 then prerat.zero + else mk (an / gcd an ad) (ad / gcd an ad) pos + +protected theorem eq {a b : prerat} (Hn : num a = num b) (Hd : denom a = denom b) : a = b := +begin + cases a with [an, ad, adpos], + cases b with [bn, bd, bdpos], + generalize adpos, generalize bdpos, + esimp at *, + rewrite [Hn, Hd], + intros, apply rfl +end + +theorem reduce_equiv : ∀ a : prerat, reduce a ≡ a +| (mk an ad adpos) := + decidable.by_cases + (assume anz : an = 0, + begin rewrite [↑reduce, if_pos anz, ↑equiv, anz], krewrite zero_mul end) + (assume annz : an ≠ 0, + by rewrite [↑reduce, if_neg annz, ↑equiv, mul.comm, -!int.mul_div_assoc + !gcd_dvd_left, -!int.mul_div_assoc !gcd_dvd_right, mul.comm]) + +theorem reduce_eq_reduce : ∀ {a b : prerat}, a ≡ b → reduce a = reduce b +| (mk an ad adpos) (mk bn bd bdpos) := + assume H : an * bd = bn * ad, + decidable.by_cases + (assume anz : an = 0, + have H' : bn * ad = 0, by rewrite [-H, anz, zero_mul], + have bnz : bn = 0, + from or_resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero H') (ne_of_gt adpos), + by rewrite [↑reduce, if_pos anz, if_pos bnz]) + (assume annz : an ≠ 0, + have bnnz : bn ≠ 0, from + assume bnz, + have H' : an * bd = 0, by rewrite [H, bnz, zero_mul], + have anz : an = 0, + from or_resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero H') (ne_of_gt bdpos), + show false, from annz anz, + begin + rewrite [↑reduce, if_neg annz, if_neg bnnz], + apply prerat.eq, + {apply div_gcd_eq_div_gcd H adpos bdpos}, + {esimp, rewrite [gcd.comm, gcd.comm bn], + apply div_gcd_eq_div_gcd_of_nonneg, + rewrite [mul.comm, -H, mul.comm], + apply annz, + apply bnnz, + apply le_of_lt adpos, + apply le_of_lt bdpos}, + end) + +end prerat + +/- + the rationals +-/ + +definition rat : Type.{1} := quot prerat.setoid +notation `ℚ` := rat + +local attribute prerat.setoid [instance] + +namespace rat + +/- operations -/ + +-- definition of_int [coercion] (i : ℤ) : ℚ := ⟦prerat.of_int i⟧ +-- definition of_nat [coercion] (n : ℕ) : ℚ := n +-- definition of_num [coercion] [reducible] (n : num) : ℚ := n + +protected definition prio := num.pred int.prio + +attribute [instance, priority rat.prio] +definition rat_has_zero : has_zero rat := +has_zero.mk (of_int 0) + +attribute [instance, priority rat.prio] +definition rat_has_one : has_one rat := +has_one.mk (of_int 1) + +theorem of_int_zero : of_int (0:int) = (0:rat) := +rfl + +theorem of_int_one : of_int (1:int) = (1:rat) := +rfl + +protected definition add : ℚ → ℚ → ℚ := +quot.lift₂ + (λ a b : prerat, ⟦prerat.add a b⟧) + (take a1 a2 b1 b2, assume H1 H2, quot.sound (prerat.add_equiv_add H1 H2)) + +protected definition mul : ℚ → ℚ → ℚ := +quot.lift₂ + (λ a b : prerat, ⟦prerat.mul a b⟧) + (take a1 a2 b1 b2, assume H1 H2, quot.sound (prerat.mul_equiv_mul H1 H2)) + +protected definition neg : ℚ → ℚ := +quot.lift + (λ a : prerat, ⟦prerat.neg a⟧) + (take a1 a2, assume H, quot.sound (prerat.neg_equiv_neg H)) + +protected definition inv : ℚ → ℚ := +quot.lift + (λ a : prerat, ⟦prerat.inv a⟧) + (take a1 a2, assume H, quot.sound (prerat.inv_equiv_inv H)) + +definition reduce : ℚ → prerat := +quot.lift + (λ a : prerat, prerat.reduce a) + @prerat.reduce_eq_reduce + +definition num (a : ℚ) : ℤ := prerat.num (reduce a) +definition denom (a : ℚ) : ℤ := prerat.denom (reduce a) + +theorem denom_pos (a : ℚ): denom a > 0 := +prerat.denom_pos (reduce a) + +attribute [instance, priority rat.prio] +definition rat_has_add : has_add rat := +has_add.mk rat.add + +attribute [instance, priority rat.prio] +definition rat_has_mul : has_mul rat := +has_mul.mk rat.mul + +attribute [instance, priority rat.prio] +definition rat_has_neg : has_neg rat := +has_neg.mk rat.neg + +attribute [instance, priority rat.prio] +definition rat_has_inv : has_inv rat := +has_inv.mk rat.inv + +attribute [reducible] +protected definition sub (a b : ℚ) : rat := a + (-b) + +attribute [instance, priority rat.prio] +definition rat_has_sub : has_sub rat := +has_sub.mk rat.sub + +lemma sub.def (a b : ℚ) : a - b = a + (-b) := +rfl + +/- properties -/ + +theorem of_int_add (a b : ℤ) : of_int (a + b) = of_int a + of_int b := +quot.sound (prerat.of_int_add a b) + +theorem of_int_mul (a b : ℤ) : of_int (a * b) = of_int a * of_int b := +quot.sound (prerat.of_int_mul a b) + +theorem of_int_neg (a : ℤ) : of_int (-a) = -(of_int a) := +quot.sound (prerat.of_int_neg a) + +theorem of_int_sub (a b : ℤ) : of_int (a - b) = of_int a - of_int b := +calc + of_int (a - b) = of_int a + of_int (-b) : of_int_add + ... = of_int a - of_int b : {of_int_neg b} + +theorem of_int.inj {a b : ℤ} (H : of_int a = of_int b) : a = b := +prerat.of_int.inj (quot.exact H) + +theorem eq_of_of_int_eq_of_int {a b : ℤ} (H : of_int a = of_int b) : a = b := +of_int.inj H + +theorem of_int_eq_of_int_iff (a b : ℤ) : of_int a = of_int b ↔ a = b := +iff.intro eq_of_of_int_eq_of_int !congr_arg + +theorem of_nat_eq (a : ℕ) : of_nat a = of_int (int.of_nat a) := +rfl + +open nat + +theorem of_nat_add (a b : ℕ) : of_nat (a + b) = of_nat a + of_nat b := +by rewrite [of_nat_eq, int.of_nat_add, rat.of_int_add] + +theorem of_nat_mul (a b : ℕ) : of_nat (a * b) = of_nat a * of_nat b := +by rewrite [of_nat_eq, int.of_nat_mul, rat.of_int_mul] + +theorem of_nat_sub {a b : ℕ} (H : a ≥ b) : of_nat (a - b) = of_nat a - of_nat b := +begin + rewrite of_nat_eq, + rewrite [int.of_nat_sub H], + rewrite [rat.of_int_sub] +end + +theorem of_nat.inj {a b : ℕ} (H : of_nat a = of_nat b) : a = b := +int.of_nat.inj (of_int.inj H) + +theorem eq_of_of_nat_eq_of_nat {a b : ℕ} (H : of_nat a = of_nat b) : a = b := +of_nat.inj H + +theorem of_nat_eq_of_nat_iff (a b : ℕ) : of_nat a = of_nat b ↔ a = b := +iff.intro of_nat.inj !congr_arg + +protected theorem add_comm (a b : ℚ) : a + b = b + a := +quot.induction_on₂ a b (take u v, quot.sound !prerat.add.comm) + +protected theorem add_assoc (a b c : ℚ) : a + b + c = a + (b + c) := +quot.induction_on₃ a b c (take u v w, quot.sound !prerat.add.assoc) + +protected theorem add_zero (a : ℚ) : a + 0 = a := +quot.induction_on a (take u, quot.sound !prerat.add_zero) + +protected theorem zero_add (a : ℚ) : 0 + a = a := !rat.add_comm ▸ !rat.add_zero + +protected theorem add_left_inv (a : ℚ) : -a + a = 0 := +quot.induction_on a (take u, quot.sound !prerat.add_left_inv) + +protected theorem mul_comm (a b : ℚ) : a * b = b * a := +quot.induction_on₂ a b (take u v, quot.sound !prerat.mul_comm) + +protected theorem mul_assoc (a b c : ℚ) : a * b * c = a * (b * c) := +quot.induction_on₃ a b c (take u v w, quot.sound !prerat.mul_assoc) + +protected theorem mul_one (a : ℚ) : a * 1 = a := +quot.induction_on a (take u, quot.sound !prerat.mul_one) + +protected theorem one_mul (a : ℚ) : 1 * a = a := !rat.mul_comm ▸ !rat.mul_one + +protected theorem left_distrib (a b c : ℚ) : a * (b + c) = a * b + a * c := +quot.induction_on₃ a b c (take u v w, quot.sound !prerat.mul_left_distrib) + +protected theorem right_distrib (a b c : ℚ) : (a + b) * c = a * c + b * c := +by rewrite [rat.mul_comm, rat.left_distrib, *rat.mul_comm c] + +protected theorem mul_inv_cancel {a : ℚ} : a ≠ 0 → a * a⁻¹ = 1 := +quot.induction_on a + (take u, + assume H, + quot.sound (!prerat.mul_inv_cancel (assume H1, H (quot.sound H1)))) + +protected theorem inv_mul_cancel {a : ℚ} (H : a ≠ 0) : a⁻¹ * a = 1 := +!rat.mul_comm ▸ rat.mul_inv_cancel H + +protected theorem zero_ne_one : (0 : ℚ) ≠ 1 := +assume H, prerat.zero_not_equiv_one (quot.exact H) + +attribute [instance] +definition has_decidable_eq : decidable_eq ℚ := +take a b, quot.rec_on_subsingleton₂ a b + (take u v, + if H : prerat.num u * prerat.denom v = prerat.num v * prerat.denom u + then decidable.inl (quot.sound H) + else decidable.inr (assume H1, H (quot.exact H1))) + +protected theorem inv_zero : inv 0 = (0 : ℚ) := +quot.sound (prerat.inv_zero' ▸ !prerat.equiv.refl) + +theorem quot_reduce (a : ℚ) : ⟦reduce a⟧ = a := +quot.induction_on a (take u, quot.sound !prerat.reduce_equiv) + +section +local attribute rat [reducible] +theorem mul_denom (a : ℚ) : a * denom a = num a := +have H : ⟦reduce a⟧ * of_int (denom a) = of_int (num a), from quot.sound (!prerat.mul_denom_equiv), +quot_reduce a ▸ H +end + +theorem coprime_num_denom (a : ℚ) : coprime (num a) (denom a) := +decidable.by_cases + (suppose a = 0, by substvars) + (quot.induction_on a + (take u H, + have H' : prerat.num u ≠ 0, from take H'', H (quot.sound (prerat.equiv_zero_of_num_eq_zero H'')), + begin + cases u with un ud udpos, + rewrite [▸*, ↑num, ↑denom, ↑reduce, ↑prerat.reduce, if_neg H', ▸*], + have gcd un ud ≠ 0, from ne_of_gt (!gcd_pos_of_ne_zero_left H'), + apply coprime_div_gcd_div_gcd this + end)) + + +attribute [trans_instance] +protected definition discrete_field : discrete_field rat := +⦃discrete_field, + add := rat.add, + add_assoc := rat.add_assoc, + zero := 0, + zero_add := rat.zero_add, + add_zero := rat.add_zero, + neg := rat.neg, + add_left_inv := rat.add_left_inv, + add_comm := rat.add_comm, + mul := rat.mul, + mul_assoc := rat.mul_assoc, + one := 1, + one_mul := rat.one_mul, + mul_one := rat.mul_one, + left_distrib := rat.left_distrib, + right_distrib := rat.right_distrib, + mul_comm := rat.mul_comm, + mul_inv_cancel := @rat.mul_inv_cancel, + inv_mul_cancel := @rat.inv_mul_cancel, + zero_ne_one := rat.zero_ne_one, + inv_zero := rat.inv_zero, + has_decidable_eq := has_decidable_eq⦄ + +attribute [instance, priority rat.prio] +definition rat_has_div : has_div rat := +has_div.mk has_div.div + +attribute [instance, priority rat.prio] +definition rat_has_pow_nat : has_pow_nat rat := +has_pow_nat.mk has_pow_nat.pow_nat + +theorem eq_num_div_denom (a : ℚ) : a = num a / denom a := +have H : of_int (denom a) ≠ 0, from assume H', ne_of_gt (denom_pos a) (of_int.inj H'), +iff.mpr (!eq_div_iff_mul_eq H) (mul_denom a) + +theorem of_int_div {a b : ℤ} (H : b ∣ a) : of_int (a / b) = of_int a / of_int b := +decidable.by_cases + (assume bz : b = 0, + by rewrite [bz, int.div_zero, of_int_zero, div_zero]) + (assume bnz : b ≠ 0, + have bnz' : of_int b ≠ 0, from assume oibz, bnz (of_int.inj oibz), + have H' : of_int (a / b) * of_int b = of_int a, from + dvd.elim H + (take c, assume Hc : a = b * c, + by rewrite [Hc, !int.mul_div_cancel_left bnz, mul.comm]), + iff.mpr (!eq_div_iff_mul_eq bnz') H') + +theorem of_nat_div {a b : ℕ} (H : b ∣ a) : of_nat (a / b) = of_nat a / of_nat b := +have H' : (int.of_nat b ∣ int.of_nat a), by rewrite [int.of_nat_dvd_of_nat_iff]; exact H, +by rewrite [of_nat_eq, int.of_nat_div, of_int_div H'] + +theorem of_int_pow (a : ℤ) (n : ℕ) : of_int (a^n) = (of_int a)^n := +begin + induction n with n ih, + apply eq.refl, + rewrite [pow_succ, pow_succ, of_int_mul, ih] +end + +theorem of_nat_pow (a : ℕ) (n : ℕ) : of_nat (a^n) = (of_nat a)^n := +by rewrite [of_nat_eq, int.of_nat_pow, of_int_pow] + +end rat diff --git a/old_library/data/rat/countable.lean b/old_library/data/rat/countable.lean new file mode 100644 index 0000000000..3e4ca578b3 --- /dev/null +++ b/old_library/data/rat/countable.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +import data.rat.basic data.countable data.encodable data.int.countable +open encodable nat int option quot + +namespace rat +definition encode_prerat : prerat → nat +| (prerat.mk n d h) := mkpair (encode n) (encode d) + +definition decode_prerat (a : nat) : option prerat := +match unpair a with +| (cn, cd) := + match decode int cn with + | some n := + match decode int cd with + | some d := if h : d > 0 then some (prerat.mk n d h) else none + | none := none + end + | none := none + end +end + +lemma decode_encode_prerat (p : prerat) : decode_prerat (encode_prerat p) = some p := +begin + cases p with n d h, unfold [encode_prerat, decode_prerat], + rewrite unpair_mkpair, esimp, rewrite [*encodek, dif_pos h] +end + +attribute [instance] +definition encodable_prerat : encodable prerat := +encodable.mk + encode_prerat + decode_prerat + decode_encode_prerat + +attribute [instance] +definition decidable_equiv : ∀ a b : prerat, decidable (prerat.equiv a b) +| (prerat.mk n₁ d₁ h₁) (prerat.mk n₂ d₂ h₂) := begin unfold prerat.equiv, exact _ end + + +attribute [instance] +definition encodable_rat : encodable rat := +@encodable_quot _ _ decidable_equiv encodable_prerat + +lemma countable_rat : countable rat := +countable_of_encodable encodable_rat +end rat diff --git a/old_library/data/rat/default.lean b/old_library/data/rat/default.lean new file mode 100644 index 0000000000..a9cb20ed7c --- /dev/null +++ b/old_library/data/rat/default.lean @@ -0,0 +1,6 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad +-/ +import .basic .order diff --git a/old_library/data/rat/order.lean b/old_library/data/rat/order.lean new file mode 100644 index 0000000000..4e0fb4f04e --- /dev/null +++ b/old_library/data/rat/order.lean @@ -0,0 +1,448 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Adds the ordering, and instantiates the rationals as an ordered field. +-/ +import data.int algebra.ordered_field algebra.group_power data.rat.basic +open quot eq.ops + +/- the ordering on representations -/ + +namespace prerat +section int_notation +open int + +variables {a b : prerat} + +definition pos (a : prerat) : Prop := num a > 0 + +definition nonneg (a : prerat) : Prop := num a ≥ 0 + +theorem pos_of_int (a : ℤ) : pos (of_int a) ↔ (a > 0) := +!iff.rfl + +theorem nonneg_of_int (a : ℤ) : nonneg (of_int a) ↔ (a ≥ 0) := +!iff.rfl + +theorem pos_eq_pos_of_equiv {a b : prerat} (H1 : a ≡ b) : pos a = pos b := +propext (iff.intro (num_pos_of_equiv H1) (num_pos_of_equiv H1⁻¹)) + +theorem nonneg_eq_nonneg_of_equiv (H : a ≡ b) : nonneg a = nonneg b := +have H1 : (0 = num a) = (0 = num b), + from propext (iff.intro + (assume H2, eq.symm (num_eq_zero_of_equiv H H2⁻¹)) + (assume H2, eq.symm (num_eq_zero_of_equiv H⁻¹ H2⁻¹))), +calc + nonneg a = (pos a ∨ 0 = num a) : propext !le_iff_lt_or_eq + ... = (pos b ∨ 0 = num a) : pos_eq_pos_of_equiv H + ... = (pos b ∨ 0 = num b) : H1 + ... = nonneg b : propext !le_iff_lt_or_eq + +theorem nonneg_zero : nonneg zero := le.refl 0 + +theorem nonneg_add (H1 : nonneg a) (H2 : nonneg b) : nonneg (add a b) := +show num a * denom b + num b * denom a ≥ 0, + from add_nonneg + (mul_nonneg H1 (le_of_lt (denom_pos b))) + (mul_nonneg H2 (le_of_lt (denom_pos a))) + +theorem nonneg_antisymm (H1 : nonneg a) (H2 : nonneg (neg a)) : a ≡ zero := +have H3 : num a = 0, from le.antisymm (nonpos_of_neg_nonneg H2) H1, +equiv_zero_of_num_eq_zero H3 + +theorem nonneg_total (a : prerat) : nonneg a ∨ nonneg (neg a) := +or.elim (le.total 0 (num a)) + (suppose 0 ≤ num a, or.inl this) + (suppose 0 ≥ num a, or.inr (neg_nonneg_of_nonpos this)) + +theorem nonneg_of_pos (H : pos a) : nonneg a := le_of_lt H + +theorem ne_zero_of_pos (H : pos a) : ¬ a ≡ zero := +assume H', ne_of_gt H (num_eq_zero_of_equiv_zero H') + +theorem pos_of_nonneg_of_ne_zero (H1 : nonneg a) (H2 : ¬ a ≡ zero) : pos a := +have num a ≠ 0, from suppose num a = 0, H2 (equiv_zero_of_num_eq_zero this), +lt_of_le_of_ne H1 (ne.symm this) + +theorem nonneg_mul (H1 : nonneg a) (H2 : nonneg b) : nonneg (mul a b) := +mul_nonneg H1 H2 + +theorem pos_mul (H1 : pos a) (H2 : pos b) : pos (mul a b) := +mul_pos H1 H2 + +end int_notation +end prerat + +local attribute prerat.setoid [instance] + +/- The ordering on the rationals. + + The definitions of pos and nonneg are kept private, because they are only meant for internal + use. Users should use a > 0 and a ≥ 0 instead of pos and nonneg. +-/ + +namespace rat +open nat int +variables {a b c : ℚ} + +/- transfer properties of pos and nonneg -/ + +private definition pos (a : ℚ) : Prop := +quot.lift prerat.pos @prerat.pos_eq_pos_of_equiv a + +private definition nonneg (a : ℚ) : Prop := +quot.lift prerat.nonneg @prerat.nonneg_eq_nonneg_of_equiv a + +private theorem pos_of_int (a : ℤ) : (a > 0) ↔ pos (of_int a) := +prerat.pos_of_int a + +private theorem nonneg_of_int (a : ℤ) : (a ≥ 0) ↔ nonneg (of_int a) := +prerat.nonneg_of_int a + +private theorem nonneg_zero : nonneg 0 := prerat.nonneg_zero + +private theorem nonneg_add : nonneg a → nonneg b → nonneg (a + b) := +quot.induction_on₂ a b @prerat.nonneg_add + +private theorem nonneg_antisymm : nonneg a → nonneg (-a) → a = 0 := +quot.induction_on a + (take u, assume H1 H2, + quot.sound (prerat.nonneg_antisymm H1 H2)) + +private theorem nonneg_total (a : ℚ) : nonneg a ∨ nonneg (-a) := +quot.induction_on a @prerat.nonneg_total + +private theorem nonneg_of_pos : pos a → nonneg a := +quot.induction_on a @prerat.nonneg_of_pos + +private theorem ne_zero_of_pos : pos a → a ≠ 0 := +quot.induction_on a (take u, assume H1 H2, prerat.ne_zero_of_pos H1 (quot.exact H2)) + +private theorem pos_of_nonneg_of_ne_zero : nonneg a → ¬ a = 0 → pos a := +quot.induction_on a + (take u, + assume h : nonneg ⟦u⟧, + suppose ⟦u⟧ ≠ (rat.of_num 0), + have ¬ (prerat.equiv u prerat.zero), from assume H, this (quot.sound H), + prerat.pos_of_nonneg_of_ne_zero h this) + +private theorem nonneg_mul : nonneg a → nonneg b → nonneg (a * b) := +quot.induction_on₂ a b @prerat.nonneg_mul + +private theorem pos_mul : pos a → pos b → pos (a * b) := +quot.induction_on₂ a b @prerat.pos_mul + +private definition decidable_pos (a : ℚ) : decidable (pos a) := +quot.rec_on_subsingleton a (take u, int.decidable_lt 0 (prerat.num u)) + +/- define order in terms of pos and nonneg -/ + +protected definition lt (a b : ℚ) : Prop := pos (b - a) +protected definition le (a b : ℚ) : Prop := nonneg (b - a) + +attribute [instance, priority rat.prio] +definition rat_has_lt : has_lt rat := +has_lt.mk rat.lt + +attribute [instance, priority rat.prio] +definition rat_has_le : has_le rat := +has_le.mk rat.le + +protected lemma lt_def (a b : ℚ) : (a < b) = pos (b - a) := +rfl + +protected lemma le_def (a b : ℚ) : (a ≤ b) = nonneg (b - a) := +rfl + +theorem of_int_lt_of_int_iff (a b : ℤ) : of_int a < of_int b ↔ a < b := +iff.symm (calc + a < b ↔ b - a > 0 : iff.symm !sub_pos_iff_lt + ... ↔ pos (of_int (b - a)) : iff.symm !pos_of_int + ... ↔ pos (of_int b - of_int a) : !of_int_sub ▸ iff.rfl + ... ↔ of_int a < of_int b : iff.rfl) + +theorem of_int_lt_of_int_of_lt {a b : ℤ} (H : a < b) : of_int a < of_int b := +iff.mpr !of_int_lt_of_int_iff H + +theorem lt_of_of_int_lt_of_int {a b : ℤ} (H : of_int a < of_int b) : a < b := +iff.mp !of_int_lt_of_int_iff H + +theorem of_int_le_of_int_iff (a b : ℤ) : of_int a ≤ of_int b ↔ (a ≤ b) := +iff.symm (calc + a ≤ b ↔ b - a ≥ 0 : iff.symm !sub_nonneg_iff_le + ... ↔ nonneg (of_int (b - a)) : iff.symm !nonneg_of_int + ... ↔ nonneg (of_int b - of_int a) : !of_int_sub ▸ iff.rfl + ... ↔ of_int a ≤ of_int b : iff.rfl) + +theorem of_int_le_of_int_of_le {a b : ℤ} (H : a ≤ b) : of_int a ≤ of_int b := +iff.mpr !of_int_le_of_int_iff H + +theorem le_of_of_int_le_of_int {a b : ℤ} (H : of_int a ≤ of_int b) : a ≤ b := +iff.mp !of_int_le_of_int_iff H + +theorem of_nat_lt_of_nat_iff (a b : ℕ) : of_nat a < of_nat b ↔ a < b := +by rewrite [*of_nat_eq, of_int_lt_of_int_iff, int.of_nat_lt_of_nat_iff] + +theorem of_nat_lt_of_nat_of_lt {a b : ℕ} (H : a < b) : of_nat a < of_nat b := +iff.mpr !of_nat_lt_of_nat_iff H + +theorem lt_of_of_nat_lt_of_nat {a b : ℕ} (H : of_nat a < of_nat b) : a < b := +iff.mp !of_nat_lt_of_nat_iff H + +theorem of_nat_le_of_nat_iff (a b : ℕ) : of_nat a ≤ of_nat b ↔ a ≤ b := +by rewrite [*of_nat_eq, of_int_le_of_int_iff, int.of_nat_le_of_nat_iff] + +theorem of_nat_le_of_nat_of_le {a b : ℕ} (H : a ≤ b) : of_nat a ≤ of_nat b := +iff.mpr !of_nat_le_of_nat_iff H + +theorem le_of_of_nat_le_of_nat {a b : ℕ} (H : of_nat a ≤ of_nat b) : a ≤ b := +iff.mp !of_nat_le_of_nat_iff H + +theorem of_nat_nonneg (a : ℕ) : (of_nat a ≥ 0) := +of_nat_le_of_nat_of_le !nat.zero_le + +protected theorem le_refl (a : ℚ) : a ≤ a := +by rewrite [rat.le_def, sub_self]; apply nonneg_zero + +protected theorem le_trans (H1 : a ≤ b) (H2 : b ≤ c) : a ≤ c := +have H3 : nonneg (c - b + (b - a)), from nonneg_add H2 H1, +begin + revert H3, + rewrite [rat.sub.def, add.assoc, sub_eq_add_neg, neg_add_cancel_left], + intro H3, apply H3 +end + +protected theorem le_antisymm (H1 : a ≤ b) (H2 : b ≤ a) : a = b := +have H3 : nonneg (-(a - b)), from !neg_sub⁻¹ ▸ H1, +have H4 : a - b = 0, from nonneg_antisymm H2 H3, +eq_of_sub_eq_zero H4 + +protected theorem le_total (a b : ℚ) : a ≤ b ∨ b ≤ a := +or.elim (nonneg_total (b - a)) + (assume H, or.inl H) + (assume H, or.inr begin rewrite neg_sub at H, exact H end) + +protected theorem le_by_cases {P : Prop} (a b : ℚ) (H : a ≤ b → P) (H2 : b ≤ a → P) : P := + or.elim (!rat.le_total) H H2 + +protected theorem lt_iff_le_and_ne (a b : ℚ) : a < b ↔ a ≤ b ∧ a ≠ b := +iff.intro + (assume H : a < b, + have b - a ≠ 0, from ne_zero_of_pos H, + have a ≠ b, from ne.symm (assume H', this (H' ▸ !sub_self)), + and.intro (nonneg_of_pos H) this) + (assume H : a ≤ b ∧ a ≠ b, + obtain aleb aneb, from H, + have b - a ≠ 0, from (assume H', aneb (eq_of_sub_eq_zero H')⁻¹), + pos_of_nonneg_of_ne_zero aleb this) + +protected theorem le_iff_lt_or_eq (a b : ℚ) : a ≤ b ↔ a < b ∨ a = b := +iff.intro + (assume h : a ≤ b, + decidable.by_cases + (suppose a = b, or.inr this) + (suppose a ≠ b, or.inl (iff.mpr !rat.lt_iff_le_and_ne (and.intro h this)))) + (suppose a < b ∨ a = b, + or.elim this + (suppose a < b, and.left (iff.mp !rat.lt_iff_le_and_ne this)) + (suppose a = b, this ▸ !rat.le_refl)) + +private theorem to_nonneg : a ≥ 0 → nonneg a := +by intros; rewrite -sub_zero; eassumption + +protected theorem add_le_add_left (H : a ≤ b) (c : ℚ) : c + a ≤ c + b := +have c + b - (c + a) = b - a, + by rewrite [sub.def, neg_add, -add.assoc, add.comm c, add_neg_cancel_right], +show nonneg (c + b - (c + a)), from this⁻¹ ▸ H + +protected theorem mul_nonneg (H1 : a ≥ (0 : ℚ)) (H2 : b ≥ (0 : ℚ)) : a * b ≥ (0 : ℚ) := +have nonneg (a * b), from nonneg_mul (to_nonneg H1) (to_nonneg H2), +begin rewrite -sub_zero at this, exact this end + +private theorem to_pos : a > 0 → pos a := +by intros; rewrite -sub_zero; eassumption + +protected theorem mul_pos (H1 : a > (0 : ℚ)) (H2 : b > (0 : ℚ)) : a * b > (0 : ℚ) := +have pos (a * b), from pos_mul (to_pos H1) (to_pos H2), +begin rewrite -sub_zero at this, exact this end + +attribute [instance] +definition decidable_lt : decidable_rel rat.lt := +take a b, decidable_pos (b - a) + +protected theorem le_of_lt (H : a < b) : a ≤ b := iff.mpr !rat.le_iff_lt_or_eq (or.inl H) + +protected theorem lt_irrefl (a : ℚ) : ¬ a < a := +take Ha, + let Hand := (iff.mp !rat.lt_iff_le_and_ne) Ha in + (and.right Hand) rfl + +protected theorem not_le_of_gt (H : a < b) : ¬ b ≤ a := +assume Hba, + let Heq := rat.le_antisymm (rat.le_of_lt H) Hba in + !rat.lt_irrefl (Heq ▸ H) + +protected theorem lt_of_lt_of_le (Hab : a < b) (Hbc : b ≤ c) : a < c := +let Hab' := rat.le_of_lt Hab in +let Hac := rat.le_trans Hab' Hbc in + (iff.mpr !rat.lt_iff_le_and_ne) (and.intro Hac + (assume Heq, rat.not_le_of_gt (Heq ▸ Hab) Hbc)) + +protected theorem lt_of_le_of_lt (Hab : a ≤ b) (Hbc : b < c) : a < c := +let Hbc' := rat.le_of_lt Hbc in +let Hac := rat.le_trans Hab Hbc' in + (iff.mpr !rat.lt_iff_le_and_ne) (and.intro Hac + (assume Heq, rat.not_le_of_gt (Heq⁻¹ ▸ Hbc) Hab)) + +protected theorem zero_lt_one : (0 : ℚ) < 1 := trivial + +protected theorem add_lt_add_left (H : a < b) (c : ℚ) : c + a < c + b := +let H' := rat.le_of_lt H in +(iff.mpr (rat.lt_iff_le_and_ne _ _)) (and.intro (rat.add_le_add_left H' _) + (take Heq, let Heq' := add_left_cancel Heq in + !rat.lt_irrefl (Heq' ▸ H))) + +attribute [trans_instance] +protected definition discrete_linear_ordered_field : + discrete_linear_ordered_field rat := +⦃discrete_linear_ordered_field, + rat.discrete_field, + le_refl := rat.le_refl, + le_trans := @rat.le_trans, + le_antisymm := @rat.le_antisymm, + le_total := @rat.le_total, + le_of_lt := @rat.le_of_lt, + lt_irrefl := rat.lt_irrefl, + lt_of_lt_of_le := @rat.lt_of_lt_of_le, + lt_of_le_of_lt := @rat.lt_of_le_of_lt, + le_iff_lt_or_eq := @rat.le_iff_lt_or_eq, + add_le_add_left := @rat.add_le_add_left, + mul_nonneg := @rat.mul_nonneg, + mul_pos := @rat.mul_pos, + decidable_lt := @decidable_lt, + zero_lt_one := rat.zero_lt_one, + add_lt_add_left := @rat.add_lt_add_left⦄ + +theorem of_nat_abs (a : ℤ) : abs (of_int a) = of_nat (int.nat_abs a) := +have ∀ n : ℕ, of_int (int.neg_succ_of_nat n) = - of_nat (nat.succ n), from λ n, rfl, +int.induction_on a + (take b, abs_of_nonneg !of_nat_nonneg) + (take b, by rewrite [this, abs_neg, abs_of_nonneg !of_nat_nonneg]) + +theorem eq_zero_of_nonneg_of_forall_lt {x : ℚ} (xnonneg : x ≥ 0) (H : ∀ ε, ε > 0 → x < ε) : + x = 0 := + decidable.by_contradiction + (suppose x ≠ 0, + have x > 0, from lt_of_le_of_ne xnonneg (ne.symm this), + have x < x, from H x this, + show false, from !lt.irrefl this) + +theorem eq_zero_of_nonneg_of_forall_le {x : ℚ} (xnonneg : x ≥ 0) (H : ∀ ε, ε > 0 → x ≤ ε) : + x = 0 := +have H' : ∀ ε, ε > 0 → x < ε, from + take ε, suppose h₁ : ε > 0, + have ε / 2 > 0, from div_pos_of_pos_of_pos h₁ two_pos, + have x ≤ ε / 2, from H _ this, + show x < ε, from lt_of_le_of_lt this (div_two_lt_of_pos h₁), +eq_zero_of_nonneg_of_forall_lt xnonneg H' + +theorem eq_zero_of_forall_abs_le {x : ℚ} (H : ∀ ε, ε > 0 → abs x ≤ ε) : + x = 0 := +decidable.by_contradiction + (suppose x ≠ 0, + have abs x = 0, from eq_zero_of_nonneg_of_forall_le !abs_nonneg H, + show false, from `x ≠ 0` (eq_zero_of_abs_eq_zero this)) + +theorem eq_of_forall_abs_sub_le {x y : ℚ} (H : ∀ ε, ε > 0 → abs (x - y) ≤ ε) : + x = y := +have x - y = 0, from eq_zero_of_forall_abs_le H, +eq_of_sub_eq_zero this + +section + open int + + theorem num_nonneg_of_nonneg {q : ℚ} (H : q ≥ 0) : num q ≥ 0 := + have of_int (num q) ≥ of_int 0, + begin + rewrite [-mul_denom], + apply rat.mul_nonneg H, + rewrite [-of_int_zero, of_int_le_of_int_iff], + exact int.le_of_lt !denom_pos + end, + show num q ≥ 0, from le_of_of_int_le_of_int this + + theorem num_pos_of_pos {q : ℚ} (H : q > 0) : num q > 0 := + have of_int (num q) > of_int 0, + begin + rewrite [-mul_denom], + apply rat.mul_pos H, + rewrite [-of_int_zero, of_int_lt_of_int_iff], + exact !denom_pos + end, + show num q > 0, from lt_of_of_int_lt_of_int this + + theorem num_neg_of_neg {q : ℚ} (H : q < 0) : num q < 0 := + have of_int (num q) < of_int 0, + begin + rewrite [-mul_denom], + apply mul_neg_of_neg_of_pos H, + change of_int (denom q) > of_int 0, + xrewrite [of_int_lt_of_int_iff], + exact !denom_pos + end, + show num q < 0, from lt_of_of_int_lt_of_int this + + theorem num_nonpos_of_nonpos {q : ℚ} (H : q ≤ 0) : num q ≤ 0 := + have of_int (num q) ≤ of_int 0, + begin + rewrite [-mul_denom], + apply mul_nonpos_of_nonpos_of_nonneg H, + change of_int (denom q) ≥ of_int 0, + xrewrite [of_int_le_of_int_iff], + exact int.le_of_lt !denom_pos + end, + show num q ≤ 0, from le_of_of_int_le_of_int this +end + +definition ubound : ℚ → ℕ := λ a : ℚ, nat.succ (int.nat_abs (num a)) + +theorem ubound_ge (a : ℚ) : of_nat (ubound a) ≥ a := +have h : abs a * abs (of_int (denom a)) = abs (of_int (num a)), from + !abs_mul ▸ !mul_denom ▸ rfl, +have of_int (denom a) > 0, from of_int_lt_of_int_of_lt !denom_pos, +have 1 ≤ abs (of_int (denom a)), begin + rewrite (abs_of_pos this), + apply of_int_le_of_int_of_le, + apply denom_pos + end, +have abs a ≤ abs (of_int (num a)), from + le_of_mul_le_of_ge_one (h ▸ !le.refl) !abs_nonneg this, +calc + a ≤ abs a : le_abs_self + ... ≤ abs (of_int (num a)) : this + ... ≤ abs (of_int (num a)) + 1 : le_add_of_nonneg_right trivial + ... = of_nat (int.nat_abs (num a)) + 1 : of_nat_abs + ... = of_nat (nat.succ (int.nat_abs (num a))) : of_nat_add + +theorem ubound_pos (a : ℚ) : ubound a > 0 := +!nat.succ_pos + +open nat + +theorem binary_nat_bound (a : ℕ) : of_nat a ≤ 2^a := + nat.induction_on a (zero_le_one) + (take n : nat, assume Hn, + calc + of_nat (nat.succ n) = (of_nat n) + 1 : of_nat_add + ... ≤ 2^n + 1 : add_le_add_right Hn + ... ≤ 2^n + (2:rat)^n : add_le_add_left (pow_ge_one_of_ge_one two_ge_one _) + ... = 2^(succ n) : pow_two_add) + +theorem binary_bound (a : ℚ) : ∃ n : ℕ, a ≤ 2^n := + exists.intro (ubound a) (calc + a ≤ of_nat (ubound a) : ubound_ge + ... ≤ 2^(ubound a) : binary_nat_bound) + +end rat diff --git a/old_library/data/rat/rat.md b/old_library/data/rat/rat.md new file mode 100644 index 0000000000..18157f9839 --- /dev/null +++ b/old_library/data/rat/rat.md @@ -0,0 +1,7 @@ +data.rat +======== + +The rational numbers. + +* [basic](basic.lean) : the rationals as a field +* [order](order.lean) : the order relations and the sign function diff --git a/old_library/data/real/basic.lean b/old_library/data/real/basic.lean new file mode 100644 index 0000000000..26845cbe12 --- /dev/null +++ b/old_library/data/real/basic.lean @@ -0,0 +1,1244 @@ +/- +Copyright (c) 2015 Robert Y. Lewis. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Robert Y. Lewis +The real numbers, constructed as equivalence classes of Cauchy sequences of rationals. +This construction follows Bishop and Bridges (1985). + +The construction of the reals is arranged in four files. + +- basic.lean proves properties about regular sequences of rationals in the namespace rat_seq, + defines ℝ to be the quotient type of regular sequences mod equivalence, and shows ℝ is a ring + in namespace real. No classical axioms are used. + +- order.lean defines an order on regular sequences and lifts the order to ℝ. In the namespace real, + ℝ is shown to be an ordered ring. No classical axioms are used. + +- division.lean defines the inverse of a regular sequence and lifts this to ℝ. If a sequence is + equivalent to the 0 sequence, its inverse is the zero sequence. In the namespace real, ℝ is shown + to be an ordered field. This construction is classical. + +- complete.lean +-/ +import data.nat data.rat.order data.pnat +open nat eq pnat +-- open - [coercion] rat + +local postfix `⁻¹` := pnat.inv + +-- small helper lemmas + +private theorem s_mul_assoc_lemma_3 (a b n : ℕ+) (p : ℚ) : + p * ((a * n)⁻¹ + (b * n)⁻¹) = p * (a⁻¹ + b⁻¹) * n⁻¹ := +by rewrite [rat.mul_assoc, right_distrib, *pnat.inv_mul_eq_mul_inv] + +private theorem s_mul_assoc_lemma_4 {n : ℕ+} {ε q : ℚ} (Hε : ε > 0) (Hq : q > 0) + (H : n ≥ pceil (q / ε)) : + q * n⁻¹ ≤ ε := +begin + note H2 := pceil_helper H (div_pos_of_pos_of_pos Hq Hε), + note H3 := mul_le_of_le_div (div_pos_of_pos_of_pos Hq Hε) H2, + rewrite -(one_mul ε), + apply mul_le_mul_of_mul_div_le, + repeat assumption +end + +private theorem find_thirds (a b : ℚ) (H : b > 0) : ∃ n : ℕ+, a + n⁻¹ + n⁻¹ + n⁻¹ < a + b := +let n := pceil (of_nat 4 / b) in +have of_nat 3 * n⁻¹ < b, from calc + of_nat 3 * n⁻¹ < of_nat 4 * n⁻¹ + : mul_lt_mul_of_pos_right dec_trivial !pnat.inv_pos + ... ≤ of_nat 4 * (b / of_nat 4) + : mul_le_mul_of_nonneg_left (!inv_pceil_div dec_trivial H) !of_nat_nonneg + ... = b / of_nat 4 * of_nat 4 : mul.comm + ... = b : !div_mul_cancel dec_trivial, + exists.intro n (calc + a + n⁻¹ + n⁻¹ + n⁻¹ = a + (1 + 1 + 1) * n⁻¹ : by rewrite [+right_distrib, +rat.one_mul, -+add.assoc] + ... = a + of_nat 3 * n⁻¹ : {show 1+1+1=of_nat 3, from dec_trivial} + ... < a + b : rat.add_lt_add_left this a) + + +private theorem squeeze {a b : ℚ} (H : ∀ j : ℕ+, a ≤ b + j⁻¹ + j⁻¹ + j⁻¹) : a ≤ b := +begin + apply le_of_not_gt, + intro Hb, + cases exists_add_lt_and_pos_of_lt Hb with [c, Hc], + cases find_thirds b c (and.right Hc) with [j, Hbj], + have Ha : a > b + j⁻¹ + j⁻¹ + j⁻¹, from lt.trans Hbj (and.left Hc), + apply (not_le_of_gt Ha) !H +end + +private theorem rewrite_helper (a b c d : ℚ) : a * b - c * d = a * (b - d) + (a - c) * d := +by rewrite [mul_sub_left_distrib, mul_sub_right_distrib, add_sub, sub_add_cancel] + +private theorem rewrite_helper3 (a b c d e f g: ℚ) : a * (b + c) - (d * e + f * g) = + (a * b - d * e) + (a * c - f * g) := +by rewrite [left_distrib, add_sub_comm] + +private theorem rewrite_helper4 (a b c d : ℚ) : a * b - c * d = (a * b - a * d) + (a * d - c * d) := +by rewrite[add_sub, sub_add_cancel] + +private theorem rewrite_helper5 (a b x y : ℚ) : a - b = (a - x) + (x - y) + (y - b) := +by rewrite[*add_sub, *sub_add_cancel] + +private theorem rewrite_helper7 (a b c d x : ℚ) : + a * b * c - d = (b * c) * (a - x) + (x * b * c - d) := +begin + have ∀ (a b c : ℚ), a * b * c = b * c * a, + begin + intros a b c, + rewrite (mul.right_comm b c a), + rewrite (mul.comm b a) + end, + rewrite [mul_sub_left_distrib, add_sub], + calc + a * b * c - d = a * b * c - x * b * c + x * b * c - d : sub_add_cancel + ... = b * c * a - b * c * x + x * b * c - d : + begin + rewrite [this a b c, this x b c] + end +end + +private theorem ineq_helper (a b : ℚ) (k m n : ℕ+) (H : a ≤ (k * 2 * m)⁻¹ + (k * 2 * n)⁻¹) + (H2 : b ≤ (k * 2 * m)⁻¹ + (k * 2 * n)⁻¹) : + (rat_of_pnat k) * a + b * (rat_of_pnat k) ≤ m⁻¹ + n⁻¹ := +have H3 : (k * 2 * m)⁻¹ + (k * 2 * n)⁻¹ = (2 * k)⁻¹ * (m⁻¹ + n⁻¹), + begin + rewrite [left_distrib, *pnat.inv_mul_eq_mul_inv], + rewrite (mul.comm k⁻¹) + end, +have H' : a ≤ (2 * k)⁻¹ * (m⁻¹ + n⁻¹), + begin + rewrite H3 at H, + exact H + end, +have H2' : b ≤ (2 * k)⁻¹ * (m⁻¹ + n⁻¹), + begin + rewrite H3 at H2, + exact H2 + end, +have a + b ≤ k⁻¹ * (m⁻¹ + n⁻¹), from calc + a + b ≤ (2 * k)⁻¹ * (m⁻¹ + n⁻¹) + (2 * k)⁻¹ * (m⁻¹ + n⁻¹) : add_le_add H' H2' + ... = ((2 * k)⁻¹ + (2 * k)⁻¹) * (m⁻¹ + n⁻¹) : by rewrite right_distrib + ... = k⁻¹ * (m⁻¹ + n⁻¹) : by rewrite (pnat.add_halves k), +calc (rat_of_pnat k) * a + b * (rat_of_pnat k) + = (rat_of_pnat k) * a + (rat_of_pnat k) * b : by rewrite (mul.comm b) + ... = (rat_of_pnat k) * (a + b) : left_distrib + ... ≤ (rat_of_pnat k) * (k⁻¹ * (m⁻¹ + n⁻¹)) : + iff.mp (!le_iff_mul_le_mul_left !rat_of_pnat_is_pos) this + ... = m⁻¹ + n⁻¹ : + by rewrite[-mul.assoc, pnat.inv_cancel_left, one_mul] + +private theorem factor_lemma (a b c d e : ℚ) : abs (a + b + c - (d + (b + e))) = abs ((a - d) + (c - e)) := + !congr_arg (calc + a + b + c - (d + (b + e)) = a + b + c - (d + b + e) : rat.add_assoc + ... = a + b - (d + b) + (c - e) : add_sub_comm + ... = a + b - b - d + (c - e) : sub_add_eq_sub_sub_swap + ... = a - d + (c - e) : add_sub_cancel) + +private theorem factor_lemma_2 (a b c d : ℚ) : (a + b) + (c + d) = (a + c) + (d + b) := +begin + note H := (binary.comm4 add.comm add.assoc a b c d), + rewrite [add.comm b d at H], + exact H +end + +-------------------------------------- +-- define cauchy sequences and equivalence. show equivalence actually is one +namespace rat_seq + +notation `seq` := ℕ+ → ℚ + +definition regular (s : seq) := ∀ m n : ℕ+, abs (s m - s n) ≤ m⁻¹ + n⁻¹ + +definition equiv (s t : seq) := ∀ n : ℕ+, abs (s n - t n) ≤ n⁻¹ + n⁻¹ +infix `≡` := equiv + +theorem equiv.refl (s : seq) : s ≡ s := +begin + intros, + rewrite [sub_self, abs_zero], + apply add_invs_nonneg +end + +theorem equiv.symm (s t : seq) (H : s ≡ t) : t ≡ s := +begin + intros, + rewrite [-abs_neg, neg_sub], + exact H n +end + +theorem bdd_of_eq {s t : seq} (H : s ≡ t) : + ∀ j : ℕ+, ∀ n : ℕ+, n ≥ 2 * j → abs (s n - t n) ≤ j⁻¹ := +begin + intros [j, n, Hn], + apply le.trans, + apply H, + rewrite -(pnat.add_halves j), + apply add_le_add, + apply inv_ge_of_le Hn, + apply inv_ge_of_le Hn +end + +theorem eq_of_bdd {s t : seq} (Hs : regular s) (Ht : regular t) + (H : ∀ j : ℕ+, ∃ Nj : ℕ+, ∀ n : ℕ+, Nj ≤ n → abs (s n - t n) ≤ j⁻¹) : s ≡ t := + begin + intros, + have Hj : (∀ j : ℕ+, abs (s n - t n) ≤ n⁻¹ + n⁻¹ + j⁻¹ + j⁻¹ + j⁻¹), begin + intros, + cases H j with [Nj, HNj], + rewrite [-(sub_add_cancel (s n) (s (max j Nj))), +sub_eq_add_neg, + add.assoc (s n + -s (max j Nj)), ↑regular at *], + apply rat.le_trans, + apply abs_add_le_abs_add_abs, + apply rat.le_trans, + apply add_le_add, + apply Hs, + rewrite [-(sub_add_cancel (s (max j Nj)) (t (max j Nj))), add.assoc], + apply abs_add_le_abs_add_abs, + apply rat.le_trans, + apply rat.add_le_add_left, + apply add_le_add, + apply HNj (max j Nj) (pnat.max_right j Nj), + apply Ht, + have hsimp : ∀ m : ℕ+, n⁻¹ + m⁻¹ + (j⁻¹ + (m⁻¹ + n⁻¹)) = n⁻¹ + n⁻¹ + j⁻¹ + (m⁻¹ + m⁻¹), + from λm, calc + n⁻¹ + m⁻¹ + (j⁻¹ + (m⁻¹ + n⁻¹)) = n⁻¹ + (j⁻¹ + (m⁻¹ + n⁻¹)) + m⁻¹ : add.right_comm + ... = n⁻¹ + (j⁻¹ + m⁻¹ + n⁻¹) + m⁻¹ : add.assoc + ... = n⁻¹ + (n⁻¹ + (j⁻¹ + m⁻¹)) + m⁻¹ : add.comm + ... = n⁻¹ + n⁻¹ + j⁻¹ + (m⁻¹ + m⁻¹) : + by rewrite[-*add.assoc], + rewrite hsimp, + have Hms : (max j Nj)⁻¹ + (max j Nj)⁻¹ ≤ j⁻¹ + j⁻¹, begin + apply add_le_add, + apply inv_ge_of_le (pnat.max_left j Nj), + apply inv_ge_of_le (pnat.max_left j Nj), + end, + apply (calc + n⁻¹ + n⁻¹ + j⁻¹ + ((max j Nj)⁻¹ + (max j Nj)⁻¹) ≤ n⁻¹ + n⁻¹ + j⁻¹ + (j⁻¹ + j⁻¹) : + rat.add_le_add_left Hms + ... = n⁻¹ + n⁻¹ + j⁻¹ + j⁻¹ + j⁻¹ : by rewrite *rat.add_assoc) + end, + apply squeeze Hj + end + +theorem eq_of_bdd_var {s t : seq} (Hs : regular s) (Ht : regular t) + (H : ∀ ε : ℚ, ε > 0 → ∃ Nj : ℕ+, ∀ n : ℕ+, Nj ≤ n → abs (s n - t n) ≤ ε) : s ≡ t := + begin + apply eq_of_bdd, + repeat assumption, + intros, + apply H, + apply pnat.inv_pos + end + +theorem bdd_of_eq_var {s t : seq} (Hs : regular s) (Ht : regular t) (Heq : s ≡ t) : + ∀ ε : ℚ, ε > 0 → ∃ Nj : ℕ+, ∀ n : ℕ+, Nj ≤ n → abs (s n - t n) ≤ ε := + begin + intro ε Hε, + cases pnat_bound Hε with [N, HN], + existsi 2 * N, + intro n Hn, + apply rat.le_trans, + apply bdd_of_eq Heq N n Hn, + exact HN -- assumption -- TODO: something funny here; what is 11.source.to_has_le_2? + end + +theorem equiv.trans (s t u : seq) (Hs : regular s) (Ht : regular t) (Hu : regular u) + (H : s ≡ t) (H2 : t ≡ u) : s ≡ u := + begin + apply eq_of_bdd Hs Hu, + intros, + existsi 2 * (2 * j), + intro n Hn, + rewrite [-sub_add_cancel (s n) (t n), *sub_eq_add_neg, add.assoc], + apply rat.le_trans, + apply abs_add_le_abs_add_abs, + have Hst : abs (s n - t n) ≤ (2 * j)⁻¹, from bdd_of_eq H _ _ Hn, + have Htu : abs (t n - u n) ≤ (2 * j)⁻¹, from bdd_of_eq H2 _ _ Hn, + rewrite -(pnat.add_halves j), + apply add_le_add, + exact Hst, exact Htu + end + +----------------------------------- +-- define operations on cauchy sequences. show operations preserve regularity + +private definition K (s : seq) : ℕ+ := pnat.pos (ubound (abs (s pone)) + 1 + 1) dec_trivial + +private theorem canon_bound {s : seq} (Hs : regular s) (n : ℕ+) : abs (s n) ≤ rat_of_pnat (K s) := + calc + abs (s n) = abs (s n - s pone + s pone) : by rewrite sub_add_cancel + ... ≤ abs (s n - s pone) + abs (s pone) : abs_add_le_abs_add_abs + ... ≤ n⁻¹ + pone⁻¹ + abs (s pone) : add_le_add_right !Hs + ... = n⁻¹ + (1 + abs (s pone)) : by rewrite [pone_inv, rat.add_assoc] + ... ≤ 1 + (1 + abs (s pone)) : add_le_add_right (inv_le_one n) + ... = abs (s pone) + (1 + 1) : + by rewrite [add.comm 1 (abs (s pone)), add.comm 1, rat.add_assoc] + ... ≤ of_nat (ubound (abs (s pone))) + (1 + 1) : add_le_add_right (!ubound_ge) + ... = of_nat (ubound (abs (s pone)) + (1 + 1)) : of_nat_add + ... = of_nat (ubound (abs (s pone)) + 1 + 1) : add.assoc + ... = rat_of_pnat (K s) : by esimp + +theorem bdd_of_regular {s : seq} (H : regular s) : ∃ b : ℚ, ∀ n : ℕ+, s n ≤ b := + begin + existsi rat_of_pnat (K s), + intros, + apply rat.le_trans, + apply le_abs_self, + apply canon_bound H + end + +theorem bdd_of_regular_strict {s : seq} (H : regular s) : ∃ b : ℚ, ∀ n : ℕ+, s n < b := + begin + cases bdd_of_regular H with [b, Hb], + existsi b + 1, + intro n, + apply rat.lt_of_le_of_lt, + apply Hb, + apply lt_add_of_pos_right, + apply zero_lt_one + end + +definition K₂ (s t : seq) := max (K s) (K t) + +private theorem K₂_symm (s t : seq) : K₂ s t = K₂ t s := + if H : K s < K t then + (have H1 : K₂ s t = K t, from pnat.max_eq_right H, + have H2 : K₂ t s = K t, from pnat.max_eq_left (pnat.not_lt_of_ge (pnat.le_of_lt H)), + by rewrite [H1, -H2]) + else + (have H1 : K₂ s t = K s, from pnat.max_eq_left H, + if J : K t < K s then + (have H2 : K₂ t s = K s, from pnat.max_eq_right J, by rewrite [H1, -H2]) + else + (have Heq : K t = K s, from + pnat.eq_of_le_of_ge (pnat.le_of_not_gt H) (pnat.le_of_not_gt J), + by rewrite [↑K₂, Heq])) + +theorem canon_2_bound_left (s t : seq) (Hs : regular s) (n : ℕ+) : + abs (s n) ≤ rat_of_pnat (K₂ s t) := + calc + abs (s n) ≤ rat_of_pnat (K s) : canon_bound Hs n + ... ≤ rat_of_pnat (K₂ s t) : rat_of_pnat_le_of_pnat_le (!pnat.max_left) + +theorem canon_2_bound_right (s t : seq) (Ht : regular t) (n : ℕ+) : + abs (t n) ≤ rat_of_pnat (K₂ s t) := + calc + abs (t n) ≤ rat_of_pnat (K t) : canon_bound Ht n + ... ≤ rat_of_pnat (K₂ s t) : rat_of_pnat_le_of_pnat_le (!pnat.max_right) + +definition sadd (s t : seq) : seq := λ n, (s (2 * n)) + (t (2 * n)) + +theorem reg_add_reg {s t : seq} (Hs : regular s) (Ht : regular t) : regular (sadd s t) := + begin + rewrite [↑regular at *, ↑sadd], + intros, + rewrite add_sub_comm, + apply rat.le_trans, + apply abs_add_le_abs_add_abs, + rewrite add_halves_double, + apply add_le_add, + apply Hs, + apply Ht + end + +definition smul (s t : seq) : seq := λ n : ℕ+, (s ((K₂ s t) * 2 * n)) * (t ((K₂ s t) * 2 * n)) + +theorem reg_mul_reg {s t : seq} (Hs : regular s) (Ht : regular t) : regular (smul s t) := + begin + rewrite [↑regular at *, ↑smul], + intros, + rewrite rewrite_helper, + apply rat.le_trans, + apply abs_add_le_abs_add_abs, + apply rat.le_trans, + apply add_le_add, + rewrite abs_mul, + apply mul_le_mul_of_nonneg_right, + apply canon_2_bound_left s t Hs, + apply abs_nonneg, + rewrite abs_mul, + apply mul_le_mul_of_nonneg_left, + apply canon_2_bound_right s t Ht, + apply abs_nonneg, + apply ineq_helper, + apply Ht, + apply Hs + end + +definition sneg (s : seq) : seq := λ n : ℕ+, - (s n) + +theorem reg_neg_reg {s : seq} (Hs : regular s) : regular (sneg s) := + begin + rewrite [↑regular at *, ↑sneg], + intros, + rewrite [-abs_neg, neg_sub, sub_neg_eq_add, add.comm], + apply Hs + end + +----------------------------------- +-- show properties of +, *, - + +definition zero : seq := λ n, 0 + +definition one : seq := λ n, 1 + +theorem s_add_comm (s t : seq) : sadd s t ≡ sadd t s := + begin + esimp [sadd], + intro n, + rewrite [sub_add_eq_sub_sub, add_sub_cancel, sub_self, abs_zero], + apply add_invs_nonneg + end + +theorem s_add_assoc (s t u : seq) (Hs : regular s) (Hu : regular u) : + sadd (sadd s t) u ≡ sadd s (sadd t u) := + begin + rewrite [↑sadd, ↑equiv, ↑regular at *], + intros, + rewrite factor_lemma, + apply rat.le_trans, + apply abs_add_le_abs_add_abs, + apply rat.le_trans, + rotate 1, + apply add_le_add_right, + apply inv_two_mul_le_inv, + rewrite [-(pnat.add_halves (2 * n)), -(pnat.add_halves n), factor_lemma_2], + apply add_le_add, + apply Hs, + apply Hu + end + +theorem s_mul_comm (s t : seq) : smul s t ≡ smul t s := + begin + rewrite ↑smul, + intros n, + rewrite [*(K₂_symm s t), rat.mul_comm, sub_self, abs_zero], + apply add_invs_nonneg + end + +private definition DK (s t : seq) := (K₂ s t) * 2 +private theorem DK_rewrite (s t : seq) : (K₂ s t) * 2 = DK s t := rfl + +private definition TK (s t u : seq) := (DK (λ (n : ℕ+), s (mul (DK s t) n) * t (mul (DK s t) n)) u) + +private theorem TK_rewrite (s t u : seq) : + (DK (λ (n : ℕ+), s (mul (DK s t) n) * t (mul (DK s t) n)) u) = TK s t u := rfl + +private theorem s_mul_assoc_lemma (s t u : seq) (a b c d : ℕ+) : + abs (s a * t a * u b - s c * t d * u d) ≤ abs (t a) * abs (u b) * abs (s a - s c) + + abs (s c) * abs (t a) * abs (u b - u d) + abs (s c) * abs (u d) * abs (t a - t d) := + begin + rewrite (rewrite_helper7 _ _ _ _ (s c)), + apply rat.le_trans, + apply abs_add_le_abs_add_abs, + rewrite rat.add_assoc, + apply add_le_add, + rewrite 2 abs_mul, + apply le.refl, + rewrite [*rat.mul_assoc, -mul_sub_left_distrib, -left_distrib, abs_mul], + apply mul_le_mul_of_nonneg_left, + rewrite rewrite_helper, + apply le.trans, + apply abs_add_le_abs_add_abs, + apply add_le_add, + rewrite abs_mul, apply rat.le_refl, + rewrite [abs_mul, rat.mul_comm], apply rat.le_refl, + apply abs_nonneg + end + +private definition Kq (s : seq) := rat_of_pnat (K s) + 1 +private theorem Kq_bound {s : seq} (H : regular s) : ∀ n, abs (s n) ≤ Kq s := + begin + intros, + apply le_of_lt, + apply lt_of_le_of_lt, + apply canon_bound H, + apply lt_add_of_pos_right, + apply zero_lt_one + end + +private theorem Kq_bound_nonneg {s : seq} (H : regular s) : 0 ≤ Kq s := + le.trans !abs_nonneg (Kq_bound H 2) + +private theorem Kq_bound_pos {s : seq} (H : regular s) : 0 < Kq s := + have H1 : 0 ≤ rat_of_pnat (K s), from rat.le_trans (!abs_nonneg) (canon_bound H 2), + add_pos_of_nonneg_of_pos H1 rat.zero_lt_one + +private theorem s_mul_assoc_lemma_5 {s t u : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (a b c : ℕ+) : abs (t a) * abs (u b) * abs (s a - s c) ≤ (Kq t) * (Kq u) * (a⁻¹ + c⁻¹) := + begin + repeat apply mul_le_mul, + apply Kq_bound Ht, + apply Kq_bound Hu, + apply abs_nonneg, + apply Kq_bound_nonneg Ht, + apply Hs, + apply abs_nonneg, + apply rat.mul_nonneg, + apply Kq_bound_nonneg Ht, + apply Kq_bound_nonneg Hu, + end + +private theorem s_mul_assoc_lemma_2 {s t u : seq} (Hs : regular s) (Ht : regular t) + (Hu : regular u) (a b c d : ℕ+) : + abs (t a) * abs (u b) * abs (s a - s c) + abs (s c) * abs (t a) * abs (u b - u d) + + abs (s c) * abs (u d) * abs (t a - t d) ≤ + (Kq t) * (Kq u) * (a⁻¹ + c⁻¹) + (Kq s) * (Kq t) * (b⁻¹ + d⁻¹) + (Kq s) * (Kq u) * (a⁻¹ + d⁻¹) := + begin + apply add_le_add_three, + repeat (assumption | apply mul_le_mul | apply Kq_bound | apply Kq_bound_nonneg | + apply abs_nonneg), + apply Hs, + apply abs_nonneg, + apply rat.mul_nonneg, + repeat (assumption | apply mul_le_mul | apply Kq_bound | apply Kq_bound_nonneg | + apply abs_nonneg), + apply Hu, + apply abs_nonneg, + apply rat.mul_nonneg, + repeat (assumption | apply mul_le_mul | apply Kq_bound | apply Kq_bound_nonneg | + apply abs_nonneg), + apply Ht, + apply abs_nonneg, + apply rat.mul_nonneg, + repeat (apply Kq_bound_nonneg; assumption) + end + +theorem s_mul_assoc {s t u : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) : + smul (smul s t) u ≡ smul s (smul t u) := + begin + apply eq_of_bdd_var, + repeat apply reg_mul_reg, + apply Hs, + apply Ht, + apply Hu, + apply reg_mul_reg Hs, + apply reg_mul_reg Ht Hu, + intros, + apply exists.intro, + intros, + rewrite [↑smul, *DK_rewrite, *TK_rewrite, -*pnat.mul_assoc, -*mul.assoc], + apply rat.le_trans, + apply s_mul_assoc_lemma, + apply rat.le_trans, + apply s_mul_assoc_lemma_2, + apply Hs, + apply Ht, + apply Hu, + rewrite [*s_mul_assoc_lemma_3, -distrib_three_right], + apply s_mul_assoc_lemma_4, + apply a, + repeat apply add_pos, + repeat apply mul_pos, + apply Kq_bound_pos Ht, + apply Kq_bound_pos Hu, + apply add_pos, + repeat apply pnat.inv_pos, + repeat apply rat.mul_pos, + apply Kq_bound_pos Hs, + apply Kq_bound_pos Ht, + apply add_pos, + repeat apply pnat.inv_pos, + repeat apply rat.mul_pos, + apply Kq_bound_pos Hs, + apply Kq_bound_pos Hu, + apply add_pos, + repeat apply pnat.inv_pos, + apply a_1 + end + +theorem zero_is_reg : regular zero := + begin + rewrite [↑regular, ↑zero], + intros, + rewrite [sub_zero, abs_zero], + apply add_invs_nonneg + end + +theorem s_zero_add (s : seq) (H : regular s) : sadd zero s ≡ s := + begin + rewrite [↑sadd, ↑zero, ↑equiv, ↑regular at H], + intros, + rewrite [rat.zero_add], + apply rat.le_trans, + apply H, + apply add_le_add, + apply inv_two_mul_le_inv, + apply rat.le_refl + end + +theorem s_add_zero (s : seq) (H : regular s) : sadd s zero ≡ s := + begin + rewrite [↑sadd, ↑zero, ↑equiv, ↑regular at H], + intros, + rewrite [rat.add_zero], + apply rat.le_trans, + apply H, + apply add_le_add, + apply inv_two_mul_le_inv, + apply rat.le_refl + end + +theorem s_neg_cancel (s : seq) (H : regular s) : sadd (sneg s) s ≡ zero := + begin + rewrite [↑sadd, ↑sneg, ↑regular at H, ↑zero, ↑equiv], + intros, + rewrite [neg_add_eq_sub, sub_self, sub_zero, abs_zero], + apply add_invs_nonneg + end + +theorem neg_s_cancel (s : seq) (H : regular s) : sadd s (sneg s) ≡ zero := + begin + apply equiv.trans, + rotate 3, + apply s_add_comm, + apply s_neg_cancel s H, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption), + apply zero_is_reg + end + +theorem add_well_defined {s t u v : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (Hv : regular v) (Esu : s ≡ u) (Etv : t ≡ v) : sadd s t ≡ sadd u v := + begin + rewrite [↑sadd, ↑equiv at *], + intros, + rewrite [add_sub_comm, add_halves_double], + apply rat.le_trans, + apply abs_add_le_abs_add_abs, + apply add_le_add, + apply Esu, + apply Etv + end + +set_option tactic.goal_names false +private theorem mul_bound_helper {s t : seq} (Hs : regular s) (Ht : regular t) (a b c : ℕ+) + (j : ℕ+) : + ∃ N : ℕ+, ∀ n : ℕ+, n ≥ N → abs (s (a * n) * t (b * n) - s (c * n) * t (c * n)) ≤ j⁻¹ := + begin + existsi pceil (((rat_of_pnat (K s)) * (b⁻¹ + c⁻¹) + (a⁻¹ + c⁻¹) * + (rat_of_pnat (K t))) * (rat_of_pnat j)), + intros n Hn, + rewrite rewrite_helper4, + apply rat.le_trans, + apply abs_add_le_abs_add_abs, + apply rat.le_trans, + rotate 1, + show n⁻¹ * ((rat_of_pnat (K s)) * (b⁻¹ + c⁻¹)) + + n⁻¹ * ((a⁻¹ + c⁻¹) * (rat_of_pnat (K t))) ≤ j⁻¹, begin + rewrite -left_distrib, + apply rat.le_trans, + apply mul_le_mul_of_nonneg_right, + apply pceil_helper Hn, + { repeat (apply mul_pos | apply add_pos | apply rat_of_pnat_is_pos | + apply pnat.inv_pos) }, + apply rat.le_of_lt, + apply add_pos, + apply rat.mul_pos, + apply rat_of_pnat_is_pos, + apply add_pos, + apply pnat.inv_pos, + apply pnat.inv_pos, + apply rat.mul_pos, + apply add_pos, + apply pnat.inv_pos, + apply pnat.inv_pos, + apply rat_of_pnat_is_pos, + have H : (rat_of_pnat (K s) * (b⁻¹ + c⁻¹) + (a⁻¹ + c⁻¹) * rat_of_pnat (K t)) ≠ 0, begin + apply ne_of_gt, + repeat (apply mul_pos | apply add_pos | apply rat_of_pnat_is_pos | apply pnat.inv_pos), + end, + rewrite (!div_helper H), + apply rat.le_refl + end, + apply add_le_add, + rewrite [-mul_sub_left_distrib, abs_mul], + apply rat.le_trans, + apply mul_le_mul, + apply canon_bound, + apply Hs, + apply Ht, + apply abs_nonneg, + apply rat.le_of_lt, + apply rat_of_pnat_is_pos, + rewrite [*pnat.inv_mul_eq_mul_inv, -right_distrib, -rat.mul_assoc, rat.mul_comm], + apply mul_le_mul_of_nonneg_left, + apply rat.le_refl, + apply rat.le_of_lt, + apply pnat.inv_pos, + rewrite [-mul_sub_right_distrib, abs_mul], + apply rat.le_trans, + apply mul_le_mul, + apply Hs, + apply canon_bound, + apply Ht, + apply abs_nonneg, + apply add_invs_nonneg, + rewrite [*pnat.inv_mul_eq_mul_inv, -right_distrib, mul.comm _ n⁻¹, rat.mul_assoc], + apply mul_le_mul, + repeat apply rat.le_refl, + apply rat.le_of_lt, + apply rat.mul_pos, + apply add_pos, + repeat apply pnat.inv_pos, + apply rat_of_pnat_is_pos, + apply rat.le_of_lt, + apply pnat.inv_pos + end + +theorem s_distrib {s t u : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) : + smul s (sadd t u) ≡ sadd (smul s t) (smul s u) := + begin + apply eq_of_bdd, + repeat (assumption | apply reg_add_reg | apply reg_mul_reg), + intros, + let exh1 := λ a b c, mul_bound_helper Hs Ht a b c (2 * j), + apply exists.elim, + apply exh1, + rotate 3, + intros N1 HN1, + let exh2 := λ d e f, mul_bound_helper Hs Hu d e f (2 * j), + apply exists.elim, + apply exh2, + rotate 3, + intros N2 HN2, + existsi max N1 N2, + intros n Hn, + rewrite [↑sadd at *, ↑smul, rewrite_helper3, -pnat.add_halves j, -*pnat.mul_assoc at *], + apply rat.le_trans, + apply abs_add_le_abs_add_abs, + apply add_le_add, + apply HN1, + apply pnat.le_trans, + apply pnat.max_left N1 N2, + apply Hn, + apply HN2, + apply pnat.le_trans, + apply pnat.max_right N1 N2, + apply Hn + end + +theorem mul_zero_equiv_zero {s t : seq} (Hs : regular s) (Ht : regular t) (Htz : t ≡ zero) : + smul s t ≡ zero := + begin + apply eq_of_bdd_var, + apply reg_mul_reg Hs Ht, + apply zero_is_reg, + intro ε Hε, + let Bd := bdd_of_eq_var Ht zero_is_reg Htz (ε / (Kq s)) + (div_pos_of_pos_of_pos Hε (Kq_bound_pos Hs)), + cases Bd with [N, HN], + existsi N, + intro n Hn, + rewrite [↑equiv at Htz, ↑zero at *, sub_zero, ↑smul, abs_mul], + apply le.trans, + apply mul_le_mul, + apply Kq_bound Hs, + have HN' : ∀ (n : ℕ+), N ≤ n → abs (t n) ≤ ε / Kq s, + from λ n, (eq.subst (sub_zero (t n)) (HN n)), + apply HN', + apply pnat.le_trans Hn, + apply pnat.mul_le_mul_left, + apply abs_nonneg, + apply le_of_lt (Kq_bound_pos Hs), + rewrite (mul_div_cancel' (ne.symm (ne_of_lt (Kq_bound_pos Hs)))), + apply le.refl + end + +private theorem neg_bound_eq_bound (s : seq) : K (sneg s) = K s := + by rewrite [↑K, ↑sneg, abs_neg] + +private theorem neg_bound2_eq_bound2 (s t : seq) : K₂ s (sneg t) = K₂ s t := + by rewrite [↑K₂, neg_bound_eq_bound] + +private theorem sneg_def (s : seq) : (λ (n : ℕ+), -(s n)) = sneg s := rfl + +theorem mul_neg_equiv_neg_mul {s t : seq} : smul s (sneg t) ≡ sneg (smul s t) := + begin + rewrite [↑equiv, ↑smul], + intros, + rewrite [↑sneg, *sub_neg_eq_add, -neg_mul_eq_mul_neg, add.comm, *sneg_def, + *neg_bound2_eq_bound2, add.right_inv, abs_zero], + apply add_invs_nonneg + end + +theorem equiv_of_diff_equiv_zero {s t : seq} (Hs : regular s) (Ht : regular t) + (H : sadd s (sneg t) ≡ zero) : s ≡ t := + begin + have hsimp : ∀ a b c d e : ℚ, a + b + c + (d + e) = b + d + a + e + c, from + λ a b c d e, calc + a + b + c + (d + e) = a + b + (d + e) + c : add.right_comm + ... = a + (b + d) + e + c : by rewrite[-*add.assoc] + ... = b + d + a + e + c : add.comm, + apply eq_of_bdd Hs Ht, + intros, + note He := bdd_of_eq H, + existsi 2 * (2 * (2 * j)), + intros n Hn, + rewrite (rewrite_helper5 _ _ (s (2 * n)) (t (2 * n))), + apply rat.le_trans, + apply abs_add_three, + apply rat.le_trans, + apply add_le_add_three, + apply Hs, + rewrite [↑sadd at He, ↑sneg at He, ↑zero at He], + let He' := λ a b c, eq.subst !sub_zero (He a b c), + apply (He' _ _ Hn), + apply Ht, + rewrite [hsimp, pnat.add_halves, -(pnat.add_halves j), -(pnat.add_halves (2 * j)), -*rat.add_assoc], + apply add_le_add_right, + apply add_le_add_three, + repeat (apply rat.le_trans; apply inv_ge_of_le Hn; apply inv_two_mul_le_inv) + end + +theorem s_sub_cancel (s : seq) : sadd s (sneg s) ≡ zero := + begin + rewrite [↑equiv, ↑sadd, ↑sneg, ↑zero], + intros, + rewrite [sub_zero, add.right_inv, abs_zero], + apply add_invs_nonneg + end + +theorem diff_equiv_zero_of_equiv {s t : seq} (Hs : regular s) (Ht : regular t) (H : s ≡ t) : + sadd s (sneg t) ≡ zero := + begin + apply equiv.trans, + rotate 4, + apply s_sub_cancel t, + rotate 2, + apply zero_is_reg, + apply add_well_defined, + repeat (assumption | apply reg_neg_reg), + apply equiv.refl, + repeat (assumption | apply reg_add_reg | apply reg_neg_reg) + end + +private theorem mul_well_defined_half1 {s t u : seq} (Hs : regular s) (Ht : regular t) + (Hu : regular u) (Etu : t ≡ u) : smul s t ≡ smul s u := + begin + apply equiv_of_diff_equiv_zero, + rotate 2, + apply equiv.trans, + rotate 3, + apply equiv.symm, + apply add_well_defined, + rotate 4, + apply equiv.refl, + apply mul_neg_equiv_neg_mul, + apply equiv.trans, + rotate 3, + apply equiv.symm, + apply s_distrib, + rotate 3, + apply mul_zero_equiv_zero, + rotate 2, + apply diff_equiv_zero_of_equiv, + repeat (assumption | apply reg_mul_reg | apply reg_neg_reg | apply reg_add_reg | + apply zero_is_reg) + end + +private theorem mul_well_defined_half2 {s t u : seq} (Hs : regular s) (Ht : regular t) + (Hu : regular u) (Est : s ≡ t) : smul s u ≡ smul t u := + begin + apply equiv.trans, + rotate 3, + apply s_mul_comm, + apply equiv.trans, + rotate 3, + apply mul_well_defined_half1, + rotate 2, + apply Ht, + rotate 1, + apply s_mul_comm, + repeat (assumption | apply reg_mul_reg) +end + +theorem mul_well_defined {s t u v : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (Hv : regular v) (Esu : s ≡ u) (Etv : t ≡ v) : smul s t ≡ smul u v := + begin + apply equiv.trans, + exact reg_mul_reg Hs Ht, + exact reg_mul_reg Hs Hv, + exact reg_mul_reg Hu Hv, + apply mul_well_defined_half1, + repeat assumption, + apply mul_well_defined_half2, + repeat assumption + end + +theorem neg_well_defined {s t : seq} (Est : s ≡ t) : sneg s ≡ sneg t := + begin + rewrite [↑sneg, ↑equiv at *], + intros, + rewrite [-abs_neg, neg_sub, sub_neg_eq_add, add.comm], + apply Est + end + +theorem one_is_reg : regular one := + begin + rewrite [↑regular, ↑one], + intros, + rewrite [sub_self, abs_zero], + apply add_invs_nonneg + end + +theorem s_one_mul {s : seq} (H : regular s) : smul one s ≡ s := + begin + intros, + rewrite [↑smul, ↑one, rat.one_mul], + apply rat.le_trans, + apply H, + apply add_le_add_right, + apply pnat.inv_mul_le_inv + end + +theorem s_mul_one {s : seq} (H : regular s) : smul s one ≡ s := + begin + apply equiv.trans, + apply reg_mul_reg H one_is_reg, + rotate 2, + apply s_mul_comm, + apply s_one_mul H, + apply reg_mul_reg one_is_reg H, + apply H + end + +theorem zero_nequiv_one : ¬ zero ≡ one := + begin + intro Hz, + rewrite [↑equiv at Hz, ↑zero at Hz, ↑one at Hz], + note H := Hz (2 * 2), + rewrite [zero_sub at H, abs_neg at H, pnat.add_halves at H], + have H' : pone⁻¹ ≤ 2⁻¹, from calc + pone⁻¹ = 1 : by rewrite -pone_inv + ... = abs 1 : abs_of_pos zero_lt_one + ... ≤ 2⁻¹ : H, + let H'' := ge_of_inv_le H', + apply absurd (one_lt_two) (pnat.not_lt_of_ge H'') + end + +--------------------------------------------- +-- constant sequences + +definition const (a : ℚ) : seq := λ n, a + +theorem const_reg (a : ℚ) : regular (const a) := + begin + intros, + rewrite [↑const, sub_self, abs_zero], + apply add_invs_nonneg + end + +theorem add_consts (a b : ℚ) : sadd (const a) (const b) ≡ const (a + b) := + by apply equiv.refl + +theorem mul_consts (a b : ℚ) : smul (const a) (const b) ≡ const (a * b) := + by apply equiv.refl + +theorem neg_const (a : ℚ) : sneg (const a) ≡ const (-a) := + by apply equiv.refl + +section + open rat + + lemma eq_of_const_equiv {a b : ℚ} (H : const a ≡ const b) : a = b := + have H₁ : ∀ n : ℕ+, abs (a - b) ≤ n⁻¹ + n⁻¹, from H, + eq_of_forall_abs_sub_le + (take ε, + suppose ε > 0, + have ε / 2 > 0, begin exact div_pos_of_pos_of_pos this two_pos end, + obtain n (Hn : n⁻¹ ≤ ε / 2), from pnat_bound this, + show abs (a - b) ≤ ε, from calc + abs (a - b) ≤ n⁻¹ + n⁻¹ : H₁ n + ... ≤ ε / 2 + ε / 2 : add_le_add Hn Hn + ... = ε : add_halves) +end + +--------------------------------------------- +-- create the type of regular sequences and lift theorems + +record reg_seq : Type := + (sq : seq) (is_reg : regular sq) + +definition requiv (s t : reg_seq) := (reg_seq.sq s) ≡ (reg_seq.sq t) +definition requiv.refl (s : reg_seq) : requiv s s := equiv.refl (reg_seq.sq s) +definition requiv.symm (s t : reg_seq) (H : requiv s t) : requiv t s := + equiv.symm (reg_seq.sq s) (reg_seq.sq t) H +definition requiv.trans (s t u : reg_seq) (H : requiv s t) (H2 : requiv t u) : requiv s u := + equiv.trans _ _ _ (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) H H2 + +definition radd (s t : reg_seq) : reg_seq := + reg_seq.mk (sadd (reg_seq.sq s) (reg_seq.sq t)) + (reg_add_reg (reg_seq.is_reg s) (reg_seq.is_reg t)) +infix + := radd + +definition rmul (s t : reg_seq) : reg_seq := + reg_seq.mk (smul (reg_seq.sq s) (reg_seq.sq t)) + (reg_mul_reg (reg_seq.is_reg s) (reg_seq.is_reg t)) +infix * := rmul + +definition rneg (s : reg_seq) : reg_seq := + reg_seq.mk (sneg (reg_seq.sq s)) (reg_neg_reg (reg_seq.is_reg s)) +prefix - := rneg + +definition radd_well_defined {s t u v : reg_seq} (H : requiv s u) (H2 : requiv t v) : + requiv (s + t) (u + v) := + add_well_defined (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) (reg_seq.is_reg v) H H2 + +definition rmul_well_defined {s t u v : reg_seq} (H : requiv s u) (H2 : requiv t v) : + requiv (s * t) (u * v) := + mul_well_defined (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) (reg_seq.is_reg v) H H2 + +definition rneg_well_defined {s t : reg_seq} (H : requiv s t) : requiv (-s) (-t) := + neg_well_defined H + +theorem requiv_is_equiv : equivalence requiv := + mk_equivalence requiv requiv.refl requiv.symm requiv.trans + +attribute [instance] +definition reg_seq.to_setoid : setoid reg_seq := + ⦃setoid, r := requiv, iseqv := requiv_is_equiv⦄ + +definition r_zero : reg_seq := + reg_seq.mk (zero) (zero_is_reg) + +definition r_one : reg_seq := + reg_seq.mk (one) (one_is_reg) + +theorem r_add_comm (s t : reg_seq) : requiv (s + t) (t + s) := + s_add_comm (reg_seq.sq s) (reg_seq.sq t) + +theorem r_add_assoc (s t u : reg_seq) : requiv (s + t + u) (s + (t + u)) := + s_add_assoc (reg_seq.sq s) (reg_seq.sq t) (reg_seq.sq u) (reg_seq.is_reg s) (reg_seq.is_reg u) + +theorem r_zero_add (s : reg_seq) : requiv (r_zero + s) s := + s_zero_add (reg_seq.sq s) (reg_seq.is_reg s) + +theorem r_add_zero (s : reg_seq) : requiv (s + r_zero) s := + s_add_zero (reg_seq.sq s) (reg_seq.is_reg s) + +theorem r_neg_cancel (s : reg_seq) : requiv (-s + s) r_zero := + s_neg_cancel (reg_seq.sq s) (reg_seq.is_reg s) + +theorem r_mul_comm (s t : reg_seq) : requiv (s * t) (t * s) := + s_mul_comm (reg_seq.sq s) (reg_seq.sq t) + +theorem r_mul_assoc (s t u : reg_seq) : requiv (s * t * u) (s * (t * u)) := + s_mul_assoc (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) + +theorem r_mul_one (s : reg_seq) : requiv (s * r_one) s := + s_mul_one (reg_seq.is_reg s) + +theorem r_one_mul (s : reg_seq) : requiv (r_one * s) s := + s_one_mul (reg_seq.is_reg s) + +theorem r_distrib (s t u : reg_seq) : requiv (s * (t + u)) (s * t + s * u) := + s_distrib (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) + +theorem r_zero_nequiv_one : ¬ requiv r_zero r_one := + zero_nequiv_one + +definition r_const (a : ℚ) : reg_seq := reg_seq.mk (const a) (const_reg a) + +theorem r_add_consts (a b : ℚ) : requiv (r_const a + r_const b) (r_const (a + b)) := add_consts a b + +theorem r_mul_consts (a b : ℚ) : requiv (r_const a * r_const b) (r_const (a * b)) := mul_consts a b + +theorem r_neg_const (a : ℚ) : requiv (-r_const a) (r_const (-a)) := neg_const a + +end rat_seq +---------------------------------------------- +-- take quotients to get ℝ and show it's a comm ring + +open rat_seq +definition real := quot reg_seq.to_setoid +namespace real +notation `ℝ` := real + +protected definition prio := num.pred rat.prio + +protected definition add (x y : ℝ) : ℝ := + (quot.lift_on₂ x y (λ a b, quot.mk (a + b)) + (take a b c d : reg_seq, take Hab : requiv a c, take Hcd : requiv b d, + quot.sound (radd_well_defined Hab Hcd))) + +--infix [priority real.prio] + := add + +protected definition mul (x y : ℝ) : ℝ := + (quot.lift_on₂ x y (λ a b, quot.mk (a * b)) + (take a b c d : reg_seq, take Hab : requiv a c, take Hcd : requiv b d, + quot.sound (rmul_well_defined Hab Hcd))) +--infix [priority real.prio] * := mul + +protected definition neg (x : ℝ) : ℝ := + (quot.lift_on x (λ a, quot.mk (-a)) (take a b : reg_seq, take Hab : requiv a b, + quot.sound (rneg_well_defined Hab))) +--prefix [priority real.prio] `-` := neg + +attribute [instance, priority real.prio] +definition real_has_add : has_add real := +has_add.mk real.add + +attribute [instance, priority real.prio] +definition real_has_mul : has_mul real := +has_mul.mk real.mul + +attribute [instance, priority real.prio] +definition real_has_neg : has_neg real := +has_neg.mk real.neg + +attribute [reducible] +protected definition sub (a b : ℝ) : real := a + (-b) + +attribute [instance, priority real.prio] +definition real_has_sub : has_sub real := +has_sub.mk real.sub + +open rat -- no coercions before + +-- definition of_rat [coercion] (a : ℚ) : ℝ := quot.mk (r_const a) +-- definition of_int [coercion] (i : ℤ) : ℝ := i +-- definition of_nat [coercion] (n : ℕ) : ℝ := n +-- definition of_num [coercion] [reducible] (n : num) : ℝ := of_rat (rat.of_num n) + +attribute [reducible] +definition real_has_zero : has_zero real := has_zero.mk (of_rat 0) +local attribute real_has_zero [instance, priority real.prio] + +attribute [reducible] +definition real_has_one : has_one real := has_one.mk (of_rat 1) +local attribute real_has_one [instance, priority real.prio] + +theorem real_zero_eq_rat_zero : (0:real) = of_rat (0:rat) := +rfl + +theorem real_one_eq_rat_one : (1:real) = of_rat (1:rat) := +rfl + +protected theorem add_comm (x y : ℝ) : x + y = y + x := + quot.induction_on₂ x y (λ s t, quot.sound (r_add_comm s t)) + +protected theorem add_assoc (x y z : ℝ) : x + y + z = x + (y + z) := + quot.induction_on₃ x y z (λ s t u, quot.sound (r_add_assoc s t u)) + +protected theorem zero_add (x : ℝ) : 0 + x = x := + quot.induction_on x (λ s, quot.sound (r_zero_add s)) + +protected theorem add_zero (x : ℝ) : x + 0 = x := + quot.induction_on x (λ s, quot.sound (r_add_zero s)) + +protected theorem neg_cancel (x : ℝ) : -x + x = 0 := + quot.induction_on x (λ s, quot.sound (r_neg_cancel s)) + +protected theorem mul_assoc (x y z : ℝ) : x * y * z = x * (y * z) := + quot.induction_on₃ x y z (λ s t u, quot.sound (r_mul_assoc s t u)) + +protected theorem mul_comm (x y : ℝ) : x * y = y * x := + quot.induction_on₂ x y (λ s t, quot.sound (r_mul_comm s t)) + +protected theorem one_mul (x : ℝ) : 1 * x = x := + quot.induction_on x (λ s, quot.sound (r_one_mul s)) + +protected theorem mul_one (x : ℝ) : x * 1 = x := + quot.induction_on x (λ s, quot.sound (r_mul_one s)) + +protected theorem left_distrib (x y z : ℝ) : x * (y + z) = x * y + x * z := + quot.induction_on₃ x y z (λ s t u, quot.sound (r_distrib s t u)) + +protected theorem right_distrib (x y z : ℝ) : (x + y) * z = x * z + y * z := + by rewrite [real.mul_comm, real.left_distrib, {x * _}real.mul_comm, {y * _}real.mul_comm] + +protected theorem zero_ne_one : ¬ (0 : ℝ) = 1 := + take H : 0 = 1, + absurd (quot.exact H) (r_zero_nequiv_one) + +attribute [reducible] +protected definition comm_ring : comm_ring ℝ := + begin + fapply comm_ring.mk, + exact real.add, + exact real.add_assoc, + exact 0, + exact real.zero_add, + exact real.add_zero, + exact real.neg, + exact real.neg_cancel, + exact real.add_comm, + exact real.mul, + exact real.mul_assoc, + apply 1, + apply real.one_mul, + apply real.mul_one, + apply real.left_distrib, + apply real.right_distrib, + apply real.mul_comm + end + +theorem of_int_eq (a : ℤ) : of_int a = of_rat (rat.of_int a) := rfl + +theorem of_nat_eq (a : ℕ) : of_nat a = of_rat (rat.of_nat a) := rfl + +theorem of_rat.inj {x y : ℚ} (H : of_rat x = of_rat y) : x = y := +eq_of_const_equiv (quot.exact H) + +theorem eq_of_of_rat_eq_of_rat {x y : ℚ} (H : of_rat x = of_rat y) : x = y := +of_rat.inj H + +theorem of_rat_eq_of_rat_iff (x y : ℚ) : of_rat x = of_rat y ↔ x = y := +iff.intro eq_of_of_rat_eq_of_rat !congr_arg + +theorem of_int.inj {a b : ℤ} (H : of_int a = of_int b) : a = b := +rat.of_int.inj (of_rat.inj H) + +theorem eq_of_of_int_eq_of_int {a b : ℤ} (H : of_int a = of_int b) : a = b := +of_int.inj H + +theorem of_int_eq_of_int_iff (a b : ℤ) : of_int a = of_int b ↔ a = b := +iff.intro of_int.inj !congr_arg + +theorem of_nat.inj {a b : ℕ} (H : of_nat a = of_nat b) : a = b := +int.of_nat.inj (of_int.inj H) + +theorem eq_of_of_nat_eq_of_nat {a b : ℕ} (H : of_nat a = of_nat b) : a = b := +of_nat.inj H + +theorem of_nat_eq_of_nat_iff (a b : ℕ) : of_nat a = of_nat b ↔ a = b := +iff.intro of_nat.inj !congr_arg + +theorem of_rat_add (a b : ℚ) : of_rat (a + b) = of_rat a + of_rat b := + quot.sound (r_add_consts a b) + +theorem of_rat_neg (a : ℚ) : of_rat (-a) = -of_rat a := + eq.symm (quot.sound (r_neg_const a)) + +theorem of_rat_mul (a b : ℚ) : of_rat (a * b) = of_rat a * of_rat b := + quot.sound (r_mul_consts a b) + +theorem of_rat_zero : of_rat 0 = 0 := rfl + +theorem of_rat_one : of_rat 1 = 1 := rfl + +open int + +theorem of_int_add (a b : ℤ) : of_int (a + b) = of_int a + of_int b := + by rewrite [of_int_eq, rat.of_int_add, of_rat_add] + +theorem of_int_neg (a : ℤ) : of_int (-a) = -of_int a := + by rewrite [of_int_eq, rat.of_int_neg, of_rat_neg] + +theorem of_int_mul (a b : ℤ) : of_int (a * b) = of_int a * of_int b := + by rewrite [of_int_eq, rat.of_int_mul, of_rat_mul] + +theorem of_nat_add (a b : ℕ) : of_nat (a + b) = of_nat a + of_nat b := + by rewrite [of_nat_eq, rat.of_nat_add, of_rat_add] + +theorem of_nat_mul (a b : ℕ) : of_nat (a * b) = of_nat a * of_nat b := + by rewrite [of_nat_eq, rat.of_nat_mul, of_rat_mul] + +theorem add_half_of_rat (n : ℕ+) : of_rat (2 * n)⁻¹ + of_rat (2 * n)⁻¹ = of_rat (n⁻¹) := + by rewrite [-of_rat_add, pnat.add_halves] + +theorem one_add_one : 1 + 1 = (2 : ℝ) := rfl + +end real diff --git a/old_library/data/real/complete.lean b/old_library/data/real/complete.lean new file mode 100644 index 0000000000..e56255bb60 --- /dev/null +++ b/old_library/data/real/complete.lean @@ -0,0 +1,1004 @@ +/- +Copyright (c) 2015 Robert Y. Lewis. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Robert Y. Lewis +The real numbers, constructed as equivalence classes of Cauchy sequences of rationals. +This construction follows Bishop and Bridges (1985). + +At this point, we no longer proceed constructively: this file makes heavy use of decidability, +excluded middle, and Hilbert choice. Two sets of definitions of Cauchy sequences, convergence, +etc are available in the libray, one with rates and one without. The definitions here, with rates, + are amenable to be used constructively if and when that development takes place. The second set of +definitions available in /library/theories/analysis/metric_space.lean are the usual classical ones. + +Here, we show that ℝ is complete. The proofs of Cauchy completeness and the supremum property +are independent of each other. +-/ + +import data.real.basic data.real.order data.real.division data.rat data.nat data.pnat +open rat +local postfix ⁻¹ := pnat.inv +open eq.ops pnat classical + +namespace rat_seq + +theorem rat_approx {s : seq} (H : regular s) : + ∀ n : ℕ+, ∃ q : ℚ, ∃ N : ℕ+, ∀ m : ℕ+, m ≥ N → abs (s m - q) ≤ n⁻¹ := + begin + intro n, + existsi (s (2 * n)), + existsi 2 * n, + intro m Hm, + apply le.trans, + apply H, + rewrite -(pnat.add_halves n), + apply add_le_add_right, + apply inv_ge_of_le Hm + end + +theorem rat_approx_seq {s : seq} (H : regular s) : + ∀ n : ℕ+, ∃ q : ℚ, s_le (s_abs (sadd s (sneg (const q)))) (const n⁻¹) := + begin + intro m, + rewrite ↑s_le, + cases rat_approx H m with [q, Hq], + cases Hq with [N, HN], + existsi q, + apply nonneg_of_bdd_within, + repeat (apply reg_add_reg | apply reg_neg_reg | apply abs_reg_of_reg | apply const_reg + | assumption), + intro n, + existsi N, + intro p Hp, + rewrite ↑[sadd, sneg, s_abs, const], + apply le.trans, + rotate 1, + rewrite -sub_eq_add_neg, + apply sub_le_sub_left, + apply HN, + apply pnat.le_trans, + apply Hp, + rewrite -*pnat.mul_assoc, + apply pnat.mul_le_mul_left, + rewrite [sub_self, -neg_zero], + apply neg_le_neg, + apply rat.le_of_lt, + apply pnat.inv_pos + end + +theorem r_rat_approx (s : reg_seq) : + ∀ n : ℕ+, ∃ q : ℚ, r_le (r_abs (radd s (rneg (r_const q)))) (r_const n⁻¹) := + rat_approx_seq (reg_seq.is_reg s) + +theorem const_bound {s : seq} (Hs : regular s) (n : ℕ+) : + s_le (s_abs (sadd s (sneg (const (s n))))) (const n⁻¹) := + begin + rewrite ↑[s_le, nonneg, s_abs, sadd, sneg, const], + intro m, + rewrite -sub_eq_add_neg, + apply iff.mp !le_add_iff_neg_le_sub_left, + apply le.trans, + apply Hs, + apply add_le_add_right, + rewrite -*pnat.mul_assoc, + apply inv_ge_of_le, + apply pnat.mul_le_mul_left + end + +theorem abs_const (a : ℚ) : const (abs a) ≡ s_abs (const a) := + by apply equiv.refl + +theorem r_abs_const (a : ℚ) : requiv (r_const (abs a) ) (r_abs (r_const a)) := abs_const a + +theorem equiv_abs_of_ge_zero {s : seq} (Hs : regular s) (Hz : s_le zero s) : s_abs s ≡ s := + begin + apply eq_of_bdd, + apply abs_reg_of_reg Hs, + apply Hs, + intro j, + rewrite ↑s_abs, + let Hz' := s_nonneg_of_ge_zero Hs Hz, + existsi 2 * j, + intro n Hn, + cases em (s n ≥ 0) with [Hpos, Hneg], + rewrite [abs_of_nonneg Hpos, sub_self, abs_zero], + apply rat.le_of_lt, + apply pnat.inv_pos, + let Hneg' := lt_of_not_ge Hneg, + have Hsn : -s n - s n > 0, from add_pos (neg_pos_of_neg Hneg') (neg_pos_of_neg Hneg'), + rewrite [abs_of_neg Hneg', abs_of_pos Hsn], + apply le.trans, + apply add_le_add, + repeat (apply neg_le_neg; apply Hz'), + rewrite neg_neg, + apply le.trans, + apply add_le_add, + repeat (apply inv_ge_of_le; apply Hn), + krewrite pnat.add_halves, + end + +theorem equiv_neg_abs_of_le_zero {s : seq} (Hs : regular s) (Hz : s_le s zero) : s_abs s ≡ sneg s := + begin + apply eq_of_bdd, + apply abs_reg_of_reg Hs, + apply reg_neg_reg Hs, + intro j, + rewrite [↑s_abs, ↑s_le at Hz], + have Hz' : nonneg (sneg s), begin + apply nonneg_of_nonneg_equiv, + rotate 3, + apply Hz, + rotate 2, + apply s_zero_add, + repeat (apply Hs | apply zero_is_reg | apply reg_neg_reg | apply reg_add_reg) + end, + existsi 2 * j, + intro n Hn, + cases em (s n ≥ 0) with [Hpos, Hneg], + have Hsn : s n + s n ≥ 0, from add_nonneg Hpos Hpos, + rewrite [abs_of_nonneg Hpos, ↑sneg, sub_neg_eq_add, abs_of_nonneg Hsn], + rewrite [↑nonneg at Hz', ↑sneg at Hz'], + apply le.trans, + apply add_le_add, + repeat apply (le_of_neg_le_neg !Hz'), + apply le.trans, + apply add_le_add, + repeat (apply inv_ge_of_le; apply Hn), + krewrite pnat.add_halves, + let Hneg' := lt_of_not_ge Hneg, + rewrite [abs_of_neg Hneg', ↑sneg, sub_neg_eq_add, neg_add_eq_sub, sub_self, + abs_zero], + apply rat.le_of_lt, + apply pnat.inv_pos + end + +theorem r_equiv_abs_of_ge_zero {s : reg_seq} (Hz : r_le r_zero s) : requiv (r_abs s) s := + equiv_abs_of_ge_zero (reg_seq.is_reg s) Hz + +theorem r_equiv_neg_abs_of_le_zero {s : reg_seq} (Hz : r_le s r_zero) : requiv (r_abs s) (-s) := + equiv_neg_abs_of_le_zero (reg_seq.is_reg s) Hz + +end rat_seq + +namespace real +open [class] rat_seq + +private theorem rewrite_helper9 (a b c : ℝ) : b - c = (b - a) - (c - a) := + by rewrite [-sub_add_eq_sub_sub_swap, sub_add_cancel] + +private theorem rewrite_helper10 (a b c d : ℝ) : c - d = (c - a) + (a - b) + (b - d) := + by rewrite [*add_sub, *sub_add_cancel] + +noncomputable definition rep (x : ℝ) : rat_seq.reg_seq := some (quot.exists_rep x) + +definition re_abs (x : ℝ) : ℝ := + quot.lift_on x (λ a, quot.mk (rat_seq.r_abs a)) + (take a b Hab, quot.sound (rat_seq.r_abs_well_defined Hab)) + +theorem r_abs_nonneg {x : ℝ} : zero ≤ x → re_abs x = x := + quot.induction_on x (λ a Ha, quot.sound (rat_seq.r_equiv_abs_of_ge_zero Ha)) + +theorem r_abs_nonpos {x : ℝ} : x ≤ zero → re_abs x = -x := + quot.induction_on x (λ a Ha, quot.sound (rat_seq.r_equiv_neg_abs_of_le_zero Ha)) + +private theorem abs_const' (a : ℚ) : of_rat (abs a) = re_abs (of_rat a) := + quot.sound (rat_seq.r_abs_const a) + +private theorem re_abs_is_abs : re_abs = abs := funext + (begin + intro x, + apply eq.symm, + cases em (zero ≤ x) with [Hor1, Hor2], + rewrite [abs_of_nonneg Hor1, r_abs_nonneg Hor1], + have Hor2' : x ≤ zero, from le_of_lt (lt_of_not_ge Hor2), + rewrite [abs_of_neg (lt_of_not_ge Hor2), r_abs_nonpos Hor2'] + end) + +theorem abs_const (a : ℚ) : of_rat (abs a) = abs (of_rat a) := + by rewrite -re_abs_is_abs + +private theorem rat_approx' (x : ℝ) : ∀ n : ℕ+, ∃ q : ℚ, re_abs (x - of_rat q) ≤ of_rat n⁻¹ := + quot.induction_on x (λ s n, rat_seq.r_rat_approx s n) + +theorem rat_approx (x : ℝ) : ∀ n : ℕ+, ∃ q : ℚ, abs (x - of_rat q) ≤ of_rat n⁻¹ := + by rewrite -re_abs_is_abs; apply rat_approx' + +noncomputable definition approx (x : ℝ) (n : ℕ+) := some (rat_approx x n) + +theorem approx_spec (x : ℝ) (n : ℕ+) : abs (x - (of_rat (approx x n))) ≤ of_rat n⁻¹ := + some_spec (rat_approx x n) + +theorem approx_spec' (x : ℝ) (n : ℕ+) : abs ((of_rat (approx x n)) - x) ≤ of_rat n⁻¹ := + by rewrite abs_sub; apply approx_spec + +theorem ex_rat_pos_lower_bound_of_pos {x : ℝ} (H : x > 0) : ∃ q : ℚ, q > 0 ∧ of_rat q ≤ x := + if Hgeo : x ≥ 1 then + exists.intro 1 (and.intro zero_lt_one Hgeo) + else + have Hdp : 1 / x > 0, from one_div_pos_of_pos H, + begin + cases rat_approx (1 / x) 2 with q Hq, + have Hqp : q > 0, begin + apply lt_of_not_ge, + intro Hq2, + note Hx' := one_div_lt_one_div_of_lt H (lt_of_not_ge Hgeo), + rewrite div_one at Hx', + have Horqn : of_rat q ≤ 0, begin + krewrite -of_rat_zero, + apply of_rat_le_of_rat_of_le Hq2 + end, + have Hgt1 : 1 / x - of_rat q > 1, from calc + 1 / x - of_rat q = 1 / x + -of_rat q : sub_eq_add_neg + ... ≥ 1 / x : le_add_of_nonneg_right (neg_nonneg_of_nonpos Horqn) + ... > 1 : Hx', + have Hpos : 1 / x - of_rat q > 0, from gt.trans Hgt1 zero_lt_one, + rewrite [abs_of_pos Hpos at Hq], + apply not_le_of_gt Hgt1, + apply le.trans, + apply Hq, + krewrite -of_rat_one, + apply of_rat_le_of_rat_of_le, + apply inv_le_one + end, + existsi 1 / (2⁻¹ + q), + split, + apply div_pos_of_pos_of_pos, + exact zero_lt_one, + apply add_pos, + apply pnat.inv_pos, + exact Hqp, + note Hle2 := sub_le_of_abs_sub_le_right Hq, + note Hle3 := le_add_of_sub_left_le Hle2, + note Hle4 := one_div_le_of_one_div_le_of_pos H Hle3, + rewrite [of_rat_divide, of_rat_add], + exact Hle4 + end + +theorem ex_rat_neg_upper_bound_of_neg {x : ℝ} (H : x < 0) : ∃ q : ℚ, q < 0 ∧ x ≤ of_rat q := + have H' : -x > 0, from neg_pos_of_neg H, + obtain q [Hq1 Hq2], from ex_rat_pos_lower_bound_of_pos H', + exists.intro (-q) (and.intro + (neg_neg_of_pos Hq1) + (le_neg_of_le_neg Hq2)) + +notation `r_seq` := ℕ+ → ℝ + +noncomputable definition converges_to_with_rate (X : r_seq) (a : ℝ) (N : ℕ+ → ℕ+) := + ∀ k : ℕ+, ∀ n : ℕ+, n ≥ N k → abs (X n - a) ≤ of_rat k⁻¹ + +noncomputable definition cauchy_with_rate (X : r_seq) (M : ℕ+ → ℕ+) := + ∀ k : ℕ+, ∀ m n : ℕ+, m ≥ M k → n ≥ M k → abs (X m - X n) ≤ of_rat k⁻¹ + +theorem cauchy_with_rate_of_converges_to_with_rate {X : r_seq} {a : ℝ} {N : ℕ+ → ℕ+} + (Hc : converges_to_with_rate X a N) : + cauchy_with_rate X (λ k, N (2 * k)) := + begin + intro k m n Hm Hn, + rewrite (rewrite_helper9 a), + apply le.trans, + apply abs_add_le_abs_add_abs, + apply le.trans, + apply add_le_add, + apply Hc, + apply Hm, + krewrite abs_neg, + apply Hc, + apply Hn, + xrewrite -of_rat_add, + apply of_rat_le_of_rat_of_le, + krewrite pnat.add_halves, + end + +private definition Nb (M : ℕ+ → ℕ+) := λ k, pnat.max (3 * k) (M (2 * k)) + +private theorem Nb_spec_right (M : ℕ+ → ℕ+) (k : ℕ+) : M (2 * k) ≤ Nb M k := !pnat.max_right + +private theorem Nb_spec_left (M : ℕ+ → ℕ+) (k : ℕ+) : 3 * k ≤ Nb M k := !pnat.max_left + +section lim_seq +parameter {X : r_seq} +parameter {M : ℕ+ → ℕ+} +hypothesis Hc : cauchy_with_rate X M +include Hc + +noncomputable definition lim_seq : ℕ+ → ℚ := + λ k, approx (X (Nb M k)) (2 * k) + +private theorem lim_seq_reg_helper {m n : ℕ+} (Hmn : M (2 * n) ≤M (2 * m)) : + abs (of_rat (lim_seq m) - X (Nb M m)) + abs (X (Nb M m) - X (Nb M n)) + abs + (X (Nb M n) - of_rat (lim_seq n)) ≤ of_rat (m⁻¹ + n⁻¹) := + begin + apply le.trans, + apply add_le_add_three, + apply approx_spec', + rotate 1, + apply approx_spec, + rotate 1, + apply Hc, + rotate 1, + apply Nb_spec_right, + rotate 1, + apply pnat.le_trans, + apply Hmn, + apply Nb_spec_right, + krewrite [-+of_rat_add], + change of_rat ((2 * m)⁻¹ + (2 * n)⁻¹ + (2 * n)⁻¹) ≤ of_rat (m⁻¹ + n⁻¹), + rewrite [add.assoc], + krewrite pnat.add_halves, + apply of_rat_le_of_rat_of_le, + apply add_le_add_right, + apply inv_ge_of_le, + apply pnat.mul_le_mul_left + end + +theorem lim_seq_reg : rat_seq.regular lim_seq := + begin + rewrite ↑rat_seq.regular, + intro m n, + apply le_of_of_rat_le_of_rat, + rewrite [abs_const, of_rat_sub, (rewrite_helper10 (X (Nb M m)) (X (Nb M n)))], + apply le.trans, + apply abs_add_three, + cases em (M (2 * m) ≥ M (2 * n)) with [Hor1, Hor2], + apply lim_seq_reg_helper Hor1, + let Hor2' := pnat.le_of_lt (pnat.lt_of_not_le Hor2), + krewrite [abs_sub (X (Nb M n)), abs_sub (X (Nb M m)), abs_sub, + rat.add_comm, add_comm_three], + apply lim_seq_reg_helper Hor2' + end + +theorem lim_seq_spec (k : ℕ+) : + rat_seq.s_le (rat_seq.s_abs (rat_seq.sadd lim_seq + (rat_seq.sneg (rat_seq.const (lim_seq k))))) (rat_seq.const k⁻¹) := + by apply rat_seq.const_bound; apply lim_seq_reg + +private noncomputable definition r_lim_seq : rat_seq.reg_seq := + rat_seq.reg_seq.mk lim_seq lim_seq_reg + +private theorem r_lim_seq_spec (k : ℕ+) : rat_seq.r_le + (rat_seq.r_abs ((rat_seq.radd r_lim_seq (rat_seq.rneg + (rat_seq.r_const ((rat_seq.reg_seq.sq r_lim_seq) k)))))) + (rat_seq.r_const k⁻¹) := + lim_seq_spec k + +noncomputable definition lim : ℝ := + quot.mk r_lim_seq + +theorem re_lim_spec (k : ℕ+) : re_abs (lim - (of_rat (lim_seq k))) ≤ of_rat k⁻¹ := + r_lim_seq_spec k + +theorem lim_spec' (k : ℕ+) : abs (lim - (of_rat (lim_seq k))) ≤ of_rat k⁻¹ := + by rewrite -re_abs_is_abs; apply re_lim_spec + +theorem lim_spec (k : ℕ+) : + abs ((of_rat (lim_seq k)) - lim) ≤ of_rat k⁻¹ := + by rewrite abs_sub; apply lim_spec' + +theorem converges_to_with_rate_of_cauchy_with_rate : converges_to_with_rate X lim (Nb M) := + begin + intro k n Hn, + rewrite (rewrite_helper10 (X (Nb M n)) (of_rat (lim_seq n))), + apply le.trans, + apply abs_add_three, + apply le.trans, + apply add_le_add_three, + apply Hc, + apply pnat.le_trans, + rotate 1, + apply Hn, + rotate_right 1, + apply Nb_spec_right, + have HMk : M (2 * k) ≤ Nb M n, begin + apply pnat.le_trans, + apply Nb_spec_right, + apply pnat.le_trans, + apply Hn, + apply pnat.le_trans, + apply pnat.mul_le_mul_left 3, + apply Nb_spec_left + end, + apply HMk, + rewrite ↑lim_seq, + apply approx_spec, + apply lim_spec, + krewrite [-+of_rat_add], + change of_rat ((2 * k)⁻¹ + (2 * n)⁻¹ + n⁻¹) ≤ of_rat k⁻¹, + apply of_rat_le_of_rat_of_le, + apply le.trans, + apply add_le_add_three, + apply rat.le_refl, + apply inv_ge_of_le, + apply pnat_mul_le_mul_left', + apply pnat.le_trans, + rotate 1, + apply Hn, + rotate_right 1, + apply Nb_spec_left, + apply inv_ge_of_le, + apply pnat.le_trans, + rotate 1, + apply Hn, + rotate_right 1, + apply Nb_spec_left, + rewrite -*pnat.mul_assoc, + krewrite pnat.p_add_fractions, + end + +end lim_seq +------------------------------------------- +-- int embedding theorems +-- archimedean properties, integer floor and ceiling +section ints + +open int + +theorem archimedean_upper (x : ℝ) : ∃ z : ℤ, x ≤ of_int z := + begin + apply quot.induction_on x, + intro s, + cases rat_seq.bdd_of_regular (rat_seq.reg_seq.is_reg s) with [b, Hb], + existsi ubound b, + have H : rat_seq.s_le (rat_seq.reg_seq.sq s) (rat_seq.const (rat.of_nat (ubound b))), begin + apply rat_seq.s_le_of_le_pointwise (rat_seq.reg_seq.is_reg s), + apply rat_seq.const_reg, + intro n, + apply rat.le_trans, + apply Hb, + apply ubound_ge + end, + apply H + end + +theorem archimedean_upper_strict (x : ℝ) : ∃ z : ℤ, x < of_int z := + begin + cases archimedean_upper x with [z, Hz], + existsi z + 1, + apply lt_of_le_of_lt, + apply Hz, + apply of_int_lt_of_int_of_lt, + apply lt_add_of_pos_right, + apply dec_trivial + end + +theorem archimedean_lower (x : ℝ) : ∃ z : ℤ, x ≥ of_int z := + begin + cases archimedean_upper (-x) with [z, Hz], + existsi -z, + rewrite [of_int_neg], + apply iff.mp !neg_le_iff_neg_le Hz + end + +theorem archimedean_lower_strict (x : ℝ) : ∃ z : ℤ, x > of_int z := + begin + cases archimedean_upper_strict (-x) with [z, Hz], + existsi -z, + rewrite [of_int_neg], + apply iff.mp !neg_lt_iff_neg_lt Hz + end + +private definition ex_floor (x : ℝ) := + (@exists_greatest_of_bdd (λ z, x ≥ of_int z) _ + (begin + existsi some (archimedean_upper_strict x), + let Har := some_spec (archimedean_upper_strict x), + intros z Hz, + apply not_le_of_gt, + apply lt_of_lt_of_le, + apply Har, + have H : of_int (some (archimedean_upper_strict x)) ≤ of_int z, begin + apply of_int_le_of_int_of_le, + apply Hz + end, + exact H + end) + (by existsi some (archimedean_lower x); apply some_spec (archimedean_lower x))) + +noncomputable definition floor (x : ℝ) : ℤ := + some (ex_floor x) + +noncomputable definition ceil (x : ℝ) : ℤ := - floor (-x) + +theorem floor_le (x : ℝ) : floor x ≤ x := + and.left (some_spec (ex_floor x)) + +theorem lt_of_floor_lt {x : ℝ} {z : ℤ} (Hz : floor x < z) : x < z := + begin + apply lt_of_not_ge, + cases some_spec (ex_floor x), + apply a_1 _ Hz + end + +theorem le_ceil (x : ℝ) : x ≤ ceil x := + begin + rewrite [↑ceil, of_int_neg], + apply iff.mp !le_neg_iff_le_neg, + apply floor_le + end + +theorem lt_of_lt_ceil {x : ℝ} {z : ℤ} (Hz : z < ceil x) : z < x := + begin + rewrite ↑ceil at Hz, + note Hz' := lt_of_floor_lt (iff.mp !lt_neg_iff_lt_neg Hz), + rewrite [of_int_neg at Hz'], + apply lt_of_neg_lt_neg Hz' + end + +theorem floor_succ (x : ℝ) : floor (x + 1) = floor x + 1 := + begin + apply by_contradiction, + intro H, + cases lt_or_gt_of_ne H with [Hgt, Hlt], + note Hl := lt_of_floor_lt Hgt, + rewrite [of_int_add at Hl], + apply not_le_of_gt (lt_of_add_lt_add_right Hl) !floor_le, + note Hl := lt_of_floor_lt (iff.mp !add_lt_iff_lt_sub_right Hlt), + rewrite [of_int_sub at Hl], + apply not_le_of_gt (iff.mpr !add_lt_iff_lt_sub_right Hl) !floor_le + end + +theorem floor_sub_one_lt_floor (x : ℝ) : floor (x - 1) < floor x := + begin + + apply @lt_of_add_lt_add_right ℤ _ _ 1, + rewrite [-floor_succ (x - 1), sub_add_cancel], + apply lt_add_of_pos_right dec_trivial + end + +theorem ceil_lt_ceil_succ (x : ℝ) : ceil x < ceil (x + 1) := + begin + rewrite [↑ceil, neg_add], + apply neg_lt_neg, + apply floor_sub_one_lt_floor + end +open nat + +theorem archimedean_small {ε : ℝ} (H : ε > 0) : ∃ (n : ℕ), 1 / succ n < ε := +let n := int.nat_abs (ceil (2 / ε)) in +have int.of_nat n ≥ ceil (2 / ε), + by rewrite of_nat_nat_abs; apply le_abs_self, +have int.of_nat (succ n) ≥ ceil (2 / ε), + begin apply le.trans, exact this, apply int.of_nat_le_of_nat_of_le, apply le_succ end, +have H₁ : int.succ n ≥ ceil (2 / ε), from of_int_le_of_int_of_le this, +have H₂ : succ n ≥ 2 / ε, from !le.trans !le_ceil H₁, +have H₃ : 2 / ε > 0, from div_pos_of_pos_of_pos two_pos H, +have 1 / succ n < ε, from calc + 1 / succ n ≤ 1 / (2 / ε) : one_div_le_one_div_of_le H₃ H₂ + ... = ε / 2 : one_div_div + ... < ε : div_two_lt_of_pos H, +exists.intro n this + +end ints +-------------------------------------------------- +-- supremum property +-- this development roughly follows the proof of completeness done in Isabelle. +-- It does not depend on the previous proof of Cauchy completeness. Much of the same +-- machinery can be used to show that Cauchy completeness implies the supremum property. + +section supremum +open prod nat +local postfix `~` := nat_of_pnat + +-- The top part of this section could be refactored. What is the appropriate place to define +-- bounds, supremum, etc? In algebra/ordered_field? They potentially apply to more than just ℝ. +parameter X : ℝ → Prop + +definition ub (x : ℝ) := ∀ y : ℝ, X y → y ≤ x +definition is_sup (x : ℝ) := ub x ∧ ∀ y : ℝ, ub y → x ≤ y + +definition lb (x : ℝ) := ∀ y : ℝ, X y → x ≤ y +definition is_inf (x : ℝ) := lb x ∧ ∀ y : ℝ, lb y → y ≤ x + +parameter elt : ℝ +hypothesis inh : X elt +parameter bound : ℝ +hypothesis bdd : ub bound + +include inh bdd + +private definition avg (a b : ℚ) := a / 2 + b / 2 + +private noncomputable definition bisect (ab : ℚ × ℚ) := + if ub (avg (pr1 ab) (pr2 ab)) then + (pr1 ab, (avg (pr1 ab) (pr2 ab))) + else + (avg (pr1 ab) (pr2 ab), pr2 ab) + +private noncomputable definition under : ℚ := rat.of_int (floor (elt - 1)) + +private theorem under_spec1 : of_rat under < elt := + have H : of_rat under < of_int (floor elt), begin + apply of_int_lt_of_int_of_lt, + apply floor_sub_one_lt_floor + end, + lt_of_lt_of_le H !floor_le + +private theorem under_spec : ¬ ub under := + begin + rewrite ↑ub, + apply not_forall_of_exists_not, + existsi elt, + apply iff.mpr !not_implies_iff_and_not, + apply and.intro, + apply inh, + apply not_le_of_gt under_spec1 + end + +private noncomputable definition over : ℚ := rat.of_int (ceil (bound + 1)) -- b + +private theorem over_spec1 : bound < of_rat over := + have H : of_int (ceil bound) < of_rat over, begin + apply of_int_lt_of_int_of_lt, + apply ceil_lt_ceil_succ + end, + lt_of_le_of_lt !le_ceil H + +private theorem over_spec : ub over := + begin + rewrite ↑ub, + intro y Hy, + apply le_of_lt, + apply lt_of_le_of_lt, + apply bdd, + apply Hy, + apply over_spec1 + end + +private noncomputable definition under_seq := λ n : ℕ, pr1 (iterate bisect n (under, over)) -- A + +private noncomputable definition over_seq := λ n : ℕ, pr2 (iterate bisect n (under, over)) -- B + +private noncomputable definition avg_seq := λ n : ℕ, avg (over_seq n) (under_seq n) -- C + +private theorem avg_symm (n : ℕ) : avg_seq n = avg (under_seq n) (over_seq n) := + by rewrite [↑avg_seq, ↑avg, add.comm] + +private theorem over_0 : over_seq 0 = over := rfl + +private theorem under_0 : under_seq 0 = under := rfl + +private theorem succ_helper (n : ℕ) : + avg (pr1 (iterate bisect n (under, over))) (pr2 (iterate bisect n (under, over))) = avg_seq n := + by rewrite avg_symm + +private theorem under_succ (n : ℕ) : under_seq (succ n) = + (if ub (avg_seq n) then under_seq n else avg_seq n) := + begin + cases em (ub (avg_seq n)) with [Hub, Hub], + rewrite [if_pos Hub], + have H : pr1 (bisect (iterate bisect n (under, over))) = under_seq n, by + rewrite [↑under_seq, ↑bisect at {2}, -succ_helper at Hub, if_pos Hub], + apply H, + rewrite [if_neg Hub], + have H : pr1 (bisect (iterate bisect n (under, over))) = avg_seq n, by + rewrite [↑bisect at {2}, -succ_helper at Hub, if_neg Hub, avg_symm], + apply H + end + +private theorem over_succ (n : ℕ) : over_seq (succ n) = + (if ub (avg_seq n) then avg_seq n else over_seq n) := + begin + cases em (ub (avg_seq n)) with [Hub, Hub], + rewrite [if_pos Hub], + have H : pr2 (bisect (iterate bisect n (under, over))) = avg_seq n, by + rewrite [↑bisect at {2}, -succ_helper at Hub, if_pos Hub, avg_symm], + apply H, + rewrite [if_neg Hub], + have H : pr2 (bisect (iterate bisect n (under, over))) = over_seq n, by + rewrite [↑over_seq, ↑bisect at {2}, -succ_helper at Hub, if_neg Hub], + apply H + end + +private theorem nat.zero_eq_0 : (zero : ℕ) = 0 := rfl + +private theorem width (n : ℕ) : over_seq n - under_seq n = (over - under) / ((2^n) : ℚ) := + nat.induction_on n + (by xrewrite [nat.zero_eq_0, over_0, under_0, pow_zero, div_one]) + (begin + intro a Ha, + rewrite [over_succ, under_succ], + let Hou := calc + (over_seq a) / 2 - (under_seq a) / 2 = ((over - under) / 2^a) / 2 : + by rewrite [div_sub_div_same, Ha] + ... = (over - under) / ((2^a) * 2) : by rewrite div_div_eq_div_mul + ... = (over - under) / 2^(a + 1) : by rewrite pow_add, + cases em (ub (avg_seq a)), + rewrite [*if_pos a_1, -add_one, -Hou, ↑avg_seq, ↑avg, sub_eq_add_neg, add.assoc, -sub_eq_add_neg, div_two_sub_self], + rewrite [*if_neg a_1, -add_one, -Hou, ↑avg_seq, ↑avg, sub_add_eq_sub_sub, + sub_self_div_two] + end) + +private theorem width_narrows : ∃ n : ℕ, over_seq n - under_seq n ≤ 1 := + begin + cases binary_bound (over - under) with [a, Ha], + existsi a, + rewrite (width a), + apply div_le_of_le_mul, + apply pow_pos dec_trivial, + rewrite rat.mul_one, + apply Ha + end + +private noncomputable definition over' := over_seq (some width_narrows) + +private noncomputable definition under' := under_seq (some width_narrows) + +private noncomputable definition over_seq' := λ n, over_seq (n + some width_narrows) + +private noncomputable definition under_seq' := λ n, under_seq (n + some width_narrows) + +private theorem over_seq'0 : over_seq' 0 = over' := + by rewrite [↑over_seq', nat.zero_add] + +private theorem under_seq'0 : under_seq' 0 = under' := + by rewrite [↑under_seq', nat.zero_add] + +private theorem under_over' : over' - under' ≤ 1 := some_spec width_narrows + +private theorem width' (n : ℕ) : over_seq' n - under_seq' n ≤ 1 / 2^n := + nat.induction_on n + (begin + xrewrite [nat.zero_eq_0, over_seq'0, under_seq'0, pow_zero, div_one], + apply under_over' + end) + (begin + intros a Ha, + rewrite [↑over_seq' at *, ↑under_seq' at *, *succ_add at *, width at *, + -add_one, -(add_one a), pow_add, pow_add _ a 1, *pow_one], + apply div_mul_le_div_mul_of_div_le_div_pos' Ha dec_trivial + end) + +private theorem PA (n : ℕ) : ¬ ub (under_seq n) := + nat.induction_on n + (by rewrite under_0; apply under_spec) + (begin + intro a Ha, + rewrite under_succ, + cases em (ub (avg_seq a)), + rewrite (if_pos a_1), + assumption, + rewrite (if_neg a_1), + assumption + end) + +private theorem PB (n : ℕ) : ub (over_seq n) := + nat.induction_on n + (by rewrite over_0; apply over_spec) + (begin + intro a Ha, + rewrite over_succ, + cases em (ub (avg_seq a)), + rewrite (if_pos a_1), + assumption, + rewrite (if_neg a_1), + assumption + end) + +private theorem under_lt_over : under < over := + begin + cases exists_not_of_not_forall under_spec with [x, Hx], + cases and_not_of_not_implies Hx with [HXx, Hxu], + apply lt_of_of_rat_lt_of_rat, + apply lt_of_lt_of_le, + apply lt_of_not_ge Hxu, + apply over_spec _ HXx + end + +private theorem under_seq_lt_over_seq : ∀ m n : ℕ, under_seq m < over_seq n := + begin + intros, + cases exists_not_of_not_forall (PA m) with [x, Hx], + cases iff.mp !not_implies_iff_and_not Hx with [HXx, Hxu], + apply lt_of_of_rat_lt_of_rat, + apply lt_of_lt_of_le, + apply lt_of_not_ge Hxu, + apply PB, + apply HXx + end + +private theorem under_seq_lt_over_seq_single : ∀ n : ℕ, under_seq n < over_seq n := + by intros; apply under_seq_lt_over_seq + +private theorem under_seq'_lt_over_seq' : ∀ m n : ℕ, under_seq' m < over_seq' n := + by intros; apply under_seq_lt_over_seq + +private theorem under_seq'_lt_over_seq'_single : ∀ n : ℕ, under_seq' n < over_seq' n := + by intros; apply under_seq_lt_over_seq + +private theorem under_seq_mono_helper (i k : ℕ) : under_seq i ≤ under_seq (i + k) := + (nat.induction_on k + (by rewrite nat.add_zero; apply rat.le_refl) + (begin + intros a Ha, + rewrite [add_succ, under_succ], + cases em (ub (avg_seq (i + a))) with [Havg, Havg], + rewrite (if_pos Havg), + apply Ha, + rewrite [if_neg Havg, ↑avg_seq, ↑avg], + apply rat.le_trans, + apply Ha, + rewrite -add_halves at {1}, + apply add_le_add_right, + apply div_le_div_of_le_of_pos, + apply rat.le_of_lt, + apply under_seq_lt_over_seq, + apply dec_trivial + end)) + +private theorem under_seq_mono (i j : ℕ) (H : i ≤ j) : under_seq i ≤ under_seq j := + begin + cases le.elim H with [k, Hk'], + rewrite -Hk', + apply under_seq_mono_helper + end + +private theorem over_seq_mono_helper (i k : ℕ) : over_seq (i + k) ≤ over_seq i := + nat.induction_on k + (by rewrite nat.add_zero; apply rat.le_refl) + (begin + intros a Ha, + rewrite [add_succ, over_succ], + cases em (ub (avg_seq (i + a))) with [Havg, Havg], + rewrite [if_pos Havg, ↑avg_seq, ↑avg], + apply rat.le_trans, + rotate 1, + apply Ha, + rotate 1, + apply add_le_of_le_sub_left, + rewrite sub_self_div_two, + apply div_le_div_of_le_of_pos, + apply rat.le_of_lt, + apply under_seq_lt_over_seq, + apply dec_trivial, + rewrite [if_neg Havg], + apply Ha + end) + +private theorem over_seq_mono (i j : ℕ) (H : i ≤ j) : over_seq j ≤ over_seq i := + begin + cases le.elim H with [k, Hk'], + rewrite -Hk', + apply over_seq_mono_helper + end + +private theorem rat_power_two_inv_ge (k : ℕ+) : 1 / 2^k~ ≤ k⁻¹ := + one_div_le_one_div_of_le !rat_of_pnat_is_pos !rat_power_two_le + +open rat_seq +private theorem regular_lemma_helper {s : seq} {m n : ℕ+} (Hm : m ≤ n) + (H : ∀ n i : ℕ+, i ≥ n → under_seq' n~ ≤ s i ∧ s i ≤ over_seq' n~) : + abs (s m - s n) ≤ m⁻¹ + n⁻¹ := + begin + cases H m n Hm with [T1under, T1over], + cases H m m (!pnat.le_refl) with [T2under, T2over], + apply rat.le_trans, + apply dist_bdd_within_interval, + apply under_seq'_lt_over_seq'_single, + rotate 1, + repeat assumption, + apply rat.le_trans, + apply width', + apply rat.le_trans, + apply rat_power_two_inv_ge, + apply le_add_of_nonneg_right, + apply rat.le_of_lt (!pnat.inv_pos) + end + +private theorem regular_lemma (s : seq) (H : ∀ n i : ℕ+, i ≥ n → under_seq' n~ ≤ s i ∧ s i ≤ over_seq' n~) : + regular s := + begin + rewrite ↑regular, + intros, + cases em (m ≤ n) with [Hm, Hn], + apply regular_lemma_helper Hm H, + note T := regular_lemma_helper (pnat.le_of_lt (pnat.lt_of_not_le Hn)) H, + rewrite [abs_sub at T, {n⁻¹ + _}add.comm at T], + exact T + end + +private noncomputable definition p_under_seq : seq := λ n : ℕ+, under_seq' n~ + +private noncomputable definition p_over_seq : seq := λ n : ℕ+, over_seq' n~ + +private theorem under_seq_regular : regular p_under_seq := + begin + apply regular_lemma, + intros n i Hni, + apply and.intro, + apply under_seq_mono, + apply add_le_add_right, + apply Hni, + apply rat.le_of_lt, + apply under_seq_lt_over_seq + end + +private theorem over_seq_regular : regular p_over_seq := + begin + apply regular_lemma, + intros n i Hni, + apply and.intro, + apply rat.le_of_lt, + apply under_seq_lt_over_seq, + apply over_seq_mono, + apply add_le_add_right, + apply Hni + end + +private noncomputable definition sup_over : ℝ := quot.mk (reg_seq.mk p_over_seq over_seq_regular) + +private noncomputable definition sup_under : ℝ := quot.mk (reg_seq.mk p_under_seq under_seq_regular) + +private theorem over_bound : ub sup_over := + begin + rewrite ↑ub, + intros y Hy, + apply le_of_le_reprs, + intro n, + apply PB, + apply Hy + end + +private theorem under_lowest_bound : ∀ y : ℝ, ub y → sup_under ≤ y := + begin + intros y Hy, + apply le_of_reprs_le, + intro n, + cases exists_not_of_not_forall (PA _) with [x, Hx], + cases and_not_of_not_implies Hx with [HXx, Hxn], + apply le.trans, + apply le_of_lt, + apply lt_of_not_ge Hxn, + apply Hy, + apply HXx + end + +private theorem under_over_equiv : p_under_seq ≡ p_over_seq := + begin + intros, + apply rat.le_trans, + have H : p_under_seq n < p_over_seq n, from !under_seq_lt_over_seq, + rewrite [abs_of_neg (iff.mpr !sub_neg_iff_lt H), neg_sub], + apply width', + apply rat.le_trans, + apply rat_power_two_inv_ge, + apply le_add_of_nonneg_left, + apply rat.le_of_lt !pnat.inv_pos + end + +private theorem under_over_eq : sup_under = sup_over := quot.sound under_over_equiv + +theorem exists_is_sup_of_inh_of_bdd : ∃ x : ℝ, is_sup x := + exists.intro sup_over (and.intro over_bound (under_over_eq ▸ under_lowest_bound)) + +end supremum +definition bounding_set (X : ℝ → Prop) (x : ℝ) : Prop := ∀ y : ℝ, X y → x ≤ y + +theorem exists_is_inf_of_inh_of_bdd (X : ℝ → Prop) (elt : ℝ) (inh : X elt) (bound : ℝ) + (bdd : lb X bound) : ∃ x : ℝ, is_inf X x := + begin + have Hinh : bounding_set X bound, begin + intros y Hy, + apply bdd, + apply Hy + end, + have Hub : ub (bounding_set X) elt, begin + intros y Hy, + apply Hy, + apply inh + end, + cases exists_is_sup_of_inh_of_bdd _ _ Hinh _ Hub with [supr, Hsupr], + existsi supr, + cases Hsupr with [Hubs1, Hubs2], + apply and.intro, + intros, + apply Hubs2, + intros z Hz, + apply Hz, + apply a, + intros y Hlby, + apply Hubs1, + intros z Hz, + apply Hlby, + apply Hz + end + +end real diff --git a/old_library/data/real/default.lean b/old_library/data/real/default.lean new file mode 100644 index 0000000000..21e4a435fd --- /dev/null +++ b/old_library/data/real/default.lean @@ -0,0 +1,6 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Robert Y. Lewis +-/ +import .basic .order .division .complete diff --git a/old_library/data/real/division.lean b/old_library/data/real/division.lean new file mode 100644 index 0000000000..d0a54beb12 --- /dev/null +++ b/old_library/data/real/division.lean @@ -0,0 +1,701 @@ +/- +Copyright (c) 2015 Robert Y. Lewis. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Robert Y. Lewis +The real numbers, constructed as equivalence classes of Cauchy sequences of rationals. +This construction follows Bishop and Bridges (1985). + +At this point, we no longer proceed constructively: this file makes heavy use of decidability +and excluded middle. +-/ +import data.real.basic data.real.order data.rat data.nat +open rat +open nat +open eq.ops pnat classical + +namespace rat_seq +local postfix ⁻¹ := pnat.inv + +----------------------------- +-- Facts about absolute values of sequences, to define inverse + +definition s_abs (s : seq) : seq := λ n, abs (s n) + +theorem abs_reg_of_reg {s : seq} (Hs : regular s) : regular (s_abs s) := + begin + intros, + apply le.trans, + apply abs_abs_sub_abs_le_abs_sub, + apply Hs + end + +theorem abs_pos_of_nonzero {s : seq} (Hs : regular s) (Hnz : sep s zero) : + ∃ N : ℕ+, ∀ m : ℕ+, m ≥ N → abs (s m) ≥ N⁻¹ := + begin + rewrite [↑sep at Hnz, ↑s_lt at Hnz], + apply or.elim Hnz, + intro Hnz1, + have H' : pos (sneg s), begin + apply pos_of_pos_equiv, + rotate 2, + apply Hnz1, + rotate 1, + apply s_zero_add, + repeat (assumption | apply reg_add_reg | apply reg_neg_reg | apply zero_is_reg) + end, + cases bdd_away_of_pos (reg_neg_reg Hs) H' with [N, HN], + existsi N, + intro m Hm, + apply le.trans, + apply HN m Hm, + rewrite ↑sneg, + apply neg_le_abs_self, + intro Hnz2, + let H' := pos_of_pos_equiv (reg_add_reg Hs (reg_neg_reg zero_is_reg)) (s_add_zero s Hs) Hnz2, + let H'' := bdd_away_of_pos Hs H', + cases H'' with [N, HN], + existsi N, + intro m Hm, + apply le.trans, + apply HN m Hm, + apply le_abs_self + end + +theorem abs_well_defined {s t : seq} (Hs : regular s) (Ht : regular t) (Heq : s ≡ t) : + s_abs s ≡ s_abs t := + begin + rewrite [↑equiv at *], + intro n, + rewrite ↑s_abs, + apply le.trans, + apply abs_abs_sub_abs_le_abs_sub, + apply Heq + end + +theorem sep_zero_of_pos {s : seq} (Hs : regular s) (Hpos : pos s) : sep s zero := + begin + apply or.inr, + apply pos_of_pos_equiv, + rotate 2, + apply Hpos, + apply Hs, + apply equiv.symm, + apply s_sub_zero Hs + end + +------------------------ +-- This section could be cleaned up. + +private noncomputable definition pb {s : seq} (Hs : regular s) (Hpos : pos s) := + some (abs_pos_of_nonzero Hs (sep_zero_of_pos Hs Hpos)) +private noncomputable definition ps {s : seq} (Hs : regular s) (Hsep : sep s zero) := + some (abs_pos_of_nonzero Hs Hsep) + + +private theorem pb_spec {s : seq} (Hs : regular s) (Hpos : pos s) : + ∀ m : ℕ+, m ≥ (pb Hs Hpos) → abs (s m) ≥ (pb Hs Hpos)⁻¹ := + some_spec (abs_pos_of_nonzero Hs (sep_zero_of_pos Hs Hpos)) + +private theorem ps_spec {s : seq} (Hs : regular s) (Hsep : sep s zero) : + ∀ m : ℕ+, m ≥ (ps Hs Hsep) → abs (s m) ≥ (ps Hs Hsep)⁻¹ := + some_spec (abs_pos_of_nonzero Hs Hsep) + +noncomputable definition s_inv {s : seq} (Hs : regular s) (n : ℕ+) : ℚ := + if H : sep s zero then + (if n < (ps Hs H) then 1 / (s ((ps Hs H) * (ps Hs H) * (ps Hs H))) + else 1 / (s ((ps Hs H) * (ps Hs H) * n))) + else 0 + +private theorem peq {s : seq} (Hsep : sep s zero) (Hpos : pos s) (Hs : regular s) : + pb Hs Hpos = ps Hs Hsep := rfl + +private theorem s_inv_of_sep_lt_p {s : seq} (Hs : regular s) (Hsep : sep s zero) {n : ℕ+} + (Hn : n < (ps Hs Hsep)) : s_inv Hs n = 1 / s ((ps Hs Hsep) * (ps Hs Hsep) * (ps Hs Hsep)) := + begin + apply eq.trans, + apply dif_pos Hsep, + apply dif_pos Hn + end + +private theorem s_inv_of_sep_gt_p {s : seq} (Hs : regular s) (Hsep : sep s zero) {n : ℕ+} + (Hn : n ≥ (ps Hs Hsep)) : s_inv Hs n = 1 / s ((ps Hs Hsep) * (ps Hs Hsep) * n) := + begin + apply eq.trans, + apply dif_pos Hsep, + apply dif_neg (pnat.not_lt_of_ge Hn) + end + +private theorem s_inv_of_pos_lt_p {s : seq} (Hs : regular s) (Hpos : pos s) {n : ℕ+} + (Hn : n < (pb Hs Hpos)) : s_inv Hs n = 1 / s ((pb Hs Hpos) * (pb Hs Hpos) * (pb Hs Hpos)) := + s_inv_of_sep_lt_p Hs (sep_zero_of_pos Hs Hpos) Hn + +private theorem s_inv_of_pos_gt_p {s : seq} (Hs : regular s) (Hpos : pos s) {n : ℕ+} + (Hn : n ≥ (pb Hs Hpos)) : s_inv Hs n = 1 / s ((pb Hs Hpos) * (pb Hs Hpos) * n) := + s_inv_of_sep_gt_p Hs (sep_zero_of_pos Hs Hpos) Hn + +private theorem le_ps {s : seq} (Hs : regular s) (Hsep : sep s zero) (n : ℕ+) : + abs (s_inv Hs n) ≤ (rat_of_pnat (ps Hs Hsep)) := + if Hn : n < ps Hs Hsep then + (begin + rewrite [(s_inv_of_sep_lt_p Hs Hsep Hn), abs_one_div], + apply div_le_pnat, + apply ps_spec, + apply pnat.mul_le_mul_left + end) + else + (begin + rewrite [(s_inv_of_sep_gt_p Hs Hsep (pnat.le_of_not_gt Hn)), abs_one_div], + apply div_le_pnat, + apply ps_spec, + rewrite pnat.mul_assoc, + apply pnat.mul_le_mul_right + end) + +theorem s_inv_zero : s_inv zero_is_reg = zero := + funext (λ n, dif_neg (!not_sep_self)) + +private theorem s_inv_of_zero' {s : seq} (Hs : regular s) (Hz : ¬ sep s zero) (n : ℕ+) : s_inv Hs n = 0 := + dif_neg Hz + +theorem s_inv_of_zero {s : seq} (Hs : regular s) (Hz : ¬ sep s zero) : s_inv Hs = zero := + begin + apply funext, + intro n, + apply s_inv_of_zero' Hs Hz n + end + +private theorem s_ne_zero_of_ge_p {s : seq} (Hs : regular s) (Hsep : sep s zero) {n : ℕ+} + (Hn : n ≥ (ps Hs Hsep)) : s n ≠ 0 := + begin + let Hps := ps_spec Hs Hsep, + apply ne_zero_of_abs_ne_zero, + apply ne_of_gt, + apply gt_of_ge_of_gt, + apply Hps, + apply Hn, + apply pnat.inv_pos + end + +theorem reg_inv_reg {s : seq} (Hs : regular s) (Hsep : sep s zero) : regular (s_inv Hs) := + begin + rewrite ↑regular, + intros, + have Hsp : s ((ps Hs Hsep) * (ps Hs Hsep) * (ps Hs Hsep)) ≠ 0, from + s_ne_zero_of_ge_p Hs Hsep !pnat.mul_le_mul_left, + have Hspn : s ((ps Hs Hsep) * (ps Hs Hsep) * n) ≠ 0, from + s_ne_zero_of_ge_p Hs Hsep (show (ps Hs Hsep) * (ps Hs Hsep) * n ≥ ps Hs Hsep, by + rewrite pnat.mul_assoc; apply pnat.mul_le_mul_right), + have Hspm : s ((ps Hs Hsep) * (ps Hs Hsep) * m) ≠ 0, from + s_ne_zero_of_ge_p Hs Hsep (show (ps Hs Hsep) * (ps Hs Hsep) * m ≥ ps Hs Hsep, by + rewrite pnat.mul_assoc; apply pnat.mul_le_mul_right), + cases em (m < ps Hs Hsep) with [Hmlt, Hmlt], + cases em (n < ps Hs Hsep) with [Hnlt, Hnlt], + rewrite [(s_inv_of_sep_lt_p Hs Hsep Hmlt), (s_inv_of_sep_lt_p Hs Hsep Hnlt)], + rewrite [sub_self, abs_zero], + apply add_invs_nonneg, + rewrite [(s_inv_of_sep_lt_p Hs Hsep Hmlt), + (s_inv_of_sep_gt_p Hs Hsep (pnat.le_of_not_gt Hnlt))], + rewrite [(!div_sub_div Hsp Hspn), div_eq_mul_one_div, *abs_mul, *mul_one, *one_mul], + apply le.trans, + apply mul_le_mul, + apply Hs, + rewrite [-(mul_one 1), -(!field.div_mul_div Hsp Hspn), abs_mul], + apply mul_le_mul, + rewrite -(s_inv_of_sep_lt_p Hs Hsep Hmlt), + apply le_ps Hs Hsep, + rewrite -(s_inv_of_sep_gt_p Hs Hsep (pnat.le_of_not_gt Hnlt)), + apply le_ps Hs Hsep, + apply abs_nonneg, + apply le_of_lt !rat_of_pnat_is_pos, + apply abs_nonneg, + apply add_invs_nonneg, + rewrite [right_distrib, *pnat_cancel', add.comm], + apply add_le_add_right, + apply inv_ge_of_le, + apply pnat.le_of_lt, + apply Hmlt, + cases em (n < ps Hs Hsep) with [Hnlt, Hnlt], + rewrite [(s_inv_of_sep_lt_p Hs Hsep Hnlt), + (s_inv_of_sep_gt_p Hs Hsep (pnat.le_of_not_gt Hmlt))], + rewrite [(!div_sub_div Hspm Hsp), div_eq_mul_one_div, *abs_mul, *mul_one, *one_mul], + apply le.trans, + apply mul_le_mul, + apply Hs, + rewrite [-(mul_one 1), -(!field.div_mul_div Hspm Hsp), abs_mul], + apply mul_le_mul, + rewrite -(s_inv_of_sep_gt_p Hs Hsep (pnat.le_of_not_gt Hmlt)), + apply le_ps Hs Hsep, + rewrite -(s_inv_of_sep_lt_p Hs Hsep Hnlt), + apply le_ps Hs Hsep, + apply abs_nonneg, + apply le_of_lt !rat_of_pnat_is_pos, + apply abs_nonneg, + apply add_invs_nonneg, + rewrite [right_distrib, *pnat_cancel', add.comm], + apply rat.add_le_add_left, + apply inv_ge_of_le, + apply pnat.le_of_lt, + apply Hnlt, + rewrite [(s_inv_of_sep_gt_p Hs Hsep (pnat.le_of_not_gt Hnlt)), + (s_inv_of_sep_gt_p Hs Hsep (pnat.le_of_not_gt Hmlt))], + rewrite [(!div_sub_div Hspm Hspn), div_eq_mul_one_div, abs_mul, *one_mul, *mul_one], + apply le.trans, + apply mul_le_mul, + apply Hs, + rewrite [-(mul_one 1), -(!field.div_mul_div Hspm Hspn), abs_mul], + apply mul_le_mul, + rewrite -(s_inv_of_sep_gt_p Hs Hsep (pnat.le_of_not_gt Hmlt)), + apply le_ps Hs Hsep, + rewrite -(s_inv_of_sep_gt_p Hs Hsep (pnat.le_of_not_gt Hnlt)), + apply le_ps Hs Hsep, + apply abs_nonneg, + apply le_of_lt !rat_of_pnat_is_pos, + apply abs_nonneg, + apply add_invs_nonneg, + rewrite [right_distrib, *pnat_cancel', add.comm], + apply le.refl + end + +theorem s_inv_ne_zero {s : seq} (Hs : regular s) (Hsep : sep s zero) (n : ℕ+) : s_inv Hs n ≠ 0 := + if H : n ≥ ps Hs Hsep then + (begin + rewrite (s_inv_of_sep_gt_p Hs Hsep H), + apply one_div_ne_zero, + apply s_ne_zero_of_ge_p, + apply pnat.le_trans, + apply H, + apply pnat.mul_le_mul_left + end) + else + (begin + rewrite (s_inv_of_sep_lt_p Hs Hsep (pnat.lt_of_not_le H)), + apply one_div_ne_zero, + apply s_ne_zero_of_ge_p, + apply pnat.mul_le_mul_left + end) + +protected theorem mul_inv {s : seq} (Hs : regular s) (Hsep : sep s zero) : + smul s (s_inv Hs) ≡ one := + begin + let Rsi := reg_inv_reg Hs Hsep, + let Rssi := reg_mul_reg Hs Rsi, + apply eq_of_bdd Rssi one_is_reg, + intros, + existsi max (ps Hs Hsep) j, + intro n Hn, + have Hnz : s_inv Hs ((K₂ s (s_inv Hs)) * 2 * n) ≠ 0, from s_inv_ne_zero Hs Hsep _, + rewrite [↑smul, ↑one, mul.comm, -(mul_one_div_cancel Hnz), + -mul_sub_left_distrib, abs_mul], + apply le.trans, + apply mul_le_mul_of_nonneg_right, + apply canon_2_bound_right s, + apply Rsi, + apply abs_nonneg, + have Hp : (K₂ s (s_inv Hs)) * 2 * n ≥ ps Hs Hsep, begin + apply pnat.le_trans, + apply pnat.max_left, + rotate 1, + apply pnat.le_trans, + apply Hn, + apply pnat.mul_le_mul_left + end, + have Hnz' : s (((ps Hs Hsep) * (ps Hs Hsep)) * ((K₂ s (s_inv Hs)) * 2 * n)) ≠ 0, from + s_ne_zero_of_ge_p Hs Hsep + (show ps Hs Hsep ≤ ((ps Hs Hsep) * (ps Hs Hsep)) * ((K₂ s (s_inv Hs)) * 2 * n), + by rewrite *pnat.mul_assoc; apply pnat.mul_le_mul_right), + rewrite [(s_inv_of_sep_gt_p Hs Hsep Hp), (division_ring.one_div_one_div Hnz')], + apply rat.le_trans, + apply mul_le_mul_of_nonneg_left, + apply Hs, + apply le_of_lt, + apply rat_of_pnat_is_pos, + rewrite [left_distrib, pnat.mul_comm ((ps Hs Hsep) * (ps Hs Hsep)), *pnat.mul_assoc, + *(@pnat.inv_mul_eq_mul_inv (K₂ s (s_inv Hs))), -*mul.assoc, *pnat.inv_cancel_left, + *one_mul, -(pnat.add_halves j)], + apply add_le_add, + apply inv_ge_of_le, + apply pnat_mul_le_mul_left', + apply pnat.le_trans, + rotate 1, + apply Hn, + rotate_right 1, + apply pnat.max_right, + apply inv_ge_of_le, + apply pnat_mul_le_mul_left', + apply pnat.le_trans, + apply pnat.max_right, + rotate 1, + apply pnat.le_trans, + apply Hn, + apply pnat.mul_le_mul_right + end + +protected theorem inv_mul {s : seq} (Hs : regular s) (Hsep : sep s zero) : + smul (s_inv Hs) s ≡ one := + begin + apply equiv.trans, + rotate 3, + apply s_mul_comm, + apply rat_seq.mul_inv, + repeat (assumption | apply reg_mul_reg | apply reg_inv_reg | apply zero_is_reg) + end + +theorem sep_of_equiv_sep {s t : seq} (Hs : regular s) (Ht : regular t) (Heq : s ≡ t) + (Hsep : sep s zero) : sep t zero := + begin + apply or.elim Hsep, + intro Hslt, + apply or.inl, + rewrite ↑s_lt at *, + apply pos_of_pos_equiv, + rotate 2, + apply Hslt, + rotate_right 1, + apply add_well_defined, + rotate 4, + apply equiv.refl, + apply neg_well_defined, + apply Heq, + intro Hslt, + apply or.inr, + rewrite ↑s_lt at *, + apply pos_of_pos_equiv, + rotate 2, + apply Hslt, + rotate_right 1, + apply add_well_defined, + rotate 5, + apply equiv.refl, + repeat (assumption | apply reg_neg_reg | apply reg_add_reg | apply zero_is_reg) + end + +theorem inv_unique {s t : seq} (Hs : regular s) (Ht : regular t) (Hsep : sep s zero) + (Heq : smul s t ≡ one) : s_inv Hs ≡ t := + begin + apply equiv.trans, + rotate 3, + apply equiv.symm, + apply s_mul_one, + rotate 1, + apply equiv.trans, + rotate 3, + apply mul_well_defined, + rotate 4, + apply equiv.refl, + apply equiv.symm, + apply Heq, + apply equiv.trans, + rotate 3, + apply equiv.symm, + apply s_mul_assoc, + rotate 3, + apply equiv.trans, + rotate 3, + apply mul_well_defined, + rotate 4, + apply rat_seq.inv_mul, + rotate 1, + apply equiv.refl, + apply s_one_mul, + repeat (assumption | apply reg_inv_reg | apply reg_mul_reg | apply one_is_reg) + end + +theorem inv_well_defined {s t : seq} (Hs : regular s) (Ht : regular t) (Heq : s ≡ t) : + s_inv Hs ≡ s_inv Ht := + if Hsep : sep s zero then + (begin + note Hsept := sep_of_equiv_sep Hs Ht Heq Hsep, + have Hm : smul t (s_inv Hs) ≡ smul s (s_inv Hs), begin + apply mul_well_defined, + repeat (assumption | apply reg_inv_reg), + apply equiv.symm s t Heq, + apply equiv.refl + end, + apply equiv.symm, + apply inv_unique, + rotate 2, + apply equiv.trans, + rotate 3, + apply Hm, + apply rat_seq.mul_inv, + repeat (assumption | apply reg_inv_reg | apply reg_mul_reg), + apply one_is_reg + end) + else + (have H : s_inv Hs = zero, from funext (λ n, dif_neg Hsep), + have Hsept : ¬ sep t zero, from + assume H', Hsep (sep_of_equiv_sep Ht Hs (equiv.symm _ _ Heq) H'), + have H' : s_inv Ht = zero, from funext (λ n, dif_neg Hsept), + by rewrite [H', H]; apply equiv.refl) + +theorem s_neg_neg {s : seq} : sneg (sneg s) ≡ s := + begin + rewrite [↑equiv, ↑sneg], + intro n, + rewrite [neg_neg, sub_self, abs_zero], + apply add_invs_nonneg + end + +theorem s_neg_sub {s t : seq} (Hs : regular s) (Ht : regular t) : + sneg (sadd s (sneg t)) ≡ sadd t (sneg s) := + begin + apply equiv.trans, + rotate 3, + apply s_neg_add_eq_s_add_neg, + apply equiv.trans, + rotate 3, + apply add_well_defined, + rotate 4, + apply equiv.refl, + apply s_neg_neg, + apply s_add_comm, + repeat (assumption | apply reg_add_reg | apply reg_neg_reg) + end + +theorem s_le_total {s t : seq} (Hs : regular s) (Ht : regular t) : s_le s t ∨ s_le t s := + if H : s_le s t then or.inl H else or.inr begin + rewrite [↑s_le at *], + have H' : ∃ n : ℕ+, -n⁻¹ > sadd t (sneg s) n, begin + apply by_contradiction, + intro Hex, + have Hex' : ∀ n : ℕ+, -n⁻¹ ≤ sadd t (sneg s) n, begin + intro m, + apply by_contradiction, + intro Hm, + note Hm' := lt_of_not_ge Hm, + note Hex'' := exists.intro m Hm', + apply Hex Hex'' + end, + apply H Hex' + end, + eapply exists.elim H', + intro m Hm, + note Hm' := neg_lt_neg Hm, + rewrite neg_neg at Hm', + apply s_nonneg_of_pos, + rotate 1, + apply pos_of_pos_equiv, + rotate 1, + apply s_neg_sub, + rotate 2, + rewrite [↑pos, ↑sneg], + existsi m, + apply Hm', + repeat (assumption | apply reg_add_reg | apply reg_neg_reg) + end + +theorem s_le_of_not_lt {s t : seq} (Hle : ¬ s_lt s t) : s_le t s := + begin + rewrite [↑s_le, ↑nonneg, ↑s_lt at Hle, ↑pos at Hle], + let Hle' := iff.mp forall_iff_not_exists Hle, + intro n, + let Hn := neg_le_neg (le_of_not_gt (Hle' n)), + rewrite [↑sadd, ↑sneg, add_neg_eq_neg_add_rev], + apply Hn + end + +theorem sep_of_nequiv {s t : seq} (Hs : regular s) (Ht : regular t) (Hneq : ¬ equiv s t) : + sep s t := + begin + rewrite ↑sep, + apply by_contradiction, + intro Hnor, + let Hand := iff.mp !not_or_iff_not_and_not Hnor, + let Hle1 := s_le_of_not_lt (and.left Hand), + let Hle2 := s_le_of_not_lt (and.right Hand), + apply Hneq (equiv_of_le_of_ge Hs Ht Hle2 Hle1) + end + +theorem s_zero_inv_equiv_zero : s_inv zero_is_reg ≡ zero := + by rewrite s_inv_zero; apply equiv.refl + +theorem lt_or_equiv_of_le {s t : seq} (Hs : regular s) (Ht : regular t) (Hle : s_le s t) : + s_lt s t ∨ s ≡ t := + if H : s ≡ t then or.inr H else + or.inl (lt_of_le_and_sep Hs Ht (and.intro Hle (sep_of_nequiv Hs Ht H))) + +theorem s_le_of_equiv_le_left {s t u : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (Heq : s ≡ t) (Hle : s_le s u) : s_le t u := + begin + rewrite ↑s_le at *, + apply nonneg_of_nonneg_equiv, + rotate 2, + apply add_well_defined, + rotate 4, + apply equiv.refl, + apply neg_well_defined, + apply Heq, + repeat (assumption | apply reg_add_reg | apply reg_neg_reg) + end + +theorem s_le_of_equiv_le_right {s t u : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (Heq : t ≡ u) (Hle : s_le s t) : s_le s u := + begin + rewrite ↑s_le at *, + apply nonneg_of_nonneg_equiv, + rotate 2, + apply add_well_defined, + rotate 4, + apply Heq, + apply equiv.refl, + repeat (assumption | apply reg_add_reg | apply reg_neg_reg) + end + +----------------------------- + +noncomputable definition r_inv (s : reg_seq) : reg_seq := reg_seq.mk (s_inv (reg_seq.is_reg s)) + (if H : sep (reg_seq.sq s) zero then reg_inv_reg (reg_seq.is_reg s) H else + have Hz : s_inv (reg_seq.is_reg s) = zero, from funext (λ n, dif_neg H), + by rewrite Hz; apply zero_is_reg) + +theorem r_inv_zero : requiv (r_inv r_zero) r_zero := + s_zero_inv_equiv_zero + +theorem r_inv_well_defined {s t : reg_seq} (H : requiv s t) : requiv (r_inv s) (r_inv t) := + inv_well_defined (reg_seq.is_reg s) (reg_seq.is_reg t) H + +theorem r_le_total (s t : reg_seq) : r_le s t ∨ r_le t s := + s_le_total (reg_seq.is_reg s) (reg_seq.is_reg t) + +theorem r_mul_inv (s : reg_seq) (Hsep : r_sep s r_zero) : requiv (s * (r_inv s)) r_one := + rat_seq.mul_inv (reg_seq.is_reg s) Hsep + +theorem r_sep_of_nequiv (s t : reg_seq) (Hneq : ¬ requiv s t) : r_sep s t := + sep_of_nequiv (reg_seq.is_reg s) (reg_seq.is_reg t) Hneq + +theorem r_lt_or_equiv_of_le (s t : reg_seq) (Hle : r_le s t) : r_lt s t ∨ requiv s t := + lt_or_equiv_of_le (reg_seq.is_reg s) (reg_seq.is_reg t) Hle + +theorem r_le_of_equiv_le_left {s t u : reg_seq} (Heq : requiv s t) (Hle : r_le s u) : r_le t u := + s_le_of_equiv_le_left (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) Heq Hle + +theorem r_le_of_equiv_le_right {s t u : reg_seq} (Heq : requiv t u) (Hle : r_le s t) : r_le s u := + s_le_of_equiv_le_right (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) Heq Hle + +definition r_abs (s : reg_seq) : reg_seq := + reg_seq.mk (s_abs (reg_seq.sq s)) (abs_reg_of_reg (reg_seq.is_reg s)) + +theorem r_abs_well_defined {s t : reg_seq} (H : requiv s t) : requiv (r_abs s) (r_abs t) := + abs_well_defined (reg_seq.is_reg s) (reg_seq.is_reg t) H + +end rat_seq + +namespace real +open [class] rat_seq + +protected noncomputable definition inv (x : ℝ) : ℝ := + quot.lift_on x (λ a, quot.mk (rat_seq.r_inv a)) + (λ a b H, quot.sound (rat_seq.r_inv_well_defined H)) + +attribute [instance, priority real.prio] +noncomputable definition real_has_inv : has_inv real := + has_inv.mk real.inv + +protected noncomputable definition div (x y : ℝ) : ℝ := + x * y⁻¹ + +noncomputable definition real_has_div : has_div real := + has_div.mk real.div + +local attribute real_has_div [instance, priority real.prio] + +protected theorem le_total (x y : ℝ) : x ≤ y ∨ y ≤ x := + quot.induction_on₂ x y (λ s t, rat_seq.r_le_total s t) + +protected theorem mul_inv_cancel' (x : ℝ) : x ≢ 0 → x * x⁻¹ = 1 := + quot.induction_on x (λ s H, quot.sound (rat_seq.r_mul_inv s H)) + +protected theorem inv_mul_cancel' (x : ℝ) : x ≢ 0 → x⁻¹ * x = 1 := + by rewrite real.mul_comm; apply real.mul_inv_cancel' + +theorem neq_of_sep {x y : ℝ} (H : x ≢ y) : ¬ x = y := + assume Heq, !not_sep_self (Heq ▸ H) + +theorem sep_of_neq {x y : ℝ} : ¬ x = y → x ≢ y := + quot.induction_on₂ x y (λ s t H, rat_seq.r_sep_of_nequiv s t (assume Heq, H (quot.sound Heq))) + +theorem sep_is_neq (x y : ℝ) : (x ≢ y) = (¬ x = y) := + propext (iff.intro neq_of_sep sep_of_neq) + +protected theorem mul_inv_cancel (x : ℝ) : x ≠ 0 → x * x⁻¹ = 1 := + !sep_is_neq ▸ !real.mul_inv_cancel' + +protected theorem inv_mul_cancel (x : ℝ) : x ≠ 0 → x⁻¹ * x = 1 := + !sep_is_neq ▸ !real.inv_mul_cancel' + +protected theorem inv_zero : (0 : ℝ)⁻¹ = 0 := quot.sound (rat_seq.r_inv_zero) + +protected theorem lt_or_eq_of_le (x y : ℝ) : x ≤ y → x < y ∨ x = y := + quot.induction_on₂ x y (λ s t H, or.elim (rat_seq.r_lt_or_equiv_of_le s t H) + (assume H1, or.inl H1) + (assume H2, or.inr (quot.sound H2))) + +protected theorem le_iff_lt_or_eq (x y : ℝ) : x ≤ y ↔ x < y ∨ x = y := + iff.intro (real.lt_or_eq_of_le x y) (real.le_of_lt_or_eq x y) + +noncomputable definition dec_lt : decidable_rel real.lt := + begin + rewrite ↑decidable_rel, + intros, + apply prop_decidable + end + +attribute [trans_instance] +protected noncomputable definition discrete_linear_ordered_field : + discrete_linear_ordered_field ℝ := + ⦃ discrete_linear_ordered_field, real.comm_ring, real.ordered_ring, + le_total := real.le_total, + mul_inv_cancel := real.mul_inv_cancel, + inv_mul_cancel := real.inv_mul_cancel, + zero_lt_one := real.zero_lt_one, + inv_zero := real.inv_zero, + le_iff_lt_or_eq := real.le_iff_lt_or_eq, + decidable_lt := dec_lt + ⦄ + +theorem of_rat_divide (x y : ℚ) : of_rat (x / y) = of_rat x / of_rat y := +by_cases + (assume yz : y = 0, by krewrite [yz, div_zero, +of_rat_zero, div_zero]) + (assume ynz : y ≠ 0, + have ynz' : of_rat y ≠ 0, from assume yz', ynz (of_rat.inj yz'), + !eq_div_of_mul_eq ynz' (by krewrite [-of_rat_mul, !div_mul_cancel ynz])) + +open int + +theorem of_int_div (x y : ℤ) (H : y ∣ x) : of_int (x / y) = of_int x / of_int y := +by rewrite [of_int_eq, rat.of_int_div H, of_rat_divide] + +theorem of_nat_div (x y : ℕ) (H : y ∣ x) : of_nat (x / y) = of_nat x / of_nat y := +by rewrite [of_nat_eq, rat.of_nat_div H, of_rat_divide] + +/- useful for proving equalities -/ + +theorem eq_zero_of_nonneg_of_forall_lt {x : ℝ} (xnonneg : x ≥ 0) (H : ∀ ε : ℝ, ε > 0 → x < ε) : + x = 0 := +decidable.by_contradiction + (suppose x ≠ 0, + have x > 0, from lt_of_le_of_ne xnonneg (ne.symm this), + have x < x, from H x this, + show false, from !lt.irrefl this) + +theorem eq_zero_of_nonneg_of_forall_le {x : ℝ} (xnonneg : x ≥ 0) (H : ∀ ε : ℝ, ε > 0 → x ≤ ε) : + x = 0 := +have ∀ ε : ℝ, ε > 0 → x < ε, from + take ε, suppose ε > 0, + have e2pos : ε / 2 > 0, from div_pos_of_pos_of_pos `ε > 0` two_pos, + have ε / 2 < ε, from div_two_lt_of_pos `ε > 0`, + begin apply lt_of_le_of_lt, apply H _ e2pos, apply this end, +eq_zero_of_nonneg_of_forall_lt xnonneg this + +theorem eq_zero_of_forall_abs_le {x : ℝ} (H : ∀ ε : ℝ, ε > 0 → abs x ≤ ε) : + x = 0 := +by_contradiction + (suppose x ≠ 0, + have abs x = 0, from eq_zero_of_nonneg_of_forall_le !abs_nonneg H, + show false, from `x ≠ 0` (eq_zero_of_abs_eq_zero this)) + +theorem eq_of_forall_abs_sub_le {x y : ℝ} (H : ∀ ε : ℝ, ε > 0 → abs (x - y) ≤ ε) : + x = y := +have x - y = 0, from eq_zero_of_forall_abs_le H, +eq_of_sub_eq_zero this +end real diff --git a/old_library/data/real/order.lean b/old_library/data/real/order.lean new file mode 100644 index 0000000000..3a032a9260 --- /dev/null +++ b/old_library/data/real/order.lean @@ -0,0 +1,1220 @@ +/- +Copyright (c) 2015 Robert Y. Lewis. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Robert Y. Lewis +The real numbers, constructed as equivalence classes of Cauchy sequences of rationals. +This construction follows Bishop and Bridges (1985). + +To do: + o Rename things and possibly make theorems private +-/ +import data.real.basic data.rat data.nat +open rat nat eq pnat + +local postfix `⁻¹` := pnat.inv + +local attribute real.real_has_zero [instance, priority real.prio] +local attribute real.real_has_one [instance, priority real.prio] + +namespace rat_seq +definition pos (s : seq) := ∃ n : ℕ+, n⁻¹ < (s n) + +definition nonneg (s : seq) := ∀ n : ℕ+, -(n⁻¹) ≤ s n + +theorem sub_sub_comm (a b c : ℚ) : a - b - c = a - c - b := + by rewrite [+sub_eq_add_neg, add.assoc, {-b+_}add.comm, -add.assoc] + +theorem bdd_away_of_pos {s : seq} (Hs : regular s) (H : pos s) : + ∃ N : ℕ+, ∀ n : ℕ+, n ≥ N → (s n) ≥ N⁻¹ := + begin + cases H with [n, Hn], + cases sep_by_inv Hn with [N, HN], + existsi N, + intro m Hm, + have Habs : abs (s m - s n) ≥ s n - s m, by rewrite abs_sub; apply le_abs_self, + have Habs' : s m + abs (s m - s n) ≥ s n, from (iff.mpr (le_add_iff_sub_left_le _ _ _)) Habs, + have HN' : N⁻¹ + N⁻¹ ≤ s n - n⁻¹, begin + rewrite sub_eq_add_neg, + apply iff.mpr (le_add_iff_sub_right_le _ _ _), + rewrite [sub_neg_eq_add, add.comm, -add.assoc], + apply le_of_lt HN + end, + rewrite add.comm at Habs', + have Hin : s m ≥ N⁻¹, from calc + s m ≥ s n - abs (s m - s n) : (iff.mp (le_add_iff_sub_left_le _ _ _)) Habs' + ... ≥ s n - (m⁻¹ + n⁻¹) : sub_le_sub_left !Hs + ... = s n - m⁻¹ - n⁻¹ : by rewrite sub_add_eq_sub_sub + ... = s n - n⁻¹ - m⁻¹ : by rewrite sub_sub_comm + ... ≥ s n - n⁻¹ - N⁻¹ : sub_le_sub_left (inv_ge_of_le Hm) + ... ≥ N⁻¹ + N⁻¹ - N⁻¹ : sub_le_sub_right HN' + ... = N⁻¹ : by rewrite add_sub_cancel, + apply Hin + end + +theorem pos_of_bdd_away {s : seq} (H : ∃ N : ℕ+, ∀ n : ℕ+, n ≥ N → (s n) ≥ N⁻¹) : pos s := + begin + cases H with [N, HN], + existsi (N + pone), + apply lt_of_lt_of_le, + apply inv_add_lt_left, + apply HN, + apply pnat.le_of_lt, + apply lt_add_left + end + +theorem bdd_within_of_nonneg {s : seq} (Hs : regular s) (H : nonneg s) : + ∀ n : ℕ+, ∃ N : ℕ+, ∀ m : ℕ+, m ≥ N → s m ≥ -n⁻¹ := + begin + intros, + existsi n, + intro m Hm, + apply le.trans, + apply neg_le_neg, + apply inv_ge_of_le, + apply Hm, + apply H + end + +theorem nonneg_of_bdd_within {s : seq} (Hs : regular s) + (H : ∀n : ℕ+, ∃ N : ℕ+, ∀ m : ℕ+, m ≥ N → s m ≥ -n⁻¹) : nonneg s := + begin + rewrite ↑nonneg, + intro k, + apply ge_of_forall_ge_sub, + intro ε Hε, + cases H (pceil ((2) / ε)) with [N, HN], + apply le.trans, + rotate 1, + apply sub_le_of_abs_sub_le_left, + apply Hs, + apply (max (pceil ((2)/ε)) N), + rewrite [+sub_eq_add_neg, neg_add, {_ + (-k⁻¹ + _)}add.comm, *add.assoc], + apply rat.add_le_add_left, + apply le.trans, + rotate 1, + apply add_le_add, + rotate 1, + apply HN (max (pceil ((2)/ε)) N) !pnat.max_right, + rotate_right 1, + apply neg_le_neg, + apply inv_ge_of_le, + apply pnat.max_left, + rewrite -neg_add, + apply neg_le_neg, + apply le.trans, + apply add_le_add, + repeat (apply inv_pceil_div; + apply add_pos; + repeat apply zero_lt_one; + exact Hε), + rewrite [add_halves], + apply rat.le_refl + end + +theorem pos_of_pos_equiv {s t : seq} (Hs : regular s) (Heq : s ≡ t) (Hp : pos s) : pos t := + begin + cases (bdd_away_of_pos Hs Hp) with [N, HN], + existsi 2 * 2 * N, + apply lt_of_lt_of_le, + rotate 1, + apply sub_le_of_abs_sub_le_right, + apply Heq, + have Hs4 : N⁻¹ ≤ s (2 * 2 * N), from HN _ (!pnat.mul_le_mul_left), + apply lt_of_lt_of_le, + rotate 1, + rewrite sub_eq_add_neg, + apply iff.mpr !add_le_add_right_iff, + apply Hs4, + rewrite [*pnat.mul_assoc, pnat.add_halves, -(pnat.add_halves N), -sub_eq_add_neg, add_sub_cancel], + apply inv_two_mul_lt_inv + end + +theorem nonneg_of_nonneg_equiv {s t : seq} (Hs : regular s) (Ht : regular t) (Heq : s ≡ t) + (Hp : nonneg s) : nonneg t := + begin + apply nonneg_of_bdd_within, + apply Ht, + intros, + cases bdd_within_of_nonneg Hs Hp (2 * 2 * n) with [Ns, HNs], + existsi max Ns (2 * 2 * n), + intro m Hm, + apply le.trans, + rotate 1, + apply sub_le_of_abs_sub_le_right, + apply Heq, + apply le.trans, + rotate 1, + apply sub_le_sub_right, + apply HNs, + apply pnat.le_trans, + rotate 1, + apply Hm, + rotate_right 1, + apply pnat.max_left, + have Hms : m⁻¹ ≤ (2 * 2 * n)⁻¹, begin + apply inv_ge_of_le, + apply pnat.le_trans, + rotate 1, + apply Hm; + apply pnat.max_right + end, + have Hms' : m⁻¹ + m⁻¹ ≤ (2 * 2 * n)⁻¹ + (2 * 2 * n)⁻¹, from add_le_add Hms Hms, + apply le.trans, + rotate 1, + apply sub_le_sub_left, + apply Hms', + rewrite [*pnat.mul_assoc, pnat.add_halves, -neg_sub, -pnat.add_halves n, sub_neg_eq_add], + apply neg_le_neg, + apply add_le_add_left, + apply inv_two_mul_le_inv + end + +definition s_le (a b : seq) := nonneg (sadd b (sneg a)) +definition s_lt (a b : seq) := pos (sadd b (sneg a)) + +theorem zero_nonneg : nonneg zero := + begin + intros, + apply neg_nonpos_of_nonneg, + apply rat.le_of_lt, + apply pnat.inv_pos + end + +theorem s_zero_lt_one : s_lt zero one := + begin + rewrite [↑s_lt, ↑zero, ↑sadd, ↑sneg, ↑one, neg_zero, add_zero, ↑pos], + existsi 2, + apply inv_lt_one_of_gt, + apply one_lt_two + end + +protected theorem le_refl {s : seq} (Hs : regular s) : s_le s s := + begin + apply nonneg_of_nonneg_equiv, + rotate 2, + apply equiv.symm, + apply neg_s_cancel s Hs, + apply zero_nonneg, + apply zero_is_reg, + apply reg_add_reg Hs (reg_neg_reg Hs) + end + +theorem s_nonneg_of_pos {s : seq} (Hs : regular s) (H : pos s) : nonneg s := + begin + apply nonneg_of_bdd_within, + apply Hs, + intros, + cases bdd_away_of_pos Hs H with [N, HN], + existsi N, + intro m Hm, + apply le.trans, + rotate 1, + apply HN, + apply Hm, + apply le.trans, + rotate 1, + apply rat.le_of_lt, + apply pnat.inv_pos, + rewrite -neg_zero, + apply neg_le_neg, + apply rat.le_of_lt, + apply pnat.inv_pos + end + +theorem s_le_of_s_lt {s t : seq} (Hs : regular s) (Ht : regular t) (H : s_lt s t) : s_le s t := + begin + rewrite [↑s_le, ↑s_lt at *], + apply s_nonneg_of_pos, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end + +theorem s_neg_add_eq_s_add_neg (s t : seq) : sneg (sadd s t) ≡ sadd (sneg s) (sneg t) := + begin + rewrite [↑equiv, ↑sadd, ↑sneg], + intros, + rewrite [neg_add, sub_self, abs_zero], + apply add_invs_nonneg + end + +theorem equiv_cancel_middle {s t u : seq} (Hs : regular s) (Ht : regular t) + (Hu : regular u) : sadd (sadd u t) (sneg (sadd u s)) ≡ sadd t (sneg s) := + begin + note Hz := zero_is_reg, + apply equiv.trans, + rotate 3, + apply add_well_defined, + rotate 4, + apply s_add_comm, + apply s_neg_add_eq_s_add_neg, + apply equiv.trans, + rotate 3, + apply s_add_assoc, + rotate 2, + apply add_well_defined, + rotate 4, + apply equiv.refl, + apply equiv.trans, + rotate 4, + apply equiv.refl, + rotate_right 1, + apply equiv.trans, + rotate 3, + apply equiv.symm, + apply s_add_assoc, + rotate 2, + apply equiv.trans, + rotate 4, + apply s_zero_add, + rotate_right 1, + apply add_well_defined, + rotate 4, + apply neg_s_cancel, + rotate 1, + apply equiv.refl, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end + +protected theorem add_le_add_of_le_right {s t : seq} (Hs : regular s) (Ht : regular t) + (Lst : s_le s t) : ∀ u : seq, regular u → s_le (sadd u s) (sadd u t) := + begin + intro u Hu, + rewrite [↑s_le at *], + apply nonneg_of_nonneg_equiv, + rotate 2, + apply equiv.symm, + apply equiv_cancel_middle, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end + +theorem s_add_lt_add_left {s t : seq} (Hs : regular s) (Ht : regular t) (Hst : s_lt s t) {u : seq} + (Hu : regular u) : s_lt (sadd u s) (sadd u t) := + begin + rewrite ↑s_lt at *, + apply pos_of_pos_equiv, + rotate 1, + apply equiv.symm, + apply equiv_cancel_middle, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end + +protected theorem add_nonneg_of_nonneg {s t : seq} (Hs : nonneg s) (Ht : nonneg t) : + nonneg (sadd s t) := + begin + intros, + rewrite [-pnat.add_halves, neg_add], + apply add_le_add, + apply Hs, + apply Ht + end + +protected theorem le_trans {s t u : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (Lst : s_le s t) (Ltu : s_le t u) : s_le s u := + begin + rewrite ↑s_le at *, + note Rz := zero_is_reg, + have Hsum : nonneg (sadd (sadd u (sneg t)) (sadd t (sneg s))), + from rat_seq.add_nonneg_of_nonneg Ltu Lst, + have H' : nonneg (sadd (sadd u (sadd (sneg t) t)) (sneg s)), begin + apply nonneg_of_nonneg_equiv, + rotate 2, + apply add_well_defined, + rotate 4, + apply s_add_assoc, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption), + apply equiv.refl, + apply nonneg_of_nonneg_equiv, + rotate 2, + apply equiv.symm, + apply s_add_assoc, + rotate 2, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end, + have H'' : sadd (sadd u (sadd (sneg t) t)) (sneg s) ≡ sadd u (sneg s), begin + apply add_well_defined, + rotate 4, + apply equiv.trans, + rotate 3, + apply add_well_defined, + rotate 4, + apply equiv.refl, + apply s_neg_cancel, + rotate 1, + apply s_add_zero, + rotate 1, + apply equiv.refl, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end, + apply nonneg_of_nonneg_equiv, + rotate 2, + apply H'', + apply H', + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end + +theorem equiv_of_le_of_ge {s t : seq} (Hs : regular s) (Ht : regular t) (Lst : s_le s t) + (Lts : s_le t s) : s ≡ t := + begin + apply equiv_of_diff_equiv_zero, + rotate 2, + rewrite [↑s_le at *, ↑nonneg at *, ↑equiv, ↑sadd at *, ↑sneg at *], + intros, + rewrite [↑zero, sub_zero], + apply abs_le_of_le_of_neg_le, + apply le_of_neg_le_neg, + rewrite [2 neg_add, neg_neg], + apply rat.le_trans, + apply neg_add_neg_le_neg_of_pos, + apply pnat.inv_pos, + rewrite add.comm, + apply Lst, + apply le_of_neg_le_neg, + rewrite [neg_add, neg_neg], + apply rat.le_trans, + apply neg_add_neg_le_neg_of_pos, + apply pnat.inv_pos, + apply Lts, + repeat assumption + end + +definition sep (s t : seq) := s_lt s t ∨ s_lt t s +local infix `≢` : 50 := sep + +theorem le_and_sep_of_lt {s t : seq} (Hs : regular s) (Ht : regular t) (Lst : s_lt s t) : + s_le s t ∧ sep s t := + begin + apply and.intro, + intros, + cases Lst with [N, HN], + let Rns := reg_neg_reg Hs, + let Rtns := reg_add_reg Ht Rns, + note Habs := sub_le_of_abs_sub_le_right (Rtns N n), + rewrite [sub_add_eq_sub_sub at Habs], + exact (calc + sadd t (sneg s) n ≥ sadd t (sneg s) N - N⁻¹ - n⁻¹ : Habs + ... ≥ 0 - n⁻¹: begin + apply sub_le_sub_right, + apply rat.le_of_lt, + apply (iff.mpr (sub_pos_iff_lt _ _)), + apply HN + end + ... = -n⁻¹ : by rewrite zero_sub), + exact or.inl Lst + end + +theorem lt_of_le_and_sep {s t : seq} (Hs : regular s) (Ht : regular t) (H : s_le s t ∧ sep s t) : + s_lt s t := + begin + note Le := and.left H, + cases and.right H with [P, Hlt], + exact P, + rewrite [↑s_le at Le, ↑nonneg at Le, ↑s_lt at Hlt, ↑pos at Hlt], + apply exists.elim Hlt, + intro N HN, + let LeN := Le N, + note HN' := (iff.mpr !neg_lt_neg_iff_lt) HN, + rewrite [↑sadd at HN', ↑sneg at HN', neg_add at HN', neg_neg at HN', add.comm at HN'], + let HN'' := not_le_of_gt HN', + apply absurd LeN HN'' + end + +theorem lt_iff_le_and_sep {s t : seq} (Hs : regular s) (Ht : regular t) : + s_lt s t ↔ s_le s t ∧ sep s t := + iff.intro (le_and_sep_of_lt Hs Ht) (lt_of_le_and_sep Hs Ht) + +theorem s_neg_zero : sneg zero ≡ zero := + begin + rewrite ↑[sneg, zero, equiv], + intros, + rewrite [sub_zero, abs_neg, abs_zero], + apply add_invs_nonneg + end + +theorem s_sub_zero {s : seq} (Hs : regular s) : sadd s (sneg zero) ≡ s := + begin + apply equiv.trans, + rotate 3, + apply add_well_defined, + rotate 4, + apply equiv.refl, + apply s_neg_zero, + apply s_add_zero, + repeat (assumption | apply reg_add_reg | apply reg_neg_reg | apply zero_is_reg) + end + +theorem s_pos_of_gt_zero {s : seq} (Hs : regular s) (Hgz : s_lt zero s) : pos s := + begin + rewrite [↑s_lt at *], + apply pos_of_pos_equiv, + rotate 1, + apply s_sub_zero, + repeat (assumption | apply reg_add_reg | apply reg_neg_reg), + apply zero_is_reg + end + +theorem s_gt_zero_of_pos {s : seq} (Hs : regular s) (Hp : pos s) : s_lt zero s := + begin + rewrite ↑s_lt, + apply pos_of_pos_equiv, + rotate 1, + apply equiv.symm, + apply s_sub_zero, + repeat assumption + end + +theorem s_nonneg_of_ge_zero {s : seq} (Hs : regular s) (Hgz : s_le zero s) : nonneg s := + begin + rewrite ↑s_le at *, + apply nonneg_of_nonneg_equiv, + rotate 2, + apply s_sub_zero, + repeat (assumption | apply reg_add_reg | apply reg_neg_reg | apply zero_is_reg) + end + +theorem s_ge_zero_of_nonneg {s : seq} (Hs : regular s) (Hn : nonneg s) : s_le zero s := + begin + rewrite ↑s_le, + apply nonneg_of_nonneg_equiv, + rotate 2, + apply equiv.symm, + apply s_sub_zero, + repeat (assumption | apply reg_add_reg | apply reg_neg_reg | apply zero_is_reg) + end + +theorem s_mul_pos_of_pos {s t : seq} (Hs : regular s) (Ht : regular t) (Hps : pos s) + (Hpt : pos t) : pos (smul s t) := + begin + rewrite [↑pos at *], + cases bdd_away_of_pos Hs Hps with [Ns, HNs], + cases bdd_away_of_pos Ht Hpt with [Nt, HNt], + existsi 2 * max Ns Nt * max Ns Nt, + rewrite ↑smul, + apply lt_of_lt_of_le, + rotate 1, + apply mul_le_mul, + apply HNs, + apply pnat.le_trans, + apply pnat.max_left Ns Nt, + rewrite -pnat.mul_assoc, + apply pnat.mul_le_mul_left, + apply HNt, + apply pnat.le_trans, + apply pnat.max_right Ns Nt, + rewrite -pnat.mul_assoc, + apply pnat.mul_le_mul_left, + apply rat.le_of_lt, + apply pnat.inv_pos, + apply rat.le_trans, + rotate 1, + apply HNs, + apply pnat.le_trans, + apply pnat.max_left Ns Nt, + rewrite -pnat.mul_assoc, + apply pnat.mul_le_mul_left, + rewrite pnat.inv_mul_eq_mul_inv, + apply mul_lt_mul, + rewrite [pnat.inv_mul_eq_mul_inv, -one_mul Ns⁻¹], + apply mul_lt_mul, + apply inv_lt_one_of_gt, + apply dec_trivial, + apply inv_ge_of_le, + apply pnat.max_left, + apply pnat.inv_pos, + apply rat.le_of_lt zero_lt_one, + apply inv_ge_of_le, + apply pnat.max_right, + apply pnat.inv_pos, + repeat (apply le_of_lt; apply pnat.inv_pos) + end + +theorem s_mul_gt_zero_of_gt_zero {s t : seq} (Hs : regular s) (Ht : regular t) + (Hzs : s_lt zero s) (Hzt : s_lt zero t) : s_lt zero (smul s t) := + s_gt_zero_of_pos + (reg_mul_reg Hs Ht) + (s_mul_pos_of_pos Hs Ht (s_pos_of_gt_zero Hs Hzs) (s_pos_of_gt_zero Ht Hzt)) + +theorem le_of_lt_or_equiv {s t : seq} (Hs : regular s) (Ht : regular t) + (Hor : (s_lt s t) ∨ (s ≡ t)) : s_le s t := + or.elim Hor + (begin + intro Hlt, + apply s_le_of_s_lt Hs Ht Hlt + end) + (begin + intro Heq, + rewrite ↑s_le, + apply nonneg_of_nonneg_equiv, + rotate 3, + apply zero_nonneg, + apply zero_is_reg, + apply reg_add_reg Ht (reg_neg_reg Hs), + apply equiv.symm, + apply diff_equiv_zero_of_equiv, + rotate 2, + apply equiv.symm, + apply Heq, + repeat assumption + end) + +theorem s_zero_mul {s : seq} : smul s zero ≡ zero := + begin + rewrite [↑equiv, ↑smul, ↑zero], + intros, + rewrite [mul_zero, sub_zero, abs_zero], + apply add_invs_nonneg + end + +theorem s_mul_nonneg_of_pos_of_zero {s t : seq} (Hs : regular s) (Ht : regular t) + (Hps : pos s) (Hpt : zero ≡ t) : nonneg (smul s t) := + begin + apply nonneg_of_nonneg_equiv, + rotate 2, + apply mul_well_defined, + rotate 4, + apply equiv.refl, + apply Hpt, + apply nonneg_of_nonneg_equiv, + rotate 2, + apply equiv.symm, + apply s_zero_mul, + apply zero_nonneg, + repeat (assumption | apply reg_mul_reg | apply zero_is_reg) + end + +theorem s_mul_nonneg_of_nonneg {s t : seq} (Hs : regular s) (Ht : regular t) + (Hps : nonneg s) (Hpt : nonneg t) : nonneg (smul s t) := + begin + intro n, + rewrite ↑smul, + apply rat.le_by_cases 0 (s (((K₂ s t) * 2) * n)), + intro Hsp, + apply rat.le_by_cases 0 (t (((K₂ s t) * 2) * n)), + intro Htp, + apply rat.le_trans, + rotate 1, + apply rat.mul_nonneg Hsp Htp, + rotate_right 1, + apply le_of_lt, + apply neg_neg_of_pos, + apply pnat.inv_pos, + intro Htn, + apply rat.le_trans, + rotate 1, + apply mul_le_mul_of_nonpos_right, + apply rat.le_trans, + apply le_abs_self, + apply canon_2_bound_left s t Hs, + apply Htn, + rotate_right 1, + apply rat.le_trans, + rotate 1, + apply mul_le_mul_of_nonneg_left, + apply Hpt, + apply le_of_lt, + apply rat_of_pnat_is_pos, + rotate 1, + rewrite -neg_mul_eq_mul_neg, + apply neg_le_neg, + rewrite [*pnat.mul_assoc, pnat.inv_mul_eq_mul_inv, -mul.assoc, pnat.inv_cancel_left, one_mul], + apply inv_ge_of_le, + apply pnat.mul_le_mul_left, + intro Hsn, + apply rat.le_by_cases 0 (t (((K₂ s t) * 2) * n)), + intro Htp, + apply rat.le_trans, + rotate 1, + apply mul_le_mul_of_nonpos_left, + apply rat.le_trans, + apply le_abs_self, + apply canon_2_bound_right s t Ht, + apply Hsn, + rotate_right 1, + apply rat.le_trans, + rotate 1, + apply mul_le_mul_of_nonneg_right, + apply Hps, + apply le_of_lt, + apply rat_of_pnat_is_pos, + rotate 1, + rewrite -neg_mul_eq_neg_mul, + apply neg_le_neg, + rewrite [+pnat.mul_assoc, pnat.inv_mul_eq_mul_inv, mul.comm, -mul.assoc, pnat.inv_cancel_left, + one_mul], + apply inv_ge_of_le, + apply pnat.mul_le_mul_left, + intro Htn, + apply le.trans, + rotate 1, + apply mul_nonneg_of_nonpos_of_nonpos, + apply Hsn, + apply Htn, + apply le_of_lt, + apply neg_neg_of_pos, + apply pnat.inv_pos + end + +theorem s_mul_ge_zero_of_ge_zero {s t : seq} (Hs : regular s) (Ht : regular t) + (Hzs : s_le zero s) (Hzt : s_le zero t) : s_le zero (smul s t) := + begin + note Hzs' := s_nonneg_of_ge_zero Hs Hzs, + note Htz' := s_nonneg_of_ge_zero Ht Hzt, + apply s_ge_zero_of_nonneg, + rotate 1, + apply s_mul_nonneg_of_nonneg, + repeat assumption, + apply reg_mul_reg Hs Ht + end + +protected theorem not_lt_self (s : seq) : ¬ s_lt s s := + begin + intro Hlt, + rewrite [↑s_lt at Hlt, ↑pos at Hlt], + apply exists.elim Hlt, + intro n Hn, esimp at Hn, + rewrite [↑sadd at Hn,↑sneg at Hn, -sub_eq_add_neg at Hn, sub_self at Hn], + apply absurd Hn (not_lt_of_ge (rat.le_of_lt !pnat.inv_pos)) + end + +theorem not_sep_self (s : seq) : ¬ s ≢ s := + begin + intro Hsep, + rewrite ↑sep at Hsep, + let Hsep' := (iff.mp !or_self) Hsep, + apply absurd Hsep' (!rat_seq.not_lt_self) + end + +theorem le_well_defined {s t u v : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (Hv : regular v) (Hsu : s ≡ u) (Htv : t ≡ v) : s_le s t ↔ s_le u v := + iff.intro + (begin + intro Hle, + rewrite [↑s_le at *], + apply nonneg_of_nonneg_equiv, + rotate 2, + apply add_well_defined, + rotate 4, + apply Htv, + apply neg_well_defined, + apply Hsu, + apply Hle, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end) + (begin + intro Hle, + rewrite [↑s_le at *], + apply nonneg_of_nonneg_equiv, + rotate 2, + apply add_well_defined, + rotate 4, + apply equiv.symm, apply Htv, + apply neg_well_defined, + apply equiv.symm, apply Hsu, + apply Hle, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end) + +theorem lt_well_defined {s t u v : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (Hv : regular v) (Hsu : s ≡ u) (Htv : t ≡ v) : s_lt s t ↔ s_lt u v := + iff.intro + (begin + intro Hle, + rewrite [↑s_lt at *], + apply pos_of_pos_equiv, + rotate 1, + apply add_well_defined, + rotate 4, + apply Htv, + apply neg_well_defined, + apply Hsu, + apply Hle, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end) + (begin + intro Hle, + rewrite [↑s_lt at *], + apply pos_of_pos_equiv, + rotate 1, + apply add_well_defined, + rotate 4, + apply equiv.symm, apply Htv, + apply neg_well_defined, + apply equiv.symm, apply Hsu, + apply Hle, + repeat (apply reg_add_reg | apply reg_neg_reg | assumption) + end) + +theorem sep_well_defined {s t u v : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (Hv : regular v) (Hsu : s ≡ u) (Htv : t ≡ v) : s ≢ t ↔ u ≢ v := + begin + rewrite ↑sep, + apply iff.intro, + intro Hor, + apply or.elim Hor, + intro Hlt, + apply or.inl, + apply iff.mp (lt_well_defined Hs Ht Hu Hv Hsu Htv), + assumption, + intro Hlt, + apply or.inr, + apply iff.mp (lt_well_defined Ht Hs Hv Hu Htv Hsu), + assumption, + intro Hor, + apply or.elim Hor, + intro Hlt, + apply or.inl, + apply iff.mpr (lt_well_defined Hs Ht Hu Hv Hsu Htv), + assumption, + intro Hlt, + apply or.inr, + apply iff.mpr (lt_well_defined Ht Hs Hv Hu Htv Hsu), + assumption + end + +theorem s_lt_of_lt_of_le {s t u : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (Hst : s_lt s t) (Htu : s_le t u) : s_lt s u := + begin + let Rtns := reg_add_reg Ht (reg_neg_reg Hs), + let Runt := reg_add_reg Hu (reg_neg_reg Ht), + have Hcan : ∀ m, sadd u (sneg s) m = (sadd t (sneg s)) m + (sadd u (sneg t)) m, begin + intro m, + rewrite [↑sadd, ↑sneg, -*sub_eq_add_neg, -sub_eq_sub_add_sub] + end, + rewrite [↑s_lt at *, ↑s_le at *], + cases bdd_away_of_pos Rtns Hst with [Nt, HNt], + cases bdd_within_of_nonneg Runt Htu (2 * Nt) with [Nu, HNu], + apply pos_of_bdd_away, + existsi max (2 * Nt) Nu, + intro n Hn, + rewrite Hcan, + apply rat.le_trans, + rotate 1, + apply add_le_add, + apply HNt, + apply pnat.le_trans, + apply pnat.mul_le_mul_left 2, + apply pnat.le_trans, + rotate 1, + apply Hn, + rotate_right 1, + apply pnat.max_left, + apply HNu, + apply pnat.le_trans, + rotate 1, + apply Hn, + rotate_right 1, + apply pnat.max_right, + rewrite [-pnat.add_halves Nt, -sub_eq_add_neg, add_sub_cancel], + apply inv_ge_of_le, + apply pnat.max_left + end + +theorem s_lt_of_le_of_lt {s t u : seq} (Hs : regular s) (Ht : regular t) (Hu : regular u) + (Hst : s_le s t) (Htu : s_lt t u) : s_lt s u := + begin + let Rtns := reg_add_reg Ht (reg_neg_reg Hs), + let Runt := reg_add_reg Hu (reg_neg_reg Ht), + have Hcan : ∀ m, sadd u (sneg s) m = (sadd t (sneg s)) m + (sadd u (sneg t)) m, begin + intro m, + rewrite [↑sadd, ↑sneg, -*sub_eq_add_neg, -sub_eq_sub_add_sub] + end, + rewrite [↑s_lt at *, ↑s_le at *], + cases bdd_away_of_pos Runt Htu with [Nu, HNu], + cases bdd_within_of_nonneg Rtns Hst (2 * Nu) with [Nt, HNt], + apply pos_of_bdd_away, + existsi max (2 * Nu) Nt, + intro n Hn, + rewrite Hcan, + apply rat.le_trans, + rotate 1, + apply add_le_add, + apply HNt, + apply pnat.le_trans, + rotate 1, + apply Hn, + rotate_right 1, + apply pnat.max_right, + apply HNu, + apply pnat.le_trans, + apply pnat.mul_le_mul_left 2, + apply pnat.le_trans, + rotate 1, + apply Hn, + rotate_right 1, + apply pnat.max_left, + rewrite [-pnat.add_halves Nu, neg_add_cancel_left], + apply inv_ge_of_le, + apply pnat.max_left + end + +theorem le_of_le_reprs {s t : seq} (Hs : regular s) (Ht : regular t) + (Hle : ∀ n : ℕ+, s_le s (const (t n))) : s_le s t := + by intro m; apply Hle (2 * m) m + +theorem le_of_reprs_le {s t : seq} (Hs : regular s) (Ht : regular t) + (Hle : ∀ n : ℕ+, s_le (const (t n)) s) : s_le t s := + by intro m; apply Hle (2 * m) m + +----------------------------- +-- of_rat theorems + +theorem const_le_const_of_le {a b : ℚ} (H : a ≤ b) : s_le (const a) (const b) := + begin + rewrite [↑s_le, ↑nonneg], + intro n, + rewrite [↑sadd, ↑sneg, ↑const], + apply le.trans, + apply neg_nonpos_of_nonneg, + apply rat.le_of_lt, + apply pnat.inv_pos, + apply iff.mpr !sub_nonneg_iff_le, + apply H + end + +theorem le_of_const_le_const {a b : ℚ} (H : s_le (const a) (const b)) : a ≤ b := + begin + rewrite [↑s_le at H, ↑nonneg at H, ↑sadd at H, ↑sneg at H, ↑const at H], + apply iff.mp !sub_nonneg_iff_le, + apply nonneg_of_ge_neg_invs _ H + end + +theorem nat_inv_lt_rat {a : ℚ} (H : a > 0) : ∃ n : ℕ+, n⁻¹ < a := + begin + existsi (pceil (1 / (a / (2)))), + apply lt_of_le_of_lt, + rotate 1, + apply div_two_lt_of_pos H, + rewrite -(one_div_one_div (a / (1 + 1))), + apply pceil_helper, + apply pnat.le_refl, + apply one_div_pos_of_pos, + apply div_pos_of_pos_of_pos H dec_trivial + end + + +theorem const_lt_const_of_lt {a b : ℚ} (H : a < b) : s_lt (const a) (const b) := + begin + rewrite [↑s_lt, ↑pos, ↑sadd, ↑sneg, ↑const], + apply nat_inv_lt_rat, + apply (iff.mpr !sub_pos_iff_lt H) + end + +theorem lt_of_const_lt_const {a b : ℚ} (H : s_lt (const a) (const b)) : a < b := + begin + rewrite [↑s_lt at H, ↑pos at H, ↑const at H, ↑sadd at H, ↑sneg at H], + cases H with [n, Hn], + apply (iff.mp !sub_pos_iff_lt), + apply lt.trans, + rotate 1, + exact Hn, + apply pnat.inv_pos + end + +theorem s_le_of_le_pointwise {s t : seq} (Hs : regular s) (Ht : regular t) + (H : ∀ n : ℕ+, s n ≤ t n) : s_le s t := + begin + rewrite [↑s_le, ↑nonneg, ↑sadd, ↑sneg], + intros, + apply le.trans, + apply iff.mpr !neg_nonpos_iff_nonneg, + apply le_of_lt, + apply pnat.inv_pos, + apply iff.mpr !sub_nonneg_iff_le, + apply H + end + +-------- lift to reg_seqs +definition r_lt (s t : reg_seq) := s_lt (reg_seq.sq s) (reg_seq.sq t) +definition r_le (s t : reg_seq) := s_le (reg_seq.sq s) (reg_seq.sq t) +definition r_sep (s t : reg_seq) := sep (reg_seq.sq s) (reg_seq.sq t) + +theorem r_le_well_defined (s t u v : reg_seq) (Hsu : requiv s u) (Htv : requiv t v) + : r_le s t = r_le u v := + propext (le_well_defined (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) + (reg_seq.is_reg v) Hsu Htv) + + +theorem r_lt_well_defined (s t u v : reg_seq) (Hsu : requiv s u) (Htv : requiv t v) + : r_lt s t = r_lt u v := + propext (lt_well_defined (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) + (reg_seq.is_reg v) Hsu Htv) + +theorem r_sep_well_defined (s t u v : reg_seq) (Hsu : requiv s u) (Htv : requiv t v) + : r_sep s t = r_sep u v := + propext (sep_well_defined (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) + (reg_seq.is_reg v) Hsu Htv) + +theorem r_le.refl (s : reg_seq) : r_le s s := rat_seq.le_refl (reg_seq.is_reg s) + +theorem r_le.trans {s t u : reg_seq} (Hst : r_le s t) (Htu : r_le t u) : r_le s u := + rat_seq.le_trans (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) Hst Htu + +theorem r_equiv_of_le_of_ge {s t : reg_seq} (Hs : r_le s t) (Hu : r_le t s) : + requiv s t := + equiv_of_le_of_ge (reg_seq.is_reg s) (reg_seq.is_reg t) Hs Hu + +theorem r_lt_iff_le_and_sep (s t : reg_seq) : r_lt s t ↔ r_le s t ∧ r_sep s t := + lt_iff_le_and_sep (reg_seq.is_reg s) (reg_seq.is_reg t) + +theorem r_add_le_add_of_le_right {s t : reg_seq} (H : r_le s t) (u : reg_seq) : + r_le (u + s) (u + t) := + rat_seq.add_le_add_of_le_right (reg_seq.is_reg s) (reg_seq.is_reg t) H + (reg_seq.sq u) (reg_seq.is_reg u) + +theorem r_add_le_add_of_le_right_var (s t u : reg_seq) (H : r_le s t) : + r_le (u + s) (u + t) := r_add_le_add_of_le_right H u + +theorem r_mul_pos_of_pos {s t : reg_seq} (Hs : r_lt r_zero s) (Ht : r_lt r_zero t) : + r_lt r_zero (s * t) := + s_mul_gt_zero_of_gt_zero (reg_seq.is_reg s) (reg_seq.is_reg t) Hs Ht + +theorem r_mul_nonneg_of_nonneg {s t : reg_seq} (Hs : r_le r_zero s) (Ht : r_le r_zero t) : + r_le r_zero (s * t) := + s_mul_ge_zero_of_ge_zero (reg_seq.is_reg s) (reg_seq.is_reg t) Hs Ht + +theorem r_not_lt_self (s : reg_seq) : ¬ r_lt s s := + rat_seq.not_lt_self (reg_seq.sq s) + +theorem r_not_sep_self (s : reg_seq) : ¬ r_sep s s := + not_sep_self (reg_seq.sq s) + +theorem r_le_of_lt {s t : reg_seq} (H : r_lt s t) : r_le s t := + s_le_of_s_lt (reg_seq.is_reg s) (reg_seq.is_reg t) H + +theorem r_lt_of_le_of_lt {s t u : reg_seq} (Hst : r_le s t) (Htu : r_lt t u) : r_lt s u := + s_lt_of_le_of_lt (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) Hst Htu + +theorem r_lt_of_lt_of_le {s t u : reg_seq} (Hst : r_lt s t) (Htu : r_le t u) : r_lt s u := + s_lt_of_lt_of_le (reg_seq.is_reg s) (reg_seq.is_reg t) (reg_seq.is_reg u) Hst Htu + +theorem r_add_lt_add_left (s t : reg_seq) (H : r_lt s t) (u : reg_seq) : r_lt (u + s) (u + t) := + s_add_lt_add_left (reg_seq.is_reg s) (reg_seq.is_reg t) H (reg_seq.is_reg u) + +theorem r_add_lt_add_left_var (s t u : reg_seq) (H : r_lt s t) : r_lt (u + s) (u + t) := + r_add_lt_add_left s t H u + +theorem r_zero_lt_one : r_lt r_zero r_one := s_zero_lt_one + +theorem r_le_of_lt_or_eq (s t : reg_seq) (H : r_lt s t ∨ requiv s t) : r_le s t := + le_of_lt_or_equiv (reg_seq.is_reg s) (reg_seq.is_reg t) H + +theorem r_const_le_const_of_le {a b : ℚ} (H : a ≤ b) : r_le (r_const a) (r_const b) := + const_le_const_of_le H + +theorem r_le_of_const_le_const {a b : ℚ} (H : r_le (r_const a) (r_const b)) : a ≤ b := + le_of_const_le_const H + +theorem r_const_lt_const_of_lt {a b : ℚ} (H : a < b) : r_lt (r_const a) (r_const b) := + const_lt_const_of_lt H + +theorem r_lt_of_const_lt_const {a b : ℚ} (H : r_lt (r_const a) (r_const b)) : a < b := + lt_of_const_lt_const H + +theorem r_le_of_le_reprs (s t : reg_seq) (Hle : ∀ n : ℕ+, r_le s (r_const (reg_seq.sq t n))) : r_le s t := + le_of_le_reprs (reg_seq.is_reg s) (reg_seq.is_reg t) Hle + +theorem r_le_of_reprs_le (s t : reg_seq) (Hle : ∀ n : ℕ+, r_le (r_const (reg_seq.sq t n)) s) : + r_le t s := + le_of_reprs_le (reg_seq.is_reg s) (reg_seq.is_reg t) Hle + +end rat_seq + +open real +open [class] rat_seq +namespace real + +protected definition lt (x y : ℝ) := + quot.lift_on₂ x y (λ a b, rat_seq.r_lt a b) rat_seq.r_lt_well_defined +protected definition le (x y : ℝ) := + quot.lift_on₂ x y (λ a b, rat_seq.r_le a b) rat_seq.r_le_well_defined + +attribute [instance, priority real.prio] +definition real_has_lt : has_lt ℝ := +has_lt.mk real.lt + +attribute [instance, priority real.prio] +definition real_has_le : has_le ℝ := +has_le.mk real.le + +definition sep (x y : ℝ) := quot.lift_on₂ x y (λ a b, rat_seq.r_sep a b) rat_seq.r_sep_well_defined +infix `≢` : 50 := sep + +protected theorem le_refl (x : ℝ) : x ≤ x := + quot.induction_on x (λ t, rat_seq.r_le.refl t) + +protected theorem le_trans {x y z : ℝ} : x ≤ y → y ≤ z → x ≤ z := + quot.induction_on₃ x y z (λ s t u, rat_seq.r_le.trans) + +protected theorem eq_of_le_of_ge {x y : ℝ} : x ≤ y → y ≤ x → x = y := + quot.induction_on₂ x y (λ s t Hst Hts, quot.sound (rat_seq.r_equiv_of_le_of_ge Hst Hts)) + +theorem lt_iff_le_and_sep (x y : ℝ) : x < y ↔ x ≤ y ∧ x ≢ y := + quot.induction_on₂ x y (λ s t, rat_seq.r_lt_iff_le_and_sep s t) + +protected theorem add_le_add_left' (x y z : ℝ) : x ≤ y → z + x ≤ z + y := + quot.induction_on₃ x y z (λ s t u, rat_seq.r_add_le_add_of_le_right_var s t u) + +protected theorem add_le_add_left (x y : ℝ) : x ≤ y → ∀ z : ℝ, z + x ≤ z + y := + take H z, real.add_le_add_left' x y z H + +protected theorem mul_pos (x y : ℝ) : 0 < x → 0 < y → 0 < x * y := + quot.induction_on₂ x y (λ s t, rat_seq.r_mul_pos_of_pos) + +protected theorem mul_nonneg (x y : ℝ) : 0 ≤ x → 0 ≤ y → 0 ≤ x * y := + quot.induction_on₂ x y (λ s t, rat_seq.r_mul_nonneg_of_nonneg) + +theorem not_sep_self (x : ℝ) : ¬ x ≢ x := + quot.induction_on x (λ s, rat_seq.r_not_sep_self s) + +protected theorem lt_irrefl (x : ℝ) : ¬ x < x := + quot.induction_on x (λ s, rat_seq.r_not_lt_self s) + +protected theorem le_of_lt {x y : ℝ} : x < y → x ≤ y := + quot.induction_on₂ x y (λ s t H', rat_seq.r_le_of_lt H') + +protected theorem lt_of_le_of_lt {x y z : ℝ} : x ≤ y → y < z → x < z := + quot.induction_on₃ x y z (λ s t u H H', rat_seq.r_lt_of_le_of_lt H H') + +protected theorem lt_of_lt_of_le {x y z : ℝ} : x < y → y ≤ z → x < z := + quot.induction_on₃ x y z (λ s t u H H', rat_seq.r_lt_of_lt_of_le H H') + +protected theorem add_lt_add_left' (x y z : ℝ) : x < y → z + x < z + y := + quot.induction_on₃ x y z (λ s t u, rat_seq.r_add_lt_add_left_var s t u) + +protected theorem add_lt_add_left (x y : ℝ) : x < y → ∀ z : ℝ, z + x < z + y := + take H z, real.add_lt_add_left' x y z H + +protected theorem zero_lt_one : (0 : ℝ) < (1 : ℝ) := rat_seq.r_zero_lt_one + +protected theorem le_of_lt_or_eq (x y : ℝ) : x < y ∨ x = y → x ≤ y := + (quot.induction_on₂ x y (λ s t H, or.elim H (take H', begin + apply rat_seq.r_le_of_lt_or_eq, + apply or.inl H' + end) + (take H', begin + apply rat_seq.r_le_of_lt_or_eq, + apply (or.inr (quot.exact H')) + end))) + +attribute [trans_instance] +definition ordered_ring : ordered_ring ℝ := +⦃ ordered_ring, real.comm_ring, + le_refl := real.le_refl, + le_trans := @real.le_trans, + mul_pos := real.mul_pos, + mul_nonneg := real.mul_nonneg, + zero_ne_one := real.zero_ne_one, + add_le_add_left := real.add_le_add_left, + le_antisymm := @real.eq_of_le_of_ge, + lt_irrefl := real.lt_irrefl, + lt_of_le_of_lt := @real.lt_of_le_of_lt, + lt_of_lt_of_le := @real.lt_of_lt_of_le, + le_of_lt := @real.le_of_lt, + add_lt_add_left := real.add_lt_add_left +⦄ + +open int +theorem of_rat_sub (a b : ℚ) : of_rat (a - b) = of_rat a - of_rat b := rfl + +theorem of_int_sub (a b : ℤ) : of_int (a - b) = of_int a - of_int b := + by rewrite [of_int_eq, rat.of_int_sub, of_rat_sub] + +theorem of_rat_le_of_rat_of_le {a b : ℚ} : a ≤ b → of_rat a ≤ of_rat b := + rat_seq.r_const_le_const_of_le + +theorem le_of_of_rat_le_of_rat {a b : ℚ} : of_rat a ≤ of_rat b → a ≤ b := + rat_seq.r_le_of_const_le_const + +theorem of_rat_le_of_rat_iff (a b : ℚ) : of_rat a ≤ of_rat b ↔ a ≤ b := + iff.intro le_of_of_rat_le_of_rat of_rat_le_of_rat_of_le + +theorem of_rat_lt_of_rat_of_lt {a b : ℚ} : a < b → of_rat a < of_rat b := + rat_seq.r_const_lt_const_of_lt + +theorem lt_of_of_rat_lt_of_rat {a b : ℚ} : of_rat a < of_rat b → a < b := + rat_seq.r_lt_of_const_lt_const + +theorem of_rat_lt_of_rat_iff (a b : ℚ) : of_rat a < of_rat b ↔ a < b := + iff.intro lt_of_of_rat_lt_of_rat of_rat_lt_of_rat_of_lt + +theorem of_int_le_of_int_iff (a b : ℤ) : of_int a ≤ of_int b ↔ (a ≤ b) := + begin rewrite [+of_int_eq, of_rat_le_of_rat_iff], apply rat.of_int_le_of_int_iff end + +theorem of_int_le_of_int_of_le {a b : ℤ} : (a ≤ b) → of_int a ≤ of_int b := + iff.mpr !of_int_le_of_int_iff + +theorem le_of_of_int_le_of_int {a b : ℤ} : of_int a ≤ of_int b → (a ≤ b) := + iff.mp !of_int_le_of_int_iff + +theorem of_int_lt_of_int_iff (a b : ℤ) : of_int a < of_int b ↔ (a < b) := + by rewrite [*of_int_eq, of_rat_lt_of_rat_iff]; apply rat.of_int_lt_of_int_iff + +theorem of_int_lt_of_int_of_lt {a b : ℤ} : (a < b) → of_int a < of_int b := + iff.mpr !of_int_lt_of_int_iff + +theorem lt_of_of_int_lt_of_int {a b : ℤ} : of_int a < of_int b → (a < b) := + iff.mp !of_int_lt_of_int_iff + +theorem of_nat_le_of_nat_iff (a b : ℕ) : of_nat a ≤ of_nat b ↔ (a ≤ b) := + by rewrite [*of_nat_eq, of_rat_le_of_rat_iff]; apply rat.of_nat_le_of_nat_iff + +theorem of_nat_le_of_nat_of_le {a b : ℕ} : (a ≤ b) → of_nat a ≤ of_nat b := + iff.mpr !of_nat_le_of_nat_iff + +theorem le_of_of_nat_le_of_nat {a b : ℕ} : of_nat a ≤ of_nat b → (a ≤ b) := + iff.mp !of_nat_le_of_nat_iff + +theorem of_nat_lt_of_nat_iff (a b : ℕ) : of_nat a < of_nat b ↔ (a < b) := + by rewrite [*of_nat_eq, of_rat_lt_of_rat_iff]; apply rat.of_nat_lt_of_nat_iff + +theorem of_nat_lt_of_nat_of_lt {a b : ℕ} : (a < b) → of_nat a < of_nat b := + iff.mpr !of_nat_lt_of_nat_iff + +theorem lt_of_of_nat_lt_of_nat {a b : ℕ} : of_nat a < of_nat b → (a < b) := + iff.mp !of_nat_lt_of_nat_iff + +theorem of_rat_pos_of_pos {q : ℚ} (Hq : q > 0) : of_rat q > 0 := + of_rat_lt_of_rat_of_lt Hq + +theorem of_rat_nonneg_of_nonneg {q : ℚ} (Hq : q ≥ 0) : of_rat q ≥ 0 := + of_rat_le_of_rat_of_le Hq + +theorem of_rat_neg_of_neg {q : ℚ} (Hq : q < 0) : of_rat q < 0 := + of_rat_lt_of_rat_of_lt Hq + +theorem of_rat_nonpos_of_nonpos {q : ℚ} (Hq : q ≤ 0) : of_rat q ≤ 0 := + of_rat_le_of_rat_of_le Hq + +theorem of_nat_nonneg (a : ℕ) : of_nat a ≥ 0 := +of_rat_le_of_rat_of_le !rat.of_nat_nonneg + +theorem of_nat_succ_pos (k : ℕ) : 0 < of_nat k + 1 := + add_pos_of_nonneg_of_pos (of_nat_nonneg k) real.zero_lt_one + +theorem of_rat_pow (a : ℚ) (n : ℕ) : of_rat (a^n) = (of_rat a)^n := +begin + induction n with n ih, + apply eq.refl, + rewrite [2 pow_succ, of_rat_mul, ih] +end + +theorem of_int_pow (a : ℤ) (n : ℕ) : of_int (#int a^n) = (of_int a)^n := +by rewrite [of_int_eq, rat.of_int_pow, of_rat_pow] + +theorem of_nat_pow (a : ℕ) (n : ℕ) : of_nat (#nat a^n) = (of_nat a)^n := +by rewrite [of_nat_eq, rat.of_nat_pow, of_rat_pow] + +open rat_seq +theorem le_of_le_reprs (x : ℝ) (t : seq) (Ht : regular t) : (∀ n : ℕ+, x ≤ t n) → + x ≤ quot.mk (reg_seq.mk t Ht) := + quot.induction_on x (take s Hs, + show r_le s (reg_seq.mk t Ht), from + have H' : ∀ n : ℕ+, r_le s (r_const (t n)), from Hs, + by apply r_le_of_le_reprs; apply Hs) + +theorem le_of_reprs_le (x : ℝ) (t : seq) (Ht : regular t) : (∀ n : ℕ+, t n ≤ x) → + x ≥ ((quot.mk (reg_seq.mk t Ht)) : ℝ) := + quot.induction_on x (take s Hs, + show r_le (reg_seq.mk t Ht) s, from + have H' : ∀ n : ℕ+, r_le (r_const (t n)) s, from Hs, + by apply r_le_of_reprs_le; apply Hs) + +end real diff --git a/old_library/data/real/real.md b/old_library/data/real/real.md new file mode 100644 index 0000000000..39f128218c --- /dev/null +++ b/old_library/data/real/real.md @@ -0,0 +1,9 @@ +data.real +======== + +The real numbers: classically, as a quotient type; constructively, as a setoid. + +* [basic](basic.lean) : the reals as a commutative ring (constructive) +* [order](order.lean) : the reals as an ordered ring (constructive) +* [division](division.lean) : the reals as a discrete linear ordered field (classical) +* [complete](complete.lean) : the reals are Cauchy complete (classical) diff --git a/old_library/data/set/basic.lean b/old_library/data/set/basic.lean new file mode 100644 index 0000000000..0dc45166f6 --- /dev/null +++ b/old_library/data/set/basic.lean @@ -0,0 +1,1007 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad, Leonardo de Moura +-/ +import logic.connectives logic.identities algebra.binary +open eq.ops binary function + +definition set (X : Type) := X → Prop + +namespace set + +variable {X : Type} + +/- membership and subset -/ + +definition mem (x : X) (a : set X) := a x +infix ∈ := mem +notation a ∉ b := ¬ mem a b + +theorem ext {a b : set X} (H : ∀x, x ∈ a ↔ x ∈ b) : a = b := +funext (take x, propext (H x)) + +definition subset (a b : set X) := ∀⦃x⦄, x ∈ a → x ∈ b +infix ⊆ := subset + +definition superset (s t : set X) : Prop := t ⊆ s +infix ⊇ := superset + +theorem subset.refl (a : set X) : a ⊆ a := take x, assume H, H + +theorem subset.trans {a b c : set X} (subab : a ⊆ b) (subbc : b ⊆ c) : a ⊆ c := +take x, assume ax, subbc (subab ax) + +theorem subset.antisymm {a b : set X} (h₁ : a ⊆ b) (h₂ : b ⊆ a) : a = b := +ext (λ x, iff.intro (λ ina, h₁ ina) (λ inb, h₂ inb)) + +-- an alterantive name +theorem eq_of_subset_of_subset {a b : set X} (h₁ : a ⊆ b) (h₂ : b ⊆ a) : a = b := +subset.antisymm h₁ h₂ + +theorem mem_of_subset_of_mem {s₁ s₂ : set X} {a : X} : s₁ ⊆ s₂ → a ∈ s₁ → a ∈ s₂ := +assume h₁ h₂, h₁ _ h₂ + +/- strict subset -/ + +definition strict_subset (a b : set X) := a ⊆ b ∧ a ≠ b +infix ` ⊂ `:50 := strict_subset + +theorem strict_subset.irrefl (a : set X) : ¬ a ⊂ a := +assume h, absurd rfl (and.elim_right h) + +/- bounded quantification -/ + +abbreviation bounded_forall (a : set X) (P : X → Prop) := ∀⦃x⦄, x ∈ a → P x +notation `forallb` binders ` ∈ ` a `, ` r:(scoped:1 P, P) := bounded_forall a r +notation `∀₀` binders ` ∈ ` a `, ` r:(scoped:1 P, P) := bounded_forall a r + +abbreviation bounded_exists (a : set X) (P : X → Prop) := ∃⦃x⦄, x ∈ a ∧ P x +notation `existsb` binders ` ∈ ` a `, ` r:(scoped:1 P, P) := bounded_exists a r +notation `∃₀` binders ` ∈ ` a `, ` r:(scoped:1 P, P) := bounded_exists a r + +theorem bounded_exists.intro {P : X → Prop} {s : set X} {x : X} (xs : x ∈ s) (Px : P x) : + ∃₀ x ∈ s, P x := +exists.intro x (and.intro xs Px) + +lemma bounded_forall_congr {A : Type} {S : set A} {P Q : A → Prop} (H : ∀₀ x ∈ S, P x ↔ Q x) : + (∀₀ x ∈ S, P x) = (∀₀ x ∈ S, Q x) := +begin + apply propext, + apply forall_congr, + intros x, + apply imp_congr_right, + apply H +end + +lemma bounded_exists_congr {A : Type} {S : set A} {P Q : A → Prop} (H : ∀₀ x ∈ S, P x ↔ Q x) : + (∃₀ x ∈ S, P x) = (∃₀ x ∈ S, Q x) := +begin + apply propext, + apply exists_congr, + intros x, + apply and_congr_right, + apply H +end + +section + local attribute classical.prop_decidable [instance] + + lemma not_bounded_exists {A : Type} {S : set A} {P : A → Prop} : + (¬ (∃₀ x ∈ S, P x)) = (∀₀ x ∈ S, ¬ P x) := + begin + rewrite forall_iff_not_exists, + apply propext, + apply forall_congr, + intro x, + rewrite not_and_iff_not_or_not, + rewrite imp_iff_not_or + end + + lemma not_bounded_forall {A : Type} {S : set A} {P : A → Prop} : + (¬ (∀₀ x ∈ S, P x)) = (∃₀ x ∈ S, ¬ P x) := + calc (¬ (∀₀ x ∈ S, P x)) = ¬ ¬ (∃₀ x ∈ S, ¬ P x) : + begin + rewrite not_bounded_exists, + apply (congr_arg not), + apply bounded_forall_congr, + intros x H, + rewrite not_not_iff + end + ... = (∃₀ x ∈ S, ¬ P x) : by (rewrite not_not_iff) + +end + +/- empty set -/ + +definition empty : set X := λx, false +notation `∅` := empty + +theorem not_mem_empty (x : X) : ¬ (x ∈ ∅) := +assume H : x ∈ ∅, H + +theorem mem_empty_eq (x : X) : x ∈ ∅ = false := rfl + +theorem eq_empty_of_forall_not_mem {s : set X} (H : ∀ x, x ∉ s) : s = ∅ := +ext (take x, iff.intro + (assume xs, absurd xs (H x)) + (assume xe, absurd xe !not_mem_empty)) + +theorem ne_empty_of_mem {s : set X} {x : X} (H : x ∈ s) : s ≠ ∅ := + begin intro Hs, rewrite Hs at H, apply not_mem_empty _ H end + +section + local attribute classical.prop_decidable [instance] + + theorem exists_mem_of_ne_empty {s : set X} (H : s ≠ ∅) : ∃ x, x ∈ s := + by_contradiction (assume H', H (eq_empty_of_forall_not_mem (forall_not_of_not_exists H'))) +end + +theorem empty_subset (s : set X) : ∅ ⊆ s := +take x, assume H, false.elim H + +theorem eq_empty_of_subset_empty {s : set X} (H : s ⊆ ∅) : s = ∅ := +subset.antisymm H (empty_subset s) + +theorem subset_empty_iff (s : set X) : s ⊆ ∅ ↔ s = ∅ := +iff.intro eq_empty_of_subset_empty (take xeq, by rewrite xeq; apply subset.refl ∅) + +lemma bounded_forall_empty_iff {P : X → Prop} : + (∀₀x∈∅, P x) ↔ true := +iff.intro (take H, true.intro) (take H, by contradiction) + +/- universal set -/ + +definition univ : set X := λx, true + +theorem mem_univ (x : X) : x ∈ univ := trivial + +theorem mem_univ_iff (x : X) : x ∈ univ ↔ true := !iff.refl + +theorem mem_univ_eq (x : X) : x ∈ univ = true := rfl + +theorem empty_ne_univ [h : inhabited X] : (empty : set X) ≠ univ := +assume H : empty = univ, +absurd (mem_univ (inhabited.value h)) (eq.rec_on H (not_mem_empty _)) + +theorem subset_univ (s : set X) : s ⊆ univ := λ x H, trivial + +theorem eq_univ_of_univ_subset {s : set X} (H : univ ⊆ s) : s = univ := +eq_of_subset_of_subset (subset_univ s) H + +theorem eq_univ_of_forall {s : set X} (H : ∀ x, x ∈ s) : s = univ := +ext (take x, iff.intro (assume H', trivial) (assume H', H x)) + +/- union -/ + +definition union (a b : set X) : set X := λx, x ∈ a ∨ x ∈ b +notation a ∪ b := union a b + +theorem mem_union_left {x : X} {a : set X} (b : set X) : x ∈ a → x ∈ a ∪ b := +assume h, or.inl h + +theorem mem_union_right {x : X} {b : set X} (a : set X) : x ∈ b → x ∈ a ∪ b := +assume h, or.inr h + +theorem mem_unionl {x : X} {a b : set X} : x ∈ a → x ∈ a ∪ b := +assume h, or.inl h + +theorem mem_unionr {x : X} {a b : set X} : x ∈ b → x ∈ a ∪ b := +assume h, or.inr h + +theorem mem_or_mem_of_mem_union {x : X} {a b : set X} (H : x ∈ a ∪ b) : x ∈ a ∨ x ∈ b := H + +theorem mem_union.elim {x : X} {a b : set X} {P : Prop} + (H₁ : x ∈ a ∪ b) (H₂ : x ∈ a → P) (H₃ : x ∈ b → P) : P := +or.elim H₁ H₂ H₃ + +theorem mem_union_iff (x : X) (a b : set X) : x ∈ a ∪ b ↔ x ∈ a ∨ x ∈ b := !iff.refl + +theorem mem_union_eq (x : X) (a b : set X) : x ∈ a ∪ b = (x ∈ a ∨ x ∈ b) := rfl + +theorem union_self (a : set X) : a ∪ a = a := +ext (take x, !or_self) + +theorem union_empty (a : set X) : a ∪ ∅ = a := +ext (take x, !or_false) + +theorem empty_union (a : set X) : ∅ ∪ a = a := +ext (take x, !false_or) + +theorem union_comm (a b : set X) : a ∪ b = b ∪ a := +ext (take x, or.comm) + +theorem union_assoc (a b c : set X) : (a ∪ b) ∪ c = a ∪ (b ∪ c) := +ext (take x, or.assoc) + +theorem union_left_comm (s₁ s₂ s₃ : set X) : s₁ ∪ (s₂ ∪ s₃) = s₂ ∪ (s₁ ∪ s₃) := +!left_comm union_comm union_assoc s₁ s₂ s₃ + +theorem union_right_comm (s₁ s₂ s₃ : set X) : (s₁ ∪ s₂) ∪ s₃ = (s₁ ∪ s₃) ∪ s₂ := +!right_comm union_comm union_assoc s₁ s₂ s₃ + +theorem subset_union_left (s t : set X) : s ⊆ s ∪ t := λ x H, or.inl H + +theorem subset_union_right (s t : set X) : t ⊆ s ∪ t := λ x H, or.inr H + +theorem union_subset {s t r : set X} (sr : s ⊆ r) (tr : t ⊆ r) : s ∪ t ⊆ r := +λ x xst, or.elim xst (λ xs, sr xs) (λ xt, tr xt) + +/- intersection -/ + +definition inter (a b : set X) : set X := λx, x ∈ a ∧ x ∈ b +notation a ∩ b := inter a b + +theorem mem_inter_iff (x : X) (a b : set X) : x ∈ a ∩ b ↔ x ∈ a ∧ x ∈ b := !iff.refl + +theorem mem_inter_eq (x : X) (a b : set X) : x ∈ a ∩ b = (x ∈ a ∧ x ∈ b) := rfl + +theorem mem_inter {x : X} {a b : set X} (Ha : x ∈ a) (Hb : x ∈ b) : x ∈ a ∩ b := +and.intro Ha Hb + +theorem mem_of_mem_inter_left {x : X} {a b : set X} (H : x ∈ a ∩ b) : x ∈ a := +and.left H + +theorem mem_of_mem_inter_right {x : X} {a b : set X} (H : x ∈ a ∩ b) : x ∈ b := +and.right H + +theorem inter_self (a : set X) : a ∩ a = a := +ext (take x, !and_self) + +theorem inter_empty (a : set X) : a ∩ ∅ = ∅ := +ext (take x, !and_false) + +theorem empty_inter (a : set X) : ∅ ∩ a = ∅ := +ext (take x, !false_and) + +theorem nonempty_of_inter_nonempty_right {T : Type} {s t : set T} (H : s ∩ t ≠ ∅) : t ≠ ∅ := +suppose t = ∅, +have s ∩ t = ∅, by rewrite this; apply inter_empty, +H this + +theorem nonempty_of_inter_nonempty_left {T : Type} {s t : set T} (H : s ∩ t ≠ ∅) : s ≠ ∅ := +suppose s = ∅, +have s ∩ t = ∅, by rewrite this; apply empty_inter, +H this + +theorem inter_comm (a b : set X) : a ∩ b = b ∩ a := +ext (take x, !and.comm) + +theorem inter_assoc (a b c : set X) : (a ∩ b) ∩ c = a ∩ (b ∩ c) := +ext (take x, !and.assoc) + +theorem inter_left_comm (s₁ s₂ s₃ : set X) : s₁ ∩ (s₂ ∩ s₃) = s₂ ∩ (s₁ ∩ s₃) := +!left_comm inter_comm inter_assoc s₁ s₂ s₃ + +theorem inter_right_comm (s₁ s₂ s₃ : set X) : (s₁ ∩ s₂) ∩ s₃ = (s₁ ∩ s₃) ∩ s₂ := +!right_comm inter_comm inter_assoc s₁ s₂ s₃ + +theorem inter_univ (a : set X) : a ∩ univ = a := +ext (take x, !and_true) + +theorem univ_inter (a : set X) : univ ∩ a = a := +ext (take x, !true_and) + +theorem inter_subset_left (s t : set X) : s ∩ t ⊆ s := λ x H, and.left H + +theorem inter_subset_right (s t : set X) : s ∩ t ⊆ t := λ x H, and.right H + +theorem inter_subset_inter_right {s t : set X} (u : set X) (H : s ⊆ t) : s ∩ u ⊆ t ∩ u := +take x, assume xsu, and.intro (H (and.left xsu)) (and.right xsu) + +theorem inter_subset_inter_left {s t : set X} (u : set X) (H : s ⊆ t) : u ∩ s ⊆ u ∩ t := +take x, assume xus, and.intro (and.left xus) (H (and.right xus)) + +theorem subset_inter {s t r : set X} (rs : r ⊆ s) (rt : r ⊆ t) : r ⊆ s ∩ t := +λ x xr, and.intro (rs xr) (rt xr) + +theorem not_mem_of_mem_of_not_mem_inter_left {s t : set X} {x : X} (Hxs : x ∈ s) (Hnm : x ∉ s ∩ t) : x ∉ t := + suppose x ∈ t, + have x ∈ s ∩ t, from and.intro Hxs this, + show false, from Hnm this + +theorem not_mem_of_mem_of_not_mem_inter_right {s t : set X} {x : X} (Hxs : x ∈ t) (Hnm : x ∉ s ∩ t) : x ∉ s := + suppose x ∈ s, + have x ∈ s ∩ t, from and.intro this Hxs, + show false, from Hnm this + +/- distributivity laws -/ + +theorem inter_distrib_left (s t u : set X) : s ∩ (t ∪ u) = (s ∩ t) ∪ (s ∩ u) := +ext (take x, !and.left_distrib) + +theorem inter_distrib_right (s t u : set X) : (s ∪ t) ∩ u = (s ∩ u) ∪ (t ∩ u) := +ext (take x, !and.right_distrib) + +theorem union_distrib_left (s t u : set X) : s ∪ (t ∩ u) = (s ∪ t) ∩ (s ∪ u) := +ext (take x, !or.left_distrib) + +theorem union_distrib_right (s t u : set X) : (s ∩ t) ∪ u = (s ∪ u) ∩ (t ∪ u) := +ext (take x, !or.right_distrib) + +/- set-builder notation -/ + +-- {x : X | P} +definition set_of (P : X → Prop) : set X := P +notation `{` binder ` | ` r:(scoped:1 P, set_of P) `}` := r + +-- {x ∈ s | P} +definition sep (P : X → Prop) (s : set X) : set X := λx, x ∈ s ∧ P x +notation `{` binder ` ∈ ` s ` | ` r:(scoped:1 p, sep p s) `}` := r + +/- insert -/ + +definition insert (x : X) (a : set X) : set X := {y : X | y = x ∨ y ∈ a} + +-- '{x, y, z} +notation `'{`:max a:(foldr `, ` (x b, insert x b) ∅) `}`:0 := a + +theorem subset_insert (x : X) (a : set X) : a ⊆ insert x a := +take y, assume ys, or.inr ys + +theorem mem_insert (x : X) (s : set X) : x ∈ insert x s := +or.inl rfl + +theorem mem_insert_of_mem {x : X} {s : set X} (y : X) : x ∈ s → x ∈ insert y s := +assume h, or.inr h + +theorem eq_or_mem_of_mem_insert {x a : X} {s : set X} : x ∈ insert a s → x = a ∨ x ∈ s := +assume h, h + +theorem mem_of_mem_insert_of_ne {x a : X} {s : set X} (xin : x ∈ insert a s) : x ≠ a → x ∈ s := +or_resolve_right (eq_or_mem_of_mem_insert xin) + +theorem mem_insert_eq (x a : X) (s : set X) : x ∈ insert a s = (x = a ∨ x ∈ s) := +propext (iff.intro !eq_or_mem_of_mem_insert + (or.rec (λH', (eq.substr H' !mem_insert)) !mem_insert_of_mem)) + +theorem insert_eq_of_mem {a : X} {s : set X} (H : a ∈ s) : insert a s = s := +ext (λ x, eq.substr (mem_insert_eq x a s) + (or_iff_right_of_imp (λH1, eq.substr H1 H))) + +theorem insert.comm (x y : X) (s : set X) : insert x (insert y s) = insert y (insert x s) := +ext (take a, by rewrite [*mem_insert_eq, propext !or.left_comm]) + +-- useful in proofs by induction +theorem forall_of_forall_insert {P : X → Prop} {a : X} {s : set X} + (H : ∀ x, x ∈ insert a s → P x) : + ∀ x, x ∈ s → P x := +λ x xs, H x (!mem_insert_of_mem xs) + +lemma bounded_forall_insert_iff {P : X → Prop} {a : X} {s : set X} : + (∀₀x ∈ insert a s, P x) ↔ P a ∧ (∀₀x ∈ s, P x) := +begin + apply iff.intro, all_goals (intro H), + { apply and.intro, + { apply H, apply mem_insert }, + { intro x Hx, apply H, apply mem_insert_of_mem, assumption } }, + { intro x Hx, cases Hx with eq Hx, + { cases eq, apply (and.elim_left H) }, + { apply (and.elim_right H), assumption } } +end + +/- singleton -/ + +theorem mem_singleton_iff (a b : X) : a ∈ '{b} ↔ a = b := +iff.intro + (assume ainb, or.elim ainb (λ aeqb, aeqb) (λ f, false.elim f)) + (assume aeqb, or.inl aeqb) + +theorem mem_singleton (a : X) : a ∈ '{a} := !mem_insert + +theorem eq_of_mem_singleton {x y : X} (h : x ∈ '{y}) : x = y := +or.elim (eq_or_mem_of_mem_insert h) + (suppose x = y, this) + (suppose x ∈ ∅, absurd this !not_mem_empty) + +theorem mem_singleton_of_eq {x y : X} (H : x = y) : x ∈ '{y} := +eq.symm H ▸ mem_singleton y + +theorem insert_eq (x : X) (s : set X) : insert x s = '{x} ∪ s := +ext (take y, iff.intro + (suppose y ∈ insert x s, + or.elim this (suppose y = x, or.inl (or.inl this)) (suppose y ∈ s, or.inr this)) + (suppose y ∈ '{x} ∪ s, + or.elim this + (suppose y ∈ '{x}, or.inl (eq_of_mem_singleton this)) + (suppose y ∈ s, or.inr this))) + +theorem pair_eq_singleton (a : X) : '{a, a} = '{a} := +by rewrite [insert_eq_of_mem !mem_singleton] + +theorem singleton_ne_empty (a : X) : '{a} ≠ ∅ := +begin + intro H, + apply not_mem_empty a, + rewrite -H, + apply mem_insert +end + +/- separation -/ + +theorem mem_sep {s : set X} {P : X → Prop} {x : X} (xs : x ∈ s) (Px : P x) : x ∈ {x ∈ s | P x} := +and.intro xs Px + +theorem eq_sep_of_subset {s t : set X} (ssubt : s ⊆ t) : s = {x ∈ t | x ∈ s} := +ext (take x, iff.intro + (suppose x ∈ s, and.intro (ssubt this) this) + (suppose x ∈ {x ∈ t | x ∈ s}, and.right this)) + +theorem mem_sep_iff {s : set X} {P : X → Prop} {x : X} : x ∈ {x ∈ s | P x} ↔ x ∈ s ∧ P x := +!iff.refl + +theorem sep_subset (s : set X) (P : X → Prop) : {x ∈ s | P x} ⊆ s := +take x, assume H, and.left H + +theorem forall_not_of_sep_empty {s : set X} {P : X → Prop} (H : {x ∈ s | P x} = ∅) : ∀₀ x ∈ s, ¬ P x := + take x, suppose x ∈ s, suppose P x, + have x ∈ {x ∈ s | P x}, from and.intro `x ∈ s` this, + show false, from ne_empty_of_mem this H + +/- complement -/ + +definition compl (s : set X) : set X := {x | x ∉ s} +prefix `-` := compl + +theorem mem_compl {s : set X} {x : X} (H : x ∉ s) : x ∈ -s := H + +theorem not_mem_of_mem_compl {s : set X} {x : X} (H : x ∈ -s) : x ∉ s := H + +theorem mem_compl_iff (s : set X) (x : X) : x ∈ -s ↔ x ∉ s := !iff.refl + +theorem inter_compl_self (s : set X) : s ∩ -s = ∅ := +ext (take x, !and_not_self_iff) + +theorem compl_inter_self (s : set X) : -s ∩ s = ∅ := +ext (take x, !not_and_self_iff) + +/- some classical identities -/ + +section + local attribute classical.prop_decidable [instance] + + theorem compl_empty : -(∅ : set X) = univ := + ext (take x, iff.intro (assume H, trivial) (assume H, not_false)) + + theorem compl_union (s t : set X) : -(s ∪ t) = -s ∩ -t := + ext (take x, !not_or_iff_not_and_not) + + theorem compl_compl (s : set X) : -(-s) = s := + ext (take x, !not_not_iff) + + theorem compl_inter (s t : set X) : -(s ∩ t) = -s ∪ -t := + ext (take x, !not_and_iff_not_or_not) + + theorem compl_univ : -(univ : set X) = ∅ := + by rewrite [-compl_empty, compl_compl] + + theorem union_eq_compl_compl_inter_compl (s t : set X) : s ∪ t = -(-s ∩ -t) := + ext (take x, !or_iff_not_and_not) + + theorem inter_eq_compl_compl_union_compl (s t : set X) : s ∩ t = -(-s ∪ -t) := + ext (take x, !and_iff_not_or_not) + + theorem union_compl_self (s : set X) : s ∪ -s = univ := + ext (take x, !or_not_self_iff) + + theorem compl_union_self (s : set X) : -s ∪ s = univ := + ext (take x, !not_or_self_iff) + + theorem compl_comp_compl : + #function compl ∘ compl = @id (set X) := + funext (λ s, compl_compl s) +end + +/- set difference -/ + +definition diff (s t : set X) : set X := {x ∈ s | x ∉ t} +infix `\`:70 := diff + +theorem mem_diff {s t : set X} {x : X} (H1 : x ∈ s) (H2 : x ∉ t) : x ∈ s \ t := +and.intro H1 H2 + +theorem mem_of_mem_diff {s t : set X} {x : X} (H : x ∈ s \ t) : x ∈ s := +and.left H + +theorem not_mem_of_mem_diff {s t : set X} {x : X} (H : x ∈ s \ t) : x ∉ t := +and.right H + +theorem mem_diff_iff (s t : set X) (x : X) : x ∈ s \ t ↔ x ∈ s ∧ x ∉ t := !iff.refl + +theorem mem_diff_eq (s t : set X) (x : X) : x ∈ s \ t = (x ∈ s ∧ x ∉ t) := rfl + +theorem diff_eq (s t : set X) : s \ t = s ∩ -t := rfl + +theorem union_diff_cancel {s t : set X} [dec : Π x, decidable (x ∈ s)] (H : s ⊆ t) : s ∪ (t \ s) = t := +ext (take x, iff.intro + (assume H1 : x ∈ s ∪ (t \ s), or.elim H1 (assume H2, !H H2) (assume H2, and.left H2)) + (assume H1 : x ∈ t, + decidable.by_cases + (suppose x ∈ s, or.inl this) + (suppose x ∉ s, or.inr (and.intro H1 this)))) + +theorem diff_subset (s t : set X) : s \ t ⊆ s := inter_subset_left s _ + +theorem compl_eq_univ_diff (s : set X) : -s = univ \ s := +ext (take x, iff.intro (assume H, and.intro trivial H) (assume H, and.right H)) + +/- powerset -/ + +definition powerset (s : set X) : set (set X) := {x : set X | x ⊆ s} +prefix `𝒫`:100 := powerset + +theorem mem_powerset {x s : set X} (H : x ⊆ s) : x ∈ 𝒫 s := H + +theorem subset_of_mem_powerset {x s : set X} (H : x ∈ 𝒫 s) : x ⊆ s := H + +theorem mem_powerset_iff (x s : set X) : x ∈ 𝒫 s ↔ x ⊆ s := !iff.refl + +/- function image -/ + +section image + +variables {Y Z : Type} + +abbreviation eq_on (f1 f2 : X → Y) (a : set X) : Prop := +∀₀ x ∈ a, f1 x = f2 x + +definition image (f : X → Y) (a : set X) : set Y := {y : Y | ∃x, x ∈ a ∧ f x = y} +infix ` ' ` := image + +theorem image_eq_image_of_eq_on {f1 f2 : X → Y} {a : set X} (H1 : eq_on f1 f2 a) : + f1 ' a = f2 ' a := +ext (take y, iff.intro + (assume H2, + obtain x (H3 : x ∈ a ∧ f1 x = y), from H2, + have H4 : x ∈ a, from and.left H3, + have H5 : f2 x = y, from (H1 H4)⁻¹ ⬝ and.right H3, + exists.intro x (and.intro H4 H5)) + (assume H2, + obtain x (H3 : x ∈ a ∧ f2 x = y), from H2, + have H4 : x ∈ a, from and.left H3, + have H5 : f1 x = y, from (H1 H4) ⬝ and.right H3, + exists.intro x (and.intro H4 H5))) + +theorem mem_image {f : X → Y} {a : set X} {x : X} {y : Y} + (H1 : x ∈ a) (H2 : f x = y) : y ∈ f ' a := +exists.intro x (and.intro H1 H2) + +theorem mem_image_of_mem (f : X → Y) {x : X} {a : set X} (H : x ∈ a) : f x ∈ image f a := +mem_image H rfl + +lemma image_comp (f : Y → Z) (g : X → Y) (a : set X) : (f ∘ g) ' a = f ' (g ' a) := +ext (take z, + iff.intro + (assume Hz : z ∈ (f ∘ g) ' a, + obtain x (Hx₁ : x ∈ a) (Hx₂ : f (g x) = z), from Hz, + have Hgx : g x ∈ g ' a, from mem_image Hx₁ rfl, + show z ∈ f ' (g ' a), from mem_image Hgx Hx₂) + (assume Hz : z ∈ f ' (g 'a), + obtain y (Hy₁ : y ∈ g ' a) (Hy₂ : f y = z), from Hz, + obtain x (Hz₁ : x ∈ a) (Hz₂ : g x = y), from Hy₁, + show z ∈ (f ∘ g) ' a, from mem_image Hz₁ (Hz₂⁻¹ ▸ Hy₂))) + +lemma image_subset {a b : set X} (f : X → Y) (H : a ⊆ b) : f ' a ⊆ f ' b := +take y, assume Hy : y ∈ f ' a, +obtain x (Hx₁ : x ∈ a) (Hx₂ : f x = y), from Hy, +mem_image (H Hx₁) Hx₂ + +theorem image_union (f : X → Y) (s t : set X) : + image f (s ∪ t) = image f s ∪ image f t := +ext (take y, iff.intro + (assume H : y ∈ image f (s ∪ t), + obtain x [(xst : x ∈ s ∪ t) (fxy : f x = y)], from H, + or.elim xst + (assume xs, or.inl (mem_image xs fxy)) + (assume xt, or.inr (mem_image xt fxy))) + (assume H : y ∈ image f s ∪ image f t, + or.elim H + (assume yifs : y ∈ image f s, + obtain x [(xs : x ∈ s) (fxy : f x = y)], from yifs, + mem_image (or.inl xs) fxy) + (assume yift : y ∈ image f t, + obtain x [(xt : x ∈ t) (fxy : f x = y)], from yift, + mem_image (or.inr xt) fxy))) + +theorem image_empty (f : X → Y) : image f ∅ = ∅ := +eq_empty_of_forall_not_mem + (take y, suppose y ∈ image f ∅, + obtain x [(H : x ∈ empty) H'], from this, + H) + +theorem mem_image_compl (t : set X) (S : set (set X)) : + t ∈ compl ' S ↔ -t ∈ S := +iff.intro + (suppose t ∈ compl ' S, + obtain t' [(Ht' : t' ∈ S) (Ht : -t' = t)], from this, + show -t ∈ S, by rewrite [-Ht, compl_compl]; exact Ht') + (suppose -t ∈ S, + have -(-t) ∈ compl 'S, from mem_image_of_mem compl this, + show t ∈ compl 'S, from compl_compl t ▸ this) + +theorem image_id (s : set X) : id ' s = s := +ext (take x, iff.intro + (suppose x ∈ id ' s, + obtain x' [(Hx' : x' ∈ s) (x'eq : x' = x)], from this, + show x ∈ s, by rewrite [-x'eq]; apply Hx') + (suppose x ∈ s, mem_image_of_mem id this)) + +theorem compl_compl_image (S : set (set X)) : + compl ' (compl ' S) = S := +by rewrite [-image_comp, compl_comp_compl, image_id] + +lemma bounded_forall_image_of_bounded_forall {f : X → Y} {S : set X} {P : Y → Prop} + (H : ∀₀ x ∈ S, P (f x)) : ∀₀ y ∈ f ' S, P y := +begin + intro x' Hx; + cases Hx with x Hx; + cases Hx with Hx eq; + rewrite (eq⁻¹); + apply H; + assumption +end + +lemma bounded_forall_image_iff {f : X → Y} {S : set X} {P : Y → Prop} : + (∀₀ y ∈ f ' S, P y) ↔ (∀₀ x ∈ S, P (f x)) := +iff.intro (take H x Hx, H _ (!mem_image_of_mem `x ∈ S`)) bounded_forall_image_of_bounded_forall + +lemma image_insert_eq {f : X → Y} {a : X} {S : set X} : + f ' insert a S = insert (f a) (f ' S) := +begin + apply set.ext, + intro x, apply iff.intro, all_goals (intros H), + { cases H with y Hy, cases Hy with Hy eq, rewrite (eq⁻¹), cases Hy with y_eq, + { rewrite y_eq, apply mem_insert }, + { apply mem_insert_of_mem, apply mem_image_of_mem, assumption } }, + { cases H with eq Hx, + { rewrite eq, apply mem_image_of_mem, apply mem_insert }, + { cases Hx with y Hy, cases Hy with Hy eq, + rewrite (eq⁻¹), apply mem_image_of_mem, apply mem_insert_of_mem, assumption } } +end + +end image + +/- collections of disjoint sets -/ + +definition disjoint_sets (S : set (set X)) : Prop := ∀ a b, a ∈ S → b ∈ S → a ≠ b → a ∩ b = ∅ + +theorem disjoint_sets_empty : disjoint_sets (∅ : set (set X)) := +take a b, assume H, !not.elim !not_mem_empty H + +theorem disjoint_sets_union {s t : set (set X)} (Hs : disjoint_sets s) (Ht : disjoint_sets t) + (H : ∀ x y, x ∈ s ∧ y ∈ t → x ∩ y = ∅) : + disjoint_sets (s ∪ t) := +take a b, assume Ha Hb Hneq, or.elim Ha + (assume H1, or.elim Hb + (suppose b ∈ s, (Hs a b) H1 this Hneq) + (suppose b ∈ t, (H a b) (and.intro H1 this))) + (assume H2, or.elim Hb + (suppose b ∈ s, !inter_comm ▸ ((H b a) (and.intro this H2))) + (suppose b ∈ t, (Ht a b) H2 this Hneq)) + +theorem disjoint_sets_singleton (s : set (set X)) : disjoint_sets '{s} := +take a b, assume Ha Hb Hneq, +absurd (eq.trans ((iff.elim_left !mem_singleton_iff) Ha) ((iff.elim_left !mem_singleton_iff) Hb)⁻¹) + Hneq + +/- large unions -/ + +section large_unions + variables {I : Type} + variable a : set I + variable b : I → set X + variable C : set (set X) + + definition sUnion : set X := {x : X | ∃₀ c ∈ C, x ∈ c} + definition sInter : set X := {x : X | ∀₀ c ∈ C, x ∈ c} + + prefix `⋃₀`:110 := sUnion + prefix `⋂₀`:110 := sInter + + definition Union : set X := {x : X | ∃i, x ∈ b i} + definition Inter : set X := {x : X | ∀i, x ∈ b i} + + notation `⋃` binders `, ` r:(scoped f, Union f) := r + notation `⋂` binders `, ` r:(scoped f, Inter f) := r + + definition bUnion : set X := {x : X | ∃₀ i ∈ a, x ∈ b i} + definition bInter : set X := {x : X | ∀₀ i ∈ a, x ∈ b i} + + notation `⋃` binders ` ∈ ` s `, ` r:(scoped f, bUnion s f) := r + notation `⋂` binders ` ∈ ` s `, ` r:(scoped f, bInter s f) := r + +end large_unions + +-- sUnion and sInter: a collection (set) of sets + +theorem mem_sUnion {x : X} {t : set X} {S : set (set X)} (Hx : x ∈ t) (Ht : t ∈ S) : + x ∈ ⋃₀ S := +exists.intro t (and.intro Ht Hx) + +theorem not_mem_of_not_mem_sUnion {x : X} {t : set X} {S : set (set X)} (Hx : x ∉ ⋃₀ S) (Ht : t ∈ S) : + x ∉ t := + suppose x ∈ t, + have x ∈ ⋃₀ S, from mem_sUnion this Ht, + show false, from Hx this + +theorem mem_sInter {x : X} {t : set X} {S : set (set X)} (H : ∀₀ t ∈ S, x ∈ t) : + x ∈ ⋂₀ S := +H + +theorem sInter_subset_of_mem {S : set (set X)} {t : set X} (tS : t ∈ S) : + (⋂₀ S) ⊆ t := +take x, assume H, H t tS + +theorem subset_sUnion_of_mem {S : set (set X)} {t : set X} (tS : t ∈ S) : + t ⊆ (⋃₀ S) := +take x, assume H, exists.intro t (and.intro tS H) + +theorem sUnion_empty : ⋃₀ ∅ = (∅ : set X) := +eq_empty_of_forall_not_mem + (take x, suppose x ∈ sUnion ∅, + obtain t [(Ht : t ∈ ∅) Ht'], from this, + show false, from Ht) + +theorem sInter_empty : ⋂₀ ∅ = (univ : set X) := +eq_univ_of_forall (λ x s H, false.elim H) + +theorem sUnion_singleton (s : set X) : ⋃₀ '{s} = s := +ext (take x, iff.intro + (suppose x ∈ sUnion '{s}, + obtain u [(Hu : u ∈ '{s}) (xu : x ∈ u)], from this, + have u = s, from eq_of_mem_singleton Hu, + show x ∈ s, by rewrite -this; apply xu) + (suppose x ∈ s, + mem_sUnion this (mem_singleton s))) + +theorem sInter_singleton (s : set X) : ⋂₀ '{s} = s := +ext (take x, iff.intro + (suppose x ∈ ⋂₀ '{s}, show x ∈ s, from this (mem_singleton s)) + (suppose x ∈ s, take u, suppose u ∈ '{s}, + show x ∈ u, by rewrite [eq_of_mem_singleton this]; assumption)) + +theorem sUnion_union (S T : set (set X)) : ⋃₀ (S ∪ T) = ⋃₀ S ∪ ⋃₀ T := +ext (take x, iff.intro + (suppose x ∈ sUnion (S ∪ T), + obtain u [(Hu : u ∈ S ∪ T) (xu : x ∈ u)], from this, + or.elim Hu + (assume uS, or.inl (mem_sUnion xu uS)) + (assume uT, or.inr (mem_sUnion xu uT))) + (suppose x ∈ sUnion S ∪ sUnion T, + or.elim this + (suppose x ∈ sUnion S, + obtain u [(uS : u ∈ S) (xu : x ∈ u)], from this, + mem_sUnion xu (or.inl uS)) + (suppose x ∈ sUnion T, + obtain u [(uT : u ∈ T) (xu : x ∈ u)], from this, + mem_sUnion xu (or.inr uT)))) + +theorem sInter_union (S T : set (set X)) : ⋂₀ (S ∪ T) = ⋂₀ S ∩ ⋂₀ T := +ext (take x, iff.intro + (assume H : x ∈ ⋂₀ (S ∪ T), + and.intro (λ u uS, H (or.inl uS)) (λ u uT, H (or.inr uT))) + (assume H : x ∈ ⋂₀ S ∩ ⋂₀ T, + take u, suppose u ∈ S ∪ T, or.elim this (λ uS, and.left H u uS) (λ uT, and.right H u uT))) + +theorem sUnion_insert (s : set X) (T : set (set X)) : + ⋃₀ (insert s T) = s ∪ ⋃₀ T := +by rewrite [insert_eq, sUnion_union, sUnion_singleton] + +theorem sInter_insert (s : set X) (T : set (set X)) : + ⋂₀ (insert s T) = s ∩ ⋂₀ T := +by rewrite [insert_eq, sInter_union, sInter_singleton] + +theorem compl_sUnion (S : set (set X)) : + - ⋃₀ S = ⋂₀ (compl ' S) := +ext (take x, iff.intro + (assume H : x ∈ -(⋃₀ S), + take t, suppose t ∈ compl ' S, + obtain t' [(Ht' : t' ∈ S) (Ht : -t' = t)], from this, + have x ∈ -t', from suppose x ∈ t', H (mem_sUnion this Ht'), + show x ∈ t, by rewrite -Ht; apply this) + (assume H : x ∈ ⋂₀ (compl ' S), + suppose x ∈ ⋃₀ S, + obtain t [(tS : t ∈ S) (xt : x ∈ t)], from this, + have -t ∈ compl ' S, from mem_image_of_mem compl tS, + have x ∈ -t, from H this, + show false, proof this xt qed)) + +theorem sUnion_eq_compl_sInter_compl (S : set (set X)) : + ⋃₀ S = - ⋂₀ (compl ' S) := +by rewrite [-compl_compl, compl_sUnion] + +theorem compl_sInter (S : set (set X)) : + - ⋂₀ S = ⋃₀ (compl ' S) := +by rewrite [sUnion_eq_compl_sInter_compl, compl_compl_image] + +theorem sInter_eq_comp_sUnion_compl (S : set (set X)) : + ⋂₀ S = -(⋃₀ (compl ' S)) := +by rewrite [-compl_compl, compl_sInter] + +theorem inter_sUnion_nonempty_of_inter_nonempty {s t : set X} {S : set (set X)} (Hs : t ∈ S) (Hne : s ∩ t ≠ ∅) : + s ∩ ⋃₀ S ≠ ∅ := + obtain x Hsx Htx, from exists_mem_of_ne_empty Hne, + have x ∈ ⋃₀ S, from mem_sUnion Htx Hs, + ne_empty_of_mem (mem_inter Hsx this) + +theorem sUnion_inter_nonempty_of_inter_nonempty {s t : set X} {S : set (set X)} (Hs : t ∈ S) (Hne : t ∩ s ≠ ∅) : + (⋃₀ S) ∩ s ≠ ∅ := + obtain x Htx Hsx, from exists_mem_of_ne_empty Hne, + have x ∈ ⋃₀ S, from mem_sUnion Htx Hs, + ne_empty_of_mem (mem_inter this Hsx) + +-- Union and Inter: a family of sets indexed by a type + +theorem Union_subset {I : Type} {b : I → set X} {c : set X} (H : ∀ i, b i ⊆ c) : (⋃ i, b i) ⊆ c := +take x, +suppose x ∈ Union b, +obtain i (Hi : x ∈ b i), from this, +show x ∈ c, from H i Hi + +theorem subset_Inter {I : Type} {b : I → set X} {c : set X} (H : ∀ i, c ⊆ b i) : c ⊆ ⋂ i, b i := +λ x cx i, H i cx + +theorem Union_eq_sUnion_image {X I : Type} (s : I → set X) : (⋃ i, s i) = ⋃₀ (s ' univ) := +ext (take x, iff.intro + (suppose x ∈ Union s, + obtain i (Hi : x ∈ s i), from this, + mem_sUnion Hi (mem_image_of_mem s trivial)) + (suppose x ∈ sUnion (s ' univ), + obtain t [(Ht : t ∈ s ' univ) (Hx : x ∈ t)], from this, + obtain i [univi (Hi : s i = t)], from Ht, + exists.intro i (show x ∈ s i, by rewrite Hi; apply Hx))) + +theorem Inter_eq_sInter_image {X I : Type} (s : I → set X) : (⋂ i, s i) = ⋂₀ (s ' univ) := +ext (take x, iff.intro + (assume H : x ∈ Inter s, + take t, + suppose t ∈ s 'univ, + obtain i [univi (Hi : s i = t)], from this, + show x ∈ t, by rewrite -Hi; exact H i) + (assume H : x ∈ ⋂₀ (s ' univ), + take i, + have s i ∈ s ' univ, from mem_image_of_mem s trivial, + show x ∈ s i, from H this)) + +theorem compl_Union {X I : Type} (s : I → set X) : - (⋃ i, s i) = (⋂ i, - s i) := +by rewrite [Union_eq_sUnion_image, compl_sUnion, -image_comp, -Inter_eq_sInter_image] + +theorem compl_Inter {X I : Type} (s : I → set X) : -(⋂ i, s i) = (⋃ i, - s i) := +by rewrite [Inter_eq_sInter_image, compl_sInter, -image_comp, -Union_eq_sUnion_image] + +theorem Union_eq_comp_Inter_comp {X I : Type} (s : I → set X) : (⋃ i, s i) = - (⋂ i, - s i) := +by rewrite [-compl_compl, compl_Union] + +theorem Inter_eq_comp_Union_comp {X I : Type} (s : I → set X) : (⋂ i, s i) = - (⋃ i, -s i) := +by rewrite [-compl_compl, compl_Inter] + +lemma inter_distrib_Union_left {X I : Type} (s : I → set X) (a : set X) : + a ∩ (⋃ i, s i) = ⋃ i, a ∩ s i := +ext (take x, iff.intro + (assume H, obtain i Hi, from and.elim_right H, + have x ∈ a ∩ s i, from and.intro (and.elim_left H) Hi, + show _, from exists.intro i this) + (assume H, obtain i [xa xsi], from H, + show _, from and.intro xa (exists.intro i xsi))) + +section + local attribute classical.prop_decidable [instance] + + lemma union_distrib_Inter_left {X I : Type} (s : I → set X) (a : set X) : + a ∪ (⋂ i, s i) = ⋂ i, a ∪ s i := + ext (take x, iff.intro + (assume H, or.elim H + (assume H1, take i, or.inl H1) + (assume H1, take i, or.inr (H1 i))) + (assume H, + by_cases + (suppose x ∈ a, or.inl this) + (suppose x ∉ a, or.inr (take i, or.resolve_left (H i) this)))) +end + +-- these are useful for turning binary union / intersection into countable ones + +definition bin_ext (s t : set X) (n : ℕ) : set X := +nat.cases_on n s (λ m, t) + +lemma Union_bin_ext (s t : set X) : (⋃ i, bin_ext s t i) = s ∪ t := +ext (take x, iff.intro + (assume H, + obtain i (Hi : x ∈ (bin_ext s t) i), from H, + by cases i; apply or.inl Hi; apply or.inr Hi) + (assume H, + or.elim H + (suppose x ∈ s, exists.intro 0 this) + (suppose x ∈ t, exists.intro 1 this))) + +lemma Inter_bin_ext (s t : set X) : (⋂ i, bin_ext s t i) = s ∩ t := +ext (take x, iff.intro + (assume H, and.intro (H 0) (H 1)) + (assume H, by intro i; cases i; + apply and.elim_left H; apply and.elim_right H)) + +-- bUnion and bInter: a family of sets indexed by a set ("b" is for bounded) + +variable {Y : Type} + +theorem mem_bUnion {s : set X} {f : X → set Y} {x : X} {y : Y} + (xs : x ∈ s) (yfx : y ∈ f x) : + y ∈ ⋃ x ∈ s, f x := +exists.intro x (and.intro xs yfx) + +theorem mem_bInter {s : set X} {f : X → set Y} {y : Y} (H : ∀₀ x ∈ s, y ∈ f x) : + y ∈ ⋂ x ∈ s, f x := +H + +theorem bUnion_subset {s : set X} {t : set Y} {f : X → set Y} (H : ∀₀ x ∈ s, f x ⊆ t) : + (⋃ x ∈ s, f x) ⊆ t := +take y, assume Hy, +obtain x [xs yfx], from Hy, +show y ∈ t, from H xs yfx + +theorem subset_bInter {s : set X} {t : set Y} {f : X → set Y} (H : ∀₀ x ∈ s, t ⊆ f x) : + t ⊆ ⋂ x ∈ s, f x := +take y, assume yt, take x, assume xs, H xs yt + +theorem subset_bUnion_of_mem {s : set X} {f : X → set Y} {x : X} (xs : x ∈ s) : + f x ⊆ ⋃ x ∈ s, f x := +take y, assume Hy, mem_bUnion xs Hy + +theorem bInter_subset_of_mem {s : set X} {f : X → set Y} {x : X} (xs : x ∈ s) : + (⋂ x ∈ s, f x) ⊆ f x := +take y, assume Hy, Hy x xs + +theorem bInter_empty (f : X → set Y) : (⋂ x ∈ (∅ : set X), f x) = univ := +eq_univ_of_forall (take y x xine, absurd xine !not_mem_empty) + +theorem bInter_singleton (a : X) (f : X → set Y) : (⋂ x ∈ '{a}, f x) = f a := +ext (take y, iff.intro + (assume H, H a !mem_singleton) + (assume H, λ x xa, by rewrite [eq_of_mem_singleton xa]; apply H)) + +theorem bInter_union (s t : set X) (f : X → set Y) : + (⋂ x ∈ s ∪ t, f x) = (⋂ x ∈ s, f x) ∩ (⋂ x ∈ t, f x) := +ext (take y, iff.intro + (assume H, and.intro (λ x xs, H x (or.inl xs)) (λ x xt, H x (or.inr xt))) + (assume H, λ x xst, or.elim (xst) (λ xs, and.left H x xs) (λ xt, and.right H x xt))) + +theorem bInter_insert (a : X) (s : set X) (f : X → set Y) : + (⋂ x ∈ insert a s, f x) = f a ∩ (⋂ x ∈ s, f x) := +by rewrite [insert_eq, bInter_union, bInter_singleton] + +theorem bInter_pair (a b : X) (f : X → set Y) : + (⋂ x ∈ '{a, b}, f x) = f a ∩ f b := +by rewrite [*bInter_insert, bInter_empty, inter_univ] + +theorem bUnion_empty (f : X → set Y) : (⋃ x ∈ (∅ : set X), f x) = ∅ := +eq_empty_of_forall_not_mem (λ y H, obtain x [xine yfx], from H, + !not_mem_empty xine) + +theorem bUnion_singleton (a : X) (f : X → set Y) : (⋃ x ∈ '{a}, f x) = f a := +ext (take y, iff.intro + (assume H, obtain x [xina yfx], from H, + show y ∈ f a, by rewrite [-eq_of_mem_singleton xina]; exact yfx) + (assume H, exists.intro a (and.intro !mem_singleton H))) + +theorem bUnion_union (s t : set X) (f : X → set Y) : + (⋃ x ∈ s ∪ t, f x) = (⋃ x ∈ s, f x) ∪ (⋃ x ∈ t, f x) := +ext (take y, iff.intro + (assume H, obtain x [xst yfx], from H, + or.elim xst + (λ xs, or.inl (exists.intro x (and.intro xs yfx))) + (λ xt, or.inr (exists.intro x (and.intro xt yfx)))) + (assume H, or.elim H + (assume H1, obtain x [xs yfx], from H1, + exists.intro x (and.intro (or.inl xs) yfx)) + (assume H1, obtain x [xt yfx], from H1, + exists.intro x (and.intro (or.inr xt) yfx)))) + +theorem bUnion_insert (a : X) (s : set X) (f : X → set Y) : + (⋃ x ∈ insert a s, f x) = f a ∪ (⋃ x ∈ s, f x) := +by rewrite [insert_eq, bUnion_union, bUnion_singleton] + +theorem bUnion_pair (a b : X) (f : X → set Y) : + (⋃ x ∈ '{a, b}, f x) = f a ∪ f b := +by rewrite [*bUnion_insert, bUnion_empty, union_empty] + +end set diff --git a/old_library/data/set/card.lean b/old_library/data/set/card.lean new file mode 100644 index 0000000000..05f3dcbbe6 --- /dev/null +++ b/old_library/data/set/card.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Cardinality of finite sets. +-/ +import .finite data.finset.card +open nat classical + +namespace set + +variable {A : Type} + +noncomputable definition card (s : set A) := finset.card (set.to_finset s) + +theorem card_to_set (s : finset A) : card (finset.to_set s) = finset.card s := +by rewrite [↑card, to_finset_to_set] + +theorem card_of_not_finite {s : set A} (nfins : ¬ finite s) : card s = 0 := +by rewrite [↑card, to_finset_of_not_finite nfins] + +theorem card_empty : card (∅ : set A) = 0 := +by rewrite [-finset.to_set_empty, card_to_set] + +theorem card_insert_of_mem {a : A} {s : set A} (H : a ∈ s) : card (insert a s) = card s := +if fins : finite s then + (by rewrite [↑card, to_finset_insert, -mem_to_finset_eq at H, finset.card_insert_of_mem H]) +else + (have ¬ finite (insert a s), from suppose _, absurd (!finite_of_finite_insert this) fins, + by rewrite [card_of_not_finite fins, card_of_not_finite this]) + +theorem card_insert_of_not_mem {a : A} {s : set A} [finite s] (H : a ∉ s) : + card (insert a s) = card s + 1 := +by rewrite [↑card, to_finset_insert, -mem_to_finset_eq at H, finset.card_insert_of_not_mem H] + +theorem card_insert_le (a : A) (s : set A) [finite s] : + card (insert a s) ≤ card s + 1 := +if H : a ∈ s then by rewrite [card_insert_of_mem H]; apply le_succ +else by rewrite [card_insert_of_not_mem H] + +theorem card_singleton (a : A) : card '{a} = 1 := +by rewrite [card_insert_of_not_mem !not_mem_empty, card_empty] + +/- Note: the induction tactic does not work well with the set induction principle with the + extra predicate "finite". -/ +theorem eq_empty_of_card_eq_zero {s : set A} [finite s] : card s = 0 → s = ∅ := +induction_on_finite s + (by intro H; exact rfl) + (begin + intro a s' fins' anins IH H, + rewrite (card_insert_of_not_mem anins) at H, + apply nat.no_confusion H + end) + +theorem card_upto (n : ℕ) : card {i | i < n} = n := +by rewrite [↑card, to_finset_upto, finset.card_upto] + +theorem card_add_card (s₁ s₂ : set A) [finite s₁] [finite s₂] : + card s₁ + card s₂ = card (s₁ ∪ s₂) + card (s₁ ∩ s₂) := +begin + rewrite [-to_set_to_finset s₁, -to_set_to_finset s₂], + rewrite [-finset.to_set_union, -finset.to_set_inter, *card_to_set], + apply finset.card_add_card +end + +theorem card_union (s₁ s₂ : set A) [finite s₁] [finite s₂] : + card (s₁ ∪ s₂) = card s₁ + card s₂ - card (s₁ ∩ s₂) := +calc + card (s₁ ∪ s₂) = card (s₁ ∪ s₂) + card (s₁ ∩ s₂) - card (s₁ ∩ s₂) : nat.add_sub_cancel + ... = card s₁ + card s₂ - card (s₁ ∩ s₂) : card_add_card s₁ s₂ + +theorem card_union_of_disjoint {s₁ s₂ : set A} [finite s₁] [finite s₂] (H : s₁ ∩ s₂ = ∅) : + card (s₁ ∪ s₂) = card s₁ + card s₂ := +by rewrite [card_union, H, card_empty] + +theorem card_eq_card_add_card_diff {s₁ s₂ : set A} [finite s₁] [finite s₂] (H : s₁ ⊆ s₂) : + card s₂ = card s₁ + card (s₂ \ s₁) := +have H1 : s₁ ∩ (s₂ \ s₁) = ∅, + from eq_empty_of_forall_not_mem (take x, assume H, (and.right (and.right H)) (and.left H)), +have s₂ = s₁ ∪ (s₂ \ s₁), from eq.symm (union_diff_cancel H), +calc + card s₂ = card (s₁ ∪ (s₂ \ s₁)) : {this} + ... = card s₁ + card (s₂ \ s₁) : card_union_of_disjoint H1 + +theorem card_le_card_of_subset {s₁ s₂ : set A} [finite s₁] [finite s₂] (H : s₁ ⊆ s₂) : + card s₁ ≤ card s₂ := +calc + card s₂ = card s₁ + card (s₂ \ s₁) : card_eq_card_add_card_diff H + ... ≥ card s₁ : le_add_right + +variable {B : Type} + +theorem card_image_eq_of_inj_on {f : A → B} {s : set A} [finite s] (injfs : inj_on f s) : + card (image f s) = card s := +begin + rewrite [↑card, to_finset_image]; + apply finset.card_image_eq_of_inj_on, + rewrite to_set_to_finset, + apply injfs +end + +theorem card_le_of_inj_on (a : set A) (b : set B) [finite b] + (Pex : ∃ f : A → B, inj_on f a ∧ (image f a ⊆ b)) : + card a ≤ card b := +by_cases + (assume fina : finite a, + obtain f H, from Pex, + finset.card_le_of_inj_on (to_finset a) (to_finset b) + (exists.intro f + begin + rewrite [finset.subset_eq_to_set_subset, finset.to_set_image, *to_set_to_finset], + exact H + end)) + (assume nfina : ¬ finite a, + by rewrite [card_of_not_finite nfina]; exact !zero_le) + +theorem card_image_le (f : A → B) (s : set A) [finite s] : card (image f s) ≤ card s := +by rewrite [↑card, to_finset_image]; apply finset.card_image_le + +theorem inj_on_of_card_image_eq {f : A → B} {s : set A} [finite s] + (H : card (image f s) = card s) : inj_on f s := +begin + rewrite -to_set_to_finset, + apply finset.inj_on_of_card_image_eq, + rewrite [-to_finset_to_set (finset.image _ _), finset.to_set_image, to_set_to_finset], + exact H +end + +theorem card_pos_of_mem {a : A} {s : set A} [finite s] (H : a ∈ s) : card s > 0 := +have (#finset a ∈ to_finset s), by rewrite [finset.mem_eq_mem_to_set, to_set_to_finset]; apply H, +finset.card_pos_of_mem this + +theorem eq_of_card_eq_of_subset {s₁ s₂ : set A} [finite s₁] [finite s₂] + (Hcard : card s₁ = card s₂) (Hsub : s₁ ⊆ s₂) : + s₁ = s₂ := +begin + rewrite [-to_set_to_finset s₁, -to_set_to_finset s₂, -finset.eq_eq_to_set_eq], + apply finset.eq_of_card_eq_of_subset Hcard, + rewrite [to_finset_subset_to_finset_eq], + exact Hsub +end + +theorem exists_two_of_card_gt_one {s : set A} (H : 1 < card s) : ∃ a b, a ∈ s ∧ b ∈ s ∧ a ≠ b := +have fins : finite s, from + by_contradiction + (assume nfins, by rewrite [card_of_not_finite nfins at H]; apply !not_succ_le_zero H), +by rewrite [-to_set_to_finset s]; apply finset.exists_two_of_card_gt_one H + +end set diff --git a/old_library/data/set/classical_inverse.lean b/old_library/data/set/classical_inverse.lean new file mode 100644 index 0000000000..292f15ab67 --- /dev/null +++ b/old_library/data/set/classical_inverse.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad, Andrew Zipperer + +Using classical logic, defines an inverse function. +-/ +import .function .map +open eq.ops classical + +namespace set + +variables {X Y : Type} + +noncomputable definition inv_fun (f : X → Y) (a : set X) (dflt : X) (y : Y) : X := +if H : ∃₀ x ∈ a, f x = y then some H else dflt + +theorem inv_fun_pos {f : X → Y} {a : set X} {dflt : X} {y : Y} + (H : ∃₀ x ∈ a, f x = y) : (inv_fun f a dflt y ∈ a) ∧ (f (inv_fun f a dflt y) = y) := +have H1 : inv_fun f a dflt y = some H, from dif_pos H, +H1⁻¹ ▸ some_spec H + +theorem inv_fun_neg {f : X → Y} {a : set X} {dflt : X} {y : Y} + (H : ¬ ∃₀ x ∈ a, f x = y) : inv_fun f a dflt y = dflt := +dif_neg H + +variables {f : X → Y} {a : set X} {b : set Y} + +theorem maps_to_inv_fun {dflt : X} (dflta : dflt ∈ a) : + maps_to (inv_fun f a dflt) b a := +let f' := inv_fun f a dflt in +take y, +assume yb : y ∈ b, +show f' y ∈ a, from + by_cases + (assume H : ∃₀ x ∈ a, f x = y, + and.left (inv_fun_pos H)) + (assume H : ¬ ∃₀ x ∈ a, f x = y, + (inv_fun_neg H)⁻¹ ▸ dflta) + +theorem left_inv_on_inv_fun_of_inj_on (dflt : X) (H : inj_on f a) : + left_inv_on (inv_fun f a dflt) f a := +let f' := inv_fun f a dflt in +take x, +assume xa : x ∈ a, +have H1 : ∃₀ x' ∈ a, f x' = f x, from exists.intro x (and.intro xa rfl), +have H2 : f' (f x) ∈ a ∧ f (f' (f x)) = f x, from inv_fun_pos H1, +show f' (f x) = x, from H (and.left H2) xa (and.right H2) + +theorem surj_on_inv_fun_of_inj_on (dflt : X) (mapsto : maps_to f a b) (H : inj_on f a) : + surj_on (inv_fun f a dflt) b a := +surj_on_of_right_inv_on mapsto (left_inv_on_inv_fun_of_inj_on dflt H) + +theorem right_inv_on_inv_fun_of_surj_on (dflt : X) (H : surj_on f a b) : + right_inv_on (inv_fun f a dflt) f b := +let f' := inv_fun f a dflt in +take y, +assume yb: y ∈ b, +obtain x (Hx : x ∈ a ∧ f x = y), from H yb, +have Hy : f' y ∈ a ∧ f (f' y) = y, from inv_fun_pos (exists.intro x Hx), +and.right Hy + +theorem inj_on_inv_fun (dflt : X) (H : surj_on f a b) : + inj_on (inv_fun f a dflt) b := +inj_on_of_left_inv_on (right_inv_on_inv_fun_of_surj_on dflt H) + +end set + +open set + +namespace map + +variables {X Y : Type} {a : set X} {b : set Y} + +protected noncomputable definition inverse (f : map a b) {dflt : X} (dflta : dflt ∈ a) := +map.mk (inv_fun f a dflt) (@maps_to_inv_fun _ _ _ _ b _ dflta) + +theorem left_inverse_inverse {f : map a b} {dflt : X} (dflta : dflt ∈ a) (H : map.injective f) : + map.left_inverse (map.inverse f dflta) f := +left_inv_on_inv_fun_of_inj_on dflt H + +theorem right_inverse_inverse {f : map a b} {dflt : X} (dflta : dflt ∈ a) (H : map.surjective f) : + map.right_inverse (map.inverse f dflta) f := +right_inv_on_inv_fun_of_surj_on dflt H + +theorem is_inverse_inverse {f : map a b} {dflt : X} (dflta : dflt ∈ a) (H : map.bijective f) : +map.is_inverse (map.inverse f dflta) f := +and.intro + (left_inverse_inverse dflta (and.left H)) + (right_inverse_inverse dflta (and.right H)) + +end map diff --git a/old_library/data/set/comm_semiring.lean b/old_library/data/set/comm_semiring.lean new file mode 100644 index 0000000000..0df47f3f30 --- /dev/null +++ b/old_library/data/set/comm_semiring.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +(set A) is an instance of a commutative semiring +-/ +import data.set.basic algebra.ring +open set + +attribute [instance] +definition set_comm_semiring (A : Type) : comm_semiring (set A) := +⦃ comm_semiring, + add := union, + mul := inter, + zero := empty, + one := univ, + add_assoc := union_assoc, + add_comm := union_comm, + zero_add := empty_union, + add_zero := union_empty, + mul_assoc := inter_assoc, + mul_comm := inter_comm, + zero_mul := empty_inter, + mul_zero := inter_empty, + one_mul := univ_inter, + mul_one := inter_univ, + left_distrib := inter_distrib_left, + right_distrib := inter_distrib_right +⦄ diff --git a/old_library/data/set/default.lean b/old_library/data/set/default.lean new file mode 100644 index 0000000000..b4f2189cfb --- /dev/null +++ b/old_library/data/set/default.lean @@ -0,0 +1,6 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad +-/ +import .basic .function .map .finite .card .filter diff --git a/old_library/data/set/equinumerosity.lean b/old_library/data/set/equinumerosity.lean new file mode 100644 index 0000000000..93a64198cc --- /dev/null +++ b/old_library/data/set/equinumerosity.lean @@ -0,0 +1,241 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Two sets are equinumerous, or equipollent, if there is a bijection between them. It is sometimes +said that two such sets "have the same cardinality." +-/ +import .classical_inverse data.nat +open eq.ops classical nat + +/- two versions of Cantor's theorem -/ + +namespace set + +variables {X : Type} {A : set X} + +theorem not_surj_on_pow (f : X → set X) : ¬ surj_on f A (𝒫 A) := +let diag := {x ∈ A | x ∉ f x} in +have diag ⊆ A, from sep_subset _ _, +assume H : surj_on f A (𝒫 A), +obtain x [(xA : x ∈ A) (Hx : f x = diag)], from H `diag ⊆ A`, +have x ∉ f x, from + suppose x ∈ f x, + have x ∈ diag, from Hx ▸ this, + have x ∉ f x, from and.right this, + show false, from this `x ∈ f x`, +have x ∈ diag, from and.intro xA this, +have x ∈ f x, from Hx⁻¹ ▸ this, +show false, from `x ∉ f x` this + +theorem not_inj_on_pow {f : set X → X} (H : maps_to f (𝒫 A) A) : ¬ inj_on f (𝒫 A) := +let diag := f ' {x ∈ 𝒫 A | f x ∉ x} in +have diag ⊆ A, from image_subset_of_maps_to_of_subset H (sep_subset _ _), +assume H₁ : inj_on f (𝒫 A), +have f diag ∈ diag, from by_contradiction + (suppose f diag ∉ diag, + have diag ∈ {x ∈ 𝒫 A | f x ∉ x}, from and.intro `diag ⊆ A` this, + have f diag ∈ diag, from mem_image_of_mem f this, + show false, from `f diag ∉ diag` this), +obtain x [(Hx : x ∈ 𝒫 A ∧ f x ∉ x) (fxeq : f x = f diag)], from this, +have x = diag, from H₁ (and.left Hx) `diag ⊆ A` fxeq, +have f diag ∉ diag, from this ▸ and.right Hx, +show false, from this `f diag ∈ diag` + +end set + +/- +The Schröder-Bernstein theorem. The proof below is nonconstructive, in three ways: +(1) We need a left inverse to g (we could get around this by supplying one). +(2) The definition of h below assumes that membership in Union U is decidable. +(3) We ultimately case split on whether B is empty, and choose an element if it isn't. + +Rather than mark every auxiliary construction as "private", we put them all in a +separate namespace. +-/ + +namespace schroeder_bernstein +section +open set + parameters {X Y : Type} + parameter {A : set X} + parameter {B : set Y} + parameter {f : X → Y} + parameter (f_maps_to : maps_to f A B) + parameter (finj : inj_on f A) + parameter {g : Y → X} + parameter (g_maps_to : maps_to g B A) + parameter (ginj : inj_on g B) + parameter {dflt : Y} -- for now, assume B is nonempty + parameter (dfltB : dflt ∈ B) + + /- g⁻¹ : A → B -/ + + noncomputable definition ginv : X → Y := inv_fun g B dflt + + lemma ginv_maps_to : maps_to ginv A B := + maps_to_inv_fun dfltB + + lemma ginv_g_eq {b : Y} (bB : b ∈ B) : ginv (g b) = b := + left_inv_on_inv_fun_of_inj_on dflt ginj bB + + /- define a sequence of sets U -/ + + definition U : ℕ → set X + | U 0 := A \ (g ' B) + | U (n + 1) := g ' (f ' (U n)) + + lemma U_subset_A : ∀ n, U n ⊆ A + | 0 := show U 0 ⊆ A, + from diff_subset _ _ + | (n + 1) := have f ' (U n) ⊆ B, + from image_subset_of_maps_to_of_subset f_maps_to (U_subset_A n), + show U (n + 1) ⊆ A, + from image_subset_of_maps_to_of_subset g_maps_to this + + lemma g_ginv_eq {a : X} (aA : a ∈ A) (anU : a ∉ Union U) : g (ginv a) = a := + using ginj, + have a ∈ g ' B, from by_contradiction + (suppose a ∉ g ' B, + have a ∈ U 0, from and.intro aA this, + have a ∈ Union U, from exists.intro 0 this, + show false, from anU this), + obtain b [(bB : b ∈ B) (gbeq : g b = a)], from this, + calc + g (ginv a) = g (ginv (g b)) : gbeq + ... = g b : ginv_g_eq bB + ... = a : gbeq + + /- h : A → B -/ + + noncomputable definition h x := if x ∈ Union U then f x else ginv x + + lemma h_maps_to : maps_to h A B := + using f_maps_to dfltB, + take a, + suppose a ∈ A, + show h a ∈ B, from + by_cases + (suppose a ∈ Union U, + begin rewrite [↑h, if_pos this], exact f_maps_to `a ∈ A` end) + (suppose a ∉ Union U, + begin rewrite [↑h, if_neg this], exact ginv_maps_to `a ∈ A` end) + + /- h is injective -/ + + lemma aux {a₁ a₂ : X} (H₁ : a₁ ∈ Union U) (a₂A : a₂ ∈ A) (heq : h a₁ = h a₂) : a₂ ∈ Union U := + using ginj, + obtain n (a₁Un : a₁ ∈ U n), from H₁, + have ha₁eq : h a₁ = f a₁, + from dif_pos H₁, + show a₂ ∈ Union U, from by_contradiction + (suppose a₂ ∉ Union U, + have ha₂eq : h a₂ = ginv a₂, + from dif_neg this, + have g (f a₁) = a₂, from calc + g (f a₁) = g (h a₁) : ha₁eq + ... = g (h a₂) : heq + ... = g (ginv a₂) : ha₂eq + ... = a₂ : g_ginv_eq a₂A `a₂ ∉ Union U`, + have g (f a₁) ∈ g ' (f ' (U n)), + from mem_image_of_mem g (mem_image_of_mem f a₁Un), + have a₂ ∈ U (n + 1), + from `g (f a₁) = a₂` ▸ this, + have a₂ ∈ Union U, + from exists.intro _ this, + show false, from `a₂ ∉ Union U` `a₂ ∈ Union U`) + + lemma h_inj : inj_on h A := + take a₁ a₂, + suppose a₁ ∈ A, + suppose a₂ ∈ A, + assume heq : h a₁ = h a₂, + show a₁ = a₂, from + by_cases + (assume a₁UU : a₁ ∈ Union U, + have a₂UU : a₂ ∈ Union U, + from aux a₁UU `a₂ ∈ A` heq, + have f a₁ = f a₂, from calc + f a₁ = h a₁ : dif_pos a₁UU + ... = h a₂ : heq + ... = f a₂ : dif_pos a₂UU, + show a₁ = a₂, from + finj `a₁ ∈ A` `a₂ ∈ A` this) + (assume a₁nUU : a₁ ∉ Union U, + have a₂nUU : a₂ ∉ Union U, + from assume H, a₁nUU (aux H `a₁ ∈ A` heq⁻¹), + have eq₁ : g (ginv a₁) = a₁, from g_ginv_eq `a₁ ∈ A` a₁nUU, + have eq₂ : g (ginv a₂) = a₂, from g_ginv_eq `a₂ ∈ A` a₂nUU, + have ginv a₁ = ginv a₂, from calc + ginv a₁ = h a₁ : dif_neg a₁nUU + ... = h a₂ : heq + ... = ginv a₂ : dif_neg a₂nUU, + show a₁ = a₂, from calc + a₁ = g (ginv a₁) : eq₁ -- g_ginv_eq `a₁ ∈ A` a₁nUU + ... = g (ginv a₂) : this + ... = a₂ : eq₂) -- g_ginv_eq `a₂ ∈ A` a₂nUU) + + /- h is surjective -/ + + lemma h_surj : surj_on h A B := + take b, + suppose b ∈ B, + using f_maps_to, + by_cases + (suppose g b ∈ Union U, + obtain n (gbUn : g b ∈ U n), from this, + begin + cases n with n, + {have g b ∈ U 0, from gbUn, + have g b ∉ g ' B, from and.right this, + have g b ∈ g ' B, from mem_image_of_mem g `b ∈ B`, + show b ∈ h ' A, from absurd `g b ∈ g ' B` `g b ∉ g ' B`}, + {have g b ∈ U (succ n), from gbUn, + have g b ∈ g ' (f ' (U n)), from this, + obtain b' [(b'fUn : b' ∈ f ' (U n)) (geq : g b' = g b)], from this, + obtain a [(aUn : a ∈ U n) (faeq : f a = b')], from b'fUn, + have g (f a) = g b, by rewrite [faeq, geq], + have a ∈ A, from U_subset_A n aUn, + have f a ∈ B, from f_maps_to this, + have f a = b, from ginj `f a ∈ B` `b ∈ B` `g (f a) = g b`, + have a ∈ Union U, from exists.intro n aUn, + have h a = f a, from dif_pos this, + show b ∈ h ' A, from mem_image `a ∈ A` (`h a = f a` ⬝ `f a = b`)} + end) + (suppose g b ∉ Union U, + have eq₁ : h (g b) = ginv (g b), from dif_neg this, + have eq₂ : ginv (g b) = b, from ginv_g_eq `b ∈ B`, + have g b ∈ A, from g_maps_to `b ∈ B`, + show b ∈ h ' A, from mem_image `g b ∈ A` (eq₁ ⬝ eq₂)) +end +end schroeder_bernstein + +namespace set +section + parameters {X Y : Type} + parameter {A : set X} + parameter {B : set Y} + parameter {f : X → Y} + parameter (f_maps_to : maps_to f A B) + parameter (finj : inj_on f A) + parameter {g : Y → X} + parameter (g_maps_to : maps_to g B A) + parameter (ginj : inj_on g B) + + include g g_maps_to ginj + theorem schroeder_bernstein : ∃ h, bij_on h A B := + by_cases + (assume H : ∀ b, b ∉ B, + have fsurj : surj_on f A B, from take b, suppose b ∈ B, absurd this !H, + exists.intro f (and.intro f_maps_to (and.intro finj fsurj))) + (assume H : ¬ ∀ b, b ∉ B, + have ∃ b, b ∈ B, from exists_of_not_forall_not H, + obtain b bB, from this, + let h := @schroeder_bernstein.h X Y A B f g b in + have h_maps_to : maps_to h A B, from schroeder_bernstein.h_maps_to f_maps_to bB, + have hinj : inj_on h A, from schroeder_bernstein.h_inj finj ginj, -- ginj, + have hsurj : surj_on h A B, from schroeder_bernstein.h_surj f_maps_to g_maps_to ginj, + exists.intro h (and.intro h_maps_to (and.intro hinj hsurj))) +end +end set diff --git a/old_library/data/set/filter.lean b/old_library/data/set/filter.lean new file mode 100644 index 0000000000..0f0cff07a1 --- /dev/null +++ b/old_library/data/set/filter.lean @@ -0,0 +1,561 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad, Jacob Gross + +Filters, following Hölzl, Immler, and Huffman, "Type classes and filters for mathematical +analysis in Isabelle/HOL". +-/ +import data.set.function logic.identities algebra.complete_lattice +namespace set +local attribute classical.prop_decidable [instance] + +structure filter (A : Type) := +(sets : set (set A)) +(univ_mem_sets : univ ∈ sets) +(inter_closed : ∀ {a b}, a ∈ sets → b ∈ sets → a ∩ b ∈ sets) +(is_mono : ∀ {a b}, a ⊆ b → a ∈ sets → b ∈ sets) + +-- attribute filter.sets [coercion] + +namespace filter -- i.e. set.filter + +variable {A : Type} +variables {P Q : A → Prop} +variables {F₁ : filter A} {F₂ : filter A} {F : filter A} + +definition eventually (P : A → Prop) (F : filter A) : Prop := +P ∈ F + +-- TODO: notation for eventually? +-- notation `forallf` binders `∈` F `,` r:(scoped:1 P, P) := eventually r F +-- notation `'∀f` binders `∈` F `,` r:(scoped:1 P, P) := eventually r F + +theorem eventually_true (F : filter A) : eventually (λx, true) F := +!filter.univ_mem_sets + +theorem eventually_of_forall (F : filter A) (H : ∀ x, P x) : eventually P F := +by rewrite [eq_univ_of_forall H]; apply eventually_true + +theorem eventually_mono (H₁ : eventually P F) (H₂ : ∀x, P x → Q x) : eventually Q F := +!filter.is_mono H₂ H₁ + +theorem eventually_congr (H : ∀ x, P x ↔ Q x) (H' : eventually P F) : eventually Q F := +have P = Q, from ext H, +using this, by rewrite -this; exact H' + +theorem eventually_and (H₁ : eventually P F) (H₂ : eventually Q F) : + eventually (λ x, P x ∧ Q x) F := +!filter.inter_closed H₁ H₂ + +theorem eventually_of_eventually_and_left {P Q : A → Prop} {F : filter A} + (H : eventually (λ x, P x ∧ Q x) F) : + eventually P F := +!filter.is_mono (λ x HPQ, and.elim_left HPQ) H + +theorem eventually_of_eventually_and_right {P Q : A → Prop} {F : filter A} + (H : eventually (λ x, P x ∧ Q x) F) : + eventually Q F := +!filter.is_mono (λ x HPQ, and.elim_right HPQ) H + +theorem eventually_mp (H₁ : eventually (λx, P x → Q x) F) (H₂ : eventually P F) : + eventually Q F := +have ∀ x, (P x → Q x) ∧ P x → Q x, from take x, assume H, and.left H (and.right H), +eventually_mono (eventually_and H₁ H₂) this + +theorem eventually_mpr (H₁ : eventually P F) (H₂ : eventually (λx, P x → Q x) F) : + eventually Q F := eventually_mp H₂ H₁ + +variables (P Q F) +theorem eventually_and_iff : eventually (λ x, P x ∧ Q x) F ↔ eventually P F ∧ eventually Q F := +iff.intro + (assume H, and.intro + (eventually_mpr H (eventually_of_forall F (take x, and.left))) + (eventually_mpr H (eventually_of_forall F (take x, and.right)))) + (assume H, eventually_and (and.left H) (and.right H)) +variables {P Q F} + +-- TODO: port eventually_ball_finite_distrib, etc. + +theorem eventually_choice {B : Type} [nonemptyB : nonempty B] {R : A → B → Prop} {F : filter A} + (H : eventually (λ x, ∃ y, R x y) F) : ∃ f, eventually (λ x, R x (f x)) F := +let f := λ x, epsilon (λ y, R x y) in +exists.intro f + (eventually_mono H + (take x, suppose ∃ y, R x y, + show R x (f x), from epsilon_spec this)) + +theorem exists_not_of_not_eventually (H : ¬ eventually P F) : ∃ x, ¬ P x := +exists_not_of_not_forall (assume H', H (eventually_of_forall F H')) + +theorem eventually_iff_mp (H₁ : eventually (λ x, P x ↔ Q x) F) (H₂ : eventually P F) : + eventually Q F := +eventually_mono (eventually_and H₁ H₂) (λ x H, iff.mp (and.left H) (and.right H)) + +theorem eventually_iff_mpr (H₁ : eventually (λ x, P x ↔ Q x) F) (H₂ : eventually Q F) : + eventually P F := +eventually_mono (eventually_and H₁ H₂) (λ x H, iff.mpr (and.left H) (and.right H)) + +theorem eventually_iff_iff (H : eventually (λ x, P x ↔ Q x) F) : eventually P F ↔ eventually Q F := +iff.intro (eventually_iff_mp H) (eventually_iff_mpr H) + +/- frequently -/ + +definition frequently (P : A → Prop) (F : filter A) : Prop := ¬ eventually (λ x, ¬ P x) F + +theorem not_frequently_of_eventually : eventually (λ x, ¬ P x) F → ¬ frequently P F := +not_not_intro + +theorem frequently_mono (H₁ : frequently P F) (H₂ : ∀ x, P x → Q x) : frequently Q F := + not.mto (λ H, eventually_mono H ( λ x, not.mto (H₂ x))) H₁ + +theorem frequently_mp (ev : eventually (λ x, P x → Q x) F) : + frequently P F → frequently Q F := +not.mto (λ H, eventually_mp (eventually_mono ev (λ x HPQ, not.mto HPQ)) H) + +theorem not_frequently_false : ¬ frequently (λ x, false) F := +begin + apply not_not_intro, + apply eventually_congr, + intro x, apply iff.symm not_false_iff, + exact eventually_true F +end + +section + local attribute classical.prop_decidable [instance] + + theorem not_frequently_iff : ¬ frequently P F ↔ eventually (λ x, ¬ P x) F := + by unfold frequently; rewrite not_not_iff + + theorem exists_of_frequently : frequently P F → ∃ x, P x := + assume H, obtain x Hx, from !exists_not_of_not_eventually H, + show _, from exists.intro x (not_not_elim Hx) + + theorem frequently_inl (H : frequently P F) : frequently (λx, P x ∨ Q x) F := + assume H' : eventually (λx, ¬ (P x ∨ Q x)) F, + have (λx, ¬ (P x ∨ Q x)) = λ x, ¬ P x ∧ ¬ Q x, + by apply funext; intro x; rewrite not_or_iff_not_and_not, + show false, by rewrite this at H'; exact H (eventually_of_eventually_and_left H') + + theorem frequently_inr (H : frequently Q F) : frequently (λx, P x ∨ Q x) F := + begin + apply frequently_mp, + apply eventually_of_forall, + intro x, apply or.swap, + exact frequently_inl H + end +end + +/- filters form a lattice under ⊇ -/ + +protected theorem eq : sets F₁ = sets F₂ → F₁ = F₂ := +begin + cases F₁ with s₁ u₁ i₁ m₁, cases F₂ with s₂ u₂ i₂ m₂, esimp, + intro eqs₁s₂, revert [u₁, i₁, m₁, u₂, i₂, m₂], + subst s₁, intros, exact rfl +end + +namespace complete_lattice + attribute [reducible] + definition le (F₁ F₂ : filter A) := F₁ ⊇ F₂ + local infix `≤`:50 := le + + attribute [reducible] + definition ge (F₁ F₂ : filter A) := F₁ ⊆ F₂ + local infix `≥`:50 := ge + + theorem le_refl (F : filter A) : F ≤ F := subset.refl _ + + theorem le_trans {F₁ F₂ F₃ : filter A} (H₁ : F₁ ≤ F₂) (H₂ : F₂ ≤ F₃) : F₁ ≤ F₃ := + subset.trans H₂ H₁ + + theorem le_antisymm (H₁ : F₁ ≤ F₂) (H₂ : F₂ ≤ F₁) : F₁ = F₂ := + filter.eq (eq_of_subset_of_subset H₂ H₁) + + definition sup (F₁ F₂ : filter A) : filter A := + ⦃ filter, + sets := F₁ ∩ F₂, + univ_mem_sets := and.intro (filter.univ_mem_sets F₁) (filter.univ_mem_sets F₂), + inter_closed := abstract + λ a b Ha Hb, + and.intro + (filter.inter_closed F₁ (and.left Ha) (and.left Hb)) + (filter.inter_closed F₂ (and.right Ha) (and.right Hb)) + end, + is_mono := abstract + λ a b Hsub Ha, + and.intro + (filter.is_mono F₁ Hsub (and.left Ha)) + (filter.is_mono F₂ Hsub (and.right Ha)) + end + ⦄ + local infix ` ⊔ `:65 := sup + + definition inf (F₁ F₂ : filter A) : filter A := + ⦃ filter, + sets := {r | ∃₀ s ∈ F₁, ∃₀ t ∈ F₂, r ⊇ s ∩ t}, + univ_mem_sets := abstract + bounded_exists.intro (univ_mem_sets F₁) + (bounded_exists.intro (univ_mem_sets F₂) + (by rewrite univ_inter; apply subset.refl)) + end, + inter_closed := abstract + λ a b Ha Hb, + obtain a₁ [a₁F₁ [a₂ [a₂F₂ (Ha' : a ⊇ a₁ ∩ a₂)]]], from Ha, + obtain b₁ [b₁F₁ [b₂ [b₂F₂ (Hb' : b ⊇ b₁ ∩ b₂)]]], from Hb, + have a₁ ∩ b₁ ∩ (a₂ ∩ b₂) = a₁ ∩ a₂ ∩ (b₁ ∩ b₂), + by rewrite [*inter_assoc, inter_left_comm b₁], + have a ∩ b ⊇ a₁ ∩ b₁ ∩ (a₂ ∩ b₂), + begin + rewrite this, + apply subset_inter, + {apply subset.trans, + apply inter_subset_left, + exact Ha'}, + apply subset.trans, + apply inter_subset_right, + exact Hb' + end, + bounded_exists.intro (inter_closed F₁ a₁F₁ b₁F₁) + (bounded_exists.intro (inter_closed F₂ a₂F₂ b₂F₂) + this) + end, + is_mono := abstract + λ a b Hsub Ha, + obtain a₁ [a₁F₁ [a₂ [a₂F₂ (Ha' : a ⊇ a₁ ∩ a₂)]]], from Ha, + bounded_exists.intro a₁F₁ + (bounded_exists.intro a₂F₂ (subset.trans Ha' Hsub)) + end + ⦄ + infix `⊓`:70 := inf + + definition Sup (S : set (filter A)) : filter A := + ⦃ filter, + sets := ⋂ F ∈ S, sets F, + univ_mem_sets := λ F FS, univ_mem_sets F, + inter_closed := abstract + λ a b Ha Hb F FS, + inter_closed F (Ha F FS) (Hb F FS) + end, + is_mono := abstract + λ a b asubb Ha F FS, + is_mono F asubb (Ha F FS) + end + ⦄ + local prefix `⨆ `:65 := Sup + + definition Inf (S : set (filter A)) : filter A := + Sup {F | ∀ G, G ∈ S → G ≥ F} + + local prefix `⨅ `:70 := Inf + + theorem le_sup_left (F₁ F₂ : filter A) : F₁ ≤ F₁ ⊔ F₂ := + inter_subset_left _ _ + + theorem le_sup_right (F₁ F₂ : filter A) : F₂ ≤ F₁ ⊔ F₂ := + inter_subset_right _ _ + + theorem sup_le (H₁ : F₁ ≤ F) (H₂ : F₂ ≤ F) : F₁ ⊔ F₂ ≤ F := + subset_inter H₁ H₂ + + theorem inf_le_left (F₁ F₂ : filter A) : F₁ ⊓ F₂ ≤ F₁ := + take s, suppose s ∈ F₁, + bounded_exists.intro `s ∈ F₁` + (bounded_exists.intro (univ_mem_sets F₂) (by rewrite inter_univ; apply subset.refl)) + + theorem inf_le_right (F₁ F₂ : filter A) : F₁ ⊓ F₂ ≤ F₂ := + take s, suppose s ∈ F₂, + bounded_exists.intro (univ_mem_sets F₁) + (bounded_exists.intro `s ∈ F₂` (by rewrite univ_inter; apply subset.refl)) + + theorem le_inf (H₁ : F ≤ F₁) (H₂ : F ≤ F₂) : F ≤ F₁ ⊓ F₂ := + take s : set A, suppose (s ∈ (F₁ ⊓ F₂ : set (set A))), + obtain a₁ [a₁F₁ [a₂ [a₂F₂ (Hsub : s ⊇ a₁ ∩ a₂)]]], from this, + have a₁ ∈ F, from H₁ a₁F₁, + have a₂ ∈ F, from H₂ a₂F₂, + show s ∈ F, from is_mono F Hsub (inter_closed F `a₁ ∈ F` `a₂ ∈ F`) + + theorem Sup_le {F : filter A} {S : set (filter A)} (H : ∀₀ G ∈ S, G ≤ F) : ⨆ S ≤ F := + λ s Fs G GS, H GS Fs + + theorem le_Sup {F : filter A} {S : set (filter A)} (FS : F ∈ S) : F ≤ ⨆ S := + λ s sInfS, sInfS F FS + + theorem le_Inf {F : filter A} {S : set (filter A)} (H : ∀₀ G ∈ S, F ≤ G) : F ≤ ⨅ S := + le_Sup H + + theorem Inf_le {F : filter A} {S : set (filter A)} (FS : F ∈ S) : ⨅ S ≤ F := + Sup_le (λ G GS, GS F FS) +end complete_lattice + +attribute [trans_instance] +protected definition complete_lattice : complete_lattice (filter A) := +⦃ complete_lattice, + le := complete_lattice.le, + le_refl := complete_lattice.le_refl, + le_trans := @complete_lattice.le_trans A, + le_antisymm := @complete_lattice.le_antisymm A, + inf := complete_lattice.inf, + le_inf := @complete_lattice.le_inf A, + inf_le_left := @complete_lattice.inf_le_left A, + inf_le_right := @complete_lattice.inf_le_right A, + sup := complete_lattice.sup, + sup_le := @complete_lattice.sup_le A, + le_sup_left := complete_lattice.le_sup_left, + le_sup_right := complete_lattice.le_sup_right, + Inf := complete_lattice.Inf, + Inf_le := @complete_lattice.Inf_le A, + le_Inf := @complete_lattice.le_Inf A, + Sup := complete_lattice.Sup, + Sup_le := @complete_lattice.Sup_le A, + le_Sup := @complete_lattice.le_Sup A +⦄ + +protected theorem subset_of_le {F₁ F₂ : filter A} (H : F₁ ≤ F₂) : sets F₂ ⊆ sets F₁ := H + +protected theorem le_of_subset {F₁ F₂ : filter A} (H : sets F₂ ⊆ sets F₁) : F₁ ≤ F₂ := H + +theorem sets_Sup (S : set (filter A)) : sets (⨆ S) = ⋂ F ∈ S, sets F := rfl + +theorem sets_sup (F₁ F₂ : filter A) : sets (F₁ ⊔ F₂) = sets F₁ ∩ sets F₂ := rfl + +theorem sets_inf (F₁ F₂ : filter A) : sets (F₁ ⊓ F₂) = {r | ∃₀ s ∈ F₁, ∃₀ t ∈ F₂, r ⊇ s ∩ t} := rfl + +/- eventually and lattice operations -/ + +theorem eventually_of_le (H₁ : eventually P F₁) (H₂ : F₂ ≤ F₁) : eventually P F₂ := +filter.subset_of_le H₂ H₁ + +theorem le_of_forall_eventually (H : ∀ P, eventually P F₁ → eventually P F₂) : F₂ ≤ F₁ := H + +theorem eventually_Sup_iff (P : A → Prop) (S : set (filter A)) : + eventually P (⨆ S) ↔ ∀₀ F ∈ S, eventually P F := +by rewrite [↑eventually, sets_Sup] + +theorem eventually_Sup {P : A → Prop} {S : set (filter A)} (H : ∀₀ F ∈ S, eventually P F) : + eventually P (⨆ S) := +iff.mpr (eventually_Sup_iff P S) H + +theorem eventually_of_eventually_Sup {P : A → Prop} {S : set (filter A)} + (H : eventually P (⨆ S)) {F : filter A} (FS : F ∈ S) : + eventually P F := +iff.mp (eventually_Sup_iff P S) H F FS + +theorem eventually_sup_iff (P : A → Prop) (F₁ F₂ : filter A) : + eventually P (F₁ ⊔ F₂) ↔ eventually P F₁ ∧ eventually P F₂ := +by rewrite [↑eventually, sets_sup] + +theorem eventually_sup {P : A → Prop} {F₁ F₂ : filter A} + (H₁ : eventually P F₁) (H₂ : eventually P F₂) : + eventually P (F₁ ⊔ F₂) := +iff.mpr (eventually_sup_iff P F₁ F₂) (and.intro H₁ H₂) + +theorem eventually_of_eventually_sup_left {P : A → Prop} {F₁ F₂ : filter A} + (H : eventually P (F₁ ⊔ F₂)) : eventually P F₁ := +and.left (iff.mp (eventually_sup_iff P F₁ F₂) H) + +theorem eventually_of_eventually_sup_right {P : A → Prop} {F₁ F₂ : filter A} + (H : eventually P (F₁ ⊔ F₂)) : eventually P F₂ := +and.right (iff.mp (eventually_sup_iff P F₁ F₂) H) + +theorem eventually_inf_iff (P : A → Prop) (F₁ F₂ : filter A) : + eventually P (F₁ ⊓ F₂) ↔ (∃ S, eventually S F₁ ∧ ∃ T, eventually T F₂ ∧ (P ⊇ S ∩ T)) := +by rewrite [↑eventually, sets_inf] + +theorem eventually_inf {P : A → Prop} {F₁ F₂ : filter A} + {S : A → Prop} (HS : eventually S F₁) (T : A → Prop) (HT : eventually T F₂) (HP : P ⊇ S ∩ T) : + eventually P (F₁ ⊓ F₂) := +iff.mpr (eventually_inf_iff P F₁ F₂) + (exists.intro S (and.intro HS (exists.intro T (and.intro HT HP)))) + +theorem exists_of_eventually_inf {P : A → Prop} {F₁ F₂ : filter A} (H : eventually P (F₁ ⊓ F₂)) : + ∃ S, eventually S F₁ ∧ ∃ T, eventually T F₂ ∧ (P ⊇ S ∩ T) := +iff.mp (eventually_inf_iff P F₁ F₂) H + +/- top and bot -/ + +protected definition bot (A : Type) : filter A := +⦃ filter, + sets := univ, + univ_mem_sets := trivial, + inter_closed := λ a b Ha Hb, trivial, + is_mono := λ a b Ha Hsub, trivial +⦄ + +protected definition top (A : Type) : filter A := +⦃ filter, + sets := '{univ}, + univ_mem_sets := !or.inl rfl, + inter_closed := abstract + λ a b Ha Hb, + by rewrite [*!mem_singleton_iff at *]; substvars; exact !inter_univ + end, + is_mono := abstract + λ a b Hsub Ha, + begin + rewrite [mem_singleton_iff at Ha], subst [Ha], + exact or.inl (eq_univ_of_univ_subset Hsub) + end + end +⦄ + +protected theorem bot_eq : ⊥ = filter.bot A := +le.antisymm !bot_le + begin + apply le_of_forall_eventually, + intro P H, + apply mem_univ + end + +protected theorem top_eq : ⊤ = filter.top A := +le.antisymm + (le_of_forall_eventually + (λ P H, + have P = univ, from eq_of_mem_singleton H, + by rewrite this; apply eventually_true ⊤)) + !le_top + +theorem sets_bot_eq : sets ⊥ = (univ : set (set A)) := +by rewrite filter.bot_eq + +theorem sets_top_eq : sets ⊤ = ('{univ} : set (set A)) := +by rewrite filter.top_eq + +theorem eventually_bot (P : A → Prop) : eventually P ⊥ := +by rewrite [↑eventually, sets_bot_eq]; apply mem_univ + +theorem eventually_top_of_forall (H : ∀ x, P x) : eventually P ⊤ := +by rewrite [↑eventually, sets_top_eq, mem_singleton_iff]; exact eq_univ_of_forall H + +theorem forall_of_eventually_top : eventually P ⊤ → ∀ x, P x := +by rewrite [↑eventually, sets_top_eq, mem_singleton_iff]; intro H x; rewrite H; exact trivial + +theorem eventually_top_iff (P : A → Prop) : eventually P top ↔ ∀ x, P x := +iff.intro forall_of_eventually_top eventually_top_of_forall + +/- filter generated by a collection of sets -/ + +inductive sets_generated_by {A : Type} (B : set (set A)) : set A → Prop := +| generators_mem : ∀ ⦃s : set A⦄, s ∈ B → sets_generated_by B s +| univ_mem : sets_generated_by B univ +| inter_mem : ∀ {a b}, sets_generated_by B a → sets_generated_by B b → sets_generated_by B (a ∩ b) +| mono : ∀ {a b}, a ⊆ b → sets_generated_by B a → sets_generated_by B b + +attribute [reducible] +definition filter_generated_by {A : Type} (B : set (set A)) : filter A := +⦃filter, + sets := sets_generated_by B, + univ_mem_sets := sets_generated_by.univ_mem B, + inter_closed := @sets_generated_by.inter_mem A B, + is_mono := @sets_generated_by.mono A B ⦄ + +theorem generators_subset_generated_by (B : set (set A)) : B ⊆ filter_generated_by B := +λ s H, sets_generated_by.generators_mem H + +theorem sets_generated_by_initial {B : set (set A)} {F : filter A} (H : B ⊆ sets F) : + sets_generated_by B ⊆ F := +begin + intro s Hs, + induction Hs with s sB s t os ot soA toA S SB SOA, + {exact H sB}, + {exact filter.univ_mem_sets F}, + {exact filter.inter_closed F soA toA}, + exact filter.is_mono F SOA v_0 +end + +theorem le_filter_generated_by {B : set (set A)} {F : filter A} + (H : B ⊆ sets F) : F ≤ filter_generated_by B := +sets_generated_by_initial H + +/- principal filter -/ + +definition principal (s : set A) : filter A := filter_generated_by '{s} + +theorem mem_principal (s : set A) : s ∈ principal s := +!generators_subset_generated_by !mem_singleton + +theorem eventually_principal {s : set A} {P : A → Prop} (H : s ⊆ P) : eventually P (principal s) := +!filter.is_mono H !mem_principal + +theorem subset_of_eventually_principal {s : set A} {P : A → Prop} + (H : eventually P (principal s)) : s ⊆ P := +begin + induction H with s' Ps' a b Ha Hb ssuba ssubb a b asubb Ha ssuba, + {rewrite [eq_of_mem_singleton Ps']; exact subset.refl s}, + {exact subset_univ s}, + {exact subset_inter ssuba ssubb}, + {exact subset.trans ssuba asubb} +end + +theorem eventually_principal_iff (s P : set A) : eventually P (principal s) ↔ (s ⊆ P) := +iff.intro subset_of_eventually_principal eventually_principal + +theorem sets_principal (s : set A) : sets (principal s) = { t | s ⊆ t } := +ext (take P, eventually_principal_iff s P) + +theorem principal_empty : principal (∅ : set A) = ⊥ := +begin + apply filter.eq, + rewrite [sets_principal, sets_bot_eq], + show { t | ∅ ⊆ t} = univ, from ext (take x, iff.intro + (assume H, trivial) + (assume H, empty_subset x)) +end + +theorem principal_univ_eq : principal (@univ A) = ⊤ := +begin + apply filter.eq, + rewrite [sets_principal, sets_top_eq], + show { t | univ ⊆ t} = '{univ}, from ext (take x, iff.intro + (assume H : univ ⊆ x, mem_singleton_of_eq (!eq_univ_of_univ_subset H)) + (assume H : x ∈ '{univ}, by rewrite [eq_of_mem_singleton H]; apply subset.refl)) +end + +theorem principal_le_principal {s t : set A} (H : s ⊆ t) : principal s ≤ principal t := +begin + apply filter.le_of_subset, + rewrite *sets_principal, + show { u | t ⊆ u } ⊆ { u | s ⊆ u }, from + take u, suppose t ⊆ u, subset.trans H this +end + +theorem subset_of_principal_le_principal {s t : set A} (H : principal s ≤ principal t) : s ⊆ t := +begin + note H' := filter.subset_of_le H, + revert H', rewrite *sets_principal, + intro H', + exact H' (subset.refl t) +end + +theorem principal_refines_principal_iff {s t : set A} : principal s ≤ principal t ↔ s ⊆ t := +iff.intro subset_of_principal_le_principal principal_le_principal + +theorem principal_sup_principal {s t : set A} : principal s ⊔ principal t = principal (s ∪ t) := +begin + apply filter.eq, + rewrite [sets_sup, *sets_principal], + apply ext, intro u, apply iff.intro, + exact (suppose s ⊆ u ∧ t ⊆ u, + show s ∪ t ⊆ u, from union_subset (and.left this) (and.right this)), + exact suppose s ∪ t ⊆ u, + and.intro (subset.trans (subset_union_left _ _) this) + (subset.trans (subset_union_right _ _) this) +end + + +theorem principal_inf_principal {s t : set A} : principal s ⊓ principal t = principal (s ∩ t) := +begin + apply filter.eq, + rewrite [sets_inf, *sets_principal], + apply ext, intro u, apply iff.intro, + {intro H, + show s ∩ t ⊆ u, from + obtain s' [(ss' : s ⊆ s') [t' [(tt' : t ⊆ t') (Hu : s' ∩ t' ⊆ u)]]], from H, + take x, assume H', Hu (and.intro (ss' (and.left H')) (tt' (and.right H')))}, + {intro H', + exact exists.intro s (and.intro (subset.refl s) (exists.intro t + (and.intro (subset.refl t) H')))} +end + +end filter +end set diff --git a/old_library/data/set/finite.lean b/old_library/data/set/finite.lean new file mode 100644 index 0000000000..2a01c6c066 --- /dev/null +++ b/old_library/data/set/finite.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +The notion of "finiteness" for sets. This approach is not computational: for example, just because +an element s : set A satsifies finite s doesn't mean that we can compute the cardinality. For +a computational representation, use the finset type. +-/ +import data.finset.to_set .classical_inverse +open nat classical + +variable {A : Type} + +namespace set + +attribute [class] +definition finite (s : set A) : Prop := ∃ (s' : finset A), s = finset.to_set s' + +attribute [instance] +theorem finite_finset (s : finset A) : finite (finset.to_set s) := +exists.intro s rfl + +/- to finset: casts every set to a finite set -/ + +noncomputable definition to_finset (s : set A) : finset A := +if fins : finite s then some fins else finset.empty + +theorem to_finset_of_not_finite {s : set A} (nfins : ¬ finite s) : to_finset s = (#finset ∅) := +by rewrite [↑to_finset, dif_neg nfins] + +theorem to_set_to_finset (s : set A) [fins : finite s] : finset.to_set (to_finset s) = s := +by rewrite [↑to_finset, dif_pos fins]; exact eq.symm (some_spec fins) + +theorem mem_to_finset_eq (a : A) (s : set A) [finite s] : + (#finset a ∈ to_finset s) = (a ∈ s) := +by rewrite [-to_set_to_finset at {2}] + +theorem to_set_to_finset_of_not_finite {s : set A} (nfins : ¬ finite s) : + finset.to_set (to_finset s) = ∅ := +by rewrite [to_finset_of_not_finite nfins] + +theorem to_finset_to_set (s : finset A) : to_finset (finset.to_set s) = s := +by rewrite [finset.eq_eq_to_set_eq, to_set_to_finset (finset.to_set s)] + +theorem to_finset_eq_of_to_set_eq {s : set A} {t : finset A} (H : finset.to_set t = s) : + to_finset s = t := +finset.eq_of_to_set_eq_to_set (by subst [s]; rewrite to_finset_to_set) + +/- finiteness -/ + +theorem finite_of_to_set_to_finset_eq {s : set A} (H : finset.to_set (to_finset s) = s) : + finite s := +by rewrite -H; apply finite_finset + +attribute [instance] +theorem finite_empty : finite (∅ : set A) := +by rewrite [-finset.to_set_empty]; apply finite_finset + +theorem to_finset_empty : to_finset (∅ : set A) = (#finset ∅) := +to_finset_eq_of_to_set_eq !finset.to_set_empty + +theorem to_finset_eq_empty_of_eq_empty {s : set A} [fins : finite s] (H : s = ∅) : + to_finset s = finset.empty := by rewrite [H, to_finset_empty] + +theorem eq_empty_of_to_finset_eq_empty {s : set A} [fins : finite s] + (H : to_finset s = finset.empty) : + s = ∅ := by rewrite [-finset.to_set_empty, -H, to_set_to_finset] + +theorem to_finset_eq_empty (s : set A) [fins : finite s] : + (to_finset s = finset.empty) ↔ (s = ∅) := +iff.intro eq_empty_of_to_finset_eq_empty to_finset_eq_empty_of_eq_empty + +attribute [instance] +theorem finite_insert (a : A) (s : set A) [finite s] : finite (insert a s) := +exists.intro (finset.insert a (to_finset s)) + (by rewrite [finset.to_set_insert, to_set_to_finset]) + +theorem to_finset_insert (a : A) (s : set A) [finite s] : + to_finset (insert a s) = finset.insert a (to_finset s) := +by apply to_finset_eq_of_to_set_eq; rewrite [finset.to_set_insert, to_set_to_finset] + +attribute [instance] +theorem finite_union (s t : set A) [finite s] [finite t] : + finite (s ∪ t) := +exists.intro (#finset to_finset s ∪ to_finset t) + (by rewrite [finset.to_set_union, *to_set_to_finset]) + +theorem to_finset_union (s t : set A) [finite s] [finite t] : + to_finset (s ∪ t) = (#finset to_finset s ∪ to_finset t) := +by apply to_finset_eq_of_to_set_eq; rewrite [finset.to_set_union, *to_set_to_finset] + +attribute [instance] +theorem finite_inter (s t : set A) [finite s] [finite t] : + finite (s ∩ t) := +exists.intro (#finset to_finset s ∩ to_finset t) + (by rewrite [finset.to_set_inter, *to_set_to_finset]) + +theorem to_finset_inter (s t : set A) [finite s] [finite t] : + to_finset (s ∩ t) = (#finset to_finset s ∩ to_finset t) := +by apply to_finset_eq_of_to_set_eq; rewrite [finset.to_set_inter, *to_set_to_finset] + +attribute [instance] +theorem finite_sep (s : set A) (p : A → Prop) [finite s] : + finite {x ∈ s | p x} := +exists.intro (finset.sep p (to_finset s)) + (by rewrite [finset.to_set_sep, *to_set_to_finset]) + +theorem to_finset_sep (s : set A) (p : A → Prop) [finite s] : + to_finset {x ∈ s | p x} = (#finset {x ∈ to_finset s | p x}) := +by apply to_finset_eq_of_to_set_eq; rewrite [finset.to_set_sep, to_set_to_finset] + +attribute [instance] +theorem finite_image {B : Type} (f : A → B) (s : set A) [finite s] : + finite (f ' s) := +exists.intro (finset.image f (to_finset s)) + (by rewrite [finset.to_set_image, *to_set_to_finset]) + +theorem to_finset_image {B : Type} (f : A → B) (s : set A) + [fins : finite s] : + to_finset (f ' s) = (#finset f ' (to_finset s)) := +by apply to_finset_eq_of_to_set_eq; rewrite [finset.to_set_image, to_set_to_finset] + +attribute [instance] +theorem finite_diff (s t : set A) [finite s] : finite (s \ t) := +!finite_sep + +theorem to_finset_diff (s t : set A) [finite s] [finite t] : + to_finset (s \ t) = (#finset to_finset s \ to_finset t) := +by apply to_finset_eq_of_to_set_eq; rewrite [finset.to_set_diff, *to_set_to_finset] + +theorem finite_subset {s t : set A} [finite t] (ssubt : s ⊆ t) : finite s := +by rewrite (eq_sep_of_subset ssubt); apply finite_sep + +theorem to_finset_subset_to_finset_eq (s t : set A) [finite s] [finite t] : + (#finset to_finset s ⊆ to_finset t) = (s ⊆ t) := +by rewrite [finset.subset_eq_to_set_subset, *to_set_to_finset] + +theorem finite_of_finite_insert {s : set A} {a : A} (finias : finite (insert a s)) : finite s := +finite_subset (subset_insert a s) + +attribute [instance] +theorem finite_upto (n : ℕ) : finite {i | i < n} := +by rewrite [-finset.to_set_upto n]; apply finite_finset + +theorem to_finset_upto (n : ℕ) : to_finset {i | i < n} = finset.upto n := +by apply (to_finset_eq_of_to_set_eq !finset.to_set_upto) + +theorem finite_of_surj_on {B : Type} {f : A → B} {s : set A} [finite s] {t : set B} + (H : surj_on f s t) : + finite t := +finite_subset H + +theorem finite_of_inj_on {B : Type} {f : A → B} {s : set A} {t : set B} [finite t] + (mapsto : maps_to f s t) (injf : inj_on f s) : + finite s := +if H : s = ∅ then + by rewrite H; apply _ +else + obtain (dflt : A) (xs : dflt ∈ s), from exists_mem_of_ne_empty H, + let finv := inv_fun f s dflt in + have surj_on finv t s, from surj_on_inv_fun_of_inj_on dflt mapsto injf, + finite_of_surj_on this + +theorem finite_of_bij_on {B : Type} {f : A → B} {s : set A} {t : set B} [finite s] + (bijf : bij_on f s t) : + finite t := +finite_of_surj_on (surj_on_of_bij_on bijf) + +theorem finite_of_bij_on' {B : Type} {f : A → B} {s : set A} {t : set B} [finite t] + (bijf : bij_on f s t) : + finite s := +finite_of_inj_on (maps_to_of_bij_on bijf) (inj_on_of_bij_on bijf) + +theorem finite_iff_finite_of_bij_on {B : Type} {f : A → B} {s : set A} {t : set B} + (bijf : bij_on f s t) : + finite s ↔ finite t := +iff.intro (assume fs, finite_of_bij_on bijf) (assume ft, finite_of_bij_on' bijf) + +theorem finite_powerset (s : set A) [finite s] : finite 𝒫 s := +have H : 𝒫 s = finset.to_set ' (finset.to_set (#finset 𝒫 (to_finset s))), + from ext (take t, iff.intro + (suppose t ∈ 𝒫 s, + have t ⊆ s, from this, + have finite t, from finite_subset this, + have (#finset to_finset t ∈ 𝒫 (to_finset s)), + by rewrite [finset.mem_powerset_iff_subset, to_finset_subset_to_finset_eq]; apply `t ⊆ s`, + have to_finset t ∈ (finset.to_set (finset.powerset (to_finset s))), from this, + mem_image this (by rewrite to_set_to_finset)) + (assume H', + obtain t' [(tmem : (#finset t' ∈ 𝒫 (to_finset s))) (teq : finset.to_set t' = t)], + from H', + show t ⊆ s, + begin + rewrite [-teq, finset.mem_powerset_iff_subset at tmem, -to_set_to_finset s], + rewrite -finset.subset_eq_to_set_subset, assumption + end)), +by rewrite H; apply finite_image + +/- induction for finite sets -/ + +attribute [recursor 6] +theorem induction_finite {P : set A → Prop} + (H1 : P ∅) (H2 : ∀ ⦃a : A⦄, ∀ {s : set A} [finite s], a ∉ s → P s → P (insert a s)) : + ∀ (s : set A) [finite s], P s := +begin + intro s fins, + rewrite [-to_set_to_finset s], + generalize to_finset s, + intro s', + induction s' using finset.induction with a s' nains ih, + {rewrite finset.to_set_empty, apply H1}, + rewrite [finset.to_set_insert], + apply H2, + {rewrite -finset.mem_eq_mem_to_set, assumption}, + exact ih +end + +theorem induction_on_finite {P : set A → Prop} (s : set A) [finite s] + (H1 : P ∅) (H2 : ∀ ⦃a : A⦄, ∀ {s : set A} [finite s], a ∉ s → P s → P (insert a s)) : + P s := +induction_finite H1 H2 s + +end set diff --git a/old_library/data/set/function.lean b/old_library/data/set/function.lean new file mode 100644 index 0000000000..e2bc7740dd --- /dev/null +++ b/old_library/data/set/function.lean @@ -0,0 +1,406 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad, Andrew Zipperer, Haitao Zhang + +Functions between subsets of finite types. +-/ +import .basic +open function eq.ops + +namespace set + +variables {X Y Z : Type} + +/- preimages -/ + +definition preimage {A B:Type} (f : A → B) (Y : set B) : set A := { x | f x ∈ Y } + +notation f ` '- ` s := preimage f s + +theorem mem_preimage_iff (f : X → Y) (a : set Y) (x : X) : + f x ∈ a ↔ x ∈ f '- a := +!iff.refl + +theorem mem_preimage {f : X → Y} {a : set Y} {x : X} (H : f x ∈ a) : + x ∈ f '- a := H + +theorem mem_of_mem_preimage {f : X → Y} {a : set Y} {x : X} (H : x ∈ f '- a) : + f x ∈ a := +proof H qed + +theorem preimage_comp (f : Y → Z) (g : X → Y) (a : set Z) : + (f ∘ g) '- a = g '- (f '- a) := +ext (take x, !iff.refl) + +lemma image_subset_iff {A B : Type} {f : A → B} {X : set A} {Y : set B} : + f ' X ⊆ Y ↔ X ⊆ f '- Y := +@bounded_forall_image_iff A B f X Y + +theorem preimage_subset {a b : set Y} (f : X → Y) (H : a ⊆ b) : + f '- a ⊆ f '- b := +λ x H', proof @H (f x) H' qed + +theorem preimage_id (s : set Y) : (λx, x) '- s = s := +ext (take x, !iff.refl) + +theorem preimage_union (f : X → Y) (s t : set Y) : + f '- (s ∪ t) = f '- s ∪ f '- t := +ext (take x, !iff.refl) + +theorem preimage_inter (f : X → Y) (s t : set Y) : + f '- (s ∩ t) = f '- s ∩ f '- t := +ext (take x, !iff.refl) + +theorem preimage_compl (f : X → Y) (s : set Y) : + f '- (-s) = -(f '- s) := +ext (take x, !iff.refl) + +theorem preimage_diff (f : X → Y) (s t : set Y) : + f '- (s \ t) = f '- s \ f '- t := +ext (take x, !iff.refl) + +theorem image_preimage_subset (f : X → Y) (s : set Y) : + f ' (f '- s) ⊆ s := +take y, suppose y ∈ f ' (f '- s), + obtain x [xfis fxeqy], from this, + show y ∈ s, by rewrite -fxeqy; exact xfis + +theorem subset_preimage_image (s : set X) (f : X → Y) : + s ⊆ f '- (f ' s) := +take x, suppose x ∈ s, +show f x ∈ f ' s, from mem_image_of_mem f this + +theorem inter_preimage_subset (s : set X) (t : set Y) (f : X → Y) : + s ∩ f '- t ⊆ f '- (f ' s ∩ t) := +take x, assume H : x ∈ s ∩ f '- t, +mem_preimage (show f x ∈ f ' s ∩ t, + from and.intro (mem_image_of_mem f (and.left H)) (mem_of_mem_preimage (and.right H))) + +theorem union_preimage_subset (s : set X) (t : set Y) (f : X → Y) : + s ∪ f '- t ⊆ f '- (f ' s ∪ t) := +take x, assume H : x ∈ s ∪ f '- t, +mem_preimage (show f x ∈ f ' s ∪ t, + from or.elim H + (suppose x ∈ s, or.inl (mem_image_of_mem f this)) + (suppose x ∈ f '- t, or.inr (mem_of_mem_preimage this))) + +theorem image_inter (f : X → Y) (s : set X) (t : set Y) : + f ' s ∩ t = f ' (s ∩ f '- t) := +ext (take y, iff.intro + (suppose y ∈ f ' s ∩ t, + obtain [x [xs fxeqy]] yt, from this, + have x ∈ s ∩ f '- t, + from and.intro xs (mem_preimage (show f x ∈ t, by rewrite fxeqy; exact yt)), + mem_image this fxeqy) + (suppose y ∈ f ' (s ∩ f '- t), + obtain x [[xs xfit] fxeqy], from this, + and.intro (mem_image xs fxeqy) + (show y ∈ t, by rewrite -fxeqy; exact mem_of_mem_preimage xfit))) + +theorem image_union_supset (f : X → Y) (s : set X) (t : set Y) : + f ' s ∪ t ⊇ f ' (s ∪ f '- t) := +take y, assume H, +obtain x [xmem fxeqy], from H, +or.elim xmem + (suppose x ∈ s, or.inl (mem_image this fxeqy)) + (suppose x ∈ f '- t, or.inr (show y ∈ t, by rewrite -fxeqy; exact mem_of_mem_preimage this)) + +/- maps to -/ + +attribute [reducible] +definition maps_to (f : X → Y) (a : set X) (b : set Y) : Prop := ∀⦃x⦄, x ∈ a → f x ∈ b + +theorem maps_to_of_eq_on {f1 f2 : X → Y} {a : set X} {b : set Y} (eq_on_a : eq_on f1 f2 a) + (maps_to_f1 : maps_to f1 a b) : + maps_to f2 a b := +take x, +assume xa : x ∈ a, +have H : f1 x ∈ b, from maps_to_f1 xa, +show f2 x ∈ b, from eq_on_a xa ▸ H + +theorem maps_to_comp {g : Y → Z} {f : X → Y} {a : set X} {b : set Y} {c : set Z} + (H1 : maps_to g b c) (H2 : maps_to f a b) : maps_to (g ∘ f) a c := +take x, assume H : x ∈ a, H1 (H2 H) + +theorem maps_to_univ_univ (f : X → Y) : maps_to f univ univ := +take x, assume H, trivial + +theorem image_subset_of_maps_to_of_subset {f : X → Y} {a : set X} {b : set Y} (mfab : maps_to f a b) + {c : set X} (csuba : c ⊆ a) : + f ' c ⊆ b := +take y, +suppose y ∈ f ' c, +obtain x [(xc : x ∈ c) (yeq : f x = y)], from this, +have x ∈ a, from csuba `x ∈ c`, +have f x ∈ b, from mfab this, +show y ∈ b, from yeq ▸ this + +theorem image_subset_of_maps_to {f : X → Y} {a : set X} {b : set Y} (mfab : maps_to f a b) : + f ' a ⊆ b := +image_subset_of_maps_to_of_subset mfab (subset.refl a) + +/- injectivity -/ + +attribute [reducible] +definition inj_on (f : X → Y) (a : set X) : Prop := +∀⦃x1 x2 : X⦄, x1 ∈ a → x2 ∈ a → f x1 = f x2 → x1 = x2 + +theorem inj_on_empty (f : X → Y) : inj_on f ∅ := + take x₁ x₂, assume H₁ H₂ H₃, false.elim H₁ + +theorem inj_on_of_eq_on {f1 f2 : X → Y} {a : set X} (eq_f1_f2 : eq_on f1 f2 a) + (inj_f1 : inj_on f1 a) : + inj_on f2 a := +take x1 x2 : X, +assume ax1 : x1 ∈ a, +assume ax2 : x2 ∈ a, +assume H : f2 x1 = f2 x2, +have H' : f1 x1 = f1 x2, from eq_f1_f2 ax1 ⬝ H ⬝ (eq_f1_f2 ax2)⁻¹, +show x1 = x2, from inj_f1 ax1 ax2 H' + +theorem inj_on_comp {g : Y → Z} {f : X → Y} {a : set X} {b : set Y} + (fab : maps_to f a b) (Hg : inj_on g b) (Hf: inj_on f a) : + inj_on (g ∘ f) a := +take x1 x2 : X, +assume x1a : x1 ∈ a, +assume x2a : x2 ∈ a, +have fx1b : f x1 ∈ b, from fab x1a, +have fx2b : f x2 ∈ b, from fab x2a, +assume H1 : g (f x1) = g (f x2), +have H2 : f x1 = f x2, from Hg fx1b fx2b H1, +show x1 = x2, from Hf x1a x2a H2 + +theorem inj_on_of_inj_on_of_subset {f : X → Y} {a b : set X} (H1 : inj_on f b) (H2 : a ⊆ b) : + inj_on f a := +take x1 x2 : X, assume (x1a : x1 ∈ a) (x2a : x2 ∈ a), +assume H : f x1 = f x2, +show x1 = x2, from H1 (H2 x1a) (H2 x2a) H + +lemma injective_iff_inj_on_univ {f : X → Y} : injective f ↔ inj_on f univ := +iff.intro + (assume H, take x₁ x₂, assume ax₁ ax₂, H x₁ x₂) + (assume H : inj_on f univ, + take x₁ x₂ Heq, + show x₁ = x₂, from H trivial trivial Heq) + +/- surjectivity -/ + +attribute [reducible] +definition surj_on (f : X → Y) (a : set X) (b : set Y) : Prop := b ⊆ f ' a + +theorem surj_on_of_eq_on {f1 f2 : X → Y} {a : set X} {b : set Y} (eq_f1_f2 : eq_on f1 f2 a) + (surj_f1 : surj_on f1 a b) : + surj_on f2 a b := +take y, assume H : y ∈ b, +obtain x (H1 : x ∈ a ∧ f1 x = y), from surj_f1 H, +have H2 : x ∈ a, from and.left H1, +have H3 : f2 x = y, from (eq_f1_f2 H2)⁻¹ ⬝ and.right H1, +exists.intro x (and.intro H2 H3) + +theorem surj_on_comp {g : Y → Z} {f : X → Y} {a : set X} {b : set Y} {c : set Z} + (Hg : surj_on g b c) (Hf: surj_on f a b) : + surj_on (g ∘ f) a c := +take z, +assume zc : z ∈ c, +obtain y (H1 : y ∈ b ∧ g y = z), from Hg zc, +obtain x (H2 : x ∈ a ∧ f x = y), from Hf (and.left H1), +show ∃x, x ∈ a ∧ g (f x) = z, from + exists.intro x + (and.intro + (and.left H2) + (calc + g (f x) = g y : {and.right H2} + ... = z : and.right H1)) + +lemma surjective_iff_surj_on_univ {f : X → Y} : surjective f ↔ surj_on f univ univ := +iff.intro + (assume H, take y, assume Hy, + obtain x Hx, from H y, + mem_image trivial Hx) + (assume H, take y, + obtain x H1x H2x, from H y trivial, + exists.intro x H2x) + +lemma image_eq_of_maps_to_of_surj_on {f : X → Y} {a : set X} {b : set Y} + (H1 : maps_to f a b) (H2 : surj_on f a b) : + f ' a = b := +eq_of_subset_of_subset (image_subset_of_maps_to H1) H2 + +/- bijectivity -/ + +attribute [reducible] +definition bij_on (f : X → Y) (a : set X) (b : set Y) : Prop := +maps_to f a b ∧ inj_on f a ∧ surj_on f a b + +lemma maps_to_of_bij_on {f : X → Y} {a : set X} {b : set Y} (H : bij_on f a b) : + maps_to f a b := +and.left H + +lemma inj_on_of_bij_on {f : X → Y} {a : set X} {b : set Y} (H : bij_on f a b) : + inj_on f a := +and.left (and.right H) + +lemma surj_on_of_bij_on {f : X → Y} {a : set X} {b : set Y} (H : bij_on f a b) : + surj_on f a b := +and.right (and.right H) + +lemma bij_on.mk {f : X → Y} {a : set X} {b : set Y} + (H₁ : maps_to f a b) (H₂ : inj_on f a) (H₃ : surj_on f a b) : + bij_on f a b := +and.intro H₁ (and.intro H₂ H₃) + +theorem bij_on_of_eq_on {f1 f2 : X → Y} {a : set X} {b : set Y} (eqf : eq_on f1 f2 a) + (H : bij_on f1 a b) : bij_on f2 a b := +match H with and.intro Hmap (and.intro Hinj Hsurj) := + and.intro + (maps_to_of_eq_on eqf Hmap) + (and.intro + (inj_on_of_eq_on eqf Hinj) + (surj_on_of_eq_on eqf Hsurj)) +end + +lemma image_eq_of_bij_on {f : X → Y} {a : set X} {b : set Y} (bfab : bij_on f a b) : + f ' a = b := +image_eq_of_maps_to_of_surj_on (and.left bfab) (and.right (and.right bfab)) + +theorem bij_on_comp {g : Y → Z} {f : X → Y} {a : set X} {b : set Y} {c : set Z} + (Hg : bij_on g b c) (Hf: bij_on f a b) : + bij_on (g ∘ f) a c := +match Hg with and.intro Hgmap (and.intro Hginj Hgsurj) := + match Hf with and.intro Hfmap (and.intro Hfinj Hfsurj) := + and.intro + (maps_to_comp Hgmap Hfmap) + (and.intro + (inj_on_comp Hfmap Hginj Hfinj) + (surj_on_comp Hgsurj Hfsurj)) + end +end + +lemma bijective_iff_bij_on_univ {f : X → Y} : bijective f ↔ bij_on f univ univ := +iff.intro + (assume H, + obtain Hinj Hsurj, from H, + and.intro (maps_to_univ_univ f) + (and.intro + (iff.mp !injective_iff_inj_on_univ Hinj) + (iff.mp !surjective_iff_surj_on_univ Hsurj))) + (assume H, + obtain Hmaps Hinj Hsurj, from H, + (and.intro + (iff.mpr !injective_iff_inj_on_univ Hinj) + (iff.mpr !surjective_iff_surj_on_univ Hsurj))) + +/- left inverse -/ + +-- g is a left inverse to f on a +attribute [reducible] +definition left_inv_on (g : Y → X) (f : X → Y) (a : set X) : Prop := +∀₀ x ∈ a, g (f x) = x + +theorem left_inv_on_of_eq_on_left {g1 g2 : Y → X} {f : X → Y} {a : set X} {b : set Y} + (fab : maps_to f a b) (eqg : eq_on g1 g2 b) (H : left_inv_on g1 f a) : left_inv_on g2 f a := +take x, +assume xa : x ∈ a, +calc + g2 (f x) = g1 (f x) : (eqg (fab xa))⁻¹ + ... = x : H xa + +theorem left_inv_on_of_eq_on_right {g : Y → X} {f1 f2 : X → Y} {a : set X} + (eqf : eq_on f1 f2 a) (H : left_inv_on g f1 a) : left_inv_on g f2 a := +take x, +assume xa : x ∈ a, +calc + g (f2 x) = g (f1 x) : {(eqf xa)⁻¹} + ... = x : H xa + +theorem inj_on_of_left_inv_on {g : Y → X} {f : X → Y} {a : set X} (H : left_inv_on g f a) : + inj_on f a := +take x1 x2, +assume x1a : x1 ∈ a, +assume x2a : x2 ∈ a, +assume H1 : f x1 = f x2, +calc + x1 = g (f x1) : H x1a + ... = g (f x2) : H1 + ... = x2 : H x2a + +theorem left_inv_on_comp {f' : Y → X} {g' : Z → Y} {g : Y → Z} {f : X → Y} + {a : set X} {b : set Y} (fab : maps_to f a b) + (Hf : left_inv_on f' f a) (Hg : left_inv_on g' g b) : left_inv_on (f' ∘ g') (g ∘ f) a := +take x : X, +assume xa : x ∈ a, +have fxb : f x ∈ b, from fab xa, +calc + f' (g' (g (f x))) = f' (f x) : Hg fxb + ... = x : Hf xa + +/- right inverse -/ + +-- g is a right inverse to f on a +attribute [reducible] +definition right_inv_on (g : Y → X) (f : X → Y) (b : set Y) : Prop := +left_inv_on f g b + +theorem right_inv_on_of_eq_on_left {g1 g2 : Y → X} {f : X → Y} {a : set X} {b : set Y} + (eqg : eq_on g1 g2 b) (H : right_inv_on g1 f b) : right_inv_on g2 f b := +left_inv_on_of_eq_on_right eqg H + +theorem right_inv_on_of_eq_on_right {g : Y → X} {f1 f2 : X → Y} {a : set X} {b : set Y} + (gba : maps_to g b a) (eqf : eq_on f1 f2 a) (H : right_inv_on g f1 b) : right_inv_on g f2 b := +left_inv_on_of_eq_on_left gba eqf H + +theorem surj_on_of_right_inv_on {g : Y → X} {f : X → Y} {a : set X} {b : set Y} + (gba : maps_to g b a) (H : right_inv_on g f b) : + surj_on f a b := +take y, +assume yb : y ∈ b, +have gya : g y ∈ a, from gba yb, +have H1 : f (g y) = y, from H yb, +exists.intro (g y) (and.intro gya H1) + +theorem right_inv_on_comp {f' : Y → X} {g' : Z → Y} {g : Y → Z} {f : X → Y} + {c : set Z} {b : set Y} (g'cb : maps_to g' c b) + (Hf : right_inv_on f' f b) (Hg : right_inv_on g' g c) : right_inv_on (f' ∘ g') (g ∘ f) c := +left_inv_on_comp g'cb Hg Hf + +theorem right_inv_on_of_inj_on_of_left_inv_on {f : X → Y} {g : Y → X} {a : set X} {b : set Y} + (fab : maps_to f a b) (gba : maps_to g b a) (injf : inj_on f a) (lfg : left_inv_on f g b) : + right_inv_on f g a := +take x, assume xa : x ∈ a, +have H : f (g (f x)) = f x, from lfg (fab xa), +injf (gba (fab xa)) xa H + +theorem eq_on_of_left_inv_of_right_inv {g1 g2 : Y → X} {f : X → Y} {a : set X} {b : set Y} + (g2ba : maps_to g2 b a) (Hg1 : left_inv_on g1 f a) (Hg2 : right_inv_on g2 f b) : eq_on g1 g2 b := +take y, +assume yb : y ∈ b, +calc + g1 y = g1 (f (g2 y)) : {(Hg2 yb)⁻¹} + ... = g2 y : Hg1 (g2ba yb) + +theorem left_inv_on_of_surj_on_right_inv_on {f : X → Y} {g : Y → X} {a : set X} {b : set Y} + (surjf : surj_on f a b) (rfg : right_inv_on f g a) : + left_inv_on f g b := +take y, assume yb : y ∈ b, +obtain x (xa : x ∈ a) (Hx : f x = y), from surjf yb, +calc + f (g y) = f (g (f x)) : Hx + ... = f x : rfg xa + ... = y : Hx + +/- inverses -/ + +-- g is an inverse to f viewed as a map from a to b +attribute [reducible] +definition inv_on (g : Y → X) (f : X → Y) (a : set X) (b : set Y) : Prop := +left_inv_on g f a ∧ right_inv_on g f b + +theorem bij_on_of_inv_on {g : Y → X} {f : X → Y} {a : set X} {b : set Y} (fab : maps_to f a b) + (gba : maps_to g b a) (H : inv_on g f a b) : bij_on f a b := +and.intro fab + (and.intro + (inj_on_of_left_inv_on (and.left H)) + (surj_on_of_right_inv_on gba (and.right H))) + +end set diff --git a/old_library/data/set/map.lean b/old_library/data/set/map.lean new file mode 100644 index 0000000000..f313d8bb73 --- /dev/null +++ b/old_library/data/set/map.lean @@ -0,0 +1,176 @@ +/- +Copyright (c) 2014 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad, Andrew Zipperer + +Functions between subsets of finite types, bundled with the domain and range. +-/ +import data.set.function +open eq.ops + +namespace set + +record map {X Y : Type} (a : set X) (b : set Y) := (func : X → Y) (mapsto : maps_to func a b) +-- attribute map.func [coercion] + +namespace map + +variables {X Y Z: Type} +variables {a : set X} {b : set Y} {c : set Z} + +/- the equivalence relation -/ + +attribute [reducible] +protected definition equiv (f1 f2 : map a b) : Prop := eq_on f1 f2 a + +namespace equiv_notation + infix `~` := map.equiv +end equiv_notation +open equiv_notation + +protected theorem equiv.refl (f : map a b) : f ~ f := take x, assume H, rfl + +protected theorem equiv.symm {f₁ f₂ : map a b} : f₁ ~ f₂ → f₂ ~ f₁ := +assume H : f₁ ~ f₂, +take x, assume Ha : x ∈ a, eq.symm (H Ha) + +protected theorem equiv.trans {f₁ f₂ f₃ : map a b} : f₁ ~ f₂ → f₂ ~ f₃ → f₁ ~ f₃ := +assume H₁ : f₁ ~ f₂, assume H₂ : f₂ ~ f₃, +take x, assume Ha : x ∈ a, eq.trans (H₁ Ha) (H₂ Ha) + +protected theorem equiv.is_equivalence {X Y : Type} (a : set X) (b : set Y) : + equivalence (@map.equiv X Y a b) := +mk_equivalence (@map.equiv X Y a b) (@equiv.refl X Y a b) (@equiv.symm X Y a b) + (@equiv.trans X Y a b) + +/- compose -/ + +protected definition comp (g : map b c) (f : map a b) : map a c := +map.mk (#function g ∘ f) (maps_to_comp (mapsto g) (mapsto f)) + +notation g ∘ f := map.comp g f + +/- range -/ + +protected definition range (f : map a b) : set Y := image f a + +theorem range_eq_range_of_equiv {f1 f2 : map a b} (H : f1 ~ f2) : map.range f1 = map.range f2 := +image_eq_image_of_eq_on H + +/- injective -/ + +protected definition injective (f : map a b) : Prop := inj_on f a + +theorem injective_of_equiv {f1 f2 : map a b} (H1 : f1 ~ f2) (H2 : map.injective f1) : + map.injective f2 := +inj_on_of_eq_on H1 H2 + +theorem injective_comp {g : map b c} {f : map a b} (Hg : map.injective g) (Hf: map.injective f) : + map.injective (g ∘ f) := +inj_on_comp (mapsto f) Hg Hf + +/- surjective -/ + +protected definition surjective (f : map a b) : Prop := surj_on f a b + +theorem surjective_of_equiv {f1 f2 : map a b} (H1 : f1 ~ f2) (H2 : map.surjective f1) : + map.surjective f2 := +surj_on_of_eq_on H1 H2 + +theorem surjective_comp {g : map b c} {f : map a b} (Hg : map.surjective g) + (Hf: map.surjective f) : + map.surjective (g ∘ f) := +surj_on_comp Hg Hf + +theorem image_eq_of_surjective {f : map a b} (H : map.surjective f) : f ' a = b := +image_eq_of_maps_to_of_surj_on (map.mapsto f) H + +/- bijective -/ + +protected definition bijective (f : map a b) : Prop := map.injective f ∧ map.surjective f + +theorem bijective_of_equiv {f1 f2 : map a b} (H1 : f1 ~ f2) (H2 : map.bijective f1) : + map.bijective f2 := +and.intro (injective_of_equiv H1 (and.left H2)) (surjective_of_equiv H1 (and.right H2)) + +theorem bijective_comp {g : map b c} {f : map a b} (Hg : map.bijective g) (Hf: map.bijective f) : + map.bijective (g ∘ f) := +obtain Hg₁ Hg₂, from Hg, +obtain Hf₁ Hf₂, from Hf, +and.intro (injective_comp Hg₁ Hf₁) (surjective_comp Hg₂ Hf₂) + +theorem image_eq_of_bijective {f : map a b} (H : map.bijective f) : f ' a = b := +image_eq_of_surjective (proof and.right H qed) + +/- left inverse -/ + +-- g is a left inverse to f +protected definition left_inverse (g : map b a) (f : map a b) : Prop := left_inv_on g f a + +theorem left_inverse_of_equiv_left {g1 g2 : map b a} {f : map a b} (eqg : g1 ~ g2) + (H : map.left_inverse g1 f) : map.left_inverse g2 f := +left_inv_on_of_eq_on_left (mapsto f) eqg H + +theorem left_inverse_of_equiv_right {g : map b a} {f1 f2 : map a b} (eqf : f1 ~ f2) + (H : map.left_inverse g f1) : map.left_inverse g f2 := +left_inv_on_of_eq_on_right eqf H + +theorem injective_of_left_inverse {g : map b a} {f : map a b} (H : map.left_inverse g f) : + map.injective f := +inj_on_of_left_inv_on H + +theorem left_inverse_comp {f' : map b a} {g' : map c b} {g : map b c} {f : map a b} + (Hf : map.left_inverse f' f) (Hg : map.left_inverse g' g) : + map.left_inverse (f' ∘ g') (g ∘ f) := +left_inv_on_comp (mapsto f) Hf Hg + +/- right inverse -/ + +-- g is a right inverse to f +protected definition right_inverse (g : map b a) (f : map a b) : Prop := map.left_inverse f g + +theorem right_inverse_of_equiv_left {g1 g2 : map b a} {f : map a b} (eqg : g1 ~ g2) + (H : map.right_inverse g1 f) : map.right_inverse g2 f := +map.left_inverse_of_equiv_right eqg H + +theorem right_inverse_of_equiv_right {g : map b a} {f1 f2 : map a b} (eqf : f1 ~ f2) + (H : map.right_inverse g f1) : map.right_inverse g f2 := +map.left_inverse_of_equiv_left eqf H + +theorem right_inverse_of_injective_of_left_inverse {f : map a b} {g : map b a} + (injf : map.injective f) (lfg : map.left_inverse f g) : + map.right_inverse f g := +right_inv_on_of_inj_on_of_left_inv_on (mapsto f) (mapsto g) injf lfg + +theorem surjective_of_right_inverse {g : map b a} {f : map a b} (H : map.right_inverse g f) : + map.surjective f := +surj_on_of_right_inv_on (mapsto g) H + +theorem left_inverse_of_surjective_of_right_inverse {f : map a b} {g : map b a} + (surjf : map.surjective f) (rfg : map.right_inverse f g) : + map.left_inverse f g := +left_inv_on_of_surj_on_right_inv_on surjf rfg + +theorem right_inverse_comp {f' : map b a} {g' : map c b} {g : map b c} {f : map a b} + (Hf : map.right_inverse f' f) (Hg : map.right_inverse g' g) : + map.right_inverse (f' ∘ g') (g ∘ f) := +map.left_inverse_comp Hg Hf + +theorem equiv_of_map.left_inverse_of_right_inverse {g1 g2 : map b a} {f : map a b} + (H1 : map.left_inverse g1 f) (H2 : map.right_inverse g2 f) : g1 ~ g2 := +eq_on_of_left_inv_of_right_inv (mapsto g2) H1 H2 + +/- inverse -/ + +-- g is an inverse to f +protected definition is_inverse (g : map b a) (f : map a b) : Prop := +map.left_inverse g f ∧ map.right_inverse g f + +theorem bijective_of_is_inverse {g : map b a} {f : map a b} (H : map.is_inverse g f) : + map.bijective f := +and.intro + (injective_of_left_inverse (and.left H)) + (surjective_of_right_inverse (and.right H)) + +end map +end set diff --git a/old_library/data/set/set.md b/old_library/data/set/set.md new file mode 100644 index 0000000000..9dcd44b216 --- /dev/null +++ b/old_library/data/set/set.md @@ -0,0 +1,14 @@ +data.set +======== + +Subsets of an arbitrary type. + +* [basic](basic.lean) : unions, intersections, etc. +* [comm_semiring](comm_semiring.lean) +* [function](function.lean) : functions from one set to another +* [map](map.lean) : set functions bundled with their domain and codomain +* [finite](finite.lean) : the "finite" predicate on sets +* [card](card.lean) : cardinality (for finite sets) +* [filter](filter.lean) : filters on sets +* [classical_inverse](classical_inverse.lean) : inverse functions, defined classically +* [equinumerosity](equinumerosity.lean) \ No newline at end of file diff --git a/old_library/data/sigma.lean b/old_library/data/sigma.lean new file mode 100644 index 0000000000..4f7abd9c0c --- /dev/null +++ b/old_library/data/sigma.lean @@ -0,0 +1,46 @@ +/- +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, Floris van Doorn + +Sigma types, aka dependent sum. +-/ +import logic.cast +open inhabited sigma.ops + +namespace sigma + universe variables u v + variables {A A' : Type.{u}} {B : A → Type.{v}} {B' : A' → Type.{v}} + + definition unpack {C : (Σa, B a) → Type} {u : Σa, B a} : C (sigma.mk u.1 u.2) → C u := + sigma.rec_on u (λ u1 u2 H, H) + + theorem dpair_heq {a : A} {a' : A'} {b : B a} {b' : B' a'} + (HB : B == B') (Ha : a == a') (Hb : b == b') : (sigma.mk a b) == (sigma.mk a' b') := + hcongr_arg4 @mk (type_eq_of_heq Ha) HB Ha Hb + + protected theorem heq {p : Σa : A, B a} {p' : Σa' : A', B' a'} (HB : B == B') : + ∀(H₁ : p.1 == p'.1) (H₂ : p.2 == p'.2), p == p' := + destruct p (take a₁ b₁, destruct p' (take a₂ b₂ H₁ H₂, dpair_heq HB H₁ H₂)) + + attribute [instance] + protected definition is_inhabited [H₁ : inhabited A] [H₂ : inhabited (B (default A))] : + inhabited (sigma B) := + inhabited.destruct H₁ (λa, inhabited.destruct H₂ (λb, inhabited.mk (sigma.mk (default A) b))) + + variables {C : Πa, B a → Type} {D : Πa b, C a b → Type} + + definition dtrip (a : A) (b : B a) (c : C a b) := (sigma.mk a (sigma.mk b c)) + definition dquad (a : A) (b : B a) (c : C a b) (d : D a b c) := (sigma.mk a (sigma.mk b (sigma.mk c d))) + + attribute [reducible] + definition pr1' (x : Σ a, B a) := x.1 + attribute [reducible] + definition pr2' (x : Σ a b, C a b) := x.2.1 + attribute [reducible] + definition pr3 (x : Σ a b, C a b) := x.2.2 + attribute [reducible] + definition pr3' (x : Σ a b c, D a b c) := x.2.2.1 + attribute [reducible] + definition pr4 (x : Σ a b c, D a b c) := x.2.2.2 +end sigma diff --git a/old_library/data/squash.lean b/old_library/data/squash.lean new file mode 100644 index 0000000000..33370c5ff1 --- /dev/null +++ b/old_library/data/squash.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Define squash type (aka propositional truncation) using quotients. +This definition is slightly better than defining the squash type ∥A∥ as (nonempty A). +If we define it using (nonempty A), then we can only lift functions A → B to ∥A∥ → B +when B is a proposition. With quotients, we can lift to any B type that is a subsingleton +(i.e., has at most one element). +-/ +open quot + +private definition eqv {A : Type} (a b : A) : Prop := true +local infix ~ := eqv + +private lemma eqv_refl {A : Type} : ∀ a : A, a ~ a := +λ a, trivial + +private lemma eqv_symm {A : Type} : ∀ a b : A, a ~ b → b ~ a := +λ a b h, trivial + +private lemma eqv_trans {A : Type} : ∀ a b c : A, a ~ b → b ~ c → a ~ c := +λ a b c h₁ h₂, trivial + +definition squash_setoid (A : Type) : setoid A := +setoid.mk (@eqv A) (mk_equivalence (@eqv A) (@eqv_refl A) (@eqv_symm A) (@eqv_trans A)) + +definition squash (A : Type) : Type := +quot (squash_setoid A) + +namespace squash +local attribute squash_setoid [instance] + +notation `∥`:0 A `∥` := squash A + +definition mk {A : Type} (a : A) : ∥A∥ := +⟦a⟧ + +protected definition irrelevant {A : Type} : ∀ a b : ∥A∥, a = b := +λ a b, quot.induction_on₂ a b (λ a b, quot.sound trivial) + +definition lift {A B : Type} [h : subsingleton B] (f : A → B) : ∥A∥ → B := +λ s, quot.lift_on s f (λ a₁ a₂ r, subsingleton.elim (f a₁) (f a₂)) +end squash + +open squash decidable + +attribute [instance] +definition decidable_eq_squash (A : Type) : decidable_eq ∥A∥ := +λ a b, inl (squash.irrelevant a b) + +attribute [instance] +definition subsingleton_squash (A : Type) : subsingleton ∥A∥ := +subsingleton.intro (@squash.irrelevant A) diff --git a/old_library/data/stream.lean b/old_library/data/stream.lean new file mode 100644 index 0000000000..998720cead --- /dev/null +++ b/old_library/data/stream.lean @@ -0,0 +1,663 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +import data.nat data.list data.equiv +open nat function option + +definition stream (A : Type) := nat → A + +namespace stream +variables {A B C : Type} + +definition cons (a : A) (s : stream A) : stream A := +λ i, + match i with + | 0 := a + | succ n := s n + end + +notation h :: t := cons h t + +attribute [reducible] +definition head (s : stream A) : A := +s 0 + +definition tail (s : stream A) : stream A := +λ i, s (i+1) + +definition drop (n : nat) (s : stream A) : stream A := +λ i, s (i+n) + +attribute [reducible] +definition nth (n : nat) (s : stream A) : A := +s n + +protected theorem eta (s : stream A) : head s :: tail s = s := +funext (λ i, begin cases i, repeat reflexivity end) + +theorem nth_zero_cons (a : A) (s : stream A) : nth 0 (a :: s) = a := +rfl + +theorem head_cons (a : A) (s : stream A) : head (a :: s) = a := +rfl + +theorem tail_cons (a : A) (s : stream A) : tail (a :: s) = s := +rfl + +theorem tail_drop (n : nat) (s : stream A) : tail (drop n s) = drop n (tail s) := +funext (λ i, begin esimp [tail, drop], congruence, rewrite add.right_comm end) + +theorem nth_drop (n m : nat) (s : stream A) : nth n (drop m s) = nth (n+m) s := +rfl + +theorem tail_eq_drop (s : stream A) : tail s = drop 1 s := +rfl + +theorem drop_drop (n m : nat) (s : stream A) : drop n (drop m s) = drop (n+m) s := +funext (λ i, begin esimp [drop], rewrite add.assoc end) + +theorem nth_succ (n : nat) (s : stream A) : nth (succ n) s = nth n (tail s) := +rfl + +theorem drop_succ (n : nat) (s : stream A) : drop (succ n) s = drop n (tail s) := +rfl + +protected theorem ext {s₁ s₂ : stream A} : (∀ n, nth n s₁ = nth n s₂) → s₁ = s₂ := +assume h, funext h + +definition all (p : A → Prop) (s : stream A) := ∀ n, p (nth n s) + +definition any (p : A → Prop) (s : stream A) := ∃ n, p (nth n s) + +theorem all_def (p : A → Prop) (s : stream A) : all p s = ∀ n, p (nth n s) := +rfl + +theorem any_def (p : A → Prop) (s : stream A) : any p s = ∃ n, p (nth n s) := +rfl + +definition mem (a : A) (s : stream A) := any (λ b, a = b) s + +notation e ∈ s := mem e s + +theorem mem_cons (a : A) (s : stream A) : a ∈ (a::s) := +exists.intro 0 rfl + +theorem mem_cons_of_mem {a : A} {s : stream A} (b : A) : a ∈ s → a ∈ b :: s := +assume ains, obtain n (h : a = nth n s), from ains, +exists.intro (succ n) (by rewrite [nth_succ, tail_cons, h]) + +theorem eq_or_mem_of_mem_cons {a b : A} {s : stream A} : a ∈ b::s → a = b ∨ a ∈ s := +assume ainbs, obtain n (h : a = nth n (b::s)), from ainbs, +begin + cases n with n', + {left, exact h}, + {right, rewrite [nth_succ at h, tail_cons at h], existsi n', exact h} +end + +theorem mem_of_nth_eq {n : nat} {s : stream A} {a : A} : a = nth n s → a ∈ s := +assume h, exists.intro n h + +section map +variable (f : A → B) + +definition map (s : stream A) : stream B := +λ n, f (nth n s) + +theorem drop_map (n : nat) (s : stream A) : drop n (map f s) = map f (drop n s) := +stream.ext (λ i, rfl) + +theorem nth_map (n : nat) (s : stream A) : nth n (map f s) = f (nth n s) := +rfl + +theorem tail_map (s : stream A) : tail (map f s) = map f (tail s) := +begin rewrite tail_eq_drop end + +theorem head_map (s : stream A) : head (map f s) = f (head s) := +rfl + +theorem map_eq (s : stream A) : map f s = f (head s) :: map f (tail s) := +by rewrite [-stream.eta, tail_map, head_map] + +theorem map_cons (a : A) (s : stream A) : map f (a :: s) = f a :: map f s := +by rewrite [-stream.eta, map_eq] + +theorem map_id (s : stream A) : map id s = s := +rfl + +theorem map_map (g : B → C) (f : A → B) (s : stream A) : map g (map f s) = map (g ∘ f) s := +rfl + +theorem mem_map {a : A} {s : stream A} : a ∈ s → f a ∈ map f s := +assume ains, obtain n (h : a = nth n s), from ains, +exists.intro n (by rewrite [nth_map, h]) +end map + +section zip +variable (f : A → B → C) + +definition zip (s₁ : stream A) (s₂ : stream B) : stream C := +λ n, f (nth n s₁) (nth n s₂) + +theorem drop_zip (n : nat) (s₁ : stream A) (s₂ : stream B) : drop n (zip f s₁ s₂) = zip f (drop n s₁) (drop n s₂) := +stream.ext (λ i, rfl) + +theorem nth_zip (n : nat) (s₁ : stream A) (s₂ : stream B) : nth n (zip f s₁ s₂) = f (nth n s₁) (nth n s₂) := +rfl + +theorem head_zip (s₁ : stream A) (s₂ : stream B) : head (zip f s₁ s₂) = f (head s₁) (head s₂) := +rfl + +theorem tail_zip (s₁ : stream A) (s₂ : stream B) : tail (zip f s₁ s₂) = zip f (tail s₁) (tail s₂) := +rfl + +theorem zip_eq (s₁ : stream A) (s₂ : stream B) : zip f s₁ s₂ = f (head s₁) (head s₂) :: zip f (tail s₁) (tail s₂) := +by rewrite [-stream.eta] +end zip + +definition const (a : A) : stream A := +λ n, a + +theorem mem_const (a : A) : a ∈ const a := +exists.intro 0 rfl + +theorem const_eq (a : A) : const a = a :: const a := +begin + apply stream.ext, intro n, + cases n, repeat reflexivity +end + +theorem tail_const (a : A) : tail (const a) = const a := +by rewrite [const_eq at {1}] + +theorem map_const (f : A → B) (a : A) : map f (const a) = const (f a) := +rfl + +theorem nth_const (n : nat) (a : A) : nth n (const a) = a := +rfl + +theorem drop_const (n : nat) (a : A) : drop n (const a) = const a := +stream.ext (λ i, rfl) + +definition iterate (f : A → A) (a : A) : stream A := +λ n, nat.rec_on n a (λ n r, f r) + +theorem head_iterate (f : A → A) (a : A) : head (iterate f a) = a := +rfl + +theorem tail_iterate (f : A → A) (a : A) : tail (iterate f a) = iterate f (f a) := +begin + apply funext, intro n, + induction n with n' IH, + {reflexivity}, + {esimp [tail, iterate] at *, + rewrite add_one at *, + esimp at *, rewrite IH} +end + +theorem iterate_eq (f : A → A) (a : A) : iterate f a = a :: iterate f (f a) := +begin + rewrite [-stream.eta], congruence, exact !tail_iterate +end + +theorem nth_zero_iterate (f : A → A) (a : A) : nth 0 (iterate f a) = a := +rfl + +theorem nth_succ_iterate (n : nat) (f : A → A) (a : A) : nth (succ n) (iterate f a) = nth n (iterate f (f a)) := +by rewrite [nth_succ, tail_iterate] + +section bisim + variable (R : stream A → stream A → Prop) + local infix ~ := R + + definition is_bisimulation := ∀ ⦃s₁ s₂⦄, s₁ ~ s₂ → head s₁ = head s₂ ∧ tail s₁ ~ tail s₂ + + lemma nth_of_bisim (bisim : is_bisimulation R) : ∀ {s₁ s₂} n, s₁ ~ s₂ → nth n s₁ = nth n s₂ ∧ drop (n+1) s₁ ~ drop (n+1) s₂ + | s₁ s₂ 0 h := bisim h + | s₁ s₂ (n+1) h := + obtain h₁ (trel : tail s₁ ~ tail s₂), from bisim h, + nth_of_bisim n trel + + -- If two streams are bisimilar, then they are equal + theorem eq_of_bisim (bisim : is_bisimulation R) : ∀ {s₁ s₂}, s₁ ~ s₂ → s₁ = s₂ := + λ s₁ s₂ r, stream.ext (λ n, and.elim_left (nth_of_bisim R bisim n r)) +end bisim + +theorem bisim_simple (s₁ s₂ : stream A) : head s₁ = head s₂ → s₁ = tail s₁ → s₂ = tail s₂ → s₁ = s₂ := +assume hh ht₁ ht₂, eq_of_bisim + (λ s₁ s₂, head s₁ = head s₂ ∧ s₁ = tail s₁ ∧ s₂ = tail s₂) + (λ s₁ s₂ h, + obtain h₁ h₂ h₃, from h, + begin + constructor, exact h₁, rewrite [-h₂, -h₃], exact h + end) + (and.intro hh (and.intro ht₁ ht₂)) + +-- AKA coinduction freeze +theorem coinduction.{l} {A : Type.{l}} {s₁ s₂ : stream A} : + head s₁ = head s₂ → (∀ (B : Type.{l}) (fr : stream A → B), fr s₁ = fr s₂ → fr (tail s₁) = fr (tail s₂)) → s₁ = s₂ := +assume hh ht, + eq_of_bisim + (λ s₁ s₂, head s₁ = head s₂ ∧ ∀ (B : Type) (fr : stream A → B), fr s₁ = fr s₂ → fr (tail s₁) = fr (tail s₂)) + (λ s₁ s₂ h, + have h₁ : head s₁ = head s₂, from and.elim_left h, + have h₂ : head (tail s₁) = head (tail s₂), from and.elim_right h A (@head A) h₁, + have h₃ : ∀ (B : Type) (fr : stream A → B), fr (tail s₁) = fr (tail s₂) → fr (tail (tail s₁)) = fr (tail (tail s₂)), from + λ B fr, and.elim_right h B (λ s, fr (tail s)), + and.intro h₁ (and.intro h₂ h₃)) + (and.intro hh ht) + +theorem iterate_id (a : A) : iterate id a = const a := +coinduction + rfl + (λ B fr ch, by rewrite [tail_iterate, tail_const]; exact ch) + + +local attribute stream [reducible] +theorem map_iterate (f : A → A) (a : A) : iterate f (f a) = map f (iterate f a) := +begin + apply funext, intro n, + induction n with n' IH, + {reflexivity}, + { esimp [map, iterate, nth] at *, + rewrite IH } +end + +section corec + definition corec (f : A → B) (g : A → A) : A → stream B := + λ a, map f (iterate g a) + + theorem corec_def (f : A → B) (g : A → A) (a : A) : corec f g a = map f (iterate g a) := + rfl + + theorem corec_eq (f : A → B) (g : A → A) (a : A) : corec f g a = f a :: corec f g (g a) := + by rewrite [corec_def, map_eq, head_iterate, tail_iterate] + + theorem corec_id_id_eq_const (a : A) : corec id id a = const a := + by rewrite [corec_def, map_id, iterate_id] + + theorem corec_id_f_eq_iterate (f : A → A) (a : A) : corec id f a = iterate f a := + rfl +end corec + +-- corec is also known as unfold +definition unfolds (g : A → B) (f : A → A) (a : A) : stream B := +corec g f a + +theorem unfolds_eq (g : A → B) (f : A → A) (a : A) : unfolds g f a = g a :: unfolds g f (f a) := +by esimp [ unfolds ]; rewrite [corec_eq] + +theorem nth_unfolds_head_tail : ∀ (n : nat) (s : stream A), nth n (unfolds head tail s) = nth n s := +begin + intro n, induction n with n' ih, + {intro s, reflexivity}, + {intro s, rewrite [*nth_succ, unfolds_eq, tail_cons, ih]} +end + +theorem unfolds_head_eq : ∀ (s : stream A), unfolds head tail s = s := +λ s, stream.ext (λ n, nth_unfolds_head_tail n s) + +definition interleave (s₁ s₂ : stream A) : stream A := +corec + (λ p, obtain s₁ s₂, from p, head s₁) + (λ p, obtain s₁ s₂, from p, (s₂, tail s₁)) + (s₁, s₂) + +infix `⋈`:65 := interleave + +theorem interleave_eq (s₁ s₂ : stream A) : s₁ ⋈ s₂ = head s₁ :: head s₂ :: (tail s₁ ⋈ tail s₂) := +begin + esimp [interleave], rewrite corec_eq, esimp, congruence, rewrite corec_eq +end + +theorem tail_interleave (s₁ s₂ : stream A) : tail (s₁ ⋈ s₂) = s₂ ⋈ (tail s₁) := +by esimp [interleave]; rewrite corec_eq + +theorem interleave_tail_tail (s₁ s₂ : stream A) : tail s₁ ⋈ tail s₂ = tail (tail (s₁ ⋈ s₂)) := +by rewrite [interleave_eq s₁ s₂] + +theorem nth_interleave_left : ∀ (n : nat) (s₁ s₂ : stream A), nth (2*n) (s₁ ⋈ s₂) = nth n s₁ +| 0 s₁ s₂ := rfl +| (succ n) s₁ s₂ := + begin + change nth (succ (succ (2*n))) (s₁ ⋈ s₂) = nth (succ n) s₁, + rewrite [*nth_succ, interleave_eq, *tail_cons, nth_interleave_left] + end + +theorem nth_interleave_right : ∀ (n : nat) (s₁ s₂ : stream A), nth (2*n+1) (s₁ ⋈ s₂) = nth n s₂ +| 0 s₁ s₂ := rfl +| (succ n) s₁ s₂ := + begin + change nth (succ (succ (2*n+1))) (s₁ ⋈ s₂) = nth (succ n) s₂, + rewrite [*nth_succ, interleave_eq, *tail_cons, nth_interleave_right] + end + +theorem mem_interleave_left {a : A} {s₁ : stream A} (s₂ : stream A) : a ∈ s₁ → a ∈ s₁ ⋈ s₂ := +assume ains₁, obtain n h, from ains₁, +exists.intro (2*n) (by rewrite [h, nth_interleave_left]) + +theorem mem_interleave_right {a : A} {s₁ : stream A} (s₂ : stream A) : a ∈ s₂ → a ∈ s₁ ⋈ s₂ := +assume ains₂, obtain n h, from ains₂, +exists.intro (2*n+1) (by rewrite [h, nth_interleave_right]) + +definition even (s : stream A) : stream A := +corec + (λ s, head s) + (λ s, tail (tail s)) + s + +definition odd (s : stream A) : stream A := +even (tail s) + +theorem odd_eq (s : stream A) : odd s = even (tail s) := +rfl + +theorem head_even (s : stream A) : head (even s) = head s := +rfl + +theorem tail_even (s : stream A) : tail (even s) = even (tail (tail s)) := +by esimp [even]; rewrite corec_eq + +theorem even_cons_cons (a₁ a₂ : A) (s : stream A) : even (a₁ :: a₂ :: s) = a₁ :: even s := +by esimp [even]; rewrite corec_eq + +theorem even_tail (s : stream A) : even (tail s) = odd s := +rfl + +theorem even_interleave (s₁ s₂ : stream A) : even (s₁ ⋈ s₂) = s₁ := +eq_of_bisim + (λ s₁' s₁, ∃ s₂, s₁' = even (s₁ ⋈ s₂)) + (λ s₁' s₁ h, + obtain s₂ (h₁ : s₁' = even (s₁ ⋈ s₂)), from h, + begin + rewrite h₁, + constructor, + {reflexivity}, + {existsi (tail s₂), + rewrite [interleave_eq, even_cons_cons, tail_cons]} + end) + (exists.intro s₂ rfl) + +theorem interleave_even_odd (s₁ : stream A) : even s₁ ⋈ odd s₁ = s₁ := +eq_of_bisim + (λ s' s, s' = even s ⋈ odd s) + (λ s' s (h : s' = even s ⋈ odd s), + begin + rewrite h, constructor, + {reflexivity}, + {esimp, rewrite [*odd_eq, tail_interleave, tail_even]} + end) + rfl + +theorem nth_even : ∀ (n : nat) (s : stream A), nth n (even s) = nth (2*n) s +| 0 s := rfl +| (succ n) s := + begin + change nth (succ n) (even s) = nth (succ (succ (2 * n))) s, + rewrite [+nth_succ, tail_even, nth_even] + end + +theorem nth_odd : ∀ (n : nat) (s : stream A), nth n (odd s) = nth (2*n + 1) s := +λ n s, by rewrite [odd_eq, nth_even] + +theorem mem_of_mem_even (a : A) (s : stream A) : a ∈ even s → a ∈ s := +assume aines, obtain n h, from aines, +exists.intro (2*n) (by rewrite [h, nth_even]) + +theorem mem_of_mem_odd (a : A) (s : stream A) : a ∈ odd s → a ∈ s := +assume ainos, obtain n h, from ainos, +exists.intro (2*n+1) (by rewrite [h, nth_odd]) + +open list +definition append : list A → stream A → stream A +| [] s := s +| (a::l) s := a :: append l s + +theorem nil_append (s : stream A) : append [] s = s := +rfl + +theorem cons_append (a : A) (l : list A) (s : stream A) : append (a::l) s = a :: append l s := +rfl + +infix ++ := append +-- the following local notation is used just to make the following theorem clear +local infix `++ₛ`:65 := append + +theorem append_append : ∀ (l₁ l₂ : list A) (s : stream A), (l₁ ++ l₂) ++ₛ s = l₁ ++ (l₂ ++ₛ s) +| [] l₂ s := rfl +| (a::l₁) l₂ s := by rewrite [list.append_cons, *cons_append, append_append] + +theorem map_append (f : A → B) : ∀ (l : list A) (s : stream A), map f (l ++ s) = list.map f l ++ map f s +| [] s := rfl +| (a::l) s := by rewrite [cons_append, list.map_cons, map_cons, cons_append, map_append] + +theorem drop_append : ∀ (l : list A) (s : stream A), drop (length l) (l ++ s) = s +| [] s := by esimp +| (a::l) s := by rewrite [length_cons, add_one, drop_succ, cons_append, tail_cons, drop_append] + +theorem append_head_tail (s : stream A) : [head s] ++ tail s = s := +by rewrite [cons_append, nil_append, stream.eta] + +theorem mem_append_right : ∀ {a : A} (l : list A) {s : stream A}, a ∈ s → a ∈ l ++ s +| a [] s h := h +| a (b::l) s h := + have ih : a ∈ l ++ s, from mem_append_right l h, + !mem_cons_of_mem ih + +theorem mem_append_left : ∀ {a : A} {l : list A} (s : stream A), a ∈ l → a ∈ l ++ s +| a [] s h := absurd h !not_mem_nil +| a (b::l) s h := + or.elim (list.eq_or_mem_of_mem_cons h) + (λ (aeqb : a = b), exists.intro 0 aeqb) + (λ (ainl : a ∈ l), mem_cons_of_mem b (mem_append_left s ainl)) + +definition approx : nat → stream A → list A +| 0 s := [] +| (n+1) s := head s :: approx n (tail s) + +theorem approx_zero (s : stream A) : approx 0 s = [] := +rfl + +theorem approx_succ (n : nat) (s : stream A) : approx (succ n) s = head s :: approx n (tail s) := +rfl + +theorem nth_approx : ∀ (n : nat) (s : stream A), list.nth (approx (succ n) s) n = some (nth n s) +| 0 s := rfl +| (n+1) s := begin rewrite [approx_succ, add_one, list.nth_succ, nth_approx] end + +theorem append_approx_drop : ∀ (n : nat) (s : stream A), append (approx n s) (drop n s) = s := +begin + intro n, + induction n with n' ih, + {intro s, reflexivity}, + {intro s, rewrite [approx_succ, drop_succ, cons_append, ih (tail s), stream.eta]} +end + +-- Take lemma reduces a proof of equality of infinite streams to an +-- induction over all their finite approximations. +theorem take_lemma (s₁ s₂ : stream A) : (∀ (n : nat), approx n s₁ = approx n s₂) → s₁ = s₂ := +begin + intro h, apply stream.ext, intro n, + induction n with n ih, + {injection (h 1) with aux, exact aux}, + {have h₁ : some (nth (succ n) s₁) = some (nth (succ n) s₂), by rewrite [-*nth_approx, h (succ (succ n))], + injection h₁, assumption} +end + +-- auxiliary definition for cycle corecursive definition +private definition cycle_f : A × list A × A × list A → A +| (v, _, _, _) := v + +-- auxiliary definition for cycle corecursive definition +private definition cycle_g : A × list A × A × list A → A × list A × A × list A +| (v₁, [], v₀, l₀) := (v₀, l₀, v₀, l₀) +| (v₁, v₂::l₂, v₀, l₀) := (v₂, l₂, v₀, l₀) + +private lemma cycle_g_cons (a : A) (a₁ : A) (l₁ : list A) (a₀ : A) (l₀ : list A) : + cycle_g (a, a₁::l₁, a₀, l₀) = (a₁, l₁, a₀, l₀) := +rfl + +definition cycle : Π (l : list A), l ≠ nil → stream A +| [] h := absurd rfl h +| (a::l) h := corec cycle_f cycle_g (a, l, a, l) + +theorem cycle_eq : ∀ (l : list A) (h : l ≠ nil), cycle l h = l ++ cycle l h +| [] h := absurd rfl h +| (a::l) h := + have gen : ∀ l' a', corec cycle_f cycle_g (a', l', a, l) = (a' :: l') ++ₛ corec cycle_f cycle_g (a, l, a, l), + begin + intro l', + induction l' with a₁ l₁ ih, + {intro a', rewrite [corec_eq]}, + {intro a', rewrite [corec_eq, cycle_g_cons, ih a₁]} + end, + gen l a + +theorem mem_cycle {a : A} {l : list A} : ∀ (h : l ≠ []), a ∈ l → a ∈ cycle l h := +assume h ainl, by rewrite [cycle_eq]; exact !mem_append_left ainl + +theorem cycle_singleton (a : A) (h : [a] ≠ nil) : cycle [a] h = const a := +coinduction + rfl + (λ B fr ch, by rewrite [cycle_eq, const_eq]; exact ch) + +definition tails (s : stream A) : stream (stream A) := +corec id tail (tail s) + +theorem tails_eq (s : stream A) : tails s = tail s :: tails (tail s) := +by esimp [tails]; rewrite [corec_eq] + +theorem nth_tails : ∀ (n : nat) (s : stream A), nth n (tails s) = drop n (tail s) := +begin + intro n, induction n with n' ih, + {intros, reflexivity}, + {intro s, rewrite [nth_succ, drop_succ, tails_eq, tail_cons, ih]} +end + +theorem tails_eq_iterate (s : stream A) : tails s = iterate tail (tail s) := +rfl + +definition inits_core (l : list A) (s : stream A) : stream (list A) := +corec + prod.pr1 + (λ p, match p with (l', s') := (l' ++ [head s'], tail s') end) + (l, s) + +definition inits (s : stream A) : stream (list A) := +inits_core [head s] (tail s) + +theorem inits_core_eq (l : list A) (s : stream A) : inits_core l s = l :: inits_core (l ++ [head s]) (tail s) := +by esimp [inits_core]; rewrite [corec_eq] + +theorem tail_inits (s : stream A) : tail (inits s) = inits_core [head s, head (tail s)] (tail (tail s)) := +by esimp [inits]; rewrite inits_core_eq + +theorem inits_tail (s : stream A) : inits (tail s) = inits_core [head (tail s)] (tail (tail s)) := +rfl + +theorem cons_nth_inits_core : ∀ (a : A) (n : nat) (l : list A) (s : stream A), + a :: nth n (inits_core l s) = nth n (inits_core (a::l) s) := +begin + intro a n, + induction n with n' ih, + {intros, reflexivity}, + {intro l s, rewrite [*nth_succ, inits_core_eq, +tail_cons, ih, inits_core_eq (a::l) s] } +end + +theorem nth_inits : ∀ (n : nat) (s : stream A), nth n (inits s) = approx (succ n) s := +begin + intro n, induction n with n' ih, + {intros, reflexivity}, + {intros, rewrite [nth_succ, approx_succ, -ih, tail_inits, inits_tail, cons_nth_inits_core]} +end + +theorem inits_eq (s : stream A) : inits s = [head s] :: map (list.cons (head s)) (inits (tail s)) := +begin + apply stream.ext, intro n, + cases n, + {reflexivity}, + {rewrite [nth_inits, nth_succ, tail_cons, nth_map, nth_inits]} +end + +theorem zip_inits_tails (s : stream A) : zip append (inits s) (tails s) = const s := +begin + apply stream.ext, intro n, + rewrite [nth_zip, nth_inits, nth_tails, nth_const, approx_succ, + cons_append, append_approx_drop, stream.eta] +end + +definition pure (a : A) : stream A := +const a + +definition apply (f : stream (A → B)) (s : stream A) : stream B := +λ n, (nth n f) (nth n s) + +infix `⊛`:75 := apply -- input as \o* + +theorem identity (s : stream A) : pure id ⊛ s = s := +rfl +theorem composition (g : stream (B → C)) (f : stream (A → B)) (s : stream A) : pure comp ⊛ g ⊛ f ⊛ s = g ⊛ (f ⊛ s) := +rfl +theorem homomorphism (f : A → B) (a : A) : pure f ⊛ pure a = pure (f a) := +rfl +theorem interchange (fs : stream (A → B)) (a : A) : fs ⊛ pure a = pure (λ f, f a) ⊛ fs := +rfl +theorem map_eq_apply (f : A → B) (s : stream A) : map f s = pure f ⊛ s := +rfl + +definition nats : stream nat := +λ n, n + +theorem nth_nats (n : nat) : nth n nats = n := +rfl + +theorem nats_eq : nats = 0 :: map succ nats := +begin + apply stream.ext, intro n, + cases n, reflexivity, rewrite [nth_succ] +end + +section +open equiv +lemma stream_equiv_of_equiv {A B : Type} : A ≃ B → stream A ≃ stream B +| (mk f g l r) := + mk (map f) (map g) + begin intros, rewrite [map_map, id_of_left_inverse l, map_id] end + begin intros, rewrite [map_map, id_of_right_inverse r, map_id] end +end + +definition lex (rel : A → A → Prop) (s₁ s₂ : stream A) : Prop := +∃ i, rel (nth i s₁) (nth i s₂) ∧ ∀ j, j < i → nth j s₁ = nth j s₂ + +definition lex.trans {s₁ s₂ s₃} {rel : A → A → Prop} : transitive rel → lex rel s₁ s₂ → lex rel s₂ s₃ → lex rel s₁ s₃ := +assume htrans h₁ h₂, +obtain (i₁ : nat) hlt₁ he₁, from h₁, +obtain (i₂ : nat) hlt₂ he₂, from h₂, +lt.by_cases + (λ i₁lti₂ : i₁ < i₂, + have aux : nth i₁ s₂ = nth i₁ s₃, from he₂ _ i₁lti₂, + begin + existsi i₁, split, + {rewrite -aux, exact hlt₁}, + {intro j jlti₁, transitivity nth j s₂, + exact !he₁ jlti₁, + exact !he₂ (lt.trans jlti₁ i₁lti₂)} + end) + (λ i₁eqi₂ : i₁ = i₂, + begin + subst i₂, existsi i₁, split, exact htrans hlt₁ hlt₂, intro j jlti₁, + transitivity nth j s₂, + exact !he₁ jlti₁; + exact !he₂ jlti₁ + end) + (λ i₂lti₁ : i₂ < i₁, + have nth i₂ s₁ = nth i₂ s₂, from he₁ _ i₂lti₁, + begin + existsi i₂, split, + {rewrite this, exact hlt₂}, + {intro j jlti₂, transitivity nth j s₂, + exact !he₁ (lt.trans jlti₂ i₂lti₁), + exact !he₂ jlti₂} + end) +end stream diff --git a/old_library/data/tuple.lean b/old_library/data/tuple.lean new file mode 100644 index 0000000000..6140715509 --- /dev/null +++ b/old_library/data/tuple.lean @@ -0,0 +1,327 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Tuples are lists of a fixed size. +It is implemented as a subtype. +-/ +import logic data.list data.fin +open nat list subtype function + +attribute [reducible] +definition tuple (A : Type) (n : nat) := {l : list A | length l = n} + +namespace tuple + variables {A B C : Type} + + attribute [recursor 4] + theorem induction_on {P : ∀ {n}, tuple A n → Prop} + : ∀ {n} (v : tuple A n), (∀ (l : list A) {n : nat} (h : length l = n), P (tag l h)) → P v + | n (tag l h) H := @H l n h + + definition nil : tuple A 0 := + tag [] rfl + + lemma length_succ {n : nat} {l : list A} (a : A) : length l = n → length (a::l) = succ n := + λ h, congr_arg succ h + + definition cons {n : nat} : A → tuple A n → tuple A (succ n) + | a (tag v h) := tag (a::v) (length_succ a h) + + notation a :: b := cons a b + + attribute [instance] + protected definition is_inhabited [h : inhabited A] : ∀ (n : nat), inhabited (tuple A n) + | 0 := inhabited.mk nil + | (succ n) := inhabited.mk (inhabited.value h :: inhabited.value (is_inhabited n)) + + attribute [instance] + protected definition has_decidable_eq [h : decidable_eq A] : ∀ (n : nat), decidable_eq (tuple A n) := + λ n, subtype.has_decidable_eq + + definition head {n : nat} : tuple A (succ n) → A + | (tag [] h) := by contradiction + | (tag (a::v) h) := a + + definition tail {n : nat} : tuple A (succ n) → tuple A n + | (tag [] h) := by contradiction + | (tag (a::v) h) := tag v (succ.inj h) + + theorem head_cons {n : nat} (a : A) (v : tuple A n) : head (a :: v) = a := + by induction v; reflexivity + + theorem tail_cons {n : nat} (a : A) (v : tuple A n) : tail (a :: v) = v := + by induction v; reflexivity + + theorem head_lcons {n : nat} (a : A) (l : list A) (h : length (a::l) = succ n) : head (tag (a::l) h) = a := + rfl + + theorem tail_lcons {n : nat} (a : A) (l : list A) (h : length (a::l) = succ n) : tail (tag (a::l) h) = tag l (succ.inj h) := + rfl + + definition last {n : nat} : tuple A (succ n) → A + | (tag l h) := list.last l (ne_nil_of_length_eq_succ h) + + theorem eta : ∀ {n : nat} (v : tuple A (succ n)), head v :: tail v = v + | 0 (tag [] h) := by contradiction + | 0 (tag (a::l) h) := rfl + | (n+1) (tag [] h) := by contradiction + | (n+1) (tag (a::l) h) := rfl + + definition of_list (l : list A) : tuple A (list.length l) := + tag l rfl + + definition to_list {n : nat} : tuple A n → list A + | (tag l h) := l + + theorem to_list_of_list (l : list A) : to_list (of_list l) = l := + rfl + + theorem to_list_nil : to_list nil = ([] : list A) := + rfl + + theorem length_to_list {n : nat} : ∀ (v : tuple A n), list.length (to_list v) = n + | (tag l h) := h + + theorem heq_of_list_eq {n m} : ∀ {v₁ : tuple A n} {v₂ : tuple A m}, to_list v₁ = to_list v₂ → n = m → v₁ == v₂ + | (tag l₁ h₁) (tag l₂ h₂) e₁ e₂ := begin + clear heq_of_list_eq, + subst e₂, subst h₁, + unfold to_list at e₁, + subst l₁ + end + + theorem list_eq_of_heq {n m} {v₁ : tuple A n} {v₂ : tuple A m} : v₁ == v₂ → n = m → to_list v₁ = to_list v₂ := + begin + intro h₁ h₂, revert v₁ v₂ h₁, + subst n, intro v₁ v₂ h₁, rewrite [eq_of_heq h₁] + end + + theorem of_list_to_list {n : nat} (v : tuple A n) : of_list (to_list v) == v := + begin + apply heq_of_list_eq, rewrite to_list_of_list, rewrite length_to_list + end + + /- append -/ + + definition append {n m : nat} : tuple A n → tuple A m → tuple A (n + m) + | (tag l₁ h₁) (tag l₂ h₂) := tag (list.append l₁ l₂) (by rewrite [length_append, h₁, h₂]) + + infix ++ := append + + open eq.ops + + lemma push_eq_rec : ∀ {n m : nat} {l : list A} (h₁ : n = m) (h₂ : length l = n), h₁ ▹ (tag l h₂) = tag l (h₁ ▹ h₂) + | n n l (eq.refl n) h₂ := rfl + + theorem append_nil_right {n : nat} (v : tuple A n) : v ++ nil = v := + induction_on v (λ l n h, by unfold [tuple.append, tuple.nil]; congruence; apply list.append_nil_right) + + theorem append_nil_left {n : nat} (v : tuple A n) : !zero_add ▹ (nil ++ v) = v := + induction_on v (λ l n h, begin unfold [tuple.append, tuple.nil], rewrite [push_eq_rec] end) + + theorem append_nil_left_heq {n : nat} (v : tuple A n) : nil ++ v == v := + heq_of_eq_rec_left !zero_add (append_nil_left v) + + theorem append.assoc {n₁ n₂ n₃} : ∀ (v₁ : tuple A n₁) (v₂ : tuple A n₂) (v₃ : tuple A n₃), !add.assoc ▹ ((v₁ ++ v₂) ++ v₃) = v₁ ++ (v₂ ++ v₃) + | (tag l₁ h₁) (tag l₂ h₂) (tag l₃ h₃) := begin + unfold tuple.append, rewrite push_eq_rec, + congruence, + apply list.append.assoc + end + + theorem append.assoc_heq {n₁ n₂ n₃} (v₁ : tuple A n₁) (v₂ : tuple A n₂) (v₃ : tuple A n₃) : (v₁ ++ v₂) ++ v₃ == v₁ ++ (v₂ ++ v₃) := + heq_of_eq_rec_left !add.assoc (append.assoc v₁ v₂ v₃) + + /- reverse -/ + + definition reverse {n : nat} : tuple A n → tuple A n + | (tag l h) := tag (list.reverse l) (by rewrite [length_reverse, h]) + + theorem reverse_reverse {n : nat} (v : tuple A n) : reverse (reverse v) = v := + induction_on v (λ l n h, begin unfold reverse, congruence, apply list.reverse_reverse end) + + theorem tuple0_eq_nil : ∀ (v : tuple A 0), v = nil + | (tag [] h) := rfl + | (tag (a::l) h) := by contradiction + + /- mem -/ + + definition mem {n : nat} (a : A) (v : tuple A n) : Prop := + a ∈ elt_of v + + notation e ∈ s := mem e s + notation e ∉ s := ¬ e ∈ s + + theorem not_mem_nil (a : A) : a ∉ nil := + list.not_mem_nil a + + attribute [simp] + theorem mem_cons {n : nat} (a : A) (v : tuple A n) : a ∈ a :: v := + induction_on v (λ l n h, !list.mem_cons) + + theorem mem_cons_of_mem {n : nat} (y : A) {x : A} {v : tuple A n} : x ∈ v → x ∈ y :: v := + induction_on v (λ l n h₁ h₂, list.mem_cons_of_mem y h₂) + + theorem eq_or_mem_of_mem_cons {n : nat} {x y : A} {v : tuple A n} : x ∈ y::v → x = y ∨ x ∈ v := + induction_on v (λ l n h₁ h₂, eq_or_mem_of_mem_cons h₂) + + theorem mem_singleton {n : nat} {x a : A} : x ∈ (a::nil : tuple A 1) → x = a := + assume h, list.mem_singleton h + + /- map -/ + + definition map {n : nat} (f : A → B) : tuple A n → tuple B n + | (tag l h) := tag (list.map f l) (by clear map; substvars; rewrite length_map) + + theorem map_nil (f : A → B) : map f nil = nil := + rfl + + theorem map_cons {n : nat} (f : A → B) (a : A) (v : tuple A n) : map f (a::v) = f a :: map f v := + by induction v; reflexivity + + theorem map_tag {n : nat} (f : A → B) (l : list A) (h : length l = n) + : map f (tag l h) = tag (list.map f l) (by substvars; rewrite length_map) := + by reflexivity + + theorem map_map {n : nat} (g : B → C) (f : A → B) (v : tuple A n) : map g (map f v) = map (g ∘ f) v := + begin cases v, rewrite *map_tag, apply subtype.eq, apply list.map_map end + + theorem map_id {n : nat} (v : tuple A n) : map id v = v := + begin induction v, unfold map, congruence, apply list.map_id end + + theorem mem_map {n : nat} {a : A} {v : tuple A n} (f : A → B) : a ∈ v → f a ∈ map f v := + begin induction v, unfold map, apply list.mem_map end + + theorem exists_of_mem_map {n : nat} {f : A → B} {b : B} {v : tuple A n} : b ∈ map f v → ∃a, a ∈ v ∧ f a = b := + begin induction v, unfold map, apply list.exists_of_mem_map end + + theorem eq_of_map_const {n : nat} {b₁ b₂ : B} {v : tuple A n} : b₁ ∈ map (const A b₂) v → b₁ = b₂ := + begin induction v, unfold map, apply list.eq_of_map_const end + + /- product -/ + + definition product {n m : nat} : tuple A n → tuple B m → tuple (A × B) (n * m) + | (tag l₁ h₁) (tag l₂ h₂) := tag (list.product l₁ l₂) (by rewrite [length_product, h₁, h₂]) + + theorem nil_product {m : nat} (v : tuple B m) : !zero_mul ▹ product (@nil A) v = nil := + begin induction v, unfold [nil, product], rewrite push_eq_rec end + + theorem nil_product_heq {m : nat} (v : tuple B m) : product (@nil A) v == (@nil (A × B)) := + heq_of_eq_rec_left _ (nil_product v) + + theorem product_nil {n : nat} (v : tuple A n) : product v (@nil B) = nil := + begin induction v, unfold [nil, product], congruence, apply list.product_nil end + + theorem mem_product {n m : nat} {a : A} {b : B} {v₁ : tuple A n} {v₂ : tuple B m} : a ∈ v₁ → b ∈ v₂ → (a, b) ∈ product v₁ v₂ := + begin cases v₁, cases v₂, unfold product, apply list.mem_product end + + theorem mem_of_mem_product_left {n m : nat} {a : A} {b : B} {v₁ : tuple A n} {v₂ : tuple B m} : (a, b) ∈ product v₁ v₂ → a ∈ v₁ := + begin cases v₁, cases v₂, unfold product, apply list.mem_of_mem_product_left end + + theorem mem_of_mem_product_right {n m : nat} {a : A} {b : B} {v₁ : tuple A n} {v₂ : tuple B m} : (a, b) ∈ product v₁ v₂ → b ∈ v₂ := + begin cases v₁, cases v₂, unfold product, apply list.mem_of_mem_product_right end + + /- ith -/ + open fin + + definition ith {n : nat} : tuple A n → fin n → A + | (tag l h₁) (mk i h₂) := list.ith l i (by rewrite h₁; exact h₂) + + lemma ith_zero {n : nat} (a : A) (v : tuple A n) (h : 0 < succ n) : ith (a::v) (mk 0 h) = a := + by induction v; reflexivity + + lemma ith_fin_zero {n : nat} (a : A) (v : tuple A n) : ith (a::v) (fin.zero n) = a := + by unfold fin.zero; apply ith_zero + + lemma ith_succ {n : nat} (a : A) (v : tuple A n) (i : nat) (h : succ i < succ n) + : ith (a::v) (mk (succ i) h) = ith v (mk_pred i h) := + by induction v; reflexivity + + lemma ith_fin_succ {n : nat} (a : A) (v : tuple A n) (i : fin n) + : ith (a::v) (succ i) = ith v i := + begin cases i, unfold fin.succ, rewrite ith_succ end + + lemma ith_zero_eq_head {n : nat} (v : tuple A (nat.succ n)) : ith v (fin.zero n) = head v := + by rewrite [-eta v, ith_fin_zero, head_cons] + + lemma ith_succ_eq_ith_tail {n : nat} (v : tuple A (nat.succ n)) (i : fin n) : ith v (succ i) = ith (tail v) i := + by rewrite [-eta v, ith_fin_succ, tail_cons] + + protected lemma ext {n : nat} (v₁ v₂ : tuple A n) (h : ∀ i : fin n, ith v₁ i = ith v₂ i) : v₁ = v₂ := + begin + induction n with n ih, + rewrite [tuple0_eq_nil v₁, tuple0_eq_nil v₂], + rewrite [-eta v₁, -eta v₂], congruence, + show head v₁ = head v₂, by rewrite [-ith_zero_eq_head, -ith_zero_eq_head]; apply h, + have ∀ i : fin n, ith (tail v₁) i = ith (tail v₂) i, from + take i, by rewrite [-ith_succ_eq_ith_tail, -ith_succ_eq_ith_tail]; apply h, + show tail v₁ = tail v₂, from ih _ _ this + end + + /- tabulate -/ + + definition tabulate : Π {n : nat}, (fin n → A) → tuple A n + | 0 f := nil + | (n+1) f := f (fin.zero n) :: tabulate (λ i : fin n, f (succ i)) + + theorem ith_tabulate {n : nat} (f : fin n → A) (i : fin n) : ith (tabulate f) i = f i := + begin + induction n with n ih, + apply elim0 i, + cases i with v hlt, cases v, + {unfold tabulate, rewrite ith_zero}, + {unfold tabulate, rewrite [ith_succ, ih]} + end + + variable {n : ℕ} + + definition replicate : A → tuple A n + | a := tag (list.replicate n a) (length_replicate n a) + + definition dropn : Π (i:ℕ), tuple A n → tuple A (n - i) + | i (tag l p) := tag (list.dropn i l) (p ▸ list.length_dropn i l) + + definition firstn : Π (i:ℕ) {p:i ≤ n}, tuple A n → tuple A i + | i isLe (tag l p) := + let q := calc list.length (list.firstn i l) + = min i (list.length l) : list.length_firstn_eq + ... = min i n : p + ... = i : min_eq_left isLe in + tag (list.firstn i l) q + + definition map₂ : (A → B → C) → tuple A n → tuple B n → tuple C n + | f (tag x px) (tag y py) := + let z : list C := list.map₂ f x y in + let p : list.length z = n := calc + list.length z = min (list.length x) (list.length y) : list.length_map₂ + ... = min n n : by rewrite [px, py] + ... = n : min_self in + tag z p + + section accum + open prod + variable {S : Type} + + definition mapAccumR + : (A → S → S × B) → tuple A n → S → S × tuple B n + | f (tag x px) c := + let z := list.mapAccumR f x c in + let p := calc + list.length (pr₂ (list.mapAccumR f x c)) + = length x : length_mapAccumR + ... = n : px in + (pr₁ z, tag (pr₂ z) p) + + definition mapAccumR₂ + : (A → B → S → S × C) → tuple A n → tuple B n → S → S × tuple C n + | f (tag x px) (tag y py) c := + let z := list.mapAccumR₂ f x y c in + let p := calc + list.length (pr₂ (list.mapAccumR₂ f x y c)) + = min (length x) (length y) : length_mapAccumR₂ + ... = n : by rewrite [ px, py, min_self ] in + (pr₁ z, tag (pr₂ z) p) + end accum +end tuple diff --git a/old_library/data/uprod.lean b/old_library/data/uprod.lean new file mode 100644 index 0000000000..595aca412b --- /dev/null +++ b/old_library/data/uprod.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Unordered pairs +-/ +import data.prod logic.identities +open prod prod.ops quot function + +private definition eqv {A : Type} (p₁ p₂ : A × A) : Prop := +p₁ = p₂ ∨ swap p₁ = p₂ + +infix `~` := eqv -- this is "~" + +attribute [refl] +private theorem eqv.refl {A : Type} : ∀ p : A × A, p ~ p := +take p, or.inl rfl + +attribute [symm] +private theorem eqv.symm {A : Type} : ∀ p₁ p₂ : A × A, p₁ ~ p₂ → p₂ ~ p₁ := +take p₁ p₂ h, or.elim h + (λ e, by rewrite e) + (λ e, begin esimp [eqv], rewrite [-e, swap_swap], right, reflexivity end) + +attribute [trans] +private theorem eqv.trans {A : Type} : ∀ p₁ p₂ p₃ : A × A, p₁ ~ p₂ → p₂ ~ p₃ → p₁ ~ p₃ := +take p₁ p₂ p₃ h₁ h₂, or.elim h₁ + (λ e₁₂, or.elim h₂ + (λ e₂₃, by rewrite [e₁₂, e₂₃]) + (λ es₂₃, begin esimp [eqv], rewrite -es₂₃, right, congruence, assumption end)) + (λ es₁₂, or.elim h₂ + (λ e₂₃, begin esimp [eqv], rewrite es₁₂, right, assumption end) + (λ es₂₃, begin esimp [eqv], rewrite [-es₁₂ at es₂₃, swap_swap at es₂₃], left, assumption end)) + +private theorem is_equivalence (A : Type) : equivalence (@eqv A) := +mk_equivalence (@eqv A) (@eqv.refl A) (@eqv.symm A) (@eqv.trans A) + +attribute [instance] +definition uprod.setoid (A : Type) : setoid (A × A) := +setoid.mk (@eqv A) (is_equivalence A) + +definition uprod (A : Type) : Type := +quot (uprod.setoid A) + +namespace uprod + definition mk {A : Type} (a b : A) : uprod A := + ⟦(a, b)⟧ + + theorem mk_eq_mk {A : Type} (a b : A) : mk a b = mk b a := + quot.sound (or.inr rfl) + + private definition mem_fn {A : Type} (a : A) : A × A → Prop + | (a₁, a₂) := a = a₁ ∨ a = a₂ + + private lemma mem_swap {A : Type} {a : A} : ∀ {p : A × A}, mem_fn a p ↔ mem_fn a (swap p) + | (a₁, a₂) := iff.intro + (λ l : a = a₁ ∨ a = a₂, or.swap l) + (λ r : a = a₂ ∨ a = a₁, or.swap r) + + private lemma mem_coherent {A : Type} : ∀ {p₁ p₂ : A × A} (a : A), p₁ ~ p₂ → mem_fn a p₁ = mem_fn a p₂ + | (a₁, b₁) (a₂, b₂) a h := + or.elim h + (λ e, by rewrite e) + (λ es, begin rewrite -es, apply propext, rewrite (propext mem_swap) end) + + definition mem {A : Type} (a : A) (u : uprod A) : Prop := + quot.lift_on u (λ p, mem_fn a p) (λ p₁ p₂ e, mem_coherent a e) + + infix `∈` := mem + + theorem mem_mk_left {A : Type} (a b : A) : a ∈ mk a b := + or.inl rfl + + theorem mem_mk_right {A : Type} (a b : A) : b ∈ mk a b := + or.inr rfl + + theorem mem_or_mem_of_mem_mk {A : Type} {a b c : A} : c ∈ mk a b → c = a ∨ c = b := + λ h, h + + private definition map_fn {A B : Type} (f : A → B) : A × A → uprod B + | (a₁, a₂) := mk (f a₁) (f a₂) + + private lemma map_coherent {A B : Type} (f : A → B) : ∀ {p₁ p₂ : A × A}, p₁ ~ p₂ → map_fn f p₁ = map_fn f p₂ + | (a₁, b₁) (a₂, b₂) h := + or.elim h + (λ e, by rewrite e) + (λ es, begin rewrite -es, apply quot.sound, right, reflexivity end) + + definition map {A B : Type} (f : A → B) (u : uprod A) : uprod B := + quot.lift_on u (λ p, map_fn f p) (λ p₁ p₂ c, map_coherent f c) + + theorem mem_map_mk_left {A B : Type} (f : A → B) (a₁ a₂ : A) : f a₁ ∈ map f (mk a₁ a₂) := + or.inl rfl + + theorem mem_map_mk_right {A B : Type} (f : A → B) (a₁ a₂ : A) : f a₂ ∈ map f (mk a₁ a₂) := + or.inr rfl + + theorem map_map {A B C : Type} (g : B → C) (f : A → B) (u : uprod A) : map g (map f u) = map (g ∘ f) u := + quot.induction_on u (λ p : A × A, begin cases p, reflexivity end) +end uprod diff --git a/old_library/examples/ex.lean b/old_library/examples/ex.lean new file mode 100644 index 0000000000..01e5d0846f --- /dev/null +++ b/old_library/examples/ex.lean @@ -0,0 +1,245 @@ +-- Theorems/Exercises from "Logical Investigations, with the Nuprl Proof Assistant" +-- by Robert L. Constable and Anne Trostle +-- http://www.nuprl.org/MathLibrary/LogicalInvestigations/ +import logic + +-- 2. The Minimal Implicational Calculus +theorem thm1 {A B : Prop} : A → B → A := +assume Ha Hb, Ha + +theorem thm2 {A B C : Prop} : (A → B) → (A → B → C) → (A → C) := +assume Hab Habc Ha, + Habc Ha (Hab Ha) + +theorem thm3 {A B C : Prop} : (A → B) → (B → C) → (A → C) := +assume Hab Hbc Ha, + Hbc (Hab Ha) + +-- 3. False Propositions and Negation +theorem thm4 {P Q : Prop} : ¬P → P → Q := +assume Hnp Hp, + absurd Hp Hnp + +theorem thm5 {P : Prop} : P → ¬¬P := +assume (Hp : P) (HnP : ¬P), + absurd Hp HnP + +theorem thm6 {P Q : Prop} : (P → Q) → (¬Q → ¬P) := +assume (Hpq : P → Q) (Hnq : ¬Q) (Hp : P), + have Hq : Q, from Hpq Hp, + show false, from absurd Hq Hnq + +theorem thm7 {P Q : Prop} : (P → ¬P) → (P → Q) := +assume Hpnp Hp, + absurd Hp (Hpnp Hp) + +theorem thm8 {P Q : Prop} : ¬(P → Q) → (P → ¬Q) := +assume (Hn : ¬(P → Q)) (Hp : P) (Hq : Q), + -- Rermak we don't even need the hypothesis Hp + have H : P → Q, from assume H', Hq, + absurd H Hn + +-- 4. Conjunction and Disjunction +theorem thm9 {P : Prop} : (P ∨ ¬P) → (¬¬P → P) := +assume (em : P ∨ ¬P) (Hnn : ¬¬P), + or.elim em + (assume Hp, Hp) + (assume Hn, absurd Hn Hnn) + +theorem thm10 {P : Prop} : ¬¬(P ∨ ¬P) := +assume Hnem : ¬(P ∨ ¬P), + have Hnp : ¬P, from + assume Hp : P, + have Hem : P ∨ ¬P, from or.inl Hp, + absurd Hem Hnem, + have Hem : P ∨ ¬P, from or.inr Hnp, + absurd Hem Hnem + +theorem thm11 {P Q : Prop} : ¬P ∨ ¬Q → ¬(P ∧ Q) := +assume (H : ¬P ∨ ¬Q) (Hn : P ∧ Q), + or.elim H + (assume Hnp : ¬P, absurd (and.elim_left Hn) Hnp) + (assume Hnq : ¬Q, absurd (and.elim_right Hn) Hnq) + +theorem thm12 {P Q : Prop} : ¬(P ∨ Q) → ¬P ∧ ¬Q := +assume H : ¬(P ∨ Q), + have Hnp : ¬P, from assume Hp : P, absurd (or.inl Hp) H, + have Hnq : ¬Q, from assume Hq : Q, absurd (or.inr Hq) H, + and.intro Hnp Hnq + +theorem thm13 {P Q : Prop} : ¬P ∧ ¬Q → ¬(P ∨ Q) := +assume (H : ¬P ∧ ¬Q) (Hn : P ∨ Q), + or.elim Hn + (assume Hp : P, absurd Hp (and.elim_left H)) + (assume Hq : Q, absurd Hq (and.elim_right H)) + +theorem thm14 {P Q : Prop} : ¬P ∨ Q → P → Q := +assume (Hor : ¬P ∨ Q) (Hp : P), + or.elim Hor + (assume Hnp : ¬P, absurd Hp Hnp) + (assume Hq : Q, Hq) + +theorem thm15 {P Q : Prop} : (P → Q) → ¬¬(¬P ∨ Q) := +assume (Hpq : P → Q) (Hn : ¬(¬P ∨ Q)), + have H1 : ¬¬P ∧ ¬Q, from thm12 Hn, + have Hnp : ¬P, from mt Hpq (and.elim_right H1), + absurd Hnp (and.elim_left H1) + +theorem thm16 {P Q : Prop} : (P → Q) ∧ ((P ∨ ¬P) ∨ (Q ∨ ¬Q)) → ¬P ∨ Q := +assume H : (P → Q) ∧ ((P ∨ ¬P) ∨ (Q ∨ ¬Q)), + have Hpq : P → Q, from and.elim_left H, + or.elim (and.elim_right H) + (assume Hem1 : P ∨ ¬P, or.elim Hem1 + (assume Hp : P, or.inr (Hpq Hp)) + (assume Hnp : ¬P, or.inl Hnp)) + (assume Hem2 : Q ∨ ¬Q, or.elim Hem2 + (assume Hq : Q, or.inr Hq) + (assume Hnq : ¬Q, or.inl (mt Hpq Hnq))) + +-- 5. First-Order Logic: All and Exists +section +variables {T : Type} {C : Prop} {P : T → Prop} +theorem thm17a : (C → ∀x, P x) → (∀x, C → P x) := +assume H : C → ∀x, P x, + take x : T, assume Hc : C, + H Hc x + +theorem thm17b : (∀x, C → P x) → (C → ∀x, P x) := +assume (H : ∀x, C → P x) (Hc : C), + take x : T, + H x Hc + +theorem thm18a : ((∃x, P x) → C) → (∀x, P x → C) := +assume H : (∃x, P x) → C, + take x, assume Hp : P x, + have Hex : ∃x, P x, from exists.intro x Hp, + H Hex + +theorem thm18b : (∀x, P x → C) → (∃x, P x) → C := +sorry +/- +assume (H1 : ∀x, P x → C) (H2 : ∃x, P x), + obtain (w : T) (Hw : P w), from H2, + H1 w Hw +-/ + +theorem thm19a : (C ∨ ¬C) → (∃x : T, true) → (C → (∃x, P x)) → (∃x, C → P x) := +sorry +/- +assume (Hem : C ∨ ¬C) (Hin : ∃x : T, true) (H1 : C → ∃x, P x), + or.elim Hem + (assume Hc : C, + obtain (w : T) (Hw : P w), from H1 Hc, + have Hr : C → P w, from assume Hc, Hw, + exists.intro w Hr) + (assume Hnc : ¬C, + obtain (w : T) (Hw : true), from Hin, + have Hr : C → P w, from assume Hc, absurd Hc Hnc, + exists.intro w Hr) +-/ + +theorem thm19b : (∃x, C → P x) → C → (∃x, P x) := +sorry +/- +assume (H : ∃x, C → P x) (Hc : C), + obtain (w : T) (Hw : C → P w), from H, + exists.intro w (Hw Hc) +-/ + +theorem thm20a : (C ∨ ¬C) → (∃x : T, true) → ((¬∀x, P x) → ∃x, ¬P x) → ((∀x, P x) → C) → (∃x, P x → C) := +sorry +/- +assume Hem Hin Hnf H, + or.elim Hem + (assume Hc : C, + obtain (w : T) (Hw : true), from Hin, + exists.intro w (assume H : P w, Hc)) + (assume Hnc : ¬C, + have H1 : ¬(∀x, P x), from mt H Hnc, + have H2 : ∃x, ¬P x, from Hnf H1, + obtain (w : T) (Hw : ¬P w), from H2, + exists.intro w (assume H : P w, absurd H Hw)) +-/ + +theorem thm20b : (∃x, P x → C) → (∀ x, P x) → C := +sorry +/- +assume Hex Hall, + obtain (w : T) (Hw : P w → C), from Hex, + Hw (Hall w) +-/ + +theorem thm21a : (∃x : T, true) → ((∃x, P x) ∨ C) → (∃x, P x ∨ C) := +sorry +/- +assume Hin H, + or.elim H + (assume Hex : ∃x, P x, + obtain (w : T) (Hw : P w), from Hex, + exists.intro w (or.inl Hw)) + (assume Hc : C, + obtain (w : T) (Hw : true), from Hin, + exists.intro w (or.inr Hc)) +-/ + +theorem thm21b : (∃x, P x ∨ C) → ((∃x, P x) ∨ C) := +sorry +/- +assume H, + obtain (w : T) (Hw : P w ∨ C), from H, + or.elim Hw + (assume H : P w, or.inl (exists.intro w H)) + (assume Hc : C, or.inr Hc) +-/ + +theorem thm22a : (∀x, P x) ∨ C → ∀x, P x ∨ C := +assume H, take x, + or.elim H + (assume Hl, or.inl (Hl x)) + (assume Hr, or.inr Hr) + +theorem thm22b : (C ∨ ¬C) → (∀x, P x ∨ C) → ((∀x, P x) ∨ C) := +assume Hem H1, + or.elim Hem + (assume Hc : C, or.inr Hc) + (assume Hnc : ¬C, + have Hx : ∀x, P x, from + take x, + have H1 : P x ∨ C, from H1 x, + or_resolve_left H1 Hnc, + or.inl Hx) + +theorem thm23a : (∃x, P x) ∧ C → (∃x, P x ∧ C) := +sorry +/- +assume H, + have Hex : ∃x, P x, from and.elim_left H, + have Hc : C, from and.elim_right H, + obtain (w : T) (Hw : P w), from Hex, + exists.intro w (and.intro Hw Hc) +-/ + +theorem thm23b : (∃x, P x ∧ C) → (∃x, P x) ∧ C := +sorry +/- +assume H, + obtain (w : T) (Hw : P w ∧ C), from H, + have Hex : ∃x, P x, from exists.intro w (and.elim_left Hw), + and.intro Hex (and.elim_right Hw) +-/ + +theorem thm24a : (∀x, P x) ∧ C → (∀x, P x ∧ C) := +assume H, take x, + and.intro (and.elim_left H x) (and.elim_right H) + +theorem thm24b : (∃x : T, true) → (∀x, P x ∧ C) → (∀x, P x) ∧ C := +sorry +/- +assume Hin H, + obtain (w : T) (Hw : true), from Hin, + have Hc : C, from and.elim_right (H w), + have Hx : ∀x, P x, from take x, and.elim_left (H x), + and.intro Hx Hc +-/ + +end -- of section diff --git a/old_library/init/.gdb_history b/old_library/init/.gdb_history new file mode 100644 index 0000000000..e69de29bb2 diff --git a/old_library/init/alternative.lean b/old_library/init/alternative.lean new file mode 100644 index 0000000000..5624e61cb3 --- /dev/null +++ b/old_library/init/alternative.lean @@ -0,0 +1,26 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.logic init.applicative +universe variables u v + +structure [class] alternative (F : Type u → Type v) extends applicative F : Type (max u+1 v) := +(failure : Π {A : Type u}, F A) +(orelse : Π {A : Type u}, F A → F A → F A) + +attribute [inline] +definition failure {F : Type u → Type v} [alternative F] {A : Type u} : F A := +alternative.failure F + +attribute [inline] +definition orelse {F : Type u → Type v} [alternative F] {A : Type u} : F A → F A → F A := +alternative.orelse + +infixr ` <|> `:2 := orelse + +attribute [inline] +definition guard {F : Type → Type v} [alternative F] (P : Prop) [decidable P] : F unit := +if P then pure () else failure diff --git a/old_library/init/applicative.lean b/old_library/init/applicative.lean new file mode 100644 index 0000000000..1412751ceb --- /dev/null +++ b/old_library/init/applicative.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.functor +universe variables u v + +structure [class] applicative (F : Type u → Type v) extends functor F : Type (max u+1 v):= +(pure : Π {A : Type u}, A → F A) +(seq : Π {A B : Type u}, F (A → B) → F A → F B) + +attribute [inline] +definition pure {F : Type u → Type v} [applicative F] {A : Type u} : A → F A := +applicative.pure F + +attribute [inline] +definition seq_app {A B : Type u} {F : Type u → Type v} [applicative F] : F (A → B) → F A → F B := +applicative.seq + +infixr ` <*> `:2 := seq_app diff --git a/old_library/init/bool.lean b/old_library/init/bool.lean new file mode 100644 index 0000000000..ec55b2ffd6 --- /dev/null +++ b/old_library/init/bool.lean @@ -0,0 +1,32 @@ +-- Copyright (c) 2014 Microsoft Corporation. All rights reserved. +-- Released under Apache 2.0 license as described in the file LICENSE. +-- Author: Leonardo de Moura +prelude +import init.datatypes + +namespace bool + attribute [inline] + definition {u} cond {A : Type u} : bool → A → A → A + | tt a b := a + | ff a b := b + + attribute [inline] + definition bor : bool → bool → bool + | tt _ := tt + | ff tt := tt + | ff ff := ff + + attribute [inline] + definition band : bool → bool → bool + | ff _ := ff + | tt ff := ff + | tt tt := tt + + attribute [inline] + definition bnot : bool → bool + | tt := ff + | ff := tt +end bool + +notation a || b := bool.bor a b +notation a && b := bool.band a b diff --git a/old_library/init/char.lean b/old_library/init/char.lean new file mode 100644 index 0000000000..f9654c3c0a --- /dev/null +++ b/old_library/init/char.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.fin + +open nat +definition char_sz : nat := succ 255 + +definition char := fin char_sz + +namespace char +/- We cannot use tactic dec_trivial here because the tactic framework has not been defined yet. -/ +private lemma zero_lt_char_sz : 0 < char_sz := +zero_lt_succ _ + +attribute [pattern] +definition of_nat (n : nat) : char := +if H : n < char_sz then fin.mk n H else fin.mk 0 zero_lt_char_sz + +definition to_nat (c : char) : nat := +fin.val c +end char + +attribute [instance] +definition char_has_decidable_eq : decidable_eq char := +have decidable_eq (fin char_sz), from fin.has_decidable_eq _, +this + +attribute [instance] +definition char_is_inhabited : inhabited char := +⟨'A'⟩ diff --git a/old_library/init/classical.lean b/old_library/init/classical.lean new file mode 100644 index 0000000000..426712d73d --- /dev/null +++ b/old_library/init/classical.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad +-/ +prelude +import init.subtype init.funext +namespace classical +open subtype +universe variables u v +/- the axiom -/ + +-- In the presence of classical logic, we could prove this from a weaker statement: +-- axiom indefinite_description {A : Type u} {P : A->Prop} (H : ∃ x, P x) : {x : A, P x} +axiom strong_indefinite_description {A : Type u} (P : A → Prop) (H : nonempty A) : + { x \ (∃ y : A, P y) → P x} + +theorem exists_true_of_nonempty {A : Type u} (H : nonempty A) : ∃ x : A, true := +nonempty.elim H (take x, ⟨x, trivial⟩) + +noncomputable definition inhabited_of_nonempty {A : Type u} (H : nonempty A) : inhabited A := +⟨elt_of (strong_indefinite_description (λ a, true) H)⟩ + +noncomputable definition inhabited_of_exists {A : Type u} {P : A → Prop} (H : ∃ x, P x) : inhabited A := +inhabited_of_nonempty (exists.elim H (λ w Hw, ⟨w⟩)) + +/- the Hilbert epsilon function -/ + +noncomputable definition epsilon {A : Type u} [H : nonempty A] (P : A → Prop) : A := +elt_of (strong_indefinite_description P H) + +theorem epsilon_spec_aux {A : Type u} (H : nonempty A) (P : A → Prop) (Hex : ∃ y, P y) : + P (@epsilon A H P) := +have aux : (∃ y, P y) → P (elt_of (strong_indefinite_description P H)), from has_property (strong_indefinite_description P H), +aux Hex + +theorem epsilon_spec {A : Type u} {P : A → Prop} (Hex : ∃ y, P y) : + P (@epsilon A (nonempty_of_exists Hex) P) := +epsilon_spec_aux (nonempty_of_exists Hex) P Hex + +theorem epsilon_singleton {A : Type u} (a : A) : @epsilon A ⟨a⟩ (λ x, x = a) = a := +@epsilon_spec A (λ x, x = a) ⟨a, rfl⟩ + +noncomputable definition some {A : Type u} {P : A → Prop} (H : ∃ x, P x) : A := +@epsilon A (nonempty_of_exists H) P + +theorem some_spec {A : Type u} {P : A → Prop} (H : ∃ x, P x) : P (some H) := +epsilon_spec H + +/- the axiom of choice -/ + +theorem axiom_of_choice {A : Type u} {B : A → Type v} {R : Π x, B x → Prop} (H : ∀ x, ∃ y, R x y) : + ∃ (f : Π x, B x), ∀ x, R x (f x) := +have H : ∀ x, R x (some (H x)), from take x, some_spec (H x), +⟨_, H⟩ + +theorem skolem {A : Type u} {B : A → Type v} {P : Π x, B x → Prop} : + (∀ x, ∃ y, P x y) ↔ ∃ (f : Π x, B x) , (∀ x, P x (f x)) := +iff.intro + (assume H : (∀ x, ∃ y, P x y), axiom_of_choice H) + (assume H : (∃ (f : Π x, B x), (∀ x, P x (f x))), + take x, exists.elim H (λ (fw : ∀ x, B x) (Hw : ∀ x, P x (fw x)), + ⟨fw x, Hw x⟩)) +/- +Prove excluded middle using Hilbert's choice +The proof follows Diaconescu proof that shows that the axiom of choice implies the excluded middle. +-/ +section diaconescu +parameter p : Prop + +private definition U (x : Prop) : Prop := x = true ∨ p +private definition V (x : Prop) : Prop := x = false ∨ p + +private noncomputable definition u := epsilon U +private noncomputable definition v := epsilon V + +private lemma u_def : U u := +epsilon_spec ⟨true, or.inl rfl⟩ + +private lemma v_def : V v := +epsilon_spec ⟨false, or.inl rfl⟩ + +private lemma not_uv_or_p : ¬(u = v) ∨ p := +or.elim u_def + (assume Hut : u = true, + or.elim v_def + (assume Hvf : v = false, + have Hne : ¬(u = v), from eq.symm Hvf ▸ eq.symm Hut ▸ true_ne_false, + or.inl Hne) + (assume Hp : p, or.inr Hp)) + (assume Hp : p, or.inr Hp) + +private lemma p_implies_uv : p → u = v := +assume Hp : p, +have Hpred : U = V, from + funext (take x : Prop, + have Hl : (x = true ∨ p) → (x = false ∨ p), from + assume A, or.inr Hp, + have Hr : (x = false ∨ p) → (x = true ∨ p), from + assume A, or.inr Hp, + show (x = true ∨ p) = (x = false ∨ p), from + propext (iff.intro Hl Hr)), +have H' : epsilon U = epsilon V, from Hpred ▸ rfl, +show u = v, from H' + +theorem em : p ∨ ¬p := +have H : ¬(u = v) → ¬p, from mt p_implies_uv, + or.elim not_uv_or_p + (assume Hne : ¬(u = v), or.inr (H Hne)) + (assume Hp : p, or.inl Hp) +end diaconescu + +theorem prop_complete (a : Prop) : a = true ∨ a = false := +or.elim (em a) + (λ t, or.inl (propext (iff.intro (λ h, trivial) (λ h, t)))) + (λ f, or.inr (propext (iff.intro (λ h, absurd h f) (λ h, false.elim h)))) + +definition eq_true_or_eq_false := prop_complete + +section aux +attribute [elab_as_eliminator] +theorem cases_true_false (P : Prop → Prop) (H1 : P true) (H2 : P false) (a : Prop) : P a := +or.elim (prop_complete a) + (assume Ht : a = true, eq.symm Ht ▸ H1) + (assume Hf : a = false, eq.symm Hf ▸ H2) + +theorem cases_on (a : Prop) {P : Prop → Prop} (H1 : P true) (H2 : P false) : P a := +cases_true_false P H1 H2 a + +-- this supercedes by_cases in decidable +definition by_cases {p q : Prop} (Hpq : p → q) (Hnpq : ¬p → q) : q := +or.elim (em p) (assume Hp, Hpq Hp) (assume Hnp, Hnpq Hnp) + +-- this supercedes by_contradiction in decidable +theorem by_contradiction {p : Prop} (H : ¬p → false) : p := +by_cases + (assume H1 : p, H1) + (assume H1 : ¬p, false.rec _ (H H1)) + +theorem eq_false_or_eq_true (a : Prop) : a = false ∨ a = true := +cases_true_false (λ x, x = false ∨ x = true) + (or.inr rfl) + (or.inl rfl) + a + +theorem eq.of_iff {a b : Prop} (H : a ↔ b) : a = b := +iff.elim (assume H1 H2, propext (iff.intro H1 H2)) H + +theorem iff_eq_eq {a b : Prop} : (a ↔ b) = (a = b) := +propext (iff.intro + (assume H, eq.of_iff H) + (assume H, iff.of_eq H)) + +lemma eq_false {a : Prop} : (a = false) = (¬ a) := +have (a ↔ false) = (¬ a), from propext (iff_false a), +eq.subst (@iff_eq_eq a false) this + +lemma eq_true {a : Prop} : (a = true) = a := +have (a ↔ true) = a, from propext (iff_true a), +eq.subst (@iff_eq_eq a true) this +end aux + +/- All propositions are decidable -/ +noncomputable definition decidable_inhabited (a : Prop) : inhabited (decidable a) := +inhabited_of_nonempty + (or.elim (em a) + (assume Ha, ⟨is_true Ha⟩) + (assume Hna, ⟨is_false Hna⟩)) +local attribute decidable_inhabited [instance] + +noncomputable definition prop_decidable (a : Prop) : decidable a := +arbitrary (decidable a) +local attribute prop_decidable [instance] + +noncomputable definition type_decidable_eq (A : Type u) : decidable_eq A := +λ a b, prop_decidable (a = b) + +noncomputable definition type_decidable (A : Type u) : sum A (A → false) := +match (prop_decidable (nonempty A)) with +| (is_true Hp) := sum.inl (inhabited.value (inhabited_of_nonempty Hp)) +| (is_false Hn) := sum.inr (λ a, absurd (nonempty.intro a) Hn) +end + +end classical diff --git a/old_library/init/coe.lean b/old_library/init/coe.lean new file mode 100644 index 0000000000..fed1f98bfd --- /dev/null +++ b/old_library/init/coe.lean @@ -0,0 +1,161 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ + +/- +The elaborator tries to insert coercions automatically. +Only instances of has_coe type class are considered in the process. + +Lean also provides a "lifting" operator: ↑a. +It uses all instances of has_lift type class. +Every has_coe instance is also a has_lift instance. + +We recommend users only use has_coe for coercions that do not produce a lot +of ambiguity. + +All coercions and lifts can be identified with the constant coe. + +We use the has_coe_to_fun type class for encoding coercions from +a type to a function space. + +We use the has_coe_to_sort type class for encoding coercions from +a type to a sort. +-/ +prelude +import init.list init.subtype init.prod +universe variables u v + +structure [class] has_lift (A : Type u) (B : Type v) := +(lift : A → B) + +/- Auxiliary class that contains the transitive closure of has_lift. -/ +structure [class] has_lift_t (A : Type u) (B : Type v) := +(lift : A → B) + +structure [class] has_coe (A : Type u) (B : Type v) := +(coe : A → B) + +/- Auxiliary class that contains the transitive closure of has_coe. -/ +structure [class] has_coe_t (A : Type u) (B : Type v) := +(coe : A → B) + +structure [class] has_coe_to_fun (A : Type u) : Type (max u (v+1)) := +(F : Type v) (coe : A → F) + +structure [class] has_coe_to_sort (A : Type u) : Type (max u (v+1)) := +(S : Type v) (coe : A → S) + +definition lift {A : Type u} {B : Type v} [has_lift A B] : A → B := +@has_lift.lift A B _ + +definition lift_t {A : Type u} {B : Type v} [has_lift_t A B] : A → B := +@has_lift_t.lift A B _ + +definition coe_b {A : Type u} {B : Type v} [has_coe A B] : A → B := +@has_coe.coe A B _ + +definition coe_t {A : Type u} {B : Type v} [has_coe_t A B] : A → B := +@has_coe_t.coe A B _ + +set_option pp.all true +definition coe_fn_b {A : Type u} [has_coe_to_fun.{u v} A] : A → has_coe_to_fun.F.{u v} A := +has_coe_to_fun.coe + +/- User level coercion operators -/ + +definition coe {A : Type u} {B : Type v} [has_lift_t A B] : A → B := +lift_t + +definition coe_fn {A : Type u} [has_coe_to_fun.{u v} A] : A → has_coe_to_fun.F.{u v} A := +has_coe_to_fun.coe + +definition coe_sort {A : Type u} [has_coe_to_sort.{u v} A] : A → has_coe_to_sort.S.{u v} A := +has_coe_to_sort.coe + +/- Notation -/ + +notation `↑`:max a:max := coe a + +notation `⇑`:max a:max := coe_fn a + +notation `↥`:max a:max := coe_sort a + +/- Transitive closure for has_lift, has_coe, has_coe_to_fun -/ + +attribute [instance] +definition {u₁ u₂ u₃} lift_trans {A : Type u₁} {B : Type u₂} {C : Type u₃} [has_lift A B] [has_lift_t B C] : has_lift_t A C := +⟨λ a, lift_t (lift a : B)⟩ + +attribute [instance] +definition lift_base {A : Type u} {B : Type v} [has_lift A B] : has_lift_t A B := +⟨lift⟩ + +attribute [instance] +definition {u₁ u₂ u₃} coe_trans {A : Type u₁} {B : Type u₂} {C : Type u₃} [has_coe A B] [has_coe_t B C] : has_coe_t A C := +⟨λ a, coe_t (coe_b a : B)⟩ + +attribute [instance] +definition coe_base {A : Type u} {B : Type v} [has_coe A B] : has_coe_t A B := +⟨coe_b⟩ + +attribute [instance] +definition {u₁ u₂ u₃} coe_fn_trans {A : Type u₁} {B : Type u₂} [has_lift_t A B] [has_coe_to_fun.{u₂ u₃} B] : has_coe_to_fun.{u₁ u₃} A := +⟨has_coe_to_fun.F B, λ a, coe_fn (coe a)⟩ + +attribute [instance] +definition {u₁ u₂ u₃} coe_sort_trans {A : Type u₁} {B : Type u₂} [has_lift_t A B] [has_coe_to_sort.{u₂ u₃} B] : has_coe_to_sort.{u₁ u₃} A := +⟨has_coe_to_sort.S B, λ a, coe_sort (coe a)⟩ + +/- Every coercion is also a lift -/ + +attribute [instance] +definition coe_to_lift {A : Type u} {B : Type v} [has_coe_t A B] : has_lift_t A B := +⟨coe_t⟩ + +/- Basic coercions -/ + +attribute [instance] +definition coe_bool_to_Prop : has_coe bool Prop := +⟨λ b, b = tt⟩ + +attribute [instance] +definition coe_decidable_eq (b : bool) : decidable (coe b) := +show decidable (b = tt), from bool.has_decidable_eq b tt + +attribute [instance] +definition coe_subtype {A : Type u} {P : A → Prop} : has_coe {a \ P a} A := +⟨λ s, subtype.elt_of s⟩ + +/- Basic lifts -/ + +/- Remark: we can't use [has_lift_t A₂ A₁] since it will produce non-termination whenever a type class resolution + problem does not have a solution. -/ +attribute [instance] +definition {ua₁ ua₂ ub₁ ub₂} lift_fn {A₁ : Type ua₁} {A₂ : Type ua₂} {B₁ : Type ub₁} {B₂ : Type ub₂} [has_lift A₂ A₁] [has_lift_t B₁ B₂] : has_lift (A₁ → B₁) (A₂ → B₂) := +⟨λ f a, ↑(f ↑a)⟩ + +attribute [instance] +definition {ua ub₁ ub₂} lift_fn_range {A : Type ua} {B₁ : Type ub₁} {B₂ : Type ub₂} [has_lift_t B₁ B₂] : has_lift (A → B₁) (A → B₂) := +⟨λ f a, ↑(f a)⟩ + +attribute [instance] +definition {ua₁ ua₂ ub} lift_fn_dom {A₁ : Type ua₁} {A₂ : Type ua₂} {B : Type ub} [has_lift A₂ A₁] : has_lift (A₁ → B) (A₂ → B) := +⟨λ f a, f ↑a⟩ + +attribute [instance] +definition {ua₁ ua₂ ub₁ ub₂} lift_pair {A₁ : Type ua₁} {A₂ : Type ub₂} {B₁ : Type ub₁} {B₂ : Type ub₂} [has_lift_t A₁ A₂] [has_lift_t B₁ B₂] : has_lift (A₁ × B₁) (A₂ × B₂) := +⟨λ p, prod.cases_on p (λ a b, (↑a, ↑b))⟩ + +attribute [instance] +definition {ua₁ ua₂ ub} lift_pair₁ {A₁ : Type ua₁} {A₂ : Type ua₂} {B : Type ub} [has_lift_t A₁ A₂] : has_lift (A₁ × B) (A₂ × B) := +⟨λ p, prod.cases_on p (λ a b, (↑a, b))⟩ + +attribute [instance] +definition {ua ub₁ ub₂} lift_pair₂ {A : Type ua} {B₁ : Type ub₁} {B₂ : Type ub₂} [has_lift_t B₁ B₂] : has_lift (A × B₁) (A × B₂) := +⟨λ p, prod.cases_on p (λ a b, (a, ↑b))⟩ + +attribute [instance] +definition lift_list {A : Type u} {B : Type v} [has_lift_t A B] : has_lift (list A) (list B) := +⟨λ l, list.map (@coe A B _) l⟩ diff --git a/old_library/init/combinator.lean b/old_library/init/combinator.lean new file mode 100644 index 0000000000..cfcd1535bb --- /dev/null +++ b/old_library/init/combinator.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +/- Combinator calculus -/ +namespace combinator +universe variables u₁ u₂ u₃ +definition I {A : Type u₁} (a : A) := a +definition K {A : Type u₁} {B : Type u₂} (a : A) (b : B) := a +definition S {A : Type u₁} {B : Type u₂} {C : Type u₃} (x : A → B → C) (y : A → B) (z : A) := x z (y z) +end combinator diff --git a/old_library/init/datatypes.lean b/old_library/init/datatypes.lean new file mode 100644 index 0000000000..23ef9cbdae --- /dev/null +++ b/old_library/init/datatypes.lean @@ -0,0 +1,497 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Basic datatypes +-/ +prelude + +notation `Prop` := Type 0 +notation `Type₂` := Type 2 +notation `Type₃` := Type 3 + +universe variables u v + +inductive poly_unit : Type u +| star : poly_unit + +inductive unit : Type +| star : unit + +inductive true : Prop +| intro : true + +inductive false : Prop + +inductive empty : Type + +inductive eq {A : Type u} (a : A) : A → Prop +| refl : eq a + +inductive heq {A : Type u} (a : A) : Π {B : Type u}, B → Prop +| refl : heq a + +structure prod (A : Type u) (B : Type v) := +(fst : A) (snd : B) + +inductive and (a b : Prop) : Prop +| intro : a → b → and + +definition and.elim_left {a b : Prop} (H : and a b) : a := +and.rec (λ Ha Hb, Ha) H + +definition and.left := @and.elim_left + +definition and.elim_right {a b : Prop} (H : and a b) : b := +and.rec (λ Ha Hb, Hb) H + +definition and.right := @and.elim_right + +inductive sum (A : Type u) (B : Type v) +| inl {} : A → sum +| inr {} : B → sum + +attribute [reducible] +definition sum.intro_left {A : Type u} (B : Type v) (a : A) : sum A B := +sum.inl a + +attribute [reducible] +definition sum.intro_right (A : Type u) {B : Type v} (b : B) : sum A B := +sum.inr b + +inductive or (a b : Prop) : Prop +| inl {} : a → or +| inr {} : b → or + +definition or.intro_left {a : Prop} (b : Prop) (Ha : a) : or a b := +or.inl Ha + +definition or.intro_right (a : Prop) {b : Prop} (Hb : b) : or a b := +or.inr Hb + +structure sigma {A : Type u} (B : A → Type v) := +mk :: (fst : A) (snd : B fst) + +-- pos_num and num are two auxiliary datatypes used when parsing numerals such as 13, 0, 26. +-- The parser will generate the terms (pos (bit1 (bit1 (bit0 one)))), zero, and (pos (bit0 (bit1 (bit1 one)))). +-- This representation can be coerced in whatever we want (e.g., naturals, integers, reals, etc). +inductive pos_num : Type +| one : pos_num +| bit1 : pos_num → pos_num +| bit0 : pos_num → pos_num + +namespace pos_num + definition succ (a : pos_num) : pos_num := + pos_num.rec_on a (bit0 one) (λ n r, bit0 r) (λ n r, bit1 n) +end pos_num + +inductive num : Type +| zero : num +| pos : pos_num → num + +namespace num + open pos_num + definition succ (a : num) : num := + num.rec_on a (pos one) (λ p, pos (succ p)) +end num + +inductive bool : Type +| ff : bool +| tt : bool + +inductive option (A : Type u) +| none {} : option +| some : A → option + +export option (none some) +export bool (ff tt) + +inductive list (T : Type u) +| nil {} : list +| cons : T → list → list + +inductive nat +| zero : nat +| succ : nat → nat + +/- Declare builtin and reserved notation -/ + +structure [class] has_zero (A : Type u) := (zero : A) +structure [class] has_one (A : Type u) := (one : A) +structure [class] has_add (A : Type u) := (add : A → A → A) +structure [class] has_mul (A : Type u) := (mul : A → A → A) +structure [class] has_inv (A : Type u) := (inv : A → A) +structure [class] has_neg (A : Type u) := (neg : A → A) +structure [class] has_sub (A : Type u) := (sub : A → A → A) +structure [class] has_div (A : Type u) := (div : A → A → A) +structure [class] has_dvd (A : Type u) := (dvd : A → A → Prop) +structure [class] has_mod (A : Type u) := (mod : A → A → A) +structure [class] has_le (A : Type u) := (le : A → A → Prop) +structure [class] has_lt (A : Type u) := (lt : A → A → Prop) +structure [class] has_append (A : Type u) := (append : A → A → A) +structure [class] has_andthen(A : Type u) := (andthen : A → A → A) + +definition zero {A : Type u} [has_zero A] : A := has_zero.zero A +definition one {A : Type u} [has_one A] : A := has_one.one A +definition add {A : Type u} [has_add A] : A → A → A := has_add.add +definition mul {A : Type u} [has_mul A] : A → A → A := has_mul.mul +definition sub {A : Type u} [has_sub A] : A → A → A := has_sub.sub +definition div {A : Type u} [has_div A] : A → A → A := has_div.div +definition dvd {A : Type u} [has_dvd A] : A → A → Prop := has_dvd.dvd +definition mod {A : Type u} [has_mod A] : A → A → A := has_mod.mod +definition neg {A : Type u} [has_neg A] : A → A := has_neg.neg +definition inv {A : Type u} [has_inv A] : A → A := has_inv.inv +definition le {A : Type u} [has_le A] : A → A → Prop := has_le.le +definition lt {A : Type u} [has_lt A] : A → A → Prop := has_lt.lt +definition append {A : Type u} [has_append A] : A → A → A := has_append.append +definition andthen {A : Type u} [has_andthen A] : A → A → A := has_andthen.andthen + +attribute [reducible] +definition ge {A : Type u} [s : has_le A] (a b : A) : Prop := le b a +attribute [reducible] +definition gt {A : Type u} [s : has_lt A] (a b : A) : Prop := lt b a +definition bit0 {A : Type u} [s : has_add A] (a : A) : A := add a a +definition bit1 {A : Type u} [s₁ : has_one A] [s₂ : has_add A] (a : A) : A := add (bit0 a) one + +attribute [pattern] zero one bit0 bit1 add + +attribute [instance] +definition num_has_zero : has_zero num := +⟨num.zero⟩ + +attribute [instance] +definition num_has_one : has_one num := +⟨num.pos pos_num.one⟩ + +attribute [instance] +definition pos_num_has_one : has_one pos_num := +⟨pos_num.one⟩ + +namespace pos_num + definition is_one (a : pos_num) : bool := + pos_num.rec_on a tt (λ n r, ff) (λ n r, ff) + + definition pred (a : pos_num) : pos_num := + pos_num.rec_on a one (λ n r, bit0 n) (λ n r, bool.rec_on (is_one n) (bit1 r) one) + + definition size (a : pos_num) : pos_num := + pos_num.rec_on a one (λ n r, succ r) (λ n r, succ r) + + definition add (a b : pos_num) : pos_num := + pos_num.rec_on a + succ + (λ n f b, pos_num.rec_on b + (succ (bit1 n)) + (λ m r, succ (bit1 (f m))) + (λ m r, bit1 (f m))) + (λ n f b, pos_num.rec_on b + (bit1 n) + (λ m r, bit1 (f m)) + (λ m r, bit0 (f m))) + b +end pos_num + +attribute [instance] +definition pos_num_has_add : has_add pos_num := +⟨pos_num.add⟩ + +namespace num + open pos_num + + definition add (a b : num) : num := + num.rec_on a b (λ pa, num.rec_on b (pos pa) (λ pb, pos (pos_num.add pa pb))) +end num + +attribute [instance] +definition num_has_add : has_add num := +⟨num.add⟩ + +definition std.priority.default : num := 1000 +definition std.priority.max : num := 4294967295 + +namespace nat + protected definition prio := num.add std.priority.default 100 + + protected definition add (a b : nat) : nat := + nat.rec a (λ b₁ r, nat.succ r) b + + definition of_pos_num (p : pos_num) : nat := + pos_num.rec (succ zero) (λ n r, nat.add (nat.add r r) (succ zero)) (λ n r, nat.add r r) p + + definition of_num (n : num) : nat := + num.rec zero (λ p, of_pos_num p) n +end nat + +attribute pos_num_has_add pos_num_has_one num_has_zero num_has_one num_has_add + [instance, priority nat.prio] + +attribute [instance, priority nat.prio] +definition nat_has_zero : has_zero nat := +⟨nat.zero⟩ + +attribute [instance, priority nat.prio] +definition nat_has_one : has_one nat := +⟨nat.succ (nat.zero)⟩ + +attribute [instance, priority nat.prio] +definition nat_has_add : has_add nat := +⟨nat.add⟩ + +/- + Global declarations of right binding strength + + If a module reassigns these, it will be incompatible with other modules that adhere to these + conventions. + + When hovering over a symbol, use "C-c C-k" to see how to input it. +-/ +definition std.prec.max : num := 1024 -- the strength of application, identifiers, (, [, etc. +definition std.prec.arrow : num := 25 + +/- +The next definition is "max + 10". It can be used e.g. for postfix operations that should +be stronger than application. +-/ + +definition std.prec.max_plus := +num.succ (num.succ (num.succ (num.succ (num.succ (num.succ (num.succ (num.succ (num.succ + (num.succ std.prec.max))))))))) + +/- Logical operations and relations -/ + +reserve prefix `¬`:40 +reserve prefix `~`:40 +reserve infixr ` ∧ `:35 +reserve infixr ` /\ `:35 +reserve infixr ` \/ `:30 +reserve infixr ` ∨ `:30 +reserve infix ` <-> `:20 +reserve infix ` ↔ `:20 +reserve infix ` = `:50 +reserve infix ` ≠ `:50 +reserve infix ` ≈ `:50 +reserve infix ` ~ `:50 +reserve infix ` ≡ `:50 + +reserve infixl ` ⬝ `:75 +reserve infixr ` ▸ `:75 +reserve infixr ` ▹ `:75 + +/- types and type constructors -/ + +reserve infixr ` ⊕ `:30 +reserve infixr ` × `:35 + +/- arithmetic operations -/ + +reserve infixl ` + `:65 +reserve infixl ` - `:65 +reserve infixl ` * `:70 +reserve infixl ` / `:70 +reserve infixl ` % `:70 +reserve prefix `-`:100 +reserve infix ` ^ `:80 + +reserve infixr ` ∘ `:90 -- input with \comp +reserve postfix `⁻¹`:std.prec.max_plus -- input with \sy or \-1 or \inv + +reserve infix ` <= `:50 +reserve infix ` ≤ `:50 +reserve infix ` < `:50 +reserve infix ` >= `:50 +reserve infix ` ≥ `:50 +reserve infix ` > `:50 + +/- boolean operations -/ + +reserve infixl ` && `:70 +reserve infixl ` || `:65 + +/- set operations -/ + +reserve infix ` ∈ `:50 +reserve infix ` ∉ `:50 +reserve infixl ` ∩ `:70 +reserve infixl ` ∪ `:65 +reserve infix ` ⊆ `:50 +reserve infix ` ⊇ `:50 +reserve infix ` ' `:75 -- for the image of a set under a function +reserve infix ` '- `:75 -- for the preimage of a set under a function + +/- other symbols -/ + +reserve infix ` ∣ `:50 +reserve infixl ` ++ `:65 +reserve infixr ` :: `:67 +reserve infixl `; `:1 + +infix + := add +infix * := mul +infix - := sub +infix / := div +infix ∣ := dvd +infix % := mod +prefix - := neg +postfix ⁻¹ := inv +infix <= := le +infix >= := ge +infix ≤ := le +infix ≥ := ge +infix < := lt +infix > := gt +infix ++ := append +infix ; := andthen + +/- eq basic support -/ +notation a = b := eq a b + +attribute [pattern] +definition rfl {A : Type u} {a : A} : a = a := eq.refl a + +namespace eq + variables {A : Type u} + variables {a b c a': A} + + attribute [elab_as_eliminator] + theorem subst {P : A → Prop} (H₁ : a = b) (H₂ : P a) : P b := + eq.rec H₂ H₁ + + theorem trans (H₁ : a = b) (H₂ : b = c) : a = c := + subst H₂ H₁ + + theorem symm : a = b → b = a := + λ h, eq.rec (refl a) h +end eq + +notation H1 ▸ H2 := eq.subst H1 H2 + +attribute eq.subst [subst] +attribute eq.refl [refl] +attribute eq.trans [trans] +attribute eq.symm [symm] + +/- sizeof -/ + +structure [class] has_sizeof (A : Type u) := +(sizeof : A → nat) + +definition sizeof {A : Type u} [s : has_sizeof A] : A → nat := +has_sizeof.sizeof + +/- +Declare sizeof instances and lemmas for types declared before has_sizeof. +From now on, the inductive compiler will automatically generate sizeof instances and lemmas. +-/ + +/- Every type `A` has a default has_sizeof instance that just returns 0 for every element of `A` -/ +attribute [instance] +definition default_has_sizeof (A : Type u) : has_sizeof A := +⟨λ a, nat.zero⟩ + +attribute [simp, defeq, simp.sizeof] +definition default_has_sizeof_eq (A : Type u) (a : A) : @sizeof A (default_has_sizeof A) a = 0 := +rfl + +attribute [instance] +definition nat_has_sizeof : has_sizeof nat := +⟨λ a, a⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_nat_eq (a : nat) : sizeof a = a := +rfl + +attribute [instance] +definition prod_has_sizeof (A : Type u) (B : Type v) [has_sizeof A] [has_sizeof B] : has_sizeof (prod A B) := +⟨λ p, prod.cases_on p (λ a b, 1 + sizeof a + sizeof b)⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_prod_eq {A : Type u} {B : Type v} [has_sizeof A] [has_sizeof B] (a : A) (b : B) : sizeof (prod.mk a b) = 1 + sizeof a + sizeof b := +rfl + +attribute [instance] +definition sum_has_sizeof (A : Type u) (B : Type v) [has_sizeof A] [has_sizeof B] : has_sizeof (sum A B) := +⟨λ s, sum.cases_on s (λ a, 1 + sizeof a) (λ b, 1 + sizeof b)⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_sum_eq_left {A : Type u} {B : Type v} [has_sizeof A] [has_sizeof B] (a : A) : sizeof (@sum.inl A B a) = 1 + sizeof a := +rfl + +attribute [simp, defeq, simp.sizeof] +definition sizeof_sum_eq_right {A : Type u} {B : Type v} [has_sizeof A] [has_sizeof B] (b : B) : sizeof (@sum.inr A B b) = 1 + sizeof b := +rfl + +attribute [instance] +definition sigma_has_sizeof (A : Type u) (B : A → Type v) [has_sizeof A] [∀ a, has_sizeof (B a)] : has_sizeof (sigma B) := +⟨λ p, sigma.cases_on p (λ a b, 1 + sizeof a + sizeof b)⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_sigma_eq {A : Type u} {B : A → Type v} [has_sizeof A] [∀ a, has_sizeof (B a)] (a : A) (b : B a) : sizeof (@sigma.mk A B a b) = 1 + sizeof a + sizeof b := +rfl + +attribute [instance] +definition unit_has_sizeof : has_sizeof unit := +⟨λ u, 1⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_unit_eq (u : unit) : sizeof u = 1 := +rfl + +attribute [instance] +definition poly_unit_has_sizeof : has_sizeof poly_unit := +⟨λ u, 1⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_poly_unit_eq (u : poly_unit) : sizeof u = 1 := +rfl + +attribute [instance] +definition bool_has_sizeof : has_sizeof bool := +⟨λ u, 1⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_bool_eq (b : bool) : sizeof b = 1 := +rfl + +attribute [instance] +definition pos_num_has_sizeof : has_sizeof pos_num := +⟨λ p, nat.of_pos_num p⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_pos_num_eq (p : pos_num) : sizeof p = nat.of_pos_num p := +rfl + +attribute [instance] +definition num_has_sizeof : has_sizeof num := +⟨λ p, nat.of_num p⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_num_eq (n : num) : sizeof n = nat.of_num n := +rfl + +attribute [instance] +definition option_has_sizeof (A : Type u) [has_sizeof A] : has_sizeof (option A) := +⟨λ o, option.cases_on o 1 (λ a, 1 + sizeof a)⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_option_none_eq (A : Type u) [has_sizeof A] : sizeof (@none A) = 1 := +rfl + +attribute [simp, defeq, simp.sizeof] +definition sizeof_option_some_eq {A : Type u} [has_sizeof A] (a : A) : sizeof (some a) = 1 + sizeof a := +rfl + +attribute [instance] +definition list_has_sizeof (A : Type u) [has_sizeof A] : has_sizeof (list A) := +⟨λ l, list.rec_on l 1 (λ a t ih, 1 + sizeof a + ih)⟩ + +attribute [simp, defeq, simp.sizeof] +definition sizeof_list_nil_eq (A : Type u) [has_sizeof A] : sizeof (@list.nil A) = 1 := +rfl + +attribute [simp, defeq, simp.sizeof] +definition sizeof_list_cons_eq {A : Type u} [has_sizeof A] (a : A) (l : list A) : sizeof (list.cons a l) = 1 + sizeof a + sizeof l := +rfl + +attribute [simp.sizeof] +lemma nat_add_zero (n : nat) : n + 0 = n := rfl diff --git a/old_library/init/default.lean b/old_library/init/default.lean new file mode 100644 index 0000000000..df9b1fc5f9 --- /dev/null +++ b/old_library/init/default.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.datatypes init.logic +import init.relation init.nat init.prod init.sum init.combinator +import init.bool init.unit init.num init.sigma init.setoid init.quot +import init.funext init.function init.subtype init.classical +import init.monad init.option init.state init.fin init.list init.char init.string init.to_string +import init.monad_combinators +import init.timeit init.trace init.unsigned init.ordering init.list_classes init.coe +import init.wf init.nat_div init.meta init.instances +import init.wf_k init.sigma_lex +import init.simplifier init.id_locked diff --git a/old_library/init/fin.lean b/old_library/init/fin.lean new file mode 100644 index 0000000000..36a14fff59 --- /dev/null +++ b/old_library/init/fin.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.nat +open nat +structure fin (n : nat) := (val : nat) (is_lt : val < n) + +namespace fin + +variable {n : nat} + +lemma eq_of_veq : ∀ {i j : fin n}, (val i) = (val j) → i = j +| ⟨iv, ilt₁⟩ ⟨.iv, ilt₂⟩ rfl := rfl + +lemma veq_of_eq : ∀ {i j : fin n}, i = j → (val i) = (val j) +| ⟨iv, ilt⟩ .⟨iv, ilt⟩ rfl := rfl + +end fin + +open fin + +attribute [instance] +protected definition fin.has_decidable_eq (n : nat) : ∀ (i j : fin n), decidable (i = j) +| ⟨ival, ilt⟩ ⟨jval, jlt⟩ := + match nat.has_decidable_eq ival jval with + | is_true h₁ := is_true (eq_of_veq h₁) + | is_false h₁ := is_false (λ h₂, absurd (veq_of_eq h₂) h₁) + end diff --git a/old_library/init/function.lean b/old_library/init/function.lean new file mode 100644 index 0000000000..5cac2399c3 --- /dev/null +++ b/old_library/init/function.lean @@ -0,0 +1,164 @@ +/- +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, Haitao Zhang + +General operations on functions. +-/ +prelude +import init.prod init.funext init.logic +notation f ` $ `:1 a:1 := f a +universe variables u_a u_b u_c u_d u_e +variables {A : Type u_a} {B : Type u_b} {C : Type u_c} {D : Type u_d} {E : Type u_a} + +attribute [inline, reducible] +definition function.comp (f : B → C) (g : A → B) : A → C := +λ x, f (g x) + +attribute [inline, reducible] +definition function.dcomp {B : A → Type u_b} {C : Π {x : A}, B x → Type u_c} + (f : Π {x : A} (y : B x), C y) (g : Π x, B x) : Π x, C (g x) := +λ x, f (g x) + +infixr ` ∘ ` := function.comp +infixr ` ∘' `:80 := function.dcomp + +namespace function + +attribute [reducible] +definition comp_right (f : B → B → B) (g : A → B) : B → A → B := +λ b a, f b (g a) + +attribute [reducible] +definition comp_left (f : B → B → B) (g : A → B) : A → B → B := +λ a b, f (g a) b + +attribute [reducible] +definition on_fun (f : B → B → C) (g : A → B) : A → A → C := +λ x y, f (g x) (g y) + +attribute [reducible] +definition combine (f : A → B → C) (op : C → D → E) (g : A → B → D) + : A → B → E := +λ x y, op (f x y) (g x y) + +attribute [reducible] +definition const (B : Type u_b) (a : A) : B → A := +λ x, a + +attribute [reducible] +definition swap {C : A → B → Type u_c} (f : Π x y, C x y) : Π y x, C x y := +λ y x, f x y + +attribute [reducible] +definition app {B : A → Type u_b} (f : Π x, B x) (x : A) : B x := +f x + +attribute [reducible] +definition curry : (A × B → C) → A → B → C := +λ f a b, f (a, b) + +attribute [reducible] +definition uncurry : (A → B → C) → (A × B → C) := +λ f p, match p with (a, b) := f a b end + +theorem curry_uncurry (f : A → B → C) : curry (uncurry f) = f := +rfl + +theorem uncurry_curry (f : A × B → C) : uncurry (curry f) = f := +funext (λ p, match p with (a, b) := rfl end) + +infixl ` on `:1 := on_fun +notation f ` -[` op `]- ` g := combine f op g + +lemma left_id (f : A → B) : id ∘ f = f := rfl + +lemma right_id (f : A → B) : f ∘ id = f := rfl + +theorem comp.assoc (f : C → D) (g : B → C) (h : A → B) : (f ∘ g) ∘ h = f ∘ (g ∘ h) := rfl + +theorem comp.left_id (f : A → B) : id ∘ f = f := rfl + +theorem comp.right_id (f : A → B) : f ∘ id = f := rfl + +theorem comp_const_right (f : B → C) (b : B) : f ∘ (const A b) = const A (f b) := rfl + +attribute [reducible] +definition injective (f : A → B) : Prop := ∀ ⦃a₁ a₂⦄, f a₁ = f a₂ → a₁ = a₂ + +theorem injective_comp {g : B → C} {f : A → B} (Hg : injective g) (Hf : injective f) : + injective (g ∘ f) := +take a₁ a₂, assume Heq, Hf (Hg Heq) + +attribute [reducible] +definition surjective (f : A → B) : Prop := ∀ b, ∃ a, f a = b + +theorem surjective_comp {g : B → C} {f : A → B} (Hg : surjective g) (Hf : surjective f) : + surjective (g ∘ f) := +take (c : C), exists.elim (Hg c) (λ b Hb, exists.elim (Hf b) (λ a Ha, + exists.intro a (show g (f a) = c, from (eq.trans (congr_arg g Ha) Hb)))) + +definition bijective (f : A → B) := injective f ∧ surjective f + +theorem bijective_comp {g : B → C} {f : A → B} (Hg : bijective g) (Hf : bijective f) : + bijective (g ∘ f) := +and.elim Hg (λ Hginj Hgsurj, and.elim Hf (λ Hfinj Hfsurj, + ⟨injective_comp Hginj Hfinj, surjective_comp Hgsurj Hfsurj⟩)) + +-- g is a left inverse to f +definition left_inverse (g : B → A) (f : A → B) : Prop := ∀ x, g (f x) = x + +definition id_of_left_inverse {g : B → A} {f : A → B} : left_inverse g f → g ∘ f = id := +assume h, funext h + +definition has_left_inverse (f : A → B) : Prop := ∃ finv : B → A, left_inverse finv f + +-- g is a right inverse to f +definition right_inverse (g : B → A) (f : A → B) : Prop := left_inverse f g + +definition id_of_right_inverse {g : B → A} {f : A → B} : right_inverse g f → f ∘ g = id := +assume h, funext h + +definition has_right_inverse (f : A → B) : Prop := ∃ finv : B → A, right_inverse finv f + +theorem injective_of_left_inverse {g : B → A} {f : A → B} : left_inverse g f → injective f := +assume h, take a b, assume faeqfb, +have h₁ : a = g (f a), from eq.symm (h a), +have h₂ : g (f b) = b, from h b, +have h₃ : g (f a) = g (f b), from congr_arg g faeqfb, +eq.trans h₁ (eq.trans h₃ h₂) + +theorem injective_of_has_left_inverse {f : A → B} : has_left_inverse f → injective f := +assume h, exists.elim h (λ finv inv, injective_of_left_inverse inv) + +theorem right_inverse_of_injective_of_left_inverse {f : A → B} {g : B → A} + (injf : injective f) (lfg : left_inverse f g) : + right_inverse f g := +take x, +have H : f (g (f x)) = f x, from lfg (f x), +injf H + +theorem surjective_of_has_right_inverse {f : A → B} : has_right_inverse f → surjective f := +assume h, take b, +exists.elim h (λ finv inv, +have h : f (finv b) = b, from calc + f (finv b) = f (finv b) : rfl + ... = b : inv b, +⟨finv b, h⟩) + +theorem left_inverse_of_surjective_of_right_inverse {f : A → B} {g : B → A} + (surjf : surjective f) (rfg : right_inverse f g) : + left_inverse f g := +take y, exists.elim (surjf y) (λ x Hx, +calc + f (g y) = f (g (f x)) : Hx ▸ rfl + ... = f x : eq.symm (rfg x) ▸ rfl + ... = y : Hx) + +theorem injective_id : injective (@id A) := take a₁ a₂ H, H + +theorem surjective_id : surjective (@id A) := take a, ⟨a, rfl⟩ + +theorem bijective_id : bijective (@id A) := ⟨injective_id, surjective_id⟩ + +end function diff --git a/old_library/init/functor.lean b/old_library/init/functor.lean new file mode 100644 index 0000000000..cb845e9f9b --- /dev/null +++ b/old_library/init/functor.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) Luke Nelson and Jared Roesch. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Luke Nelson and Jared Roesch +-/ +prelude +universe variables u v + +structure [class] functor (F : Type u → Type v) : Type (max u+1 v) := +(map : Π {A B : Type u}, (A → B) → F A → F B) + +attribute [inline] +definition fmap {F : Type u → Type v} [functor F] {A B : Type u} : (A → B) → F A → F B := +functor.map + +infixr ` <$> `:100 := fmap diff --git a/old_library/init/funext.lean b/old_library/init/funext.lean new file mode 100644 index 0000000000..b5e7563d9f --- /dev/null +++ b/old_library/init/funext.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Extensional equality for functions, and a proof of function extensionality from quotients. +-/ +prelude +import init.quot init.logic + +namespace function + universe variables u v + variables {A : Type u} {B : A → Type v} + + protected definition equiv (f₁ f₂ : Π x : A, B x) : Prop := ∀ x, f₁ x = f₂ x + + local infix `~` := function.equiv + + protected theorem equiv.refl (f : Π x : A, B x) : f ~ f := take x, rfl + + protected theorem equiv.symm {f₁ f₂ : Π x: A, B x} : f₁ ~ f₂ → f₂ ~ f₁ := + λ H x, eq.symm (H x) + + protected theorem equiv.trans {f₁ f₂ f₃ : Π x: A, B x} : f₁ ~ f₂ → f₂ ~ f₃ → f₁ ~ f₃ := + λ H₁ H₂ x, eq.trans (H₁ x) (H₂ x) + + protected theorem equiv.is_equivalence (A : Type u) (B : A → Type v) : equivalence (@function.equiv A B) := + mk_equivalence (@function.equiv A B) (@equiv.refl A B) (@equiv.symm A B) (@equiv.trans A B) +end function + +section + open quot + universe variables u v + variables {A : Type u} {B : A → Type v} + + attribute [instance] + private definition fun_setoid (A : Type u) (B : A → Type v) : setoid (Π x : A, B x) := + setoid.mk (@function.equiv A B) (function.equiv.is_equivalence A B) + + private definition extfun (A : Type u) (B : A → Type v) : Type (imax u v) := + quot (fun_setoid A B) + + private definition fun_to_extfun (f : Π x : A, B x) : extfun A B := + ⟦f⟧ + private definition extfun_app (f : extfun A B) : Π x : A, B x := + take x, + quot.lift_on f + (λ f : Π x : A, B x, f x) + (λ f₁ f₂ H, H x) + + theorem funext {f₁ f₂ : Π x : A, B x} : (∀ x, f₁ x = f₂ x) → f₁ = f₂ := + assume H, calc + f₁ = extfun_app ⟦f₁⟧ : rfl + ... = extfun_app ⟦f₂⟧ : @sound _ _ f₁ f₂ H ▸ rfl + ... = f₂ : rfl +end + +attribute funext [intro!] + +local infix `~` := function.equiv + +attribute [instance] +definition {u v} subsingleton_pi {A : Type u} {B : A → Type v} (H : ∀ a, subsingleton (B a)) : + subsingleton (Π a, B a) := +⟨λ f₁ f₂, funext (λ a, subsingleton.elim (f₁ a) (f₂ a))⟩ diff --git a/old_library/init/id_locked.lean b/old_library/init/id_locked.lean new file mode 100644 index 0000000000..8bdb06fe91 --- /dev/null +++ b/old_library/init/id_locked.lean @@ -0,0 +1,23 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic init.meta.constructor_tactic +open tactic +/- + Define id_locked using meta-programming because we don't have + syntax for setting reducibility_hints. + + See module init.meta.declaration. +-/ +run_command do + l ← return $ level.param `l, + Ty ← return $ expr.sort l, + type ← to_expr `(Π {A : %%Ty}, A → A), + val ← to_expr `(λ {A : %%Ty} (a : A), a), + add_decl (declaration.defn `id_locked [`l] type val reducibility_hints.opaque tt) + +lemma {u} id_locked_eq {A : Type u} (a : A) : id_locked a = a := +rfl diff --git a/old_library/init/init.md b/old_library/init/init.md new file mode 100644 index 0000000000..d6be62f0bf --- /dev/null +++ b/old_library/init/init.md @@ -0,0 +1,49 @@ +init +==== + +The files in this folder are required by low-level operations, and +are always imported by default. You can suppress this behavior by +beginning a file with the keyword "prelude". + +Syntax declarations: + +* [reserved_notation](reserved_notation.lean) +* [tactic](tactic.lean) + +Datatypes and logic: + +* [datatypes](datatypes.lean) +* [logic](logic.lean) +* [classical](classical.lean) +* [bool](bool.lean) +* [num](num.lean) +* [nat](nat.lean) + +Support for well-founded recursion: + +* [relation](relation.lean) +* [wf](wf.lean) +* [wf_k](wf_k.lean) +* [measurable](measurable.lean) + +Additional datatypes: + +* [prod](prod.lean) +* [sigma](sigma.lean) + +The default import: + +* [default](default.lean) + +Module init.logic defines "inhabited" and "nonempty" +types. Constructively, inhabited types have a witness, while nonempty +types are proof irrelevant. Classically (assuming the axioms in +logic.axioms.hilbert) the two are equivalent. Type class inferences +are set up to use "inhabited" however, so users should use that to +declare that types have an element. Use "nonempty" in the hypothesis +of a theorem when the theorem does not depend on the witness chosen. + +Module init.classical declares a choice axiom, and uses it to +prove the excluded middle, propositional completeness, axiom of +choice, and prove that the decidable class is trivial when the +choice axiom is assumed. diff --git a/old_library/init/instances.lean b/old_library/init/instances.lean new file mode 100644 index 0000000000..f1903ad60f --- /dev/null +++ b/old_library/init/instances.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.meta.mk_dec_eq_instance init.subtype init.meta.occurrences init.sum +open tactic subtype +universe variables u v + +attribute [instance] +definition subtype_decidable_eq {A : Type u} {P : A → Prop} [decidable_eq A] : decidable_eq {x \ P x} := +by mk_dec_eq_instance + +set_option trace.app_builder true +attribute [instance] +definition list_decidable_eq {A : Type u} [decidable_eq A] : decidable_eq (list A) := +by mk_dec_eq_instance + +attribute [instance] +definition occurrences_decidable_eq : decidable_eq occurrences := +by mk_dec_eq_instance + +attribute [instance] +definition unit_decidable_eq : decidable_eq unit := +by mk_dec_eq_instance + +attribute [instance] +definition sum_decidable {A : Type u} {B : Type v} [decidable_eq A] [decidable_eq B] : decidable_eq (A ⊕ B) := +by mk_dec_eq_instance diff --git a/old_library/init/list.lean b/old_library/init/list.lean new file mode 100644 index 0000000000..919ed66ac4 --- /dev/null +++ b/old_library/init/list.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.logic init.nat +open decidable list + +universe variables u v + +attribute [instance] +protected definition list.is_inhabited (A : Type u) : inhabited (list A) := +⟨list.nil⟩ + +notation h :: t := cons h t +notation `[` l:(foldr `, ` (h t, cons h t) nil `]`) := l + +namespace list +variable {A : Type u} + +definition append : list A → list A → list A +| [] l := l +| (h :: s) t := h :: (append s t) + +definition length : list A → nat +| [] := 0 +| (a :: l) := length l + 1 + +open option nat + +definition nth : list A → nat → option A +| [] n := none +| (a :: l) 0 := some a +| (a :: l) (n+1) := nth l n + +definition head [inhabited A] : list A → A +| [] := default A +| (a :: l) := a + +definition tail : list A → list A +| [] := [] +| (a :: l) := l + +definition concat : Π (x : A), list A → list A +| a [] := [a] +| a (b :: l) := b :: concat a l + +definition reverse : list A → list A +| [] := [] +| (a :: l) := concat a (reverse l) + +definition map {B : Type v} (f : A → B) : list A → list B +| [] := [] +| (a :: l) := f a :: map l + +definition join : list (list A) → list A +| [] := [] +| (l :: ls) := append l (join ls) + +definition filter (p : A → Prop) [h : decidable_pred p] : list A → list A +| [] := [] +| (a::l) := if p a then a :: filter l else filter l + +definition dropn : ℕ → list A → list A +| 0 a := a +| (succ n) [] := [] +| (succ n) (x::r) := dropn n r +end list + +attribute [instance] +definition list_has_append {A : Type u} : has_append (list A) := +⟨list.append⟩ diff --git a/old_library/init/list_classes.lean b/old_library/init/list_classes.lean new file mode 100644 index 0000000000..d8d6ea39c8 --- /dev/null +++ b/old_library/init/list_classes.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.monad init.alternative +open list +universe variables u v +attribute [inline] +definition list_fmap {A : Type u} {B : Type v} (f : A → B) (l : list A) : list B := +map f l + +attribute [inline] +definition list_bind {A : Type u} {B : Type v} (a : list A) (b : A → list B) : list B := +join (map b a) + +attribute [inline] +definition list_return {A : Type u} (a : A) : list A := +[a] + +attribute [instance] +definition list_is_monad : monad list := +monad.mk @list_fmap @list_return @list_bind + +attribute [instance] +definition list_is_alternative : alternative list := +alternative.mk @list_fmap @list_return (@fapp _ _) @nil @list.append diff --git a/old_library/init/logic.lean b/old_library/init/logic.lean new file mode 100644 index 0000000000..ac6eefbade --- /dev/null +++ b/old_library/init/logic.lean @@ -0,0 +1,1028 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad, Floris van Doorn +-/ +prelude +import init.datatypes + +universe variables u v + +attribute [reducible] +definition id {A : Type u} (a : A) : A := +a + +/- TODO(Leo): for new elaborator +- Support for partially applied recursors (use eta-expansion) +- checkpoints when processing calc. +-/ + +/- implication -/ + +definition implies (a b : Prop) := a → b + +attribute [trans] +lemma implies.trans {p q r : Prop} (h₁ : implies p q) (h₂ : implies q r) : implies p r := +assume hp, h₂ (h₁ hp) + +definition trivial : true := ⟨⟩ + +definition not (a : Prop) := a → false +prefix `¬` := not + +attribute [inline] +definition absurd {a : Prop} {b : Type v} (h₁ : a) (h₂ : ¬a) : b := +false.rec b (h₂ h₁) + +attribute [intro!] +lemma not.intro {a : Prop} (h : a → false) : ¬ a := +h + +theorem mt {a b : Prop} (h₁ : a → b) (h₂ : ¬b) : ¬a := +assume ha : a, absurd (h₁ ha) h₂ + +definition implies.resolve {a b : Prop} (h : a → b) (nb : ¬ b) : ¬ a := assume ha, nb (h ha) + +/- not -/ + +theorem not_false : ¬false := +assume h : false, h + +definition non_contradictory (a : Prop) : Prop := ¬¬a + +theorem non_contradictory_intro {a : Prop} (ha : a) : ¬¬a := +assume hna : ¬a, absurd ha hna + +/- false -/ + +theorem false.elim {c : Prop} (h : false) : c := +false.rec c h + +/- eq -/ + +-- proof irrelevance is built in +theorem proof_irrel {a : Prop} (h₁ h₂ : a) : h₁ = h₂ := +rfl + +attribute [defeq] +definition id.def {A : Type u} (a : A) : id a = a := rfl + +-- Remark: we provide the universe levels explicitly to make sure `eq.drec` has the same type of `eq.rec` in the hoTT library +attribute [elab_as_eliminator] +protected theorem {u₁ u₂} eq.drec {A : Type u₂} {a : A} {C : Π (x : A), a = x → Type u₁} (h₁ : C a (eq.refl a)) {b : A} (h₂ : a = b) : C b h₂ := +eq.rec (λ h₂ : a = a, show C a h₂, from h₁) h₂ h₂ + +namespace eq + variables {A : Type u} + variables {a b c a': A} + + attribute [elab_as_eliminator] + protected theorem drec_on {a : A} {C : Π (x : A), a = x → Type v} {b : A} (h₂ : a = b) (h₁ : C a (refl a)) : C b h₂ := + eq.drec h₁ h₂ + + theorem substr {p : A → Prop} (h₁ : b = a) : p a → p b := + subst (symm h₁) + + theorem mp {A B : Type u} : (A = B) → A → B := + eq.rec_on + + theorem mpr {A B : Type u} : (A = B) → B → A := + assume h₁ h₂, eq.rec_on (eq.symm h₁) h₂ +end eq + +open eq + +theorem congr {A : Type u} {B : Type v} {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 u} {B : A → Type v} {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 : Type u} {B : Type v} {a₁ a₂ : A} (f : A → B) : a₁ = a₂ → f a₁ = f a₂ := +congr rfl + +section + variables {A : Type u} {a b c: A} + + theorem trans_rel_left (r : A → A → Prop) (h₁ : r a b) (h₂ : b = c) : r a c := + h₂ ▸ h₁ + + theorem trans_rel_right (r : A → A → Prop) (h₁ : a = b) (h₂ : r b c) : r a c := + symm h₁ ▸ h₂ +end + +section + variable {p : Prop} + + theorem of_eq_true (h : p = true) : p := + symm h ▸ trivial + + theorem not_of_eq_false (h : p = false) : ¬p := + assume hp, h ▸ hp +end + +attribute [inline] +definition cast {A B : Type u} (h : A = B) (a : A) : B := +eq.rec a h + +theorem cast_proof_irrel {A B : Type u} (h₁ h₂ : A = B) (a : A) : cast h₁ a = cast h₂ a := +rfl + +theorem cast_eq {A : Type u} (h : A = A) (a : A) : cast h a = a := +rfl + +/- ne -/ + +attribute [reducible] +definition ne {A : Type u} (a b : A) := ¬(a = b) +attribute [defeq] +definition ne.def {A : Type u} (a b : A) : ne a b = ¬ (a = b) := rfl +notation a ≠ b := ne a b + +namespace ne + variable {A : Type u} + variables {a b : A} + + theorem intro (h : a = b → false) : a ≠ b := h + + theorem elim (h : a ≠ b) : a = b → false := h + + theorem irrefl (h : a ≠ a) : false := h rfl + + theorem symm (h : a ≠ b) : b ≠ a := + assume (h₁ : b = a), h (symm h₁) +end ne + +theorem false_of_ne {A : Type u} {a : A} : a ≠ a → false := ne.irrefl + +section + variables {p : Prop} + + theorem ne_false_of_self : p → p ≠ false := + assume (hp : p) (heq : p = false), heq ▸ hp + + theorem ne_true_of_not : ¬p → p ≠ true := + assume (hnp : ¬p) (heq : p = true), (heq ▸ hnp) trivial + + theorem true_ne_false : ¬true = false := + ne_false_of_self trivial +end + +infixl ` == `:50 := heq + +section +variables {A B C : Type u} {a a' : A} {b b' : B} {c : C} + +theorem eq_of_heq (h : a == a') : a = a' := +have ∀ (A' : Type u) (a' : A') (h₁ : @heq A a A' a') (h₂ : A = A'), (eq.rec_on h₂ a : A') = a', from + λ (A' : Type u) (a' : A') (h₁ : @heq A a A' a'), heq.rec_on h₁ (λ h₂ : A = A, rfl), +show (eq.rec_on (eq.refl A) a : A) = a', from + this A a' h (eq.refl A) + +theorem heq.elim {A : Type u} {a : A} {p : A → Type v} {b : A} (h₁ : a == b) +: p a → p b := eq.rec_on (eq_of_heq h₁) + +theorem heq.subst {p : ∀ T : Type u, T → Prop} : a == b → p A a → p B b := +heq.rec_on + +theorem heq.symm (h : a == b) : b == a := +heq.rec_on h (heq.refl a) + +theorem heq_of_eq (h : a = a') : a == a' := +eq.subst h (heq.refl a) + +theorem heq.trans (h₁ : a == b) (h₂ : b == c) : a == c := +heq.subst h₂ h₁ + +theorem heq_of_heq_of_eq (h₁ : a == b) (h₂ : b = b') : a == b' := +heq.trans h₁ (heq_of_eq h₂) + +theorem heq_of_eq_of_heq (h₁ : a = a') (h₂ : a' == b) : a == b := +heq.trans (heq_of_eq h₁) h₂ + +definition type_eq_of_heq (h : a == b) : A = B := +heq.rec_on h (eq.refl A) +end + +theorem eq_rec_heq {A : Type u} {C : A → Type v} : ∀ {a a' : A} (h : a = a') (p : C a), (eq.rec_on h p : C a') == p +| a .a rfl p := heq.refl p + +theorem heq_of_eq_rec_left {A : Type u} {C : A → Type v} : ∀ {a a' : A} {p₁ : C a} {p₂ : C a'} (e : a = a') (h₂ : (eq.rec_on e p₁ : C a') = p₂), p₁ == p₂ +| a .a p₁ p₂ (eq.refl .a) h := eq.rec_on h (heq.refl p₁) + +theorem heq_of_eq_rec_right {A : Type u} {C : A → Type v} : ∀ {a a' : A} {p₁ : C a} {p₂ : C a'} (e : a' = a) (h₂ : p₁ = eq.rec_on e p₂), p₁ == p₂ +| a .a p₁ p₂ (eq.refl .a) h := + have p₁ = p₂, from h, + this ▸ heq.refl p₁ + +theorem of_heq_true {a : Prop} (h : a == true) : a := +of_eq_true (eq_of_heq h) + +theorem eq_rec_compose : ∀ {A B C : Type u} (p₁ : B = C) (p₂ : A = B) (a : A), (eq.rec_on p₁ (eq.rec_on p₂ a : B) : C) = eq.rec_on (eq.trans p₂ p₁) a +| A .A .A (eq.refl .A) (eq.refl .A) a := rfl + +theorem eq_rec_eq_eq_rec : ∀ {A₁ A₂ : Type u} {p : A₁ = A₂} {a₁ : A₁} {a₂ : A₂}, (eq.rec_on p a₁ : A₂) = a₂ → a₁ = eq.rec_on (eq.symm p) a₂ +| A .A rfl a .a rfl := rfl + +theorem eq_rec_of_heq_left : ∀ {A₁ A₂ : Type u} {a₁ : A₁} {a₂ : A₂} (h : a₁ == a₂), (eq.rec_on (type_eq_of_heq h) a₁ : A₂) = a₂ +| A .A a .a (heq.refl .a) := rfl + +theorem eq_rec_of_heq_right {A₁ A₂ : Type u} {a₁ : A₁} {a₂ : A₂} (h : a₁ == a₂) : a₁ = eq.rec_on (eq.symm (type_eq_of_heq h)) a₂ := +eq_rec_eq_eq_rec (eq_rec_of_heq_left h) + +attribute heq.refl [refl] +attribute heq.trans [trans] +attribute heq_of_heq_of_eq [trans] +attribute heq_of_eq_of_heq [trans] +attribute heq.symm [symm] + +theorem cast_heq : ∀ {A B : Type u} (h : A = B) (a : A), cast h a == a +| A .A (eq.refl .A) a := heq.refl a + +/- and -/ + +notation a /\ b := and a b +notation a ∧ b := and a b + +variables {a b c d : Prop} + +attribute and.rec [elim] +attribute and.intro [intro!] + +theorem and.elim (h₁ : a ∧ b) (h₂ : a → b → c) : c := +and.rec h₂ h₁ + +theorem and.swap : a ∧ b → b ∧ a := +assume ⟨ha, hb⟩, ⟨hb, ha⟩ + +/- or -/ + +notation a \/ b := or a b +notation a ∨ b := or a b + +attribute or.rec [elim] + +namespace or + theorem elim (h₁ : a ∨ b) (h₂ : a → c) (h₃ : b → c) : c := + or.rec h₂ h₃ h₁ +end or + +theorem non_contradictory_em (a : Prop) : ¬¬(a ∨ ¬a) := +assume not_em : ¬(a ∨ ¬a), + have neg_a : ¬a, from + assume pos_a : a, absurd (or.inl pos_a) not_em, + absurd (or.inr neg_a) not_em + +theorem or.swap : a ∨ b → b ∨ a := or.rec or.inr or.inl + +/- xor -/ +definition xor (a b : Prop) := (a ∧ ¬ b) ∨ (b ∧ ¬ a) + +/- iff -/ + +definition iff (a b : Prop) := (a → b) ∧ (b → a) + +notation a <-> b := iff a b +notation a ↔ b := iff a b + +theorem iff.intro : (a → b) → (b → a) → (a ↔ b) := and.intro + +attribute iff.intro [intro!] + +theorem iff.elim : ((a → b) → (b → a) → c) → (a ↔ b) → c := and.rec + +attribute iff.elim [recursor 5, elim] + +theorem iff.elim_left : (a ↔ b) → a → b := and.left + +definition iff.mp := @iff.elim_left + +theorem iff.elim_right : (a ↔ b) → b → a := and.right + +definition iff.mpr := @iff.elim_right + +attribute [refl] +theorem iff.refl (a : Prop) : a ↔ a := +iff.intro (assume h, h) (assume h, h) + +theorem iff.rfl {a : Prop} : a ↔ a := +iff.refl a + +attribute [trans] +theorem iff.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)) + +attribute [symm] +theorem iff.symm (h : a ↔ b) : b ↔ a := +iff.intro (iff.elim_right h) (iff.elim_left h) + +theorem iff.comm : (a ↔ b) ↔ (b ↔ a) := +iff.intro iff.symm iff.symm + +theorem iff.of_eq {a b : Prop} (h : a = b) : a ↔ b := +eq.rec_on h iff.rfl + +theorem 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_true (h : a ↔ true) : a := +iff.mp (iff.symm h) trivial + +theorem not_of_iff_false : (a ↔ false) → ¬a := iff.mp + +theorem iff_true_intro (h : a) : a ↔ true := +iff.intro + (λ hl, trivial) + (λ hr, h) + +theorem iff_false_intro (h : ¬a) : a ↔ false := +iff.intro h (false.rec a) + +theorem not_non_contradictory_iff_absurd (a : Prop) : ¬¬¬a ↔ ¬a := +iff.intro + (λ (hl : ¬¬¬a) (ha : a), hl (non_contradictory_intro ha)) + absurd + +theorem imp_congr (h₁ : a ↔ c) (h₂ : b ↔ d) : (a → b) ↔ (c → d) := +iff.intro + (λ hab hc, iff.mp h₂ (hab (iff.mpr h₁ hc))) + (λ hcd ha, iff.mpr h₂ (hcd (iff.mp h₁ ha))) + +theorem imp_congr_ctx (h₁ : a ↔ c) (h₂ : c → (b ↔ d)) : (a → b) ↔ (c → d) := +iff.intro + (λ hab hc, have ha : a, from iff.mpr h₁ hc, + have hb : b, from hab ha, + iff.mp (h₂ hc) hb) + (λ hcd ha, have hc : c, from iff.mp h₁ ha, + have hd : d, from hcd hc, +iff.mpr (h₂ hc) hd) + +theorem imp_congr_right (h : a → (b ↔ c)) : (a → b) ↔ (a → c) := +iff.intro + (take hab ha, iff.elim_left (h ha) (hab ha)) + (take hab ha, iff.elim_right (h ha) (hab ha)) + +theorem not_not_intro (ha : a) : ¬¬a := +assume hna : ¬a, hna ha + +theorem not_of_not_not_not (h : ¬¬¬a) : ¬a := +λ ha, absurd (not_not_intro ha) h + +attribute [simp] +theorem not_true : (¬ true) ↔ false := +iff_false_intro (not_not_intro trivial) + +attribute [simp] +theorem not_false_iff : (¬ false) ↔ true := +iff_true_intro not_false + +attribute [congr] +theorem not_congr (h : a ↔ b) : ¬a ↔ ¬b := +iff.intro (λ h₁ h₂, h₁ (iff.mpr h h₂)) (λ h₁ h₂, h₁ (iff.mp h h₂)) + +attribute [simp] +theorem ne_self_iff_false {A : Type u} (a : A) : (not (a = a)) ↔ false := +iff.intro false_of_ne false.elim + +attribute [simp] +theorem eq_self_iff_true {A : Type u} (a : A) : (a = a) ↔ true := +iff_true_intro rfl + +attribute [simp] +theorem heq_self_iff_true {A : Type u} (a : A) : (a == a) ↔ true := +iff_true_intro (heq.refl a) + +attribute [simp] +theorem iff_not_self (a : Prop) : (a ↔ ¬a) ↔ false := +iff_false_intro (λ h, + have h' : ¬a, from (λ ha, (iff.mp h ha) ha), + h' (iff.mpr h h')) + +attribute [simp] +theorem not_iff_self (a : Prop) : (¬a ↔ a) ↔ false := +iff_false_intro (λ h, + have h' : ¬a, from (λ ha, (iff.mpr h ha) ha), + h' (iff.mp h h')) + +attribute [simp] +theorem true_iff_false : (true ↔ false) ↔ false := +iff_false_intro (λ h, iff.mp h trivial) + +attribute [simp] +theorem false_iff_true : (false ↔ true) ↔ false := +iff_false_intro (λ h, iff.mpr h trivial) + +theorem false_of_true_iff_false : (true ↔ false) → false := +assume h, iff.mp h trivial + +/- and simp rules -/ +theorem and.imp (hac : a → c) (hbd : b → d) : a ∧ b → c ∧ d := +assume ⟨ha, hb⟩, ⟨hac ha, hbd hb⟩ + +attribute [congr] +theorem and_congr (h₁ : a ↔ c) (h₂ : b ↔ d) : (a ∧ b) ↔ (c ∧ d) := +iff.intro (and.imp (iff.mp h₁) (iff.mp h₂)) (and.imp (iff.mpr h₁) (iff.mpr h₂)) + +theorem and_congr_right (h : a → (b ↔ c)) : (a ∧ b) ↔ (a ∧ c) := +iff.intro + (assume ⟨ha, hb⟩, ⟨ha, iff.elim_left (h ha) hb⟩) + (assume ⟨ha, hc⟩, ⟨ha, iff.elim_right (h ha) hc⟩) + +attribute [simp] +theorem and.comm : a ∧ b ↔ b ∧ a := +iff.intro and.swap and.swap + +attribute [simp] +theorem and.assoc : (a ∧ b) ∧ c ↔ a ∧ (b ∧ c) := +iff.intro + (assume ⟨⟨ha, hb⟩, hc⟩, ⟨ha, ⟨hb, hc⟩⟩) + (assume ⟨ha, ⟨hb, hc⟩⟩, ⟨⟨ha, hb⟩, hc⟩) + +attribute [simp] +theorem and.left_comm : a ∧ (b ∧ c) ↔ b ∧ (a ∧ c) := +iff.trans (iff.symm and.assoc) (iff.trans (and_congr and.comm (iff.refl c)) and.assoc) + +theorem and_iff_left {a b : Prop} (hb : b) : (a ∧ b) ↔ a := +iff.intro and.left (λ ha, ⟨ha, hb⟩) + +theorem and_iff_right {a b : Prop} (ha : a) : (a ∧ b) ↔ b := +iff.intro and.right (and.intro ha) + +attribute [simp] +theorem and_true (a : Prop) : a ∧ true ↔ a := +and_iff_left trivial + +attribute [simp] +theorem true_and (a : Prop) : true ∧ a ↔ a := +and_iff_right trivial + +attribute [simp] +theorem and_false (a : Prop) : a ∧ false ↔ false := +iff_false_intro and.right + +attribute [simp] +theorem false_and (a : Prop) : false ∧ a ↔ false := +iff_false_intro and.left + +attribute [simp] +theorem not_and_self (a : Prop) : (¬a ∧ a) ↔ false := +iff_false_intro (λ h, and.elim h (λ h₁ h₂, absurd h₂ h₁)) + +attribute [simp] +theorem and_not_self (a : Prop) : (a ∧ ¬a) ↔ false := +iff_false_intro (assume ⟨h₁, h₂⟩, absurd h₁ h₂) + +attribute [simp] +theorem and_self (a : Prop) : a ∧ a ↔ a := +iff.intro and.left (assume h, ⟨h, h⟩) + +/- or simp rules -/ + +theorem or.imp (h₂ : a → c) (h₃ : b → d) : a ∨ b → c ∨ d := +or.rec (λ h, or.inl (h₂ h)) (λ h, or.inr (h₃ h)) + +theorem or.imp_left (h : a → b) : a ∨ c → b ∨ c := +or.imp h id + +theorem or.imp_right (h : a → b) : c ∨ a → c ∨ b := +or.imp id h + +attribute [congr] +theorem or_congr (h₁ : a ↔ c) (h₂ : b ↔ d) : (a ∨ b) ↔ (c ∨ d) := +iff.intro (or.imp (iff.mp h₁) (iff.mp h₂)) (or.imp (iff.mpr h₁) (iff.mpr h₂)) + +attribute [simp] +theorem or.comm : a ∨ b ↔ b ∨ a := iff.intro or.swap or.swap + +attribute [simp] +theorem or.assoc : (a ∨ b) ∨ c ↔ a ∨ (b ∨ c) := +iff.intro + (or.rec (or.imp_right or.inl) (λ h, or.inr (or.inr h))) + (or.rec (λ h, or.inl (or.inl h)) (or.imp_left or.inr)) + +attribute [simp] +theorem or.left_comm : a ∨ (b ∨ c) ↔ b ∨ (a ∨ c) := +iff.trans (iff.symm or.assoc) (iff.trans (or_congr or.comm (iff.refl c)) or.assoc) + +attribute [simp] +theorem or_true (a : Prop) : a ∨ true ↔ true := +iff_true_intro (or.inr trivial) + +attribute [simp] +theorem true_or (a : Prop) : true ∨ a ↔ true := +iff_true_intro (or.inl trivial) + +attribute [simp] +theorem or_false (a : Prop) : a ∨ false ↔ a := +iff.intro (or.rec id false.elim) or.inl + +attribute [simp] +theorem false_or (a : Prop) : false ∨ a ↔ a := +iff.trans or.comm (or_false a) + +attribute [simp] +theorem or_self (a : Prop) : a ∨ a ↔ a := +iff.intro (or.rec id id) or.inl + +/- or resolution rulse -/ + +definition or.resolve_left {a b : Prop} (h : a ∨ b) (na : ¬ a) : b := + or.elim h (λ ha, absurd ha na) id + +definition or.neg_resolve_left {a b : Prop} (h : ¬ a ∨ b) (ha : a) : b := + or.elim h (λ na, absurd ha na) id + +definition or.resolve_right {a b : Prop} (h : a ∨ b) (nb : ¬ b) : a := + or.elim h id (λ hb, absurd hb nb) + +definition or.neg_resolve_right {a b : Prop} (h : a ∨ ¬ b) (hb : b) : a := + or.elim h id (λ nb, absurd hb nb) + +/- iff simp rules -/ + +attribute [simp] +theorem iff_true (a : Prop) : (a ↔ true) ↔ a := +iff.intro (assume h, iff.mpr h trivial) iff_true_intro + +attribute [simp] +theorem true_iff (a : Prop) : (true ↔ a) ↔ a := +iff.trans iff.comm (iff_true a) + +attribute [simp] +theorem iff_false (a : Prop) : (a ↔ false) ↔ ¬ a := +iff.intro and.left iff_false_intro + +attribute [simp] +theorem false_iff (a : Prop) : (false ↔ a) ↔ ¬ a := +iff.trans iff.comm (iff_false a) + +attribute [simp] +theorem iff_self (a : Prop) : (a ↔ a) ↔ true := +iff_true_intro iff.rfl + +attribute [congr] +theorem iff_congr (h₁ : a ↔ c) (h₂ : b ↔ d) : (a ↔ b) ↔ (c ↔ d) := +and_congr (imp_congr h₁ h₂) (imp_congr h₂ h₁) + +/- exists -/ + +inductive Exists {A : Type u} (p : A → Prop) : Prop +| intro : ∀ (a : A), p a → Exists + +attribute Exists.intro [intro] + +definition exists.intro := @Exists.intro + +notation `exists` binders `, ` r:(scoped P, Exists P) := r +notation `∃` binders `, ` r:(scoped P, Exists P) := r + +attribute Exists.rec [elim] + +theorem exists.elim {A : Type u} {p : A → Prop} {b : Prop} + (h₁ : ∃ x, p x) (h₂ : ∀ (a : A), p a → b) : b := +Exists.rec h₂ h₁ + +/- exists unique -/ + +definition exists_unique {A : Type u} (p : A → Prop) := +∃ x, p x ∧ ∀ y, p y → y = x + +notation `∃!` binders `, ` r:(scoped P, exists_unique P) := r + +attribute [intro] +theorem exists_unique.intro {A : Type u} {p : A → Prop} (w : A) (h₁ : p w) (h₂ : ∀ y, p y → y = w) : + ∃! x, p x := +exists.intro w ⟨h₁, h₂⟩ + +attribute [recursor 4, elim] +theorem exists_unique.elim {A : Type u} {p : A → Prop} {b : Prop} + (h₂ : ∃! x, p x) (h₁ : ∀ x, p x → (∀ y, p y → y = x) → b) : b := +exists.elim h₂ (λ w hw, h₁ w (and.left hw) (and.right hw)) + +theorem exists_unique_of_exists_of_unique {A : Type u} {p : A → Prop} + (hex : ∃ x, p x) (hunique : ∀ y₁ y₂, p y₁ → p y₂ → y₁ = y₂) : ∃! x, p x := +exists.elim hex (λ x px, exists_unique.intro x px (take y, suppose p y, hunique y x this px)) + +theorem exists_of_exists_unique {A : Type u} {p : A → Prop} (h : ∃! x, p x) : ∃ x, p x := +exists.elim h (λ x hx, ⟨x, and.left hx⟩) + +theorem unique_of_exists_unique {A : Type u} {p : A → Prop} + (h : ∃! x, p x) {y₁ y₂ : A} (py₁ : p y₁) (py₂ : p y₂) : y₁ = y₂ := +exists_unique.elim h + (take x, suppose p x, + assume unique : ∀ y, p y → y = x, + show y₁ = y₂, from eq.trans (unique _ py₁) (eq.symm (unique _ py₂))) + +/- exists, forall, exists unique congruences -/ +attribute [congr] +theorem forall_congr {A : Type u} {p q : A → Prop} (h : ∀ a, (p a ↔ q a)) : (∀ a, p a) ↔ ∀ a, q a := +iff.intro (λ p a, iff.mp (h a) (p a)) (λ q a, iff.mpr (h a) (q a)) + +theorem exists_imp_exists {A : Type u} {p q : A → Prop} (h : ∀ a, (p a → q a)) (p : ∃ a, p a) : ∃ a, q a := +exists.elim p (λ a hp, ⟨a, h a hp⟩) + +attribute [congr] +theorem exists_congr {A : Type u} {p q : A → Prop} (h : ∀ a, (p a ↔ q a)) : (Exists p) ↔ ∃ a, q a := +iff.intro + (exists_imp_exists (λ a, iff.mp (h a))) + (exists_imp_exists (λ a, iff.mpr (h a))) + +attribute [congr] +theorem exists_unique_congr {A : Type u} {p₁ p₂ : A → Prop} (h : ∀ x, p₁ x ↔ p₂ x) : (exists_unique p₁) ↔ (∃! x, p₂ x) := -- +exists_congr (λ x, and_congr (h x) (forall_congr (λ y, imp_congr (h y) iff.rfl))) + +/- decidable -/ + +inductive [class] decidable (p : Prop) +| is_false : ¬p → decidable +| is_true : p → decidable + +export decidable (is_true is_false) + +attribute [instance] +definition decidable_true : decidable true := +is_true trivial + +attribute [instance] +definition decidable_false : decidable false := +is_false not_false + +-- We use "dependent" if-then-else to be able to communicate the if-then-else condition +-- to the branches +attribute [inline] +definition dite (c : Prop) [h : decidable c] {A : Type u} : (c → A) → (¬ c → A) → A := +λ t e, decidable.rec_on h e t + +/- if-then-else -/ + +attribute [inline] +definition ite (c : Prop) [h : decidable c] {A : Type u} (t e : A) : A := +decidable.rec_on h (λ hnc, e) (λ hc, t) + +namespace decidable + variables {p q : Prop} + + definition rec_on_true [h : decidable p] {h₁ : p → Type u} {h₂ : ¬p → Type u} (h₃ : p) (h₄ : h₁ h₃) + : decidable.rec_on h h₂ h₁ := + decidable.rec_on h (λ h, false.rec _ (h h₃)) (λ h, h₄) + + definition rec_on_false [h : decidable p] {h₁ : p → Type u} {h₂ : ¬p → Type u} (h₃ : ¬p) (h₄ : h₂ h₃) + : decidable.rec_on h h₂ h₁ := + decidable.rec_on h (λ h, h₄) (λ h, false.rec _ (h₃ h)) + + definition by_cases {q : Type u} [C : decidable p] : (p → q) → (¬p → q) → q := dite _ + + theorem em (p : Prop) [decidable p] : p ∨ ¬p := by_cases or.inl or.inr + + theorem by_contradiction [decidable p] (h : ¬p → false) : p := + if h₁ : p then h₁ else false.rec _ (h h₁) + + definition to_bool (p : Prop) [h : decidable p] : bool := + decidable.cases_on h (λ h₁, bool.ff) (λ h₂, bool.tt) +end decidable + +section + variables {p q : Prop} + definition decidable_of_decidable_of_iff (hp : decidable p) (h : p ↔ q) : decidable q := + if hp : p then is_true (iff.mp h hp) + else is_false (iff.mp (not_iff_not_of_iff h) hp) + + definition decidable_of_decidable_of_eq (hp : decidable p) (h : p = q) : decidable q := + decidable_of_decidable_of_iff hp (iff.of_eq h) + + protected definition or.by_cases [decidable p] [decidable q] {A : Type u} + (h : p ∨ q) (h₁ : p → A) (h₂ : q → A) : A := + if hp : p then h₁ hp else + if hq : q then h₂ hq else + false.rec _ (or.elim h hp hq) +end + +section + variables {p q : Prop} + + attribute [instance] + definition decidable_and [decidable p] [decidable q] : decidable (p ∧ q) := + if hp : p then + if hq : q then is_true ⟨hp, hq⟩ + else is_false (assume h : p ∧ q, hq (and.right h)) + else is_false (assume h : p ∧ q, hp (and.left h)) + + attribute [instance] + definition decidable_or [decidable p] [decidable q] : decidable (p ∨ q) := + if hp : p then is_true (or.inl hp) else + if hq : q then is_true (or.inr hq) else + is_false (or.rec hp hq) + + attribute [instance] + definition decidable_not [decidable p] : decidable (¬p) := + if hp : p then is_false (absurd hp) else is_true hp + + attribute [instance] + definition decidable_implies [decidable p] [decidable q] : decidable (p → q) := + if hp : p then + if hq : q then is_true (assume h, hq) + else is_false (assume h : p → q, absurd (h hp) hq) + else is_true (assume h, absurd h hp) + + attribute [instance] + definition decidable_iff [decidable p] [decidable q] : decidable (p ↔ q) := + decidable_and + +end + +attribute [reducible] +definition decidable_pred {A : Type u} (r : A → Prop) := Π (a : A), decidable (r a) +attribute [reducible] +definition decidable_rel {A : Type u} (r : A → A → Prop) := Π (a b : A), decidable (r a b) +attribute [reducible] +definition decidable_eq (A : Type u) := decidable_rel (@eq A) +attribute [instance] +definition decidable_ne {A : Type u} [decidable_eq A] (a b : A) : decidable (a ≠ b) := +decidable_implies + +theorem bool.ff_ne_tt : ff = tt → false +. + +definition is_dec_eq {A : Type u} (p : A → A → bool) : Prop := ∀ ⦃x y : A⦄, p x y = tt → x = y +definition is_dec_refl {A : Type u} (p : A → A → bool) : Prop := ∀ x, p x x = tt + +open decidable +attribute [instance] +protected definition bool.has_decidable_eq : ∀ a b : bool, decidable (a = b) +| ff ff := is_true rfl +| ff tt := is_false bool.ff_ne_tt +| tt ff := is_false (ne.symm bool.ff_ne_tt) +| tt tt := is_true rfl + +definition decidable_eq_of_bool_pred {A : Type u} {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 is_true (h₁ hp) + else is_false (assume hxy : x = y, absurd (h₂ y) (@eq.rec_on _ _ (λ z, ¬p z y = tt) _ hxy hp)) + +theorem decidable_eq_inl_refl {A : Type u} [h : decidable_eq A] (a : A) : h a a = is_true (eq.refl a) := +match (h a a) with +| (is_true e) := rfl +| (is_false n) := absurd rfl n +end + +theorem decidable_eq_inr_neg {A : Type u} [h : decidable_eq A] {a b : A} : Π n : a ≠ b, h a b = is_false n := +assume n, +match (h a b) with +| (is_true e) := absurd e n +| (is_false n₁) := proof_irrel n n₁ ▸ eq.refl (is_false n) +end + +/- inhabited -/ + +inductive [class] inhabited (A : Type u) +| mk : A → inhabited + +attribute [inline] +protected definition inhabited.value {A : Type u} : inhabited A → A := +λ h, inhabited.rec (λ a, a) h + +attribute [inline] +protected definition inhabited.destruct {A : Type u} {B : Type v} (h₁ : inhabited A) (h₂ : A → B) : B := +inhabited.rec h₂ h₁ + +attribute [inline] +definition default (A : Type u) [h : inhabited A] : A := +inhabited.value h + +attribute [inline, irreducible] +definition arbitrary (A : Type u) [h : inhabited A] : A := +inhabited.value h + +attribute [instance] +definition Prop.is_inhabited : inhabited Prop := +⟨true⟩ + +attribute [instance] +definition inhabited_fun (A : Type u) {B : Type v} [h : inhabited B] : inhabited (A → B) := +inhabited.rec_on h (λ b, ⟨λ a, b⟩) + +attribute [instance] +definition inhabited_Pi (A : Type u) {B : A → Type v} [Π x, inhabited (B x)] : + inhabited (Π x, B x) := +⟨λ a, default (B a)⟩ + +attribute [inline, instance] +protected definition bool.is_inhabited : inhabited bool := +⟨ff⟩ + +attribute [inline, instance] +protected definition pos_num.is_inhabited : inhabited pos_num := +⟨pos_num.one⟩ + +attribute [inline, instance] +protected definition num.is_inhabited : inhabited num := +⟨num.zero⟩ + +inductive [class] nonempty (A : Type u) : Prop +| intro : A → nonempty + +protected definition nonempty.elim {A : Type u} {p : Prop} (h₁ : nonempty A) (h₂ : A → p) : p := +nonempty.rec h₂ h₁ + +attribute [instance] +theorem nonempty_of_inhabited {A : Type u} [inhabited A] : nonempty A := +⟨default A⟩ + +theorem nonempty_of_exists {A : Type u} {p : A → Prop} : (∃ x, p x) → nonempty A +| ⟨w, h⟩ := ⟨w⟩ + +/- subsingleton -/ + +inductive [class] subsingleton (A : Type u) : Prop +| intro : (∀ a b : A, a = b) → subsingleton + +protected definition subsingleton.elim {A : Type u} [h : subsingleton A] : ∀ (a b : A), a = b := +subsingleton.rec (λ p, p) h + +protected definition subsingleton.helim {A B : Type u} [h : subsingleton A] (h : A = B) : ∀ (a : A) (b : B), a == b := +eq.rec_on h (λ a b : A, heq_of_eq (subsingleton.elim a b)) + +attribute [instance] +definition subsingleton_prop (p : Prop) : subsingleton p := +⟨λ a b, proof_irrel a b⟩ + +attribute [instance] +definition subsingleton_decidable (p : Prop) : subsingleton (decidable p) := +subsingleton.intro (λ d₁, + match d₁ with + | (is_true t₁) := (λ d₂, + match d₂ with + | (is_true t₂) := eq.rec_on (proof_irrel t₁ t₂) rfl + | (is_false f₂) := absurd t₁ f₂ + end) + | (is_false f₁) := (λ d₂, + match d₂ with + | (is_true t₂) := absurd t₂ f₁ + | (is_false f₂) := eq.rec_on (proof_irrel f₁ f₂) rfl + end) + end) + +protected theorem rec_subsingleton {p : Prop} [h : decidable p] + {h₁ : p → Type u} {h₂ : ¬p → Type u} + [h₃ : Π (h : p), subsingleton (h₁ h)] [h₄ : Π (h : ¬p), subsingleton (h₂ h)] + : subsingleton (decidable.rec_on h h₂ h₁) := +match h with +| (is_true h) := h₃ h +| (is_false h) := h₄ h +end + +theorem if_pos {c : Prop} [h : decidable c] (hc : c) {A : Type u} {t e : A} : (ite c t e) = t := +match h with +| (is_true hc) := rfl +| (is_false hnc) := absurd hc hnc +end + +theorem if_neg {c : Prop} [h : decidable c] (hnc : ¬c) {A : Type u} {t e : A} : (ite c t e) = e := +match h with +| (is_true hc) := absurd hc hnc +| (is_false hnc) := rfl +end + +attribute [simp] +theorem if_t_t (c : Prop) [h : decidable c] {A : Type u} (t : A) : (ite c t t) = t := +match h with +| (is_true hc) := rfl +| (is_false hnc) := rfl +end + +theorem implies_of_if_pos {c t e : Prop} [decidable c] (h : ite c t e) : c → t := +assume hc, eq.rec_on (if_pos hc : ite c t e = t) h + +theorem implies_of_if_neg {c t e : Prop} [decidable c] (h : ite c t e) : ¬c → e := +assume hnc, eq.rec_on (if_neg hnc : ite c t e = e) h + +theorem if_ctx_congr {A : Type u} {b c : Prop} [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 := +match dec_b, dec_c with +| (is_false h₁), (is_false h₂) := h_e h₂ +| (is_true h₁), (is_true h₂) := h_t h₂ +| (is_false h₁), (is_true h₂) := absurd h₂ (iff.mp (not_iff_not_of_iff h_c) h₁) +| (is_true h₁), (is_false h₂) := absurd h₁ (iff.mpr (not_iff_not_of_iff h_c) h₂) +end + +attribute [congr] +theorem if_congr {A : Type u} {b c : Prop} [dec_b : decidable b] [dec_c : decidable c] + {x y u v : A} + (h_c : b ↔ c) (h_t : x = u) (h_e : y = v) : + ite b x y = ite c u v := +@if_ctx_congr A b c dec_b dec_c x y u v h_c (λ h, h_t) (λ h, h_e) + +theorem if_ctx_simp_congr {A : Type u} {b c : Prop} [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 + +attribute [congr] +theorem if_simp_congr {A : Type u} {b c : Prop} [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) + +attribute [simp] +definition if_true {A : Type u} (t e : A) : (if true then t else e) = t := +if_pos trivial + +attribute [simp] +definition if_false {A : Type u} (t e : A) : (if false then t else e) = e := +if_neg not_false + +theorem if_ctx_congr_prop {b c x y u v : Prop} [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 := +match dec_b, dec_c with +| (is_false h₁), (is_false h₂) := h_e h₂ +| (is_true h₁), (is_true h₂) := h_t h₂ +| (is_false h₁), (is_true h₂) := absurd h₂ (iff.mp (not_iff_not_of_iff h_c) h₁) +| (is_true h₁), (is_false h₂) := absurd h₁ (iff.mpr (not_iff_not_of_iff h_c) h₂) +end + +attribute [congr] +theorem if_congr_prop {b c x y u v : Prop} [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 : Prop} [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) Prop 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 + +attribute [congr] +theorem if_simp_congr_prop {b c x y u v : Prop} [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) Prop u v) := +@if_ctx_simp_congr_prop b c x y u v dec_b h_c (λ h, h_t) (λ h, h_e) + +theorem dif_pos {c : Prop} [h : decidable c] (hc : c) {A : Type u} {t : c → A} {e : ¬ c → A} : dite c t e = t hc := +match h with +| (is_true hc) := rfl +| (is_false hnc) := absurd hc hnc +end + +theorem dif_neg {c : Prop} [h : decidable c] (hnc : ¬c) {A : Type u} {t : c → A} {e : ¬ c → A} : dite c t e = e hnc := +match h with +| (is_true hc) := absurd hc hnc +| (is_false hnc) := rfl +end + +theorem dif_ctx_congr {A : Type u} {b c : Prop} [dec_b : decidable b] [dec_c : decidable c] + {x : b → A} {u : c → A} {y : ¬b → A} {v : ¬c → A} + (h_c : b ↔ c) + (h_t : ∀ (h : c), x (iff.mpr h_c h) = u h) + (h_e : ∀ (h : ¬c), y (iff.mpr (not_iff_not_of_iff h_c) h) = v h) : + (@dite b dec_b A x y) = (@dite c dec_c A u v) := +match dec_b, dec_c with +| (is_false h₁), (is_false h₂) := h_e h₂ +| (is_true h₁), (is_true h₂) := h_t h₂ +| (is_false h₁), (is_true h₂) := absurd h₂ (iff.mp (not_iff_not_of_iff h_c) h₁) +| (is_true h₁), (is_false h₂) := absurd h₁ (iff.mpr (not_iff_not_of_iff h_c) h₂) +end + +theorem dif_ctx_simp_congr {A : Type u} {b c : Prop} [dec_b : decidable b] + {x : b → A} {u : c → A} {y : ¬b → A} {v : ¬c → A} + (h_c : b ↔ c) + (h_t : ∀ (h : c), x (iff.mpr h_c h) = u h) + (h_e : ∀ (h : ¬c), y (iff.mpr (not_iff_not_of_iff h_c) h) = v h) : + (@dite b dec_b A x y) = (@dite c (decidable_of_decidable_of_iff dec_b h_c) A u v) := +@dif_ctx_congr A b c dec_b (decidable_of_decidable_of_iff dec_b h_c) x u y v h_c h_t h_e + +-- Remark: dite and ite are "definitionally equal" when we ignore the proofs. +theorem dite_ite_eq (c : Prop) [h : decidable c] {A : Type u} (t : A) (e : A) : dite c (λ h, t) (λ h, e) = ite c t e := +match h with +| (is_true hc) := rfl +| (is_false hnc) := rfl +end + +-- The following symbols should not be considered in the pattern inference procedure used by +-- heuristic instantiation. +attribute and or not iff ite dite eq ne heq [no_pattern] + +definition as_true (c : Prop) [decidable c] : Prop := +if c then true else false + +definition as_false (c : Prop) [decidable c] : Prop := +if c then false else true + +definition of_as_true {c : Prop} [h₁ : decidable c] (h₂ : as_true c) : c := +match h₁, h₂ with +| (is_true h_c), h₂ := h_c +| (is_false h_c), h₂ := false.elim h₂ +end + +-- namespace used to collect congruence rules for "contextual simplification" +namespace contextual + attribute if_ctx_simp_congr [congr] + attribute if_ctx_simp_congr_prop [congr] + attribute dif_ctx_simp_congr [congr] +end contextual diff --git a/old_library/init/meta/ac_tactics.lean b/old_library/init/meta/ac_tactics.lean new file mode 100644 index 0000000000..e8bb6d00b5 --- /dev/null +++ b/old_library/init/meta/ac_tactics.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic + +namespace tactic +/- (flat_assoc op assoc e) -/ +meta_constant flat_assoc : expr → expr → expr → tactic (expr × expr) +/- (perm_ac op assoc comm e1 e2) Try to construct a proof that e1 = e2 modulo AC -/ +meta_constant perm_ac : expr → expr → expr → expr → expr → tactic expr +end tactic diff --git a/old_library/init/meta/attribute.lean b/old_library/init/meta/attribute.lean new file mode 100644 index 0000000000..7f99e108f3 --- /dev/null +++ b/old_library/init/meta/attribute.lean @@ -0,0 +1,25 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sebastian Ullrich +-/ +prelude +import init.meta.tactic + +meta_constant attribute.get_instances : name → tactic (list name) +meta_constant attribute.fingerprint : name → tactic nat + +structure user_attribute := +(name : name) +(descr : string) + +/- Registers a new user-defined attribute. The argument must be the name of a definition of type + `user_attribute` or a sub-structure. -/ +meta_constant attribute.register : name → command + +structure caching_user_attribute extends user_attribute := +(Cache : Type) +(cache : list declaration → Cache) + +meta_constant caching_user_attribute.get_cache : + Π(attr : caching_user_attribute), tactic (caching_user_attribute.Cache attr) diff --git a/old_library/init/meta/backward.lean b/old_library/init/meta/backward.lean new file mode 100644 index 0000000000..882ea3e31d --- /dev/null +++ b/old_library/init/meta/backward.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic init.meta.set_get_option_tactics + +namespace tactic +meta_constant back_lemmas : Type + +/- Create a datastructure containing all lemmas tagged as [intro]. + Lemmas are indexed using their head-symbol. + The head-symbol is computed with respect to the given transparency setting. -/ +meta_constant mk_back_lemmas_core : transparency → tactic back_lemmas +/- (back_lemmas_insert_core m lemmas lemma) adds the given lemma to the set back_lemmas. + It infers the type of the lemma, and uses its head-symbol as an index. + The head-symbol is computed with respect to the given transparency setting. -/ +meta_constant back_lemmas_insert_core : transparency → back_lemmas → expr → tactic back_lemmas +/- Return the lemmas that have the same head symbol of the given expression -/ +meta_constant back_lemmas_find : back_lemmas → expr → tactic (list expr) + +meta_definition mk_back_lemmas : tactic back_lemmas := +mk_back_lemmas_core reducible + +meta_definition back_lemmas_insert : back_lemmas → expr → tactic back_lemmas := +back_lemmas_insert_core reducible + + +/- (backward_chaining_core t insts max_depth pre_tactic leaf_tactic lemmas): perform backward chaining using + the lemmas marked as [intro] and extra_lemmas. + + The search maximum depth is \c max_depth. + + Before processing each goal, the tactic pre_tactic is invoked. The possible outcomes are: + 1) it closes the goal + 2) it does nothing, and backward_chaining_core tries applicable lemmas. + 3) it fails, and backward_chaining_core backtracks. + + Whenever no lemma is applicable, the leaf_tactic is invoked, to try to close the goal. + If insts is tt, then type class resolution is used to discharge goals. + + Remark pre_tactic may also be used to trace the execution of backward_chaining_core -/ +meta_constant backward_chaining_core : transparency → bool → nat → tactic unit → tactic unit → back_lemmas → tactic unit + +meta_definition back_lemmas_add_extra : transparency → back_lemmas → list expr → tactic back_lemmas +| m bls [] := return bls +| m bls (l::ls) := do + new_bls ← back_lemmas_insert_core m bls l, + back_lemmas_add_extra m new_bls ls + +meta_definition back_chaining_core (pre_tactic : tactic unit) (leaf_tactic : tactic unit) (extra_lemmas : list expr) : tactic unit := +do intro_lemmas ← mk_back_lemmas_core reducible, + new_lemmas ← back_lemmas_add_extra reducible intro_lemmas extra_lemmas, + max ← get_nat_option `back_chaining.max_depth 8, + backward_chaining_core reducible tt max pre_tactic leaf_tactic new_lemmas + +meta_definition back_chaining : tactic unit := +back_chaining_core skip assumption [] + +meta_definition back_chaining_using : list expr → tactic unit := +back_chaining_core skip assumption + +meta_definition back_chaining_using_hs : tactic unit := +local_context >>= back_chaining_core skip failed + +end tactic diff --git a/old_library/init/meta/congr_lemma.lean b/old_library/init/meta/congr_lemma.lean new file mode 100644 index 0000000000..a8c260d3fa --- /dev/null +++ b/old_library/init/meta/congr_lemma.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic init.meta.format init.function + +inductive congr_arg_kind +/- It is a parameter for the congruence lemma, the parameter occurs in the left and right hand sides. -/ +| fixed +/- It is not a parameter for the congruence lemma, the lemma was specialized for this parameter. + This only happens if the parameter is a subsingleton/proposition, and other parameters depend on it. -/ +| fixed_no_param +/- The lemma contains three parameters for this kind of argument a_i, b_i and (eq_i : a_i = b_i). + a_i and b_i represent the left and right hand sides, and eq_i is a proof for their equality. -/ +| eq +/- congr-simp lemma contains only one parameter for this kind of argument, and congr-lemmas contains two. + They correspond to arguments that are subsingletons/propositions. -/ +| cast +/- The lemma contains three parameters for this kind of argument a_i, b_i and (eq_i : a_i == b_i). + a_i and b_i represent the left and right hand sides, and eq_i is a proof for their heterogeneous equality. -/ +| heq + +structure congr_lemma := +(type : expr) (proof : expr) (arg_kids : list congr_arg_kind) + +namespace tactic +meta_constant mk_congr_simp_core : transparency → expr → tactic congr_lemma +meta_constant mk_congr_simp_n_core : transparency → expr → nat → tactic congr_lemma +/- Create a specialized theorem using (a prefix of) the arguments of the given application. -/ +meta_constant mk_specialized_congr_simp_core : transparency → expr → tactic congr_lemma + +meta_constant mk_congr_core : transparency → expr → tactic congr_lemma +meta_constant mk_congr_n_core : transparency → expr → nat → tactic congr_lemma +/- Create a specialized theorem using (a prefix of) the arguments of the given application. -/ +meta_constant mk_specialized_congr_core : transparency → expr → tactic congr_lemma + +meta_constant mk_hcongr_core : transparency → expr → tactic congr_lemma +meta_constant mk_hcongr_n_core : transparency → expr → nat → tactic congr_lemma + +/- If R is an equivalence relation, construct the congruence lemma + R a1 a2 -> R b1 b2 -> (R a1 b1) <-> (R a2 b2) -/ +meta_constant mk_rel_iff_congr_core : transparency → expr → tactic congr_lemma + +/- Similar to mk_rel_iff_congr + It fails if propext is not available. + + R a1 a2 -> R b1 b2 -> (R a1 b1) = (R a2 b2) -/ +meta_constant mk_rel_eq_congr_core : transparency → expr → tactic congr_lemma + +meta_definition mk_congr_simp : expr → tactic congr_lemma := +mk_congr_simp_core semireducible + +meta_definition mk_congr_simp_n : expr → nat → tactic congr_lemma := +mk_congr_simp_n_core semireducible + +meta_definition mk_specialized_congr_simp : expr → tactic congr_lemma := +mk_specialized_congr_simp_core semireducible + +meta_definition mk_congr : expr → tactic congr_lemma := +mk_congr_core semireducible + +meta_definition mk_congr_n : expr → nat → tactic congr_lemma := +mk_congr_n_core semireducible + +meta_definition mk_specialized_congr : expr → tactic congr_lemma := +mk_specialized_congr_core semireducible + +meta_definition mk_hcongr : expr → tactic congr_lemma := +mk_hcongr_core semireducible + +meta_definition mk_hcongr_n : expr → nat → tactic congr_lemma := +mk_hcongr_n_core semireducible + +meta_definition mk_rel_iff_congr : expr → tactic congr_lemma := +mk_rel_iff_congr_core semireducible + +meta_definition mk_rel_eq_congr : expr → tactic congr_lemma := +mk_rel_eq_congr_core semireducible + +end tactic diff --git a/old_library/init/meta/constructor_tactic.lean b/old_library/init/meta/constructor_tactic.lean new file mode 100644 index 0000000000..b2e47a6cd1 --- /dev/null +++ b/old_library/init/meta/constructor_tactic.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic init.function + +namespace tactic + +private meta_definition get_constructors_for (e : expr) : tactic (list name) := +do env ← get_env, + I ← return $ expr.const_name (expr.get_app_fn e), + when (environment.is_inductive env I = ff) (fail "constructor tactic failed, target is not an inductive datatype"), + return $ environment.constructors_of env I + +private meta_definition try_constructors : list name → tactic unit +| [] := fail "constructor tactic failed, none of the constructors is applicable" +| (c::cs) := (mk_const c >>= apply) <|> try_constructors cs + +meta_definition constructor : tactic unit := +target >>= get_constructors_for >>= try_constructors + +meta_definition left : tactic unit := +do tgt ← target, + [c₁, c₂] ← get_constructors_for tgt | fail "left tactic failed, target is not an inductive datatype with two constructors", + mk_const c₁ >>= apply + +meta_definition right : tactic unit := +do tgt ← target, + [c₁, c₂] ← get_constructors_for tgt | fail "left tactic failed, target is not an inductive datatype with two constructors", + mk_const c₂ >>= apply + +meta_definition constructor_idx (idx : nat) : tactic unit := +do cs ← target >>= get_constructors_for, + some c ← return $ list.nth cs (idx - 1) | fail "constructor_idx tactic failed, target is an inductive datatype, but it does not have sufficient constructors", + mk_const c >>= apply + +meta_definition split : tactic unit := +do [c] ← target >>= get_constructors_for | fail "split tactic failed, target is not an inductive datatype with only one constructor", + mk_const c >>= apply + +open expr + +private meta_definition apply_num_metavars : expr → expr → nat → tactic expr +| f ftype 0 := return f +| f ftype (n+1) := do + pi m bi d b ← whnf ftype | failed, + a ← mk_meta_var d, + new_f ← return $ expr.app f a, + new_ftype ← return $ expr.instantiate_var b a, + apply_num_metavars new_f new_ftype n + +meta_definition existsi (e : expr) : tactic unit := +do [c] ← target >>= get_constructors_for | fail "existsi tactic failed, target is not an inductive datatype with only one constructor", + fn ← mk_const c, + fn_type ← infer_type fn, + n ← get_arity fn, + when (n < 2) (fail "existsi tactic failed, constructor must have at least two arguments"), + t ← apply_num_metavars fn fn_type (n - 2), + apply (app t e) + +end tactic diff --git a/old_library/init/meta/contradiction_tactic.lean b/old_library/init/meta/contradiction_tactic.lean new file mode 100644 index 0000000000..cf56cf665b --- /dev/null +++ b/old_library/init/meta/contradiction_tactic.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic init.function + +namespace tactic + +open expr tactic decidable environment + +private meta_definition contra_A_not_A : list expr → list expr → tactic unit +| [] Hs := failed +| (H1 :: Rs) Hs := + do t_0 ← infer_type H1, + t ← whnf t_0, + (do a ← match_not t, + H2 ← find_same_type a Hs, + tgt ← target, + pr ← mk_app `absurd [tgt, H2, H1], + exact pr) + <|> contra_A_not_A Rs Hs + +private meta_definition contra_false : list expr → tactic unit +| [] := failed +| (H :: Hs) := + do t ← infer_type H, + if is_false t = tt + then do tgt ← target, + pr ← mk_app `false.rec [tgt, H], + exact pr + else contra_false Hs + +private meta_definition contra_not_a_refl_rel_a : list expr → tactic unit +| [] := failed +| (H :: Hs) := + do t ← infer_type H, + (do (lhs, rhs) ← match_ne t, + unify lhs rhs, + tgt ← target, + refl_pr ← mk_app `eq.refl [lhs], + mk_app `absurd [tgt, refl_pr, H] >>= exact) + <|> + (do p ← match_not t, + (refl_lemma, lhs, rhs) ← match_refl_app p, + unify lhs rhs, + tgt ← target, + refl_pr ← mk_app refl_lemma [lhs], + mk_app `absurd [tgt, refl_pr, H] >>= exact) + <|> + contra_not_a_refl_rel_a Hs + +private meta_definition contra_constructor_eq : list expr → tactic unit +| [] := failed +| (H :: Hs) := + do t ← infer_type H, + match (is_eq t) with + | (some (lhs_0, rhs_0)) := + do env ← get_env, + lhs ← whnf lhs_0, + rhs ← whnf rhs_0, + if is_constructor_app env lhs = tt ∧ + is_constructor_app env rhs = tt ∧ + const_name (get_app_fn lhs) ≠ const_name (get_app_fn rhs) + then do tgt ← target, + I_name ← return $ name.get_prefix (const_name (get_app_fn lhs)), + pr ← mk_app (I_name <.> "no_confusion") [tgt, lhs, rhs, H], + exact pr + else contra_constructor_eq Hs + | none := contra_constructor_eq Hs + end + +meta_definition contradiction : tactic unit := +do ctx ← local_context, + (contra_false ctx <|> + contra_not_a_refl_rel_a ctx <|> + contra_A_not_A ctx ctx <|> + contra_constructor_eq ctx <|> + fail "contradiction tactic failed") + +meta_definition exfalso : tactic unit := +do fail_if_no_goals, + assert `Hfalse (expr.const `false []), + swap, contradiction + +end tactic diff --git a/old_library/init/meta/declaration.lean b/old_library/init/meta/declaration.lean new file mode 100644 index 0000000000..d550a5dd58 --- /dev/null +++ b/old_library/init/meta/declaration.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.expr init.meta.name + +/- +Reducibility hints are used in the convertibility checker. +When trying to solve a constraint such a + + (f ...) =?= (g ...) + +where f and g are definitions, the checker has to decide which one will be unfolded. + If f (g) is opaque, then g (f) is unfolded if it is also not marked as opaque, + Else if f (g) is abbrev, then f (g) is unfolded if g (f) is also not marked as abbrev, + Else if f and g are regular, then we unfold the one with the biggest definitional height. + Otherwise both are unfolded. + +The arguments of the `regular` constructor are: the definitional height and the flag `self_opt`. + +The definitional height is by default computed by the kernel. It only takes into account +other regular definitions used in a definition. When creating declarations using meta-programming, +we can specify the definitional depth manually. + +For definitions marked as regular, we also have a hint for constraints such as + + (f a) =?= (f b) + +if self_opt == true, then checker will first try to solve (a =?= b), only if it fails, +it unfolds f. + +Remark: the hint only affects performance. None of the hints prevent the kernel from unfolding a +declaration during type checking. + +Remark: the reducibility_hints are not related to the attributes: reducible/irrelevance/semireducible. +These attributes are used by the elaborator. The reducibility_hints are used by the kernel (and elaborator). +Moreover, the reducibility_hints cannot be changed after a declaration is added to the kernel. +-/ +inductive reducibility_hints +| opaque : reducibility_hints +| abbrev : reducibility_hints +| regular : nat → bool → reducibility_hints + +/- Reflect a C++ declaration object. The VM replaces it with the C++ implementation. -/ +inductive declaration +/- definition: name, list universe parameters, type, value, is_trusted -/ +| defn : name → list name → expr → expr → reducibility_hints → bool → declaration +/- theorem: name, list universe parameters, type, value (remark: theorems are always trusted) -/ +| thm : name → list name → expr → expr → declaration +/- constant assumption: name, list universe parameters, type, is_trusted -/ +| cnst : name → list name → expr → bool → declaration +/- axiom : name → list universe parameters, type (remark: axioms are always trusted) -/ +| ax : name → list name → expr → declaration + +definition declaration.to_name : declaration → name +| (declaration.defn n ls t v h tr) := n +| (declaration.thm n ls t v) := n +| (declaration.cnst n ls t tr) := n +| (declaration.ax n ls t) := n + +definition declaration.univ_params : declaration → list name +| (declaration.defn n ls t v h tr) := ls +| (declaration.thm n ls t v) := ls +| (declaration.cnst n ls t tr) := ls +| (declaration.ax n ls t) := ls + +definition declaration.type : declaration → expr +| (declaration.defn n ls t v h tr) := t +| (declaration.thm n ls t v) := t +| (declaration.cnst n ls t tr) := t +| (declaration.ax n ls t) := t + +/- Instantiate a universe polymorphic declaration type with the given universes. -/ +meta_constant declaration.instantiate_type_univ_params : declaration → list level → option expr + +/- Instantiate a universe polymorphic declaration value with the given universes. -/ +meta_constant declaration.instantiate_value_univ_params : declaration → list level → option expr diff --git a/old_library/init/meta/default.lean b/old_library/init/meta/default.lean new file mode 100644 index 0000000000..170483c465 --- /dev/null +++ b/old_library/init/meta/default.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.name init.meta.options init.meta.format init.meta.rb_map +import init.meta.level init.meta.expr init.meta.environment init.meta.attribute +import init.meta.tactic init.meta.contradiction_tactic init.meta.constructor_tactic +import init.meta.injection_tactic init.meta.relation_tactics init.meta.fun_info +import init.meta.congr_lemma init.meta.match_tactic init.meta.ac_tactics +import init.meta.backward init.meta.rewrite_tactic init.meta.unfold_tactic +import init.meta.mk_dec_eq_instance init.meta.mk_inhabited_instance +import init.meta.simp_tactic init.meta.defeq_simp_tactic init.meta.set_get_option_tactics diff --git a/old_library/init/meta/defeq_simp_tactic.lean b/old_library/init/meta/defeq_simp_tactic.lean new file mode 100644 index 0000000000..24da667a51 --- /dev/null +++ b/old_library/init/meta/defeq_simp_tactic.lean @@ -0,0 +1,27 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic + +namespace tactic +/- Simplify the given expression using [defeq] lemmas. + The resulting expression is definitionally equal to the input. -/ +meta_constant defeq_simp_core : transparency → expr → tactic expr + +meta_definition defeq_simp : expr → tactic expr := +defeq_simp_core reducible + +meta_definition dsimp : tactic unit := +target >>= defeq_simp >>= change + +meta_definition dsimp_at (H : expr) : tactic unit := +do num_reverted : ℕ ← revert H, + (expr.pi n bi d b : expr) ← target | failed, + H_simp : expr ← defeq_simp d, + change $ expr.pi n bi H_simp b, + intron num_reverted + +end tactic diff --git a/old_library/init/meta/environment.lean b/old_library/init/meta/environment.lean new file mode 100644 index 0000000000..285c5920ee --- /dev/null +++ b/old_library/init/meta/environment.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.declaration init.meta.exceptional + +meta_constant environment : Type + +namespace environment +/- Create a standard environment using the given trust level -/ +meta_constant mk_std : nat → environment +/- Create a HoTT environment -/ +meta_constant mk_hott : nat → environment +/- Return the trust level of the given environment -/ +meta_constant trust_lvl : environment → nat +/- Return tt iff it is a standard environment -/ +meta_constant is_std : environment → bool +/- Add a new declaration to the environment -/ +meta_constant add : environment → declaration → exceptional environment +/- Retrieve a declaration from the environment -/ +meta_constant get : environment → name → exceptional declaration +/- Add a new inductive datatype to the environment + name, universe parameters, number of parameters, type, constructors (name and type) -/ +meta_constant add_inductive : environment → name → list name → nat → expr → list (name × expr) → exceptional environment +/- Return tt iff the given name is an inductive datatype -/ +meta_constant is_inductive : environment → name → bool +/- Return tt iff the given name is a constructor -/ +meta_constant is_constructor : environment → name → bool +/- Return tt iff the given name is a recursor -/ +meta_constant is_recursor : environment → name → bool +/- Return tt iff the given name is a recursive inductive datatype -/ +meta_constant is_recursive : environment → name → bool +/- Return the name of the inductive datatype of the given constructor. -/ +meta_constant inductive_type_of : environment → name → option name +/- Return the constructors of the inductive datatype with the given name -/ +meta_constant constructors_of : environment → name → list name +/- Return the recursor of the given inductive datatype -/ +meta_constant recursor_of : environment → name → option name +/- Return the number of parameters of the inductive datatype -/ +meta_constant inductive_num_params : environment → name → nat +/- Return the number of indices of the inductive datatype -/ +meta_constant inductive_num_indices : environment → name → nat +/- Return tt iff the inductive datatype recursor supports dependent elimination -/ +meta_constant inductive_dep_elim : environment → name → bool +/- Fold over declarations in the environment -/ +meta_constant fold {A :Type} : environment → A → (declaration → A → A) → A +/- (relation_info env n) returns some value if n is marked as a relation in the given environment. + the tuple contains: total number of arguments of the relation, lhs position and rhs position. -/ +meta_constant relation_info : environment → name → option (nat × nat × nat) +/- (refl_for env R) returns the name of the reflexivity theorem for the relation R -/ +meta_constant refl_for : environment → name → option name +/- (symm_for env R) returns the name of the symmetry theorem for the relation R -/ +meta_constant symm_for : environment → name → option name +/- (trans_for env R) returns the name of the transitivity theorem for the relation R -/ +meta_constant trans_for : environment → name → option name +open expr + +meta_definition is_constructor_app (env : environment) (e : expr) : bool := +is_constant (get_app_fn e) && is_constructor env (const_name (get_app_fn e)) + +meta_definition is_refl_app (env : environment) (e : expr) : option (name × expr × expr) := +match (refl_for env (const_name (get_app_fn e))) with +| (some n) := + if get_app_num_args e ≥ 2 + then some (n, app_arg (app_fn e), app_arg e) + else none +| none := none +end +end environment + +attribute [instance] +meta_definition environment.has_to_string : has_to_string environment := +has_to_string.mk (λ e, "[environment]") + +attribute [instance] +meta_definition environment.is_inhabited : inhabited environment := +inhabited.mk (environment.mk_std 0) diff --git a/old_library/init/meta/exceptional.lean b/old_library/init/meta/exceptional.lean new file mode 100644 index 0000000000..f7e4cf020e --- /dev/null +++ b/old_library/init/meta/exceptional.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.monad init.meta.format +/- +Remark: we use a function that produces a format object as the exception information. +Motivation: the formatting object may be big, and we may create it on demand. +-/ +inductive exceptional (A : Type) +| success : A → exceptional +| exception : (options → format) → exceptional + +section +open exceptional +variables {A : Type} +variables [has_to_string A] + +protected meta_definition exceptional.to_string : exceptional A → string +| (success a) := to_string a +| (exception .A e) := "Exception: " ++ to_string (e options.mk) + +attribute [instance] +protected meta_definition exceptional.has_to_string : has_to_string (exceptional A) := +has_to_string.mk exceptional.to_string +end + +namespace exceptional +variables {A B : Type} + +attribute [inline] +protected meta_definition fmap (f : A → B) (e : exceptional A) : exceptional B := +exceptional.cases_on e + (λ a, success (f a)) + (λ f, exception B f) + +attribute [inline] +protected meta_definition bind (e₁ : exceptional A) (e₂ : A → exceptional B) : exceptional B := +exceptional.cases_on e₁ + (λ a, e₂ a) + (λ f, exception B f) + +attribute [inline] +protected meta_definition return (a : A) : exceptional A := +success a + +attribute [inline] +meta_definition fail (f : format) : exceptional A := +exception A (λ u, f) +end exceptional + +attribute [instance] +meta_definition exceptional.is_monad : monad exceptional := +monad.mk @exceptional.fmap @exceptional.return @exceptional.bind diff --git a/old_library/init/meta/expr.lean b/old_library/init/meta/expr.lean new file mode 100644 index 0000000000..673b7d8132 --- /dev/null +++ b/old_library/init/meta/expr.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.level + +inductive binder_info +| default | implicit | strict_implicit | inst_implicit | other + +meta_constant macro_def : Type + +/- Reflect a C++ expr object. The VM replaces it with the C++ implementation. -/ +inductive expr +| var : unsigned → expr +| sort : level → expr +| const : name → list level → expr +| meta : name → expr → expr +| local_const : name → name → binder_info → expr → expr +| app : expr → expr → expr +| lam : name → binder_info → expr → expr → expr +| pi : name → binder_info → expr → expr → expr +| elet : name → expr → expr → expr → expr +| macro : macro_def → ∀ n : unsigned, (fin (unsigned.to_nat n) → expr) → expr + +attribute [instance] +definition expr.is_inhabited : inhabited expr := +inhabited.mk (expr.sort level.zero) + +meta_constant expr.mk_macro (d : macro_def) : list expr → expr +meta_definition expr.mk_var (n : nat) : expr := +expr.var (unsigned.of_nat n) + +meta_constant expr.has_decidable_eq : decidable_eq expr +attribute [instance] expr.has_decidable_eq +meta_constant expr.alpha_eqv : expr → expr → bool +notation a ` =ₐ `:50 b:50 := expr.alpha_eqv a b = bool.tt + +meta_constant expr.to_string : expr → string +attribute [instance] +meta_definition expr.has_to_string : has_to_string expr := +has_to_string.mk expr.to_string + +meta_constant expr.hash : expr → nat + +meta_constant expr.lt : expr → expr → bool +meta_constant expr.lex_lt : expr → expr → bool +meta_definition expr.cmp (a b : expr) : ordering := +if expr.lt a b = bool.tt then ordering.lt +else if a = b then ordering.eq +else ordering.gt + +meta_constant expr.fold {A : Type} : expr → A → (expr → unsigned → A → A) → A + +meta_constant expr.abstract_local : expr → name → expr +meta_constant expr.abstract_locals : expr → list name → expr + +meta_constant expr.instantiate_var : expr → expr → expr +meta_constant expr.instantiate_vars : expr → list expr → expr + +meta_constant expr.has_var : expr → bool +meta_constant expr.has_var_idx : expr → nat → bool +meta_constant expr.has_local : expr → bool +meta_constant expr.has_meta_var : expr → bool +meta_constant expr.lift_vars : expr → nat → nat → expr +meta_constant expr.lower_vars : expr → nat → nat → expr + +namespace expr +open decidable + +meta_definition app_of_list : expr → list expr → expr +| f [] := f +| f (p::ps) := app_of_list (expr.app f p) ps + +meta_definition is_app : expr → bool +| (app f a) := tt +| e := ff + +meta_definition app_fn : expr → expr +| (app f a) := f +| a := a + +meta_definition app_arg : expr → expr +| (app f a) := a +| a := a + +meta_definition get_app_fn : expr → expr +| (app f a) := get_app_fn f +| a := a + +meta_definition get_app_num_args : expr → nat +| (app f a) := get_app_num_args f + 1 +| e := 0 + +meta_definition get_app_args_aux : list expr → expr → list expr +| r (app f a) := get_app_args_aux (a::r) f +| r e := r + +meta_definition get_app_args : expr → list expr := +get_app_args_aux [] + +meta_definition const_name : expr → name +| (const n ls) := n +| e := name.anonymous + +meta_definition is_constant : expr → bool +| (const n ls) := tt +| e := ff + +meta_definition is_local_constant : expr → bool +| (local_const n m bi t) := tt +| e := ff + +meta_definition local_uniq_name : expr → name +| (local_const n m bi t) := n +| e := name.anonymous + +meta_definition local_pp_name : expr → name +| (local_const x n bi t) := n +| e := name.anonymous + +meta_definition is_constant_of : expr → name → bool +| (const n₁ ls) n₂ := to_bool (n₁ = n₂) +| e n := ff + +meta_definition is_app_of (e : expr) (n : name) : bool := +is_app e && is_constant_of (get_app_fn e) n + +meta_definition is_false (e : expr) : bool := +is_constant_of e `false + +meta_definition is_not : expr → option expr +| (app f a) := if is_constant_of f `not = tt then some a else none +| (pi n bi a b) := if is_false b = tt then some a else none +| e := none + +meta_definition is_eq (e : expr) : option (expr × expr) := +if is_app_of e `eq = tt ∧ get_app_num_args e = 3 +then some (app_arg (app_fn e), app_arg e) +else none + +meta_definition is_ne (e : expr) : option (expr × expr) := +if is_app_of e `ne = tt ∧ get_app_num_args e = 3 +then some (app_arg (app_fn e), app_arg e) +else none + +meta_definition is_heq (e : expr) : option (expr × expr × expr × expr) := +if is_app_of e `heq = tt ∧ get_app_num_args e = 4 +then some (app_arg (app_fn (app_fn (app_fn e))), + app_arg (app_fn (app_fn e)), + app_arg (app_fn e), + app_arg e) +else none + +meta_definition is_pi : expr → bool +| (pi n bi d b) := tt +| e := ff + +meta_definition is_let : expr → bool +| (elet n t v b) := tt +| e := ff + +meta_definition binding_name : expr → name +| (pi n m d b) := n +| (lam n m d b) := n +| e := name.anonymous + +meta_definition binding_info : expr → binder_info +| (pi n bi d b) := bi +| (lam n bi d b) := bi +| e := binder_info.default + +meta_definition binding_domain : expr → expr +| (pi n bi d b) := d +| (lam n bi d b) := d +| e := e + +meta_definition binding_body : expr → expr +| (pi n bi d b) := b +| (lam n bi d b) := b +| e := e + +meta_definition prop : expr := expr.sort level.zero + +end expr diff --git a/old_library/init/meta/format.lean b/old_library/init/meta/format.lean new file mode 100644 index 0000000000..be862acca7 --- /dev/null +++ b/old_library/init/meta/format.lean @@ -0,0 +1,158 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.options + +universe variables u v + +inductive format.color +| red | green | orange | blue | pink | cyan | grey + +meta_constant format : Type 1 +meta_constant format.line : format +meta_constant format.space : format +meta_constant format.nil : format +meta_constant format.compose : format → format → format +meta_constant format.nest : nat → format → format +meta_constant format.highlight : format → color → format +meta_constant format.group : format → format +meta_constant format.of_string : string → format +meta_constant format.of_nat : nat → format +meta_constant format.flatten : format → format +meta_constant format.to_string : format → options → string +meta_constant format.of_options : options → format +meta_constant format.is_nil : format → bool +meta_constant trace_fmt {A : Type u} : format → (unit → A) → A + + +attribute [instance] +meta_definition format.is_inhabited : inhabited format := +inhabited.mk format.space + +attribute [instance] +meta_definition format_has_append : has_append format := +has_append.mk format.compose + +attribute [instance] +meta_definition format_has_to_string : has_to_string format := +has_to_string.mk (λ f, format.to_string f options.mk) + +structure [class] has_to_format (A : Type u) := +(to_format : A → format) + +attribute [instance] +meta_definition format_has_to_format : has_to_format format := +has_to_format.mk id + +meta_definition to_fmt {A : Type u} [has_to_format A] : A → format := +has_to_format.to_format + +attribute [instance] +meta_definition coe_nat_to_format : has_coe nat format := +has_coe.mk format.of_nat + +attribute [instance] +meta_definition coe_string_to_format : has_coe string format := +has_coe.mk format.of_string + +open format list + +meta_definition format.when {A : Type u} [has_to_format A] : bool → A → format +| tt a := to_fmt a +| ff a := nil + +attribute [instance] +meta_definition options.has_to_format : has_to_format options := +has_to_format.mk (λ o, format.of_options o) + +attribute [instance] +meta_definition bool.has_to_format : has_to_format bool := +has_to_format.mk (λ b, if b = tt then of_string "tt" else of_string "ff") + +attribute [instance] +meta_definition decidable.has_to_format {p : Prop} : has_to_format (decidable p) := +has_to_format.mk (λ b : decidable p, @ite p b _ (of_string "tt") (of_string "ff")) + +attribute [instance] +meta_definition string.has_to_format : has_to_format string := +has_to_format.mk (λ s, format.of_string s) + +attribute [instance] +meta_definition nat.has_to_format : has_to_format nat := +has_to_format.mk (λ n, format.of_nat n) + +attribute [instance] +meta_definition char.has_to_format : has_to_format char := +has_to_format.mk (λ c : char, format.of_string [c]) + +meta_definition list.to_format_aux {A : Type u} [has_to_format A] : bool → list A → format +| b [] := to_fmt "" +| tt (x::xs) := to_fmt x ++ list.to_format_aux ff xs +| ff (x::xs) := to_fmt "," ++ line ++ to_fmt x ++ list.to_format_aux ff xs + +meta_definition list.to_format {A : Type u} [has_to_format A] : list A → format +| [] := to_fmt "[]" +| (x::xs) := to_fmt "[" ++ group (nest 1 (list.to_format_aux tt (x::xs))) ++ to_fmt "]" + +attribute [instance] +meta_definition list.has_to_format {A : Type u} [has_to_format A] : has_to_format (list A) := +has_to_format.mk list.to_format + +attribute [instance] string.has_to_format + +attribute [instance] +meta_definition name.has_to_format : has_to_format name := +has_to_format.mk (λ n, to_fmt (to_string n)) + +attribute [instance] +meta_definition unit.has_to_format : has_to_format unit := +has_to_format.mk (λ u, to_fmt "()") + +attribute [instance] +meta_definition option.has_to_format {A : Type u} [has_to_format A] : has_to_format (option A) := +has_to_format.mk (λ o, option.cases_on o + (to_fmt "none") + (λ a, to_fmt "(some " ++ nest 6 (to_fmt a) ++ to_fmt ")")) + +attribute [instance] +meta_definition sum.has_to_format {A : Type u} {B : Type v} [has_to_format A] [has_to_format B] : has_to_format (sum A B) := +has_to_format.mk (λ s, sum.cases_on s + (λ a, to_fmt "(inl " ++ nest 5 (to_fmt a) ++ to_fmt ")") + (λ b, to_fmt "(inr " ++ nest 5 (to_fmt b) ++ to_fmt ")")) + +open prod + +attribute [instance] +meta_definition prod.has_to_format {A : Type u} {B : Type v} [has_to_format A] [has_to_format B] : has_to_format (prod A B) := +has_to_format.mk (λ p, group (nest 1 (to_fmt "(" ++ to_fmt (fst p) ++ to_fmt "," ++ line ++ to_fmt (snd p) ++ to_fmt ")"))) + +open sigma + +attribute [instance] +meta_definition sigma.has_to_format {A : Type u} {B : A → Type v} [has_to_format A] [s : ∀ x, has_to_format (B x)] + : has_to_format (sigma B) := +has_to_format.mk (λ p, group (nest 1 (to_fmt "⟨" ++ to_fmt (fst p) ++ to_fmt "," ++ line ++ to_fmt (snd p) ++ to_fmt "⟩"))) + +open subtype + +attribute [instance] +meta_definition subtype.has_to_format {A : Type u} {P : A → Prop} [has_to_format A] : has_to_format (subtype P) := +has_to_format.mk (λ s, to_fmt (elt_of s)) + +meta_definition format.bracket : string → string → format → format +| o c f := to_fmt o ++ nest (utf8_length o) f ++ to_fmt c + +meta_definition format.paren (f : format) : format := +format.bracket "(" ")" f + +meta_definition format.cbrace (f : format) : format := +format.bracket "{" "}" f + +meta_definition format.sbracket (f : format) : format := +format.bracket "[" "]" f + +meta_definition format.dcbrace (f : format) : format := +to_fmt "⦃" ++ nest 1 f ++ to_fmt "⦄" diff --git a/old_library/init/meta/fun_info.lean b/old_library/init/meta/fun_info.lean new file mode 100644 index 0000000000..01697eb335 --- /dev/null +++ b/old_library/init/meta/fun_info.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic init.meta.format init.function + +structure param_info := +(is_implicit : bool) +(is_inst_implicit : bool) +(is_prop : bool) +(has_fwd_deps : bool) +(back_deps : list nat) -- previous parameters it depends on + +open format list decidable + +private meta_definition ppfield {A : Type} [has_to_format A] (fname : string) (v : A) : format := +group $ to_fmt fname ++ space ++ to_fmt ":=" ++ space ++ nest (length fname + 4) (to_fmt v) + +private meta_definition concat_fields (f₁ f₂ : format) : format := +if is_nil f₁ = tt then f₂ +else if is_nil f₂ = tt then f₁ +else f₁ ++ to_fmt "," ++ line ++ f₂ + +local infix `+++`:65 := concat_fields + +meta_definition param_info.to_format : param_info → format +| (param_info.mk i ii p d ds) := +group ∘ cbrace $ + when i "implicit" +++ + when ii "inst_implicit" +++ + when p "prop" +++ + when d "has_fwd_deps" +++ + when (to_bool (length ds > 0)) (to_fmt "back_deps := " ++ to_fmt ds) + +attribute [instance] +meta_definition param_info.has_to_format : has_to_format param_info := +has_to_format.mk param_info.to_format + +structure fun_info := +(params : list param_info) +(result_deps : list nat) -- parameters the result type depends on + +meta_definition fun_info_to_format : fun_info → format +| (fun_info.mk ps ds) := +group ∘ dcbrace $ + ppfield "params" ps +++ + ppfield "result_deps" ds + +attribute [instance] +meta_definition fun_info_has_to_format : has_to_format fun_info := +has_to_format.mk fun_info_to_format + +/- + specialized is true if the result of fun_info has been specifialized + using this argument. + For example, consider the function + + f : Pi (A : Type), A -> A + + Now, suppse we request get_specialize fun_info for the application + + f unit a + + fun_info_manager returns two param_info objects: + 1) specialized = true + 2) is_subsingleton = true + + Note that, in general, the second argument of f is not a subsingleton, + but it is in this particular case/specialization. + + \remark This bit is only set if it is a dependent parameter. + + Moreover, we only set is_specialized IF another parameter + becomes a subsingleton -/ +structure subsingleton_info := +(specialized : bool) +(is_subsingleton : bool) + +meta_definition subsingleton_info_to_format : subsingleton_info → format +| (subsingleton_info.mk s ss) := +group ∘ cbrace $ + when s "specialized" +++ + when ss "subsingleton" + +attribute [instance] +meta_definition subsingleton_info_has_to_format : has_to_format subsingleton_info := +has_to_format.mk subsingleton_info_to_format + +namespace tactic +meta_constant get_fun_info_core : transparency → expr → tactic fun_info +/- (get_fun_info fn n) return information assuming the function has only n arguments. + The tactic fail if n > length (params (get_fun_info fn)) -/ +meta_constant get_fun_info_n_core : transparency → expr → nat → tactic fun_info + +meta_constant get_subsingleton_info_core : transparency → expr → tactic (list subsingleton_info) +meta_constant get_subsingleton_info_n_core : transparency → expr → nat → tactic (list subsingleton_info) + +/- (get_spec_subsingleton_info t) return subsingleton parameter + information for the function application t of the form + (f a_1 ... a_n). + This tactic is more precise than (get_subsingleton_info f) and (get_subsingleton_info_n f n) + + Example: given (f : Pi (A : Type), A -> A), \c get_spec_subsingleton_info for + + f unit b + + returns a fun_info with two param_info + 1) specialized = tt + 2) is_subsingleton = tt + + The second argument is marked as subsingleton only because the resulting information + is taking into account the first argument. -/ +meta_constant get_spec_subsingleton_info_core : transparency → expr → tactic (list subsingleton_info) +meta_constant get_spec_prefix_size_core : transparency → expr → nat → tactic nat + +meta_definition get_fun_info : expr → tactic fun_info := +get_fun_info_core semireducible + +meta_definition get_fun_info_n : expr → nat → tactic fun_info := +get_fun_info_n_core semireducible + +meta_definition get_subsingleton_info : expr → tactic (list subsingleton_info) := +get_subsingleton_info_core semireducible + +meta_definition get_subsingleton_info_n : expr → nat → tactic (list subsingleton_info) := +get_subsingleton_info_n_core semireducible + +meta_definition get_spec_subsingleton_info : expr → tactic (list subsingleton_info) := +get_spec_subsingleton_info_core semireducible + +meta_definition get_spec_prefix_size : expr → nat → tactic nat := +get_spec_prefix_size_core semireducible +end tactic diff --git a/old_library/init/meta/injection_tactic.lean b/old_library/init/meta/injection_tactic.lean new file mode 100644 index 0000000000..75e35bcead --- /dev/null +++ b/old_library/init/meta/injection_tactic.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic init.function + +namespace tactic +open nat tactic environment expr list + +private meta_definition mk_intro_name : name → list name → name +| n₁ (n₂ :: ns) := n₂ +| n [] := if n = `a then `H else n + +-- Auxiliary function for introducing the new equalities produced by the +-- injection tactic +private meta_definition injection_intro : expr → list name → tactic unit +| (pi n bi b d) ns := do + Hname ← return $ mk_intro_name n ns, + H ← intro Hname, + Ht ← infer_type H, + -- Clear new hypothesis if it is of the form (a = a) + @try unit $ do { + (lhs, rhs) ← match_eq Ht, + unify lhs rhs, + clear H }, + -- If new hypothesis is of the form (@heq A a B b) where + -- A and B can be unified then convert it into (a = b) using + -- the eq_of_heq lemma + @try unit $ do { + (A, lhs, B, rhs) ← match_heq Ht, + unify A B, + Heq ← mk_app `eq [lhs, rhs], + pr ← mk_app `eq_of_heq [H], + assertv Hname Heq pr, + clear H }, + injection_intro d (tail ns) +| e ns := skip + +meta_definition injection_with (H : expr) (ns : list name) : tactic unit := +do + Ht ← infer_type H, + (lhs, rhs) ← match_eq Ht, + env ← get_env, + if is_constructor_app env lhs = tt ∧ + is_constructor_app env rhs = tt ∧ + const_name (get_app_fn lhs) = const_name (get_app_fn rhs) + then do + tgt ← target, + I_name ← return $ name.get_prefix (const_name (get_app_fn lhs)), + pr ← mk_app (I_name <.> "no_confusion") [tgt, lhs, rhs, H], + pr_type ← infer_type pr, + pr_type ← whnf pr_type, + apply pr, + injection_intro (binding_domain pr_type) ns + else fail "injection tactic failed, argument must be an equality proof where lhs and rhs are of the form (c ...), where c is a constructor" + +meta_definition injection (H : expr) : tactic unit := +injection_with H [] + +end tactic diff --git a/old_library/init/meta/level.lean b/old_library/init/meta/level.lean new file mode 100644 index 0000000000..f0459135dc --- /dev/null +++ b/old_library/init/meta/level.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.name init.meta.format + +/- Reflect a C++ level object. The VM replaces it with the C++ implementation. -/ +inductive level +| zero : level +| succ : level → level +| max : level → level → level +| imax : level → level → level +| param : name → level +| global : name → level +| meta : name → level + +attribute [instance] +definition level.is_inhabited : inhabited level := +inhabited.mk level.zero + +/- TODO(Leo): provide a definition in Lean. -/ +meta_constant level.has_decidable_eq : decidable_eq level +attribute [instance] level.has_decidable_eq +meta_constant level.lt : level → level → bool +meta_constant level.lex_lt : level → level → bool +meta_constant level.fold {A :Type} : level → A → (level → A → A) → A +/- Return the given level expression normal form -/ +meta_constant level.normalize : level → level +/- Return tt iff lhs and rhs denote the same level. + The check is done by normalization. -/ +meta_constant level.eqv : level → level → bool +/- Return tt iff the first level occurs in the second -/ +meta_constant level.occurs : level → level → bool +/- Replace a parameter named n with l in the first level if the list contains the pair (n, l) -/ +meta_constant level.instantiate : level → list (name × level) → list level +meta_constant level.to_format : level → options → format +meta_constant level.to_string : level → string + +meta_definition level.cmp (a b : level) : ordering := +if level.lt a b = bool.tt then ordering.lt +else if a = b then ordering.eq +else ordering.gt + +attribute [instance] +meta_definition level.has_to_string : has_to_string level := +has_to_string.mk level.to_string + +attribute [instance] +meta_definition level.has_to_format : has_to_format level := +has_to_format.mk (λ l, level.to_format l options.mk) + +attribute [instance] +meta_definition level.has_to_cmp : has_ordering level := +has_ordering.mk level.cmp + +meta_definition level.of_nat : nat → level +| 0 := level.zero +| (nat.succ n) := level.succ (level.of_nat n) + +open decidable +meta_definition level.has_param : level → name → bool +| (level.succ l) n := level.has_param l n +| (level.max l₁ l₂) n := level.has_param l₁ n || level.has_param l₂ n +| (level.imax l₁ l₂) n := level.has_param l₁ n || level.has_param l₂ n +| (level.param n₁) n := to_bool (n₁ = n) +| l n := ff diff --git a/old_library/init/meta/match_tactic.lean b/old_library/init/meta/match_tactic.lean new file mode 100644 index 0000000000..fb27fc78a9 --- /dev/null +++ b/old_library/init/meta/match_tactic.lean @@ -0,0 +1,103 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic init.function + +namespace tactic +structure pattern := +/- Term to match. -/ +(target : expr) +/- Set of terms that is instantiated for each successful match. -/ +(output : list expr) +/- Number of (temporary) universe meta-variables in this pattern. -/ +(nuvars : nat) +/- Number of (temporary) meta-variables in this pattern. -/ +(nmvars : nat) + +/- (mk_pattern ls es t o) creates a new pattern with (length ls) universe meta-variables and (length es) meta-variables. + In the produced pattern p, we have that + - (pattern.target p) is the term t where the universes ls and expressions es have been replaced with temporary meta-variables. + - (pattern.output p) is the list o where the universes ls and expressions es have been replaced with temporary meta-variables. + - (pattern.nuvars p) = length ls + - (pattern.nmvars p) = length es + + The tactic fails if o and the types of es do not contain all universes ls and expressions es. -/ +meta_constant mk_pattern : list level → list expr → expr → list expr → tactic pattern +/- (mk_pattern_core m p e) matches (pattern.target p) and e using transparency m. + If the matching is successful, then return the instantiation of (pattern.output p). + The tactic fails if not all (temporary) meta-variables are assigned. -/ +meta_constant match_pattern_core : transparency → pattern → expr → tactic (list expr) + +meta_definition match_pattern : pattern → expr → tactic (list expr) := +match_pattern_core semireducible + +open expr + +/- Helper function for converting a term (λ x_1 ... x_n, t) into a pattern + where x_1 ... x_n are metavariables -/ +private meta_definition to_pattern_core : expr → tactic (expr × list expr) +| (lam n bi d b) := do + id ← mk_fresh_name, + x ← return $ local_const id n bi d, + new_b ← return $ instantiate_var b x, + (p, xs) ← to_pattern_core new_b, + return (p, x::xs) +| e := return (e, []) + +/- Given a pre-term of the form (λ x_1 ... x_n, t[x_1, ..., x_n]), converts it + into the pattern t[?x_1, ..., ?x_n] -/ +meta_definition pexpr_to_pattern (p : pexpr) : tactic pattern := +do e ← to_expr p, + (new_p, xs) ← to_pattern_core e, + mk_pattern [] xs new_p xs + +/- Convert pre-term into a pattern and try to match e. + Given p of the form (λ x_1 ... x_n, t[x_1, ..., x_n]), a successful + match will produce a list of length n. -/ +meta_definition match_expr (p : pexpr) (e : expr) : tactic (list expr) := +do new_p ← pexpr_to_pattern p, + match_pattern new_p e + +private meta_definition match_subexpr_core : pattern → list expr → tactic (list expr) +| p [] := failed +| p (e::es) := + match_pattern p e + <|> + match_subexpr_core p es + <|> + if (is_app e = tt) then match_subexpr_core p (get_app_args e) + else failed + +/- Similar to match_expr, but it tries to match a subexpression of e. + Remark: the procedure does not go inside binders. -/ +meta_definition match_subexpr (p : pexpr) (e : expr) : tactic (list expr) := +do new_p ← pexpr_to_pattern p, + match_subexpr_core new_p [e] + +/- Match the main goal target. -/ +meta_definition match_target (p : pexpr) : tactic (list expr) := +target >>= match_expr p + +/- Match a subterm in the main goal target. -/ +meta_definition match_target_subexpr (p : pexpr) : tactic (list expr) := +target >>= match_subexpr p + +private meta_definition match_hypothesis_core : pattern → list expr → tactic (expr × list expr) +| p [] := failed +| p (h::hs) := do + h_type ← infer_type h, + (do r ← match_pattern p h_type, return (h, r)) + <|> + match_hypothesis_core p hs + +/- Match hypothesis in the main goal target. + The result is pair (hypothesis, substitution). -/ +meta_definition match_hypothesis (p : pexpr) : tactic (expr × list expr) := +do ctx ← local_context, + new_p ← pexpr_to_pattern p, + match_hypothesis_core new_p ctx + +end tactic diff --git a/old_library/init/meta/mk_dec_eq_instance.lean b/old_library/init/meta/mk_dec_eq_instance.lean new file mode 100644 index 0000000000..572e6e5085 --- /dev/null +++ b/old_library/init/meta/mk_dec_eq_instance.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Helper tactic for showing that a type has decidable equality. +-/ +prelude +import init.meta.contradiction_tactic init.meta.constructor_tactic +import init.meta.injection_tactic init.meta.relation_tactics +import init.meta.rec_util + +namespace tactic +open expr environment list + +/- Retrieve the name of the type we are building a decidable equality proof for. -/ +private meta_definition get_dec_eq_type_name : tactic name := +do { + (pi x1 i1 d1 (pi x2 i2 d2 b)) ← target >>= whnf | failed, + (const n ls) ← return (get_app_fn b) | failed, + when (n ≠ `decidable) failed, + (const I ls) ← return (get_app_fn d1) | failed, + return I } +<|> +fail "mk_dec_eq_instance tactic failed, target type is expected to be of the form (decidable_eq ...)" + +/- Extract (lhs, rhs) from a goal (decidable (lhs = rhs)) -/ +private meta_definition get_lhs_rhs : tactic (expr × expr) := +do + (app dec lhs_eq_rhs) ← target | fail "mk_dec_eq_instance failed, unexpected case", + match_eq lhs_eq_rhs + +private meta_definition find_next_target : list expr → list expr → tactic (expr × expr) +| (t::ts) (r::rs) := if t = r then find_next_target ts rs else return (t, r) +| l1 l2 := failed + +/- Create an inhabitant of (decidable (lhs = rhs)) -/ +private meta_definition mk_dec_eq_for (lhs : expr) (rhs : expr) : tactic expr := +do lhs_type ← infer_type lhs, + dec_type ← mk_app `decidable_eq [lhs_type] >>= whnf, + do { + inst : expr ← mk_instance dec_type, + return $ app_of_list inst [lhs, rhs] } + <|> + do { + f ← pp dec_type, + fail $ to_fmt "mk_dec_eq_instance failed, failed to generate instance for" ++ format.nest 2 (format.line ++ f) } + +/- Target is of the form (decidable (C ... = C ...)) where C is a constructor -/ +private meta_definition dec_eq_same_constructor : name → name → nat → tactic unit +| I_name F_name num_rec := +do + (lhs, rhs) ← get_lhs_rhs, + -- Try easy case first, where the proof is just reflexivity + (unify lhs rhs >> right >> reflexivity) + <|> + do { + lhs_list : list expr ← return $ get_app_args lhs, + rhs_list : list expr ← return $ get_app_args rhs, + when (length lhs_list ≠ length rhs_list) (fail "mk_dec_eq_instance failed, constructor applications have different number of arguments"), + (lhs_arg, rhs_arg) ← find_next_target lhs_list rhs_list, + rec ← is_type_app_of lhs_arg I_name, + inst ← if rec = tt + then do { + inst_fn : expr ← mk_brec_on_rec_value F_name num_rec, + return $ app inst_fn rhs_arg } + else do { + mk_dec_eq_for lhs_arg rhs_arg + }, + tgt ← target, + by_cases ← mk_mapp_core transparency.all `decidable.by_cases [none, some tgt, some inst], + apply by_cases, + -- discharge first (positive) case by recursion + intro1 >>= subst >> dec_eq_same_constructor I_name F_name (if rec = tt then num_rec + 1 else num_rec), + -- discharge second (negative) case by contradiction + intro1, left, -- decidable.is_false + intro1 >>= injection, + intros, contradiction, + return () } + +/- Easy case: target is of the form (decidable (C_1 ... = C_2 ...)) where C_1 and C_2 are distinct constructors -/ +private meta_definition dec_eq_diff_constructor : tactic unit := +left >> intron 1 >> contradiction + +/- This tactic is invoked for each case of decidable_eq. There n^2 cases, where n is the number + of constructors. -/ +private meta_definition dec_eq_case_2 (I_name : name) (F_name : name) : tactic unit := +do + (lhs, rhs) ← get_lhs_rhs, + lhs_fn : expr ← return $ get_app_fn lhs, + rhs_fn : expr ← return $ get_app_fn rhs, + if lhs_fn = rhs_fn + then dec_eq_same_constructor I_name F_name 0 + else dec_eq_diff_constructor + +private meta_definition dec_eq_case_1 (I_name : name) (F_name : name) : tactic unit := +intro `w >>= cases >> all_goals (dec_eq_case_2 I_name F_name) + +meta_definition mk_dec_eq_instance : tactic unit := +do I_name ← get_dec_eq_type_name, + env ← get_env, + v_name ← return `_v, + F_name ← return `_F, + -- Use brec_on if type is recursive. + -- We store the functional in the variable F. + if (is_recursive env I_name = tt) + then intro1 >>= (λ x, induction_core semireducible x (I_name <.> "brec_on") [v_name, F_name]) + else intro v_name >> return (), + -- Apply cases to first element of type (I ...) + get_local v_name >>= cases, + all_goals (dec_eq_case_1 I_name F_name) + +end tactic diff --git a/old_library/init/meta/mk_has_sizeof_instance.lean b/old_library/init/meta/mk_has_sizeof_instance.lean new file mode 100644 index 0000000000..c60eba4e07 --- /dev/null +++ b/old_library/init/meta/mk_has_sizeof_instance.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Helper tactic for constructing has_sizeof instance. +-/ +prelude +import init.meta.rec_util init.combinator +import init.meta.constructor_tactic + +namespace tactic +open expr environment list + +/- Retrieve the name of the type we are building a has_sizeof instance for. -/ +private meta_definition get_has_sizeof_type_name : tactic name := +do { + (app (const n ls) t) ← target >>= whnf | failed, + when (n ≠ `has_sizeof) failed, + (const I ls) ← return (get_app_fn t) | failed, + return I } +<|> +fail "mk_has_sizeof_instance tactic failed, target type is expected to be of the form (has_sizeof ...)" + +/- Try to synthesize constructor argument using type class resolution -/ +private meta_definition mk_has_sizeof_instance_for (a : expr) (use_default : bool) : tactic expr := +do t ← infer_type a, + do { + m ← mk_app `has_sizeof [t], + inst ← mk_instance m, + mk_app `sizeof [t, inst, a] } + <|> + if use_default = tt + then return (const `nat.zero []) + else do + f ← pp t, + fail (to_fmt "mk_has_sizeof_instance failed, failed to generate instance for" ++ format.nest 2 (format.line ++ f)) + +private meta_definition mk_sizeof : bool → name → name → list name → nat → tactic (list expr) +| use_default I_name F_name [] num_rec := return [] +| use_default I_name F_name (fname::fnames) num_rec := do + field ← get_local fname, + rec ← is_type_app_of field I_name, + sz ← if rec = tt then mk_brec_on_rec_value F_name num_rec else mk_has_sizeof_instance_for field use_default, + szs ← mk_sizeof use_default I_name F_name fnames (if rec = tt then num_rec + 1 else num_rec), + return (sz :: szs) + +private meta_definition mk_sum : list expr → expr +| [] := app (const `nat.succ []) (const `nat.zero []) +| (e::es) := app (app (const `nat.add []) e) (mk_sum es) + +private meta_definition has_sizeof_case (use_default : bool) (I_name F_name : name) (field_names : list name) : tactic unit := +do szs ← mk_sizeof use_default I_name F_name field_names 0, + exact (mk_sum szs) + +private meta_definition for_each_has_sizeof_goal : bool → name → name → list (list name) → tactic unit +| d I_name F_name [] := now <|> fail "mk_has_sizeof_instance failed, unexpected number of cases" +| d I_name F_name (ns::nss) := do + solve1 (has_sizeof_case d I_name F_name ns), + for_each_has_sizeof_goal d I_name F_name nss + +meta_definition mk_has_sizeof_instance_core (use_default : bool) : tactic unit := +do I_name ← get_has_sizeof_type_name, + constructor, + env ← get_env, + v_name : name ← return `_v, + F_name : name ← return `_F, + -- Use brec_on if type is recursive. + -- We store the functional in the variable F. + if (is_recursive env I_name = tt) + then intro `_v >>= (λ x, induction_core semireducible x (I_name <.> "brec_on") [v_name, F_name]) + else intro v_name >> return (), + arg_names : list (list name) ← mk_constructors_arg_names I_name `_p, + get_local v_name >>= λ v, cases_using v (join arg_names), + for_each_has_sizeof_goal use_default I_name F_name arg_names + + +meta_definition mk_has_sizeof_instance : tactic unit := +mk_has_sizeof_instance_core ff + +end tactic diff --git a/old_library/init/meta/mk_inhabited_instance.lean b/old_library/init/meta/mk_inhabited_instance.lean new file mode 100644 index 0000000000..68d4502f66 --- /dev/null +++ b/old_library/init/meta/mk_inhabited_instance.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Helper tactic for showing that a type has decidable equality. +-/ +prelude +import init.meta.contradiction_tactic init.meta.constructor_tactic +import init.meta.injection_tactic init.meta.relation_tactics + +namespace tactic +open expr environment list + +/- Retrieve the name of the type we are building an inhabitant instance for. -/ +private meta_definition get_inhabited_type_name : tactic name := +do { + (app (const n ls) t) ← target >>= whnf | failed, + when (n ≠ `inhabited) failed, + (const I ls) ← return (get_app_fn t) | failed, + return I } +<|> +fail "mk_inhabited_instance tactic failed, target type is expected to be of the form (inhabited ...)" + +/- Try to synthesize constructor argument using type class resolution -/ +private meta_definition mk_inhabited_arg : tactic unit := +do tgt ← target, + inh ← mk_app `inhabited [tgt], + inst ← mk_instance inh, + mk_app `inhabited.value [inst] >>= exact + +private meta_definition try_constructors : nat → nat → tactic unit +| 0 n := failed +| (i+1) n := + do {constructor_idx (n - i), all_goals mk_inhabited_arg, now} + <|> + try_constructors i n + +meta_definition mk_inhabited_instance : tactic unit := +do + I ← get_inhabited_type_name, + env ← get_env, + n : nat ← return $ length (constructors_of env I), + when (n = 0) (fail $ "mk_inhabited_instance failed, type '" ++ to_string I ++ "' does not have constructors"), + constructor, + (try_constructors n n) + <|> + (fail $ "mk_inhabited_instance failed, failed to build instance using all constructors of '" ++ to_string I ++ "'") + +end tactic diff --git a/old_library/init/meta/name.lean b/old_library/init/meta/name.lean new file mode 100644 index 0000000000..561742ac38 --- /dev/null +++ b/old_library/init/meta/name.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.ordering init.coe + +/- Reflect a C++ name object. The VM replaces it with the C++ implementation. -/ +inductive name +| anonymous : name +| mk_string : string → name → name +| mk_numeral : unsigned → name → name + +attribute [instance] +definition name.is_inhabited : inhabited name := +inhabited.mk name.anonymous + +definition mk_str_name (n : name) (s : string) : name := +name.mk_string s n + +definition mk_num_name (n : name) (v : nat) : name := +name.mk_numeral (unsigned.of_nat v) n + +definition mk_simple_name (s : string) : name := +mk_str_name name.anonymous s + +attribute [instance] +definition coe_string_to_name : has_coe string name := +has_coe.mk mk_simple_name + +infix ` <.> `:65 := mk_str_name + +open name + +definition name.get_prefix : name → name +| anonymous := anonymous +| (mk_string s p) := p +| (mk_numeral s p) := p + +definition name.to_string : name → string +| anonymous := "[anonymous]" +| (mk_string s anonymous) := s +| (mk_numeral v anonymous) := to_string v +| (mk_string s n) := name.to_string n ++ "." ++ s +| (mk_numeral v n) := name.to_string n ++ "." ++ to_string v + +attribute [instance] +definition name.has_to_string : has_to_string name := +has_to_string.mk name.to_string + +/- TODO(Leo): provide a definition in Lean. -/ +meta_constant name.has_decidable_eq : decidable_eq name +/- Both cmp and lex_cmp are total orders, but lex_cmp implements a lexicographical order. -/ +meta_constant name.cmp : name → name → ordering +meta_constant name.lex_cmp : name → name → ordering + +attribute [instance] name.has_decidable_eq + +attribute [instance] +meta_definition name_has_ordering : has_ordering name := +has_ordering.mk name.cmp + +/- (name.append_after n i) return a name of the form n_i -/ +meta_constant name.append_after : name → nat → name diff --git a/old_library/init/meta/occurrences.lean b/old_library/init/meta/occurrences.lean new file mode 100644 index 0000000000..268fc03989 --- /dev/null +++ b/old_library/init/meta/occurrences.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.logic init.to_string init.meta.format +import init.meta.contradiction_tactic init.meta.constructor_tactic +import init.meta.relation_tactics init.meta.injection_tactic + +/- We can specify the scope of application of some tactics using + the following type. + + - all : all occurrences of a given term are considered. + + - pos [1, 3] : only the first and third occurrences of a given + term are consiered. + + - neg [2] : all but the second occurrence of a given term + are considered. -/ +inductive occurrences +| all +| pos : list nat → occurrences +| neg : list nat → occurrences + +open occurrences + +attribute [instance] +definition occurrences_is_inhabited : inhabited occurrences := +inhabited.mk all + +definition occurrences_to_string : occurrences → string +| occurrences.all := "*" +| (occurrences.pos l) := to_string l +| (occurrences.neg l) := "-" ++ to_string l + +attribute [instance] +definition occurrences_has_to_string : has_to_string occurrences := +has_to_string.mk occurrences_to_string + +meta_definition occurrences_to_format : occurrences → format +| occurrences.all := to_fmt "*" +| (occurrences.pos l) := to_fmt l +| (occurrences.neg l) := to_fmt "-" ++ to_fmt l + +attribute [instance] +meta_definition occurrences_has_to_format : has_to_format occurrences := +has_to_format.mk occurrences_to_format + +open decidable tactic diff --git a/old_library/init/meta/options.lean b/old_library/init/meta/options.lean new file mode 100644 index 0000000000..4c4d06b9a6 --- /dev/null +++ b/old_library/init/meta/options.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.name +universe variables u +meta_constant options : Type 1 +meta_constant options.size : options → nat +meta_constant options.mk : options +meta_constant options.contains : options → name → bool +meta_constant options.set_bool : options → name → bool → options +meta_constant options.set_nat : options → name → nat → options +meta_constant options.set_string : options → name → string → options +meta_constant options.get_bool : options → name → bool → bool +meta_constant options.get_nat : options → name → nat → nat +meta_constant options.get_string : options → name → string → string +meta_constant options.join : options → options → options +meta_constant options.fold {A : Type u} : options → A → (name → A → A) → A +meta_constant options.has_decidable_eq : decidable_eq options + +attribute [instance] options.has_decidable_eq + +attribute [instance] +meta_definition options.has_add : has_add options := +has_add.mk options.join + +attribute [instance] +meta_definition options.is_inhabited : inhabited options := +inhabited.mk options.mk diff --git a/old_library/init/meta/pexpr.lean b/old_library/init/meta/pexpr.lean new file mode 100644 index 0000000000..2f79d1f68a --- /dev/null +++ b/old_library/init/meta/pexpr.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.expr +universe variables u + +/- Quoted expressions. They can be converted into expressions by using a tactic. -/ +meta_constant pexpr : Type +protected meta_constant pexpr.of_expr : expr → pexpr +protected meta_constant pexpr.subst : pexpr → pexpr → pexpr + +meta_constant pexpr.to_string : pexpr → string +attribute [instance] +meta_definition pexpr.has_to_string : has_to_string pexpr := +has_to_string.mk pexpr.to_string + +structure [class] has_to_pexpr (A : Type u) := +(to_pexpr : A → pexpr) + +meta_definition to_pexpr {A : Type u} [has_to_pexpr A] : A → pexpr := +has_to_pexpr.to_pexpr + +attribute [instance] +meta_definition pexpr.has_to_pexpr : has_to_pexpr pexpr := +has_to_pexpr.mk id + +attribute [instance] +meta_definition expr.has_to_pexpr : has_to_pexpr expr := +has_to_pexpr.mk pexpr.of_expr diff --git a/old_library/init/meta/rb_map.lean b/old_library/init/meta/rb_map.lean new file mode 100644 index 0000000000..c4c3b33987 --- /dev/null +++ b/old_library/init/meta/rb_map.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad +-/ +prelude +import init.ordering init.meta.name init.meta.format + +meta_constant {u₁ u₂} rb_map : Type u₁ → Type u₂ → Type (max u₁ u₂ 1) + +namespace rb_map +meta_constant mk_core {key : Type} (data : Type) : (key → key → ordering) → rb_map key data +meta_constant size {key : Type} {data : Type} : rb_map key data → nat +meta_constant insert {key : Type} {data : Type} : rb_map key data → key → data → rb_map key data +meta_constant erase {key : Type} {data : Type} : rb_map key data → key → rb_map key data +meta_constant contains {key : Type} {data : Type} : rb_map key data → key → bool +meta_constant find {key : Type} {data : Type} : rb_map key data → key → option data +meta_constant min {key : Type} {data : Type} : rb_map key data → option data +meta_constant max {key : Type} {data : Type} : rb_map key data → option data +meta_constant fold {key : Type} {data : Type} {A :Type} : rb_map key data → A → (key → data → A → A) → A + +attribute [inline] +meta_definition mk (key : Type) [has_ordering key] (data : Type) : rb_map key data := +mk_core data has_ordering.cmp + +open list +meta_definition of_list {key : Type} {data : Type} [has_ordering key] : list (key × data) → rb_map key data +| [] := mk key data +| ((k, v)::ls) := insert (of_list ls) k v + +end rb_map + +attribute [reducible] +meta_definition nat_map (data : Type) := rb_map nat data +namespace nat_map + export rb_map (hiding mk) + + attribute [inline] + meta_definition mk (data : Type) : nat_map data := + rb_map.mk nat data +end nat_map + +attribute [reducible] +meta_definition name_map (data : Type) := rb_map name data +namespace name_map + export rb_map (hiding mk) + + attribute [inline] + meta_definition mk (data : Type) : name_map data := + rb_map.mk name data +end name_map + +open rb_map prod +section +open format +variables {key : Type} {data : Type} [has_to_format key] [has_to_format data] +private meta_definition format_key_data (k : key) (d : data) (first : bool) : format := +(if first = tt then to_fmt "" else to_fmt "," ++ line) ++ to_fmt k ++ space ++ to_fmt "←" ++ space ++ to_fmt d + +attribute [instance] +meta_definition rb_map_has_to_format : has_to_format (rb_map key data) := +has_to_format.mk (λ m, + group (to_fmt "⟨" ++ nest 1 (fst (fold m (to_fmt "", tt) (λ k d p, (fst p ++ format_key_data k d (snd p), ff)))) ++ + to_fmt "⟩")) +end + +section +variables {key : Type} {data : Type} [has_to_string key] [has_to_string data] +private meta_definition key_data_to_string (k : key) (d : data) (first : bool) : string := +(if first = tt then "" else ", ") ++ to_string k ++ " ← " ++ to_string d + +attribute [instance] +meta_definition rb_map_has_to_string : has_to_string (rb_map key data) := +has_to_string.mk (λ m, + "⟨" ++ (fst (fold m ("", tt) (λ k d p, (fst p ++ key_data_to_string k d (snd p), ff)))) ++ "⟩") +end + +/- a variant of rb_maps that stores a list of elements for each key. + "find" returns the list of elements in the opposite order that they were inserted. -/ + +meta_definition rb_lmap (key : Type) (data : Type) : Type := rb_map key (list data) + +namespace rb_lmap + +protected meta_definition mk (key : Type) [has_ordering key] (data : Type) : rb_lmap key data := +rb_map.mk key (list data) + +meta_definition insert {key : Type} {data : Type} (rbl : rb_lmap key data) (k : key) (d : data) : + rb_lmap key data := +match (rb_map.find rbl k) with +| none := rb_map.insert rbl k [d] +| (some l) := rb_map.insert (rb_map.erase rbl k) k (d :: l) +end + +meta_definition erase {key : Type} {data : Type} (rbl : rb_lmap key data) (k : key) : + rb_lmap key data := +rb_map.erase rbl k + +meta_definition contains {key : Type} {data : Type} (rbl : rb_lmap key data) (k : key) : bool := +rb_map.contains rbl k + +meta_definition find {key : Type} {data : Type} (rbl : rb_lmap key data) (k : key) : list data := +match (rb_map.find rbl k) with +| none := [] +| (some l) := l +end + +end rb_lmap diff --git a/old_library/init/meta/rec_util.lean b/old_library/init/meta/rec_util.lean new file mode 100644 index 0000000000..96c7322c62 --- /dev/null +++ b/old_library/init/meta/rec_util.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura + +Helper tactic for showing that a type has decidable equality. +-/ +prelude +import init.meta.tactic + +namespace tactic +open expr + +/- Return tt iff e's type is of the form `(I_name ...)` -/ +meta_definition is_type_app_of (e : expr) (I_name : name) : tactic bool := +do t ← infer_type e, + return $ is_constant_of (get_app_fn t) I_name + +/- Auxiliary function for using brec_on "dictionary" -/ +private meta_definition mk_rec_inst_aux : expr → nat → tactic expr +| F 0 := do + P ← mk_app `prod.fst [F], + mk_app `prod.fst [P] +| F (n+1) := do + F' ← mk_app `prod.snd [F], + mk_rec_inst_aux F' n + +/- Construct brec_on "recursive value". F_name is the name of the brec_on "dictionary". + Type of the F_name hypothesis should be of the form (below (C ...)) where C is a constructor. + The result is the "recursive value" for the (i+1)-th recursive value of the constructor C. -/ +meta_definition mk_brec_on_rec_value (F_name : name) (i : nat) : tactic expr := +do F ← get_local F_name, + mk_rec_inst_aux F i + +meta_definition constructor_num_fields (c : name) : tactic nat := +do env ← get_env, + decl ← returnex $ environment.get env c, + ctype ← return $ declaration.type decl, + arity ← get_pi_arity ctype, + I ← returnopt $ environment.inductive_type_of env c, + nparams ← return (environment.inductive_num_params env I), + return $ arity - nparams + +private meta_definition mk_name_list_aux : name → nat → nat → list name → list name × nat +| p i 0 l := (list.reverse l, i) +| p i (j+1) l := mk_name_list_aux p (i+1) j (mk_num_name p i :: l) + +private meta_definition mk_name_list (p : name) (i : nat) (n : nat) : list name × nat := +mk_name_list_aux p i n [] + +/- Return a list of names of the form [p.i, ..., p.{i+n}] where n is + the number of fields of the constructor c -/ +meta_definition mk_constructor_arg_names (c : name) (p : name) (i : nat) : tactic (list name × nat) := +do nfields ← constructor_num_fields c, + return $ mk_name_list p i nfields + +private meta_definition mk_constructors_arg_names_aux : list name → name → nat → list (list name) → tactic (list (list name)) +| [] p i r := return (list.reverse r) +| (c::cs) p i r := do + v : list name × nat ← mk_constructor_arg_names c p i, + match v with (l, i') := mk_constructors_arg_names_aux cs p i' (l :: r) end + +/- Given an inductive datatype I with k constructors and where constructor i has n_i fields, + return the list [[p.1, ..., p.n_1], [p.{n_1 + 1}, ..., p.{n_1 + n_2}], ..., [..., p.{n_1 + ... + n_k}]] -/ +meta_definition mk_constructors_arg_names (I : name) (p : name) : tactic (list (list name)) := +do env ← get_env, + cs ← return $ environment.constructors_of env I, + mk_constructors_arg_names_aux cs p 1 [] + +end tactic diff --git a/old_library/init/meta/relation_tactics.lean b/old_library/init/meta/relation_tactics.lean new file mode 100644 index 0000000000..e2030226c3 --- /dev/null +++ b/old_library/init/meta/relation_tactics.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic init.function + +namespace tactic +open expr + +private meta_definition relation_tactic (op_for : environment → name → option name) (tac_name : string) : tactic unit := +do tgt ← target, + env ← get_env, + r ← return $ get_app_fn tgt, + match (op_for env (const_name r)) with + | (some refl) := mk_const refl >>= apply + | none := fail $ tac_name ++ " tactic failed, target is not a relation application with the expected property." + end + +meta_definition reflexivity : tactic unit := +relation_tactic environment.refl_for "reflexivity" + +meta_definition symmetry : tactic unit := +relation_tactic environment.symm_for "symmetry" + +meta_definition transitivity : tactic unit := +relation_tactic environment.trans_for "transitivity" + +end tactic diff --git a/old_library/init/meta/rewrite_tactic.lean b/old_library/init/meta/rewrite_tactic.lean new file mode 100644 index 0000000000..da8b725b34 --- /dev/null +++ b/old_library/init/meta/rewrite_tactic.lean @@ -0,0 +1,24 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.relation_tactics init.meta.occurrences + +namespace tactic +/- (rewrite_core m use_instances occs symm H) -/ +meta_constant rewrite_core : transparency → bool → occurrences → bool → expr → tactic unit +meta_constant rewrite_at_core : transparency → bool → occurrences → bool → expr → expr → tactic unit + +meta_definition rewrite (th_name : name) : tactic unit := +do th ← mk_const th_name, + rewrite_core reducible tt occurrences.all ff th, + try reflexivity + +meta_definition rewrite_at (th_name : name) (H_name : name) : tactic unit := +do th ← mk_const th_name, + H ← get_local H_name, + rewrite_at_core reducible tt occurrences.all ff th H + +end tactic diff --git a/old_library/init/meta/set_get_option_tactics.lean b/old_library/init/meta/set_get_option_tactics.lean new file mode 100644 index 0000000000..2b19250ff4 --- /dev/null +++ b/old_library/init/meta/set_get_option_tactics.lean @@ -0,0 +1,33 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic + +namespace tactic +meta_definition set_bool_option (n : name) (v : bool) : tactic unit := +do s ← read, + write $ tactic_state.set_options s (options.set_bool (tactic_state.get_options s) n v) + +meta_definition set_nat_option (n : name) (v : nat) : tactic unit := +do s ← read, + write $ tactic_state.set_options s (options.set_nat (tactic_state.get_options s) n v) + +meta_definition set_string_option (n : name) (v : string) : tactic unit := +do s ← read, + write $ tactic_state.set_options s (options.set_string (tactic_state.get_options s) n v) + +meta_definition get_bool_option (n : name) (default : bool) : tactic bool := +do s ← read, + return $ options.get_bool (tactic_state.get_options s) n default + +meta_definition get_nat_option (n : name) (default : nat) : tactic nat := +do s ← read, + return $ options.get_nat (tactic_state.get_options s) n default + +meta_definition get_string_option (n : name) (default : string) : tactic string := +do s ← read, + return $ options.get_string (tactic_state.get_options s) n default +end tactic diff --git a/old_library/init/meta/simp_tactic.lean b/old_library/init/meta/simp_tactic.lean new file mode 100644 index 0000000000..42c9686cb5 --- /dev/null +++ b/old_library/init/meta/simp_tactic.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.tactic + +namespace tactic +open list nat + +meta_constant simp_lemmas : Type + +/- Create a data-structure containing a simp lemma for every constant in the first list of + attributes, and a congr lemma for every constant in the second list of attributes. + Lemmas with type ` ` are indexed using the head-symbol of ``, + computed with respect to the given transparency setting. -/ +meta_constant mk_simp_lemmas_core : transparency → list name → list name → tactic simp_lemmas +/- Create an empty simp_lemmas. That is, it ignores the lemmas marked with the [simp] attribute. -/ +meta_constant mk_empty_simp_lemmas : tactic simp_lemmas +/- (simp_lemmas_insert_core m lemmas id lemma priority) adds the given lemma to the set simp_lemmas. -/ +meta_constant simp_lemmas_insert_core : transparency → simp_lemmas → expr → tactic simp_lemmas + +meta_definition mk_simp_lemmas : tactic simp_lemmas := +mk_simp_lemmas_core reducible [`simp] [`congr] + +meta_definition simp_lemmas_add_extra : transparency → simp_lemmas → list expr → tactic simp_lemmas +| m sls [] := return sls +| m sls (l::ls) := do + new_sls ← simp_lemmas_insert_core m sls l, + simp_lemmas_add_extra m new_sls ls + +/- Simplify the given expression using [simp] and [congr] lemmas. + The first argument is a tactic to be used to discharge proof obligations. + The second argument is the name of the relation to simplify over. + The third argument is a list of additional expressions to be considered as simp rules. + The fourth argument is the expression to be simplified. + The result is the simplified expression along with a proof that the new + expression is equivalent to the old one. + Fails if no simplifications can be performed. -/ +meta_constant simplify_core : tactic unit → name → simp_lemmas → expr → tactic (expr × expr) + +meta_definition simplify (prove_fn : tactic unit) (extra_lemmas : list expr) (e : expr) : tactic (expr × expr) := +do simp_lemmas ← mk_simp_lemmas, + new_lemmas ← simp_lemmas_add_extra reducible simp_lemmas extra_lemmas, + e_type ← infer_type e >>= whnf, + simplify_core prove_fn `eq new_lemmas e + +meta_definition simplify_goal (prove_fn : tactic unit) (extra_lemmas : list expr) : tactic unit := +do (new_target, Heq) ← target >>= simplify prove_fn extra_lemmas, + assert `Htarget new_target, swap, + Ht ← get_local `Htarget, + mk_app `eq.mpr [Heq, Ht] >>= exact + +meta_definition simp : tactic unit := +simplify_goal failed [] >> try triv + +meta_definition simp_using (Hs : list expr) : tactic unit := +simplify_goal failed Hs >> try triv + +private meta_definition is_equation : expr → bool +| (expr.pi n bi d b) := is_equation b +| e := match (expr.is_eq e) with (some a) := tt | none := ff end + +private meta_definition collect_eqs : list expr → tactic (list expr) +| [] := return [] +| (H :: Hs) := do + Eqs ← collect_eqs Hs, + Htype ← infer_type H >>= whnf, + return $ if is_equation Htype = tt then H :: Eqs else Eqs + +/- Simplify target using all hypotheses in the local context. -/ +meta_definition simp_using_hs : tactic unit := +local_context >>= collect_eqs >>= simp_using + +meta_definition simp_core_at (prove_fn : tactic unit) (extra_lemmas : list expr) (H : expr) : tactic unit := +do when (expr.is_local_constant H = ff) (fail "tactic simp_at failed, the given expression is not a hypothesis"), + Htype ← infer_type H, + (new_Htype, Heq) ← simplify prove_fn extra_lemmas Htype, + assert (expr.local_pp_name H) new_Htype, + mk_app `eq.mp [Heq, H] >>= exact, + try $ clear H + +meta_definition simp_at : expr → tactic unit := +simp_core_at failed [] + +meta_definition simp_at_using (Hs : list expr) : expr → tactic unit := +simp_core_at failed Hs + +meta_definition simp_at_using_hs (H : expr) : tactic unit := +do Hs ← local_context >>= collect_eqs, + simp_core_at failed (filter (ne H) Hs) H + +meta_definition mk_eq_simp_ext (simp_ext : expr → tactic (expr × expr)) : tactic unit := +do (lhs, rhs) ← target >>= match_eq, + (new_rhs, Heq) ← simp_ext lhs, + unify rhs new_rhs, + exact Heq + +end tactic diff --git a/old_library/init/meta/tactic.lean b/old_library/init/meta/tactic.lean new file mode 100644 index 0000000000..2a6fcd669a --- /dev/null +++ b/old_library/init/meta/tactic.lean @@ -0,0 +1,639 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.trace init.function init.option init.monad init.alternative init.nat_div +import init.meta.exceptional init.meta.format init.meta.environment init.meta.pexpr +meta_constant tactic_state : Type + +namespace tactic_state +meta_constant env : tactic_state → environment +meta_constant to_format : tactic_state → format +/- Format expression with respect to the main goal in the tactic state. + If the tactic state does not contain any goals, then format expression + using an empty local context. -/ +meta_constant format_expr : tactic_state → expr → format +meta_constant get_options : tactic_state → options +meta_constant set_options : tactic_state → options → tactic_state +end tactic_state + +attribute [instance] +meta_definition tactic_state.has_to_format : has_to_format tactic_state := +has_to_format.mk tactic_state.to_format + +inductive tactic_result (A : Type) +| success : A → tactic_state → tactic_result +| exception : (unit → format) → tactic_state → tactic_result + +open tactic_result + +section +variables {A : Type} +variables [has_to_string A] + +meta_definition tactic_result_to_string : tactic_result A → string +| (success a s) := to_string a +| (exception .A e s) := "Exception: " ++ to_string (e ()) + +attribute [instance] +meta_definition tactic_result_has_to_string : has_to_string (tactic_result A) := +has_to_string.mk tactic_result_to_string +end + +attribute [reducible] +meta_definition tactic (A : Type) := +tactic_state → tactic_result A + +section +variables {A B : Type} + +attribute [inline] +meta_definition tactic_fmap (f : A → B) (t : tactic A) : tactic B := +λ s, tactic_result.cases_on (t s) + (λ a s', success (f a) s') + (λ e s', exception B e s') + +attribute [inline] +meta_definition tactic_bind (t₁ : tactic A) (t₂ : A → tactic B) : tactic B := +λ s, tactic_result.cases_on (t₁ s) + (λ a s', t₂ a s') + (λ e s', exception B e s') + +attribute [inline] +meta_definition tactic_return (a : A) : tactic A := +λ s, success a s + +meta_definition tactic_orelse {A : Type} (t₁ t₂ : tactic A) : tactic A := +λ s, tactic_result.cases_on (t₁ s) + success + (λ e₁ s', tactic_result.cases_on (t₂ s) + success + (exception A)) +end + +attribute [instance] +meta_definition tactic_is_monad : monad tactic := +monad.mk @tactic_fmap @tactic_return @tactic_bind + +meta_definition tactic.fail {A B : Type} [has_to_format B] (msg : B) : tactic A := +λ s, exception A (λ u, to_fmt msg) s + +meta_definition tactic.failed {A : Type} : tactic A := +tactic.fail "failed" + +attribute [instance] +meta_definition tactic_is_alternative : alternative tactic := +alternative.mk @tactic_fmap (λ A a s, success a s) (@fapp _ _) @tactic.failed @tactic_orelse + +namespace tactic +variables {A : Type} + +meta_definition try (t : tactic A) : tactic unit := +λ s, tactic_result.cases_on (t s) + (λ a, success ()) + (λ e s', success () s) + +meta_definition skip : tactic unit := +success () + +open list +meta_definition foreach : list A → (A → tactic unit) → tactic unit +| [] fn := skip +| (e::es) fn := do fn e, foreach es fn + +open nat +/- (repeat_at_most n t): repeat the given tactic at most n times or until t fails -/ +meta_definition repeat_at_most : nat → tactic unit → tactic unit +| 0 t := skip +| (succ n) t := (do t, repeat_at_most n t) <|> skip + +/- (repeat_exactly n t) : execute t n times -/ +meta_definition repeat_exactly : nat → tactic unit → tactic unit +| 0 t := skip +| (succ n) t := do t, repeat_exactly n t + +meta_definition repeat : tactic unit → tactic unit := +repeat_at_most 100000 + +meta_definition returnex (e : exceptional A) : tactic A := +λ s, match e with +| (exceptional.success a) := tactic_result.success a s +| (exceptional.exception .A f) := tactic_result.exception A (λ u, f options.mk) s -- TODO(Leo): extract options from environment +end + +meta_definition returnopt (e : option A) : tactic A := +λ s, match e with +| (some a) := tactic_result.success a s +| none := tactic_result.exception A (λ u, to_fmt "failed") s +end + +/- Decorate t's exceptions with msg -/ +meta_definition decorate_ex (msg : format) (t : tactic A) : tactic A := +λ s, tactic_result.cases_on (t s) + success + (λ e, exception A (λ u, msg ++ format.nest 2 (format.line ++ e u))) + +attribute [inline] +meta_definition write (s' : tactic_state) : tactic unit := +λ s, success () s' + +attribute [inline] +meta_definition read : tactic tactic_state := +λ s, success s s +end tactic + +meta_definition tactic_format_expr (e : expr) : tactic format := +do s ← tactic.read, return (tactic_state.format_expr s e) + +structure [class] has_to_tactic_format (A : Type) := +(to_tactic_format : A → tactic format) + +attribute [instance] +meta_definition expr_has_to_tactic_format : has_to_tactic_format expr := +has_to_tactic_format.mk tactic_format_expr + +meta_definition tactic.pp {A : Type} [has_to_tactic_format A] : A → tactic format := +has_to_tactic_format.to_tactic_format + +open tactic format + +meta_definition list_to_tactic_format_aux {A : Type} [has_to_tactic_format A] : bool → list A → tactic format +| b [] := return $ to_fmt "" +| b (x::xs) := do + f₁ ← pp x, + f₂ ← list_to_tactic_format_aux ff xs, + return $ (if b = ff then to_fmt "," ++ line else nil) ++ f₁ ++ f₂ + +meta_definition list_to_tactic_format {A : Type} [has_to_tactic_format A] : list A → tactic format +| [] := return $ to_fmt "[]" +| (x::xs) := do + f ← list_to_tactic_format_aux tt (x::xs), + return $ to_fmt "[" ++ group (nest 1 f) ++ to_fmt "]" + +attribute [instance] +meta_definition list_has_to_tactic_format {A : Type} [has_to_tactic_format A] : has_to_tactic_format (list A) := +has_to_tactic_format.mk list_to_tactic_format + +attribute [instance] +meta_definition has_to_format_to_has_to_tactic_format (A : Type) [has_to_format A] : has_to_tactic_format A := +has_to_tactic_format.mk ((λ x, return x) ∘ to_fmt) + +namespace tactic +open tactic_state + +meta_definition get_env : tactic environment := +do s ← read, + return $ env s + +meta_definition get_decl (n : name) : tactic declaration := +do s ← read, + returnex $ environment.get (env s) n + +meta_definition trace {A : Type} [has_to_tactic_format A] (a : A) : tactic unit := +do fmt ← pp a, + return $ _root_.trace_fmt fmt (λ u, ()) + +meta_definition trace_state : tactic unit := +do s ← read, + trace $ to_fmt s + +inductive transparency +| all | semireducible | reducible | none + +export transparency (reducible semireducible) + +/- Return the partial term/proof constructed so far. Note that the resultant expression + may contain variables that are not declarate in the current main goal. -/ +meta_constant result : tactic expr +/- Display the partial term/proof constructed so far. This tactic is *not* equivalent to + do { r ← result, s ← read, return (format_expr s r) } because this one will format the result with respect + to the current goal, and trace_result will do it with respect to the initial goal. -/ +meta_constant format_result : tactic format +/- Return target type of the main goal. Fail if tactic_state does not have any goal left. -/ +meta_constant target : tactic expr +meta_constant intro_core : name → tactic expr +meta_constant intron : nat → tactic unit +meta_constant rename : name → name → tactic unit +/- Clear the given local constant. The tactic fails if the given expression is not a local constant. -/ +meta_constant clear : expr → tactic unit +meta_constant revert_lst : list expr → tactic nat +meta_constant whnf_core : transparency → expr → tactic expr +meta_constant eta_expand : expr → tactic expr +meta_constant unify_core : transparency → expr → expr → tactic unit +/- is_def_eq_core is similar to unify_core, but it treats metavariables as constants. -/ +meta_constant is_def_eq_core : transparency → expr → expr → tactic unit +/- Infer the type of the given expression. + Remark: transparency does not affect type inference -/ +meta_constant infer_type : expr → tactic expr + +meta_constant get_local : name → tactic expr +/- Return the hypothesis in the main goal. Fail if tactic_state does not have any goal left. -/ +meta_constant local_context : tactic (list expr) +meta_constant get_unused_name : name → option nat → tactic name +/- Helper tactic for creating simple applications where some arguments are inferred using + type inference. + + Example, given + rel.{l_1 l_2} : Pi (A : Type.{l_1}) (B : A -> Type.{l_2}), (Pi x : A, B x) -> (Pi x : A, B x) -> , Prop + nat : Type 1 + real : Type 1 + vec.{l} : Pi (A : Type l) (n : nat), Type.{l1} + f g : Pi (n : nat), vec real n + then + mk_app_core semireducible "rel" [f, g] + returns the application + rel.{1 2} nat (fun n : nat, vec real n) f g -/ +meta_constant mk_app_core : transparency → name → list expr → tactic expr +/- Similar to mk_app, but allows to specify which arguments are explicit/implicit. + Example, given + a b : nat + then + mk_mapp_core semireducible "ite" [some (a > b), none, none, some a, some b] + returns the application + @ite.{1} (a > b) (nat.decidable_gt a b) nat a b -/ +meta_constant mk_mapp_core : transparency → name → list (option expr) → tactic expr +/- Given a local constant t, if t has type (lhs = rhs) apply susbstitution. + Otherwise, try to find a local constant that has type of the form (t = t') or (t' = t). + The tactic fails if the given expression is not a local constant. -/ +meta_constant subst : expr → tactic unit +meta_constant exact : expr → tactic unit +/- Elaborate the given quoted expression with respect to the current main goal. + If the boolean argument is tt, then metavariables are tolerated and + become new goals. -/ +meta_constant to_expr_core : bool → pexpr → tactic expr +/- Return true if the given expression is a type class. -/ +meta_constant is_class : expr → tactic bool +/- Try to create an instance of the given type class. -/ +meta_constant mk_instance : expr → tactic expr +/- Change the target of the main goal. + The input expression must be definitionally equal to the current target. -/ +meta_constant change : expr → tactic unit +/- (assert H T), adds a new goal for T, and the hypothesis (H : T) in the current goal. -/ +meta_constant assert : name → expr → tactic unit +/- (assertv H T P), adds the hypothesis (H : T) in the current goal if P has type T. -/ +meta_constant assertv : name → expr → expr → tactic unit +/- (define H T), adds a new goal for T, and the hypothesis (H : T := ?M) in the current goal. -/ +meta_constant define : name → expr → tactic unit +/- (definev H T P), adds the hypothesis (H : T := P) in the current goal if P has type T. -/ +meta_constant definev : name → expr → expr → tactic unit +/- rotate goals to the left -/ +meta_constant rotate_left : nat → tactic unit +meta_constant get_goals : tactic (list expr) +meta_constant set_goals : list expr → tactic unit +/- (apply_core t all insts e), apply the expression e to the main goal, + the unification is performed using the given transparency mode. + If all is tt, then all unassigned meta-variables are added as new goals. + If insts is tt, then use type class resolution to instantiate unassigned meta-variables. -/ +meta_constant apply_core : transparency → bool → bool → expr → tactic unit +/- Create a fresh meta universe variable. -/ +meta_constant mk_meta_univ : tactic level +/- Create a fresh meta-variable with the given type. + The scope of the new meta-variable is the local context of the main goal. -/ +meta_constant mk_meta_var : expr → tactic expr +/- Return the value assigned to the given universe meta-variable. + Fail if argument is not an universe meta-variable or if it is not assigned. -/ +meta_constant get_univ_assignment : level → tactic level +/- Return the value assigned to the given meta-variable. + Fail if argument is not a meta-variable or if it is not assigned. -/ +meta_constant get_assignment : expr → tactic expr +meta_constant mk_fresh_name : tactic name +/- Return a hash code for expr that ignores inst_implicit arguments, + and proofs. -/ +meta_constant abstract_hash : expr → tactic nat +/- Return the "weight" of the given expr while ignoring inst_implicit arguments, + and proofs. -/ +meta_constant abstract_weight : expr → tactic nat +meta_constant abstract_eq : expr → expr → tactic bool +/- (induction_core m H rec ns) induction on H using recursor rec, names for the new hypotheses + are retrieved from ns. If ns does not have sufficient names, then use the internal binder names in the recursor. -/ +meta_constant induction_core : transparency → expr → name → list name → tactic unit +/- (cases_core m H ns) apply cases_on recursor, names for the new hypotheses are retrieved from ns. + H must be a local constant -/ +meta_constant cases_core : transparency → expr → list name → tactic unit +/- (generalize_core m e n) -/ +meta_constant generalize_core : transparency → expr → name → tactic unit +/- instantiate assigned metavariables in the given expression -/ +meta_constant instantiate_mvars : expr → tactic expr +/- Add the given declaration to the environment -/ +meta_constant add_decl : declaration → tactic unit +/- (set_basic_attribute_core attr_name c_name prio) set attribute attr_name for constant c_name with the given priority. + If the priority is none, then use default -/ +meta_constant set_basic_attribute_core : name → name → option nat → tactic unit +/- (unset_attribute attr_name c_name) -/ +meta_constant unset_attribute : name → name → tactic unit + +meta_definition set_basic_attribute : name → name → tactic unit := +λ a n, set_basic_attribute_core a n none + +open list nat + +/- Add (H : T := pr) to the current goal -/ +meta_definition note (n : name) (pr : expr) : tactic unit := +do t ← infer_type pr, + definev n t pr + +meta_definition whnf : expr → tactic expr := +whnf_core semireducible + +meta_definition whnf_target : tactic unit := +target >>= whnf >>= change + +meta_definition intro (n : name) : tactic expr := +do t ← target, + if expr.is_pi t = tt ∨ expr.is_let t = tt then intro_core n + else whnf_target >> intro_core n + +meta_definition intro1 : tactic expr := +intro `_ + +/- Remark: the unit argument is a trick to allow us to write a recursive definition. + Lean3 only allows recursive functions when "equations" are used. -/ +meta_definition intros_core : unit → tactic (list expr) +| u := + do t ← target, + match t with + | (expr.pi n bi d b) := do H ← intro1, Hs ← intros_core u, return (H :: Hs) + | (expr.elet n t v b) := do H ← intro1, Hs ← intros_core u, return (H :: Hs) + | e := return [] + end + +meta_definition intros : tactic (list expr) := +intros_core () + +meta_definition intro_lst : list name → tactic (list expr) +| [] := return [] +| (n::ns) := do H ← intro n, Hs ← intro_lst ns, return (H :: Hs) + +meta_definition mk_app : name → list expr → tactic expr := +mk_app_core semireducible + +meta_definition mk_mapp : name → list (option expr) → tactic expr := +mk_mapp_core semireducible + +meta_definition to_expr : pexpr → tactic expr := +to_expr_core ff + +meta_definition revert (l : expr) : tactic nat := +revert_lst [l] + +meta_definition clear_lst : list name → tactic unit +| [] := skip +| (n::ns) := do H ← get_local n, clear H, clear_lst ns + +meta_definition unify : expr → expr → tactic unit := +unify_core semireducible + +meta_definition is_def_eq : expr → expr → tactic unit := +is_def_eq_core semireducible + +meta_definition match_not (e : expr) : tactic expr := +match (expr.is_not e) with +| (some a) := return a +| none := fail "expression is not a negation" +end + +meta_definition match_eq (e : expr) : tactic (expr × expr) := +match (expr.is_eq e) with +| (some (lhs, rhs)) := return (lhs, rhs) +| none := fail "expression is not an equality" +end + +meta_definition match_ne (e : expr) : tactic (expr × expr) := +match (expr.is_ne e) with +| (some (lhs, rhs)) := return (lhs, rhs) +| none := fail "expression is not a disequality" +end + +meta_definition match_heq (e : expr) : tactic (expr × expr × expr × expr) := +do match (expr.is_heq e) with +| (some (A, lhs, B, rhs)) := return (A, lhs, B, rhs) +| none := fail "expression is not a heterogeneous equality" +end + +meta_definition match_refl_app (e : expr) : tactic (name × expr × expr) := +do env ← get_env, +match (environment.is_refl_app env e) with +| (some (R, lhs, rhs)) := return (R, lhs, rhs) +| none := fail "expression is not an application of a reflexive relation" +end + +meta_definition get_local_type (n : name) : tactic expr := +get_local n >>= infer_type + +meta_definition trace_result : tactic unit := +format_result >>= trace + +/- (find_same_type t es) tries to find in es an expression with type definitionally equal to t -/ +meta_definition find_same_type : expr → list expr → tactic expr +| e [] := failed +| e (H :: Hs) := + do t ← infer_type H, + (unify e t >> return H) <|> find_same_type e Hs + +meta_definition assumption : tactic unit := +do { ctx ← local_context, + t ← target, + H ← find_same_type t ctx, + exact H } +<|> fail "assumption tactic failed" + +/- Swap first two goals, do nothing if tactic state does not have at least two goals. -/ +meta_definition swap : tactic unit := +do gs ← get_goals, + match gs with + | (g₁ :: g₂ :: rs) := set_goals (g₂ :: g₁ :: rs) + | e := skip + end + +/- Return the number of goals that need to be solved -/ +meta_definition num_goals : tactic nat := +do gs ← get_goals, + return (length gs) + +/- We have to provide the instance argument `[has_mod nat]` because + mod for nat was not defined yet -/ +meta_definition rotate_right (n : nat) [has_mod nat] : tactic unit := +do ng ← num_goals, + if ng = 0 then skip + else rotate_left (ng - n % ng) + +meta_definition rotate : nat → tactic unit := +rotate_left + +/- first [t_1, ..., t_n] applies the first tactic that doesn't fail. + The tactic fails if all t_i's fail. -/ +meta_definition first {A : Type} : list (tactic A) → tactic A +| [] := fail "first tactic failed, no more alternatives" +| (t::ts) := t <|> first ts + +/- Applies the given tactic to the main goal and fails if it is not solved. -/ +meta_definition solve1 (tac : tactic unit) : tactic unit := +do gs ← get_goals, + match gs with + | [] := fail "focus tactic failed, there isn't any goal left to focus" + | (g::rs) := + do set_goals [g], + tac, + gs' ← get_goals, + match gs' with + | [] := set_goals rs + | gs := fail "focus tactic failed, focused goal has not been solved" + end + end + +/- solve [t_1, ... t_n] applies the first tactic that solves the main goal. -/ +meta_definition solve (ts : list (tactic unit)) : tactic unit := +first $ map solve1 ts + + private meta_definition focus_aux : list (tactic unit) → list expr → list expr → tactic unit +| [] gs rs := set_goals $ gs ++ rs +| (t::ts) (g::gs) rs := do + set_goals [g], t, rs' ← get_goals, + focus_aux ts gs (rs ++ rs') +| (t::ts) [] rs := fail "focus tactic failed, insufficient number of goals" + +/- focus [t_1, ..., t_n] applies t_i to the i-th goal. Fails if there are less tha n goals. -/ +meta_definition focus (ts : list (tactic unit)) : tactic unit := +do gs ← get_goals, focus_aux ts gs [] + +private meta_definition all_goals_core : tactic unit → list expr → list expr → tactic unit +| tac [] ac := set_goals ac +| tac (g :: gs) ac := + do set_goals [g], + tac, + new_gs ← get_goals, + all_goals_core tac gs (ac ++ new_gs) + +/- Apply the given tactic to all goals. -/ +meta_definition all_goals (tac : tactic unit) : tactic unit := +do gs ← get_goals, + all_goals_core tac gs [] + +/- LCF-style AND_THEN tactic. It applies tac1, and if succeed applies tac2 to each subgoal produced by tac1 -/ +meta_definition seq (tac1 : tactic unit) (tac2 : tactic unit) : tactic unit := +do g::gs ← get_goals | failed, + set_goals [g], + tac1, all_goals tac2, + gs' ← get_goals, + set_goals (gs' ++ gs) + +attribute [instance] +meta_definition tactic_has_andthen : has_andthen (tactic unit) := +has_andthen.mk seq + +/- Applies tac if c holds -/ +meta_definition when (c : Prop) [decidable c] (tac : tactic unit) : tactic unit := +if c then tac else skip + +meta_constant is_trace_enabled_for : name → bool + +/- Execute tac only if option trace.n is set to true. -/ +meta_definition when_tracing (n : name) (tac : tactic unit) : tactic unit := +when (is_trace_enabled_for n = tt) tac + +/- Fail if there are no remaining goals. -/ +meta_definition fail_if_no_goals : tactic unit := +do n ← num_goals, + when (n = 0) (fail "tactic failed, there are no goals to be solved") + +/- Fail if there are unsolved goals. -/ +meta_definition now : tactic unit := +do n ← num_goals, + when (n ≠ 0) (fail "now tactic failed, there are unsolved goals") + +meta_definition apply : expr → tactic unit := +apply_core semireducible ff tt + +meta_definition fapply : expr → tactic unit := +apply_core semireducible tt tt + +/- Try to solve the main goal using type class resolution. -/ +meta_definition apply_instance : tactic unit := +do tgt ← target, + b ← is_class tgt, + if b = tt then mk_instance tgt >>= exact + else fail "apply_instance tactic fail, target is not a type class" + +/- Create a list of universe meta-variables of the given size. -/ +meta_definition mk_num_meta_univs : nat → tactic (list level) +| 0 := return [] +| (succ n) := do + l ← mk_meta_univ, + ls ← mk_num_meta_univs n, + return (l::ls) + +/- Return (expr.const c [l_1, ..., l_n]) where l_i's are fresh universe meta-variables. -/ +meta_definition mk_const (c : name) : tactic expr := +do env ← get_env, + decl ← returnex (environment.get env c), + num ← return (length (declaration.univ_params decl)), + ls ← mk_num_meta_univs num, + return (expr.const c ls) + +/- Create a fresh universe ?u, a metavariable (?T : Type.{?u}), + and return metavariable (?M : ?T). + This action can be used to create a meta-variable when + we don't know its type at creation time -/ +meta_definition mk_mvar : tactic expr := +do u ← mk_meta_univ, + t ← mk_meta_var (expr.sort u), + mk_meta_var t + +private meta_definition get_pi_arity_aux : expr → tactic nat +| (expr.pi n bi d b) := + do m ← mk_fresh_name, + l ← return (expr.local_const m n bi d), + new_b ← whnf (expr.instantiate_var b l), + r ← get_pi_arity_aux new_b, + return (r + 1) +| e := return 0 + +/- Compute the arity of the given (Pi-)type -/ +meta_definition get_pi_arity (type : expr) : tactic nat := +whnf type >>= get_pi_arity_aux + +/- Compute the arity of the given function -/ +meta_definition get_arity (fn : expr) : tactic nat := +infer_type fn >>= get_pi_arity + +meta_definition triv : tactic unit := mk_const `trivial >>= exact + +meta_definition by_contradiction (H : name) : tactic expr := +do tgt : expr ← target, + (match_not tgt >> return ()) + <|> + (mk_mapp `decidable.by_contradiction [some tgt, none] >>= apply) + <|> + fail "tactic by_contradiction failed, target is not a negation nor a decidable proposition (remark: when 'local attribute classical.prop_decidable [instance]' is used all propositions are decidable)", + intro H + +meta_definition cases (H : expr) : tactic unit := +cases_core semireducible H [] + +meta_definition cases_using : expr → list name → tactic unit := +cases_core semireducible + +meta_definition generalize : expr → name → tactic unit := +generalize_core semireducible + +meta_definition generalizes : list expr → tactic unit +| [] := skip +| (e::es) := generalize e `x >> generalizes es + +meta_definition refine (e : pexpr) : tactic unit := +do tgt : expr ← target, + to_expr_core tt `((%%e : %%tgt)) >>= exact + +meta_definition expr_of_nat : nat → tactic expr +| n := + if n = 0 then to_expr `(0) + else if n = 1 then to_expr `(1) + else do + r : expr ← expr_of_nat (n / 2), + if n % 2 = 0 then to_expr `(bit0 %%r) + else to_expr `(bit1 %%r) + +notation `command`:max := tactic unit +end tactic diff --git a/old_library/init/meta/unfold_tactic.lean b/old_library/init/meta/unfold_tactic.lean new file mode 100644 index 0000000000..b0cb43a2c9 --- /dev/null +++ b/old_library/init/meta/unfold_tactic.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.meta.relation_tactics init.meta.occurrences + +namespace tactic +/- (rewrite_core m use_instances occs symm H) -/ +meta_constant unfold_expr_core : bool → occurrences → list name → expr → tactic expr + +meta_definition unfold_core (force : bool) (occs : occurrences) (ns : list name) : tactic unit := +target >>= unfold_expr_core force occs ns >>= change + +meta_definition unfold : list name → tactic unit := +unfold_core ff occurrences.all + +meta_definition unfold_occs_of (occs : list nat) (c : name) : tactic unit := +unfold_core ff (occurrences.pos occs) [c] + +meta_definition unfold_core_at (force : bool) (occs : occurrences) (ns : list name) (H : expr) : tactic unit := +do num_reverted : ℕ ← revert H, + (expr.pi n bi d b : expr) ← target | failed, + new_H : expr ← unfold_expr_core force occs ns d, + change $ expr.pi n bi new_H b, + intron num_reverted + +meta_definition unfold_at : list name → expr → tactic unit := +unfold_core_at ff occurrences.all + +end tactic diff --git a/old_library/init/monad.lean b/old_library/init/monad.lean new file mode 100644 index 0000000000..1fbf1be534 --- /dev/null +++ b/old_library/init/monad.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) Luke Nelson and Jared Roesch. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Luke Nelson and Jared Roesch +-/ +prelude +import init.applicative init.string init.trace +universe variables u v + +structure [class] monad (M : Type u → Type v) extends functor M : Type (max u+1 v) := +(ret : Π {A : Type u}, A → M A) +(bind : Π {A B : Type u}, M A → (A → M B) → M B) + +attribute [inline] +definition return {M : Type u → Type v} [monad M] {A : Type u} : A → M A := +monad.ret M + +definition fapp {M : Type u → Type v} [monad M] {A B : Type u} (f : M (A → B)) (a : M A) : M B := +do g ← f, + b ← a, + return (g b) + +attribute [inline, instance] +definition monad_is_applicative (M : Type u → Type v) [monad M] : applicative M := +applicative.mk (@fmap _ _) (@return _ _) (@fapp _ _) + +attribute [inline] +definition monad.and_then {A B : Type u} {M : Type u → Type v} [monad M] (a : M A) (b : M B) : M B := +do a, b + +infixl ` >>= `:2 := monad.bind +infixl ` >> `:2 := monad.and_then diff --git a/old_library/init/monad_combinators.lean b/old_library/init/monad_combinators.lean new file mode 100644 index 0000000000..5cbbb63ac7 --- /dev/null +++ b/old_library/init/monad_combinators.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad + +Monad combinators, as in Haskell's Control.Monad. +-/ +prelude +import init.monad init.list +namespace monad + +definition mapM {m : Type → Type} [monad m] {A B : Type} (f : A → m B) : list A → m (list B) +| [] := return [] +| (h :: t) := do h' ← f h, t' ← mapM t, return (h' :: t') + +definition mapM' {m : Type → Type} [monad m] {A B : Type} (f : A → m B) : list A → m unit +| [] := return () +| (h :: t) := f h >> mapM' t + +definition forM {m : Type → Type} [monad m] {A B : Type} (l : list A) (f : A → m B) : m (list B) := +mapM f l + +definition forM' {m : Type → Type} [monad m] {A B : Type} (l : list A) (f : A → m B) : m unit := +mapM' f l + +definition sequence {m : Type → Type} [monad m] {A : Type} : list (m A) → m (list A) +| [] := return [] +| (h :: t) := do h' ← h, t' ← sequence t, return (h' :: t') + +definition sequence' {m : Type → Type} [monad m] {A : Type} : list (m A) → m unit +| [] := return () +| (h :: t) := h >> sequence' t + +infix ` =<< `:2 := λ u v, v >>= u + +infix ` >=> `:2 := λ s t a, s a >>= t + +infix ` <=< `:2 := λ t s a, s a >>= t + +definition join {m : Type → Type} [monad m] {A : Type} (a : m (m A)) : m A := +bind a id + +definition filterM {m : Type → Type} [monad m] {A : Type} (f : A → m bool) : list A → m (list A) +| [] := return [] +| (h :: t) := do b ← f h, t' ← filterM t, bool.cond b (return (h :: t')) (return t') + +definition whenb {m : Type → Type} [monad m] (b : bool) (t : m unit) : m unit := +bool.cond b t (return ()) + +definition unlessb {m : Type → Type} [monad m] (b : bool) (t : m unit) : m unit := +bool.cond b (return ()) t + +definition condM {m : Type → Type} [monad m] {A : Type} (mbool : m bool) + (tm fm : m A) : m A := +do b ← mbool, bool.cond b tm fm + +definition liftM {m : Type → Type} [monad m] {A R : Type} (f : A → R) (ma : m A) : m R := +do a ← ma, return (f a) + +definition liftM₂ {m : Type → Type} [monad m] {A R : Type} (f : A → A → R) (ma₁ ma₂: m A) : m R := +do a₁ ← ma₁, a₂ ← ma₂, return (f a₁ a₂) + +definition liftM₃ {m : Type → Type} [monad m] {A R : Type} (f : A → A → A → R) + (ma₁ ma₂ ma₃ : m A) : m R := +do a₁ ← ma₁, a₂ ← ma₂, a₃ ← ma₃, return (f a₁ a₂ a₃) + +definition liftM₄ {m : Type → Type} [monad m] {A R : Type} (f : A → A → A → A → R) + (ma₁ ma₂ ma₃ ma₄ : m A) : m R := +do a₁ ← ma₁, a₂ ← ma₂, a₃ ← ma₃, a₄ ← ma₄, return (f a₁ a₂ a₃ a₄) + +definition liftM₅ {m : Type → Type} [monad m] {A R : Type} (f : A → A → A → A → A → R) + (ma₁ ma₂ ma₃ ma₄ ma₅ : m A) : m R := +do a₁ ← ma₁, a₂ ← ma₂, a₃ ← ma₃, a₄ ← ma₄, a₅ ← ma₅, return (f a₁ a₂ a₃ a₄ a₅) + +end monad diff --git a/old_library/init/nat.lean b/old_library/init/nat.lean new file mode 100644 index 0000000000..a261dd2351 --- /dev/null +++ b/old_library/init/nat.lean @@ -0,0 +1,375 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Floris van Doorn, Leonardo de Moura +-/ +prelude +import init.relation init.num + +notation `ℕ` := nat + +namespace nat + protected theorem zero_add : ∀ n : ℕ, 0 + n = n + | 0 := rfl + | (n+1) := congr_arg succ (zero_add n) + + theorem succ_add : ∀ n m : ℕ, (succ n) + m = succ (n + m) + | n 0 := rfl + | n (m+1) := congr_arg succ (succ_add n m) + + protected theorem add_comm : ∀ n m : ℕ, n + m = m + n + | n 0 := eq.symm (nat.zero_add n) + | n (m+1) := + suffices succ (n + m) = succ (m + n), from + eq.symm (succ_add m n) ▸ this, + congr_arg succ (add_comm n m) + + protected theorem bit0_succ_eq (n : ℕ) : bit0 (succ n) = succ (succ (bit0 n)) := + show succ (succ n + n) = succ (succ (n + n)), from + succ_add n n ▸ rfl + + protected theorem bit1_eq_succ_bit0 (n : ℕ) : bit1 n = succ (bit0 n) := + rfl + + protected theorem bit1_succ_eq (n : ℕ) : bit1 (succ n) = succ (succ (bit1 n)) := + eq.trans (nat.bit1_eq_succ_bit0 (succ n)) (congr_arg succ (nat.bit0_succ_eq n)) + + theorem succ_ne_zero (n : ℕ) : succ n ≠ 0 := + assume h, nat.no_confusion h + + theorem succ_ne_self : ∀ n : ℕ, succ n ≠ n + | 0 h := absurd h (nat.succ_ne_zero 0) + | (n+1) h := succ_ne_self n (nat.no_confusion h (λ h, h)) + + protected theorem one_ne_zero : 1 ≠ (0 : ℕ) := + assume h, nat.no_confusion h + + protected theorem bit0_ne_zero : ∀ n : ℕ, n ≠ 0 → bit0 n ≠ 0 + | 0 h := absurd rfl h + | (n+1) h := nat.succ_ne_zero _ + + protected theorem bit1_ne_zero (n : ℕ) : bit1 n ≠ 0 := + show succ (n + n) ≠ 0, from + succ_ne_zero (n + n) + + protected theorem bit1_ne_one : ∀ n : ℕ, n ≠ 0 → bit1 n ≠ 1 + | 0 h h1 := absurd rfl h + | (n+1) h h1 := nat.no_confusion h1 (λ h2, absurd h2 (nat.succ_ne_zero _)) + + protected theorem bit0_ne_one : ∀ n : ℕ, bit0 n ≠ 1 + | 0 h := absurd h (ne.symm nat.one_ne_zero) + | (n+1) h := + have h1 : succ (succ (n + n)) = 1, from succ_add n n ▸ h, + nat.no_confusion h1 + (λ h2, absurd h2 (succ_ne_zero (n + n))) + + protected theorem add_self_ne_one : ∀ (n : ℕ), n + n ≠ 1 + | 0 h := nat.no_confusion h + | (n+1) h := + have h1 : succ (succ (n + n)) = 1, from succ_add n n ▸ h, + nat.no_confusion h1 (λ h2, absurd h2 (nat.succ_ne_zero (n + n))) + + protected theorem bit1_ne_bit0 : ∀ (n m : ℕ), bit1 n ≠ bit0 m + | 0 m h := absurd h (ne.symm (nat.add_self_ne_one m)) + | (n+1) 0 h := + have h1 : succ (bit0 (succ n)) = 0, from h, + absurd h1 (nat.succ_ne_zero _) + | (n+1) (m+1) h := + have h1 : succ (succ (bit1 n)) = succ (succ (bit0 m)), from + nat.bit0_succ_eq m ▸ nat.bit1_succ_eq n ▸ h, + have h2 : bit1 n = bit0 m, from + nat.no_confusion h1 (λ h2', nat.no_confusion h2' (λ h2'', h2'')), + absurd h2 (bit1_ne_bit0 n m) + + inductive le (a : ℕ) : ℕ → Prop + | nat_refl : le a -- use nat_refl to avoid overloading le.refl + | step : Π {b}, le b → le (succ b) + + attribute [instance, priority nat.prio] + definition nat_has_le : has_le ℕ := + ⟨nat.le⟩ + + attribute [refl] + protected definition le_refl : ∀ a : ℕ, a ≤ a := + le.nat_refl + + attribute [reducible] + protected definition lt (n m : ℕ) := succ n ≤ m + + attribute [instance, priority nat.prio] + definition nat_has_lt : has_lt ℕ := + ⟨nat.lt⟩ + + definition pred : ℕ → ℕ + | 0 := 0 + | (a+1) := a + + protected definition sub : ℕ → ℕ → ℕ + | a 0 := a + | a (b+1) := pred (sub a b) + + protected definition mul (a b : ℕ) : ℕ := + nat.rec_on b zero (λ b₁ r, r + a) + + attribute [instance, priority nat.prio] + definition nat_has_sub : has_sub ℕ := + ⟨nat.sub⟩ + + attribute [instance, priority nat.prio] + definition nat_has_mul : has_mul ℕ := + ⟨nat.mul⟩ + + attribute [instance, priority nat.prio] + protected definition has_decidable_eq : ∀ x y : ℕ, decidable (x = y) + | zero zero := is_true rfl + | (succ x) zero := is_false (λ h, nat.no_confusion h) + | zero (succ y) := is_false (λ h, nat.no_confusion h) + | (succ x) (succ y) := + match has_decidable_eq x y with + | is_true xeqy := is_true (xeqy ▸ eq.refl (succ x)) + | is_false xney := is_false (λ h, nat.no_confusion h (λ xeqy, absurd xeqy xney)) + end + + /- properties of inequality -/ + + protected theorem le_of_eq {n m : ℕ} (p : n = m) : n ≤ m := + p ▸ le.nat_refl n + + theorem le_succ (n : ℕ) : n ≤ succ n := + le.step (nat.le_refl n) + + theorem pred_le : ∀ (n : ℕ), pred n ≤ n + | 0 := le.nat_refl 0 + | (succ a) := le.step (le.nat_refl a) + + attribute [simp] + theorem le_succ_iff_true (n : ℕ) : n ≤ succ n ↔ true := + iff_true_intro (le_succ n) + + attribute [simp] + theorem pred_le_iff_true (n : ℕ) : pred n ≤ n ↔ true := + iff_true_intro (pred_le n) + + protected theorem le_trans {n m k : ℕ} (h1 : n ≤ m) : m ≤ k → n ≤ k := + le.rec h1 (λ p h2, le.step) + + theorem le_succ_of_le {n m : ℕ} (h : n ≤ m) : n ≤ succ m := + nat.le_trans h (le_succ m) + + theorem le_of_succ_le {n m : ℕ} (h : succ n ≤ m) : n ≤ m := + nat.le_trans (le_succ n) h + + protected theorem le_of_lt {n m : ℕ} (h : n < m) : n ≤ m := + le_of_succ_le h + + theorem succ_le_succ {n m : ℕ} : n ≤ m → succ n ≤ succ m := + λ h, le.rec (nat.le_refl (succ n)) (λ a b, le.step) h + + theorem pred_le_pred {n m : ℕ} : n ≤ m → pred n ≤ pred m := + λ h, le.rec (nat.le_refl (pred n)) (λ n, nat.rec (λ a b, b) (λ a b c, le.step) n) h + + theorem le_of_succ_le_succ {n m : ℕ} : succ n ≤ succ m → n ≤ m := + pred_le_pred + + theorem le_succ_of_pred_le {n m : ℕ} : pred n ≤ m → n ≤ succ m := + nat.cases_on n le.step (λ a, succ_le_succ) + + theorem not_succ_le_zero : ∀ (n : ℕ), succ n ≤ 0 → false + . + + theorem succ_le_zero_iff_false (n : ℕ) : succ n ≤ 0 ↔ false := + iff_false_intro (not_succ_le_zero n) + + theorem not_succ_le_self : ∀ n : ℕ, ¬succ n ≤ n := + λ n, nat.rec (not_succ_le_zero 0) (λ a b c, b (le_of_succ_le_succ c)) n + + attribute [simp] + theorem succ_le_self_iff_false (n : ℕ) : succ n ≤ n ↔ false := + iff_false_intro (not_succ_le_self n) + + theorem zero_le : ∀ (n : ℕ), 0 ≤ n + | 0 := nat.le_refl 0 + | (n+1) := le.step (zero_le n) + + attribute [simp] + theorem zero_le_iff_true (n : ℕ) : 0 ≤ n ↔ true := + iff_true_intro (zero_le n) + + protected theorem one_le_bit1 (n : ℕ) : 1 ≤ bit1 n := + show 1 ≤ succ (bit0 n), from + succ_le_succ (zero_le (bit0 n)) + + protected theorem one_le_bit0 : ∀ (n : ℕ), n ≠ 0 → 1 ≤ bit0 n + | 0 h := absurd rfl h + | (n+1) h := + suffices 1 ≤ succ (succ (bit0 n)), from + eq.symm (nat.bit0_succ_eq n) ▸ this, + succ_le_succ (zero_le (succ (bit0 n))) + + definition lt.step {n m : ℕ} : n < m → n < succ m := le.step + + theorem zero_lt_succ (n : ℕ) : 0 < succ n := + succ_le_succ (zero_le n) + + attribute [simp] + theorem zero_lt_succ_iff_true (n : ℕ) : 0 < succ n ↔ true := + iff_true_intro (zero_lt_succ n) + + protected theorem lt_trans {n m k : ℕ} (h₁ : n < m) : m < k → n < k := + nat.le_trans (le.step h₁) + + protected theorem lt_of_le_of_lt {n m k : ℕ} (h₁ : n ≤ m) : m < k → n < k := + nat.le_trans (succ_le_succ h₁) + + protected theorem lt_of_lt_of_le {n m k : ℕ} : n < m → m ≤ k → n < k := nat.le_trans + + protected theorem lt_irrefl (n : ℕ) : ¬n < n := + not_succ_le_self n + + theorem lt_self_iff_false (n : ℕ) : n < n ↔ false := + iff_false_intro (λ h, absurd h (nat.lt_irrefl n)) + + theorem self_lt_succ (n : ℕ) : n < succ n := nat.le_refl (succ n) + + attribute [simp] + theorem self_lt_succ_iff_true (n : ℕ) : n < succ n ↔ true := + iff_true_intro (self_lt_succ n) + + definition lt.base (n : ℕ) : n < succ n := nat.le_refl (succ n) + + theorem le_lt_antisymm {n m : ℕ} (h₁ : n ≤ m) (h₂ : m < n) : false := + nat.lt_irrefl n (nat.lt_of_le_of_lt h₁ h₂) + + protected theorem le_antisymm {n m : ℕ} (h₁ : n ≤ m) : m ≤ n → n = m := + le.cases_on h₁ (λ a, rfl) (λ a b c, absurd (nat.lt_of_le_of_lt b c) (nat.lt_irrefl n)) + + theorem lt_le_antisymm {n m : ℕ} (h₁ : n < m) (h₂ : m ≤ n) : false := + le_lt_antisymm h₂ h₁ + + protected theorem nat.lt_asymm {n m : ℕ} (h₁ : n < m) : ¬ m < n := + le_lt_antisymm (nat.le_of_lt h₁) + + theorem not_lt_zero (a : ℕ) : ¬ a < 0 := not_succ_le_zero a + + attribute [simp] + theorem lt_zero_iff_false (a : ℕ) : a < 0 ↔ false := + iff_false_intro (not_lt_zero a) + + protected theorem eq_or_lt_of_le {a b : ℕ} (h : a ≤ b) : a = b ∨ a < b := + le.cases_on h (or.inl rfl) (λ n h, or.inr (succ_le_succ h)) + + protected theorem le_of_eq_or_lt {a b : ℕ} (h : a = b ∨ a < b) : a ≤ b := + or.elim h nat.le_of_eq nat.le_of_lt + + theorem succ_lt_succ {a b : ℕ} : a < b → succ a < succ b := + succ_le_succ + + theorem lt_of_succ_lt {a b : ℕ} : succ a < b → a < b := + le_of_succ_le + + theorem lt_of_succ_lt_succ {a b : ℕ} : succ a < succ b → a < b := + le_of_succ_le_succ + + attribute [instance, priority nat.prio] + protected definition decidable_le : ∀ a b : ℕ, decidable (a ≤ b) + | 0 b := is_true (zero_le b) + | (a+1) 0 := is_false (not_succ_le_zero a) + | (a+1) (b+1) := + match decidable_le a b with + | is_true h := is_true (succ_le_succ h) + | is_false h := is_false (λ a, h (le_of_succ_le_succ a)) + end + + attribute [instance, priority nat.prio] + protected definition decidable_lt : ∀ a b : ℕ, decidable (a < b) := + λ a b, nat.decidable_le (succ a) b + + protected theorem lt_or_ge : ∀ (a b : ℕ), a < b ∨ a ≥ b + | a 0 := or.inr (zero_le a) + | a (b+1) := + match lt_or_ge a b with + | or.inl h := or.inl (le_succ_of_le h) + | or.inr h := + match nat.eq_or_lt_of_le h with + | or.inl h1 := or.inl (h1 ▸ self_lt_succ b) + | or.inr h1 := or.inr h1 + end + end + + protected definition {u} lt_ge_by_cases {a b : ℕ} {C : Type u} (h₁ : a < b → C) (h₂ : a ≥ b → C) : C := + decidable.by_cases h₁ (λ h, h₂ (or.elim (nat.lt_or_ge a b) (λ a, absurd a h) (λ a, a))) + + protected definition {u} lt_by_cases {a b : ℕ} {C : Type u} (h₁ : a < b → C) (h₂ : a = b → C) + (h₃ : b < a → C) : C := + nat.lt_ge_by_cases h₁ (λ h₁, + nat.lt_ge_by_cases h₃ (λ h, h₂ (nat.le_antisymm h h₁))) + + protected theorem lt_trichotomy (a b : ℕ) : a < b ∨ a = b ∨ b < a := + nat.lt_by_cases (λ h, or.inl h) (λ h, or.inr (or.inl h)) (λ h, or.inr (or.inr h)) + + protected theorem eq_or_lt_of_not_lt {a b : ℕ} (hnlt : ¬ a < b) : a = b ∨ b < a := + or.elim (nat.lt_trichotomy a b) + (λ hlt, absurd hlt hnlt) + (λ h, h) + + theorem lt_succ_of_le {a b : ℕ} : a ≤ b → a < succ b := + succ_le_succ + + theorem lt_of_succ_le {a b : ℕ} (h : succ a ≤ b) : a < b := h + + theorem succ_le_of_lt {a b : ℕ} (h : a < b) : succ a ≤ b := h + + attribute [simp] + theorem succ_sub_succ_eq_sub (a b : ℕ) : succ a - succ b = a - b := + nat.rec_on b + (show succ a - succ zero = a - zero, from (eq.refl (succ a - succ zero))) + (λ b, congr_arg pred) + + theorem sub_eq_succ_sub_succ (a b : ℕ) : a - b = succ a - succ b := + eq.symm (succ_sub_succ_eq_sub a b) + + attribute [simp] + theorem zero_sub_eq_zero : ∀ a : ℕ, 0 - a = 0 + | 0 := rfl + | (a+1) := congr_arg pred (zero_sub_eq_zero a) + + theorem zero_eq_zero_sub (a : ℕ) : 0 = 0 - a := + eq.symm (zero_sub_eq_zero a) + + theorem sub_le (a b : ℕ) : a - b ≤ a := + nat.rec_on b (nat.le_refl (a - 0)) (λ b₁, nat.le_trans (pred_le (a - b₁))) + + attribute [simp] + theorem sub_le_iff_true (a b : ℕ) : a - b ≤ a ↔ true := + iff_true_intro (sub_le a b) + + theorem sub_lt : ∀ {a b : ℕ}, 0 < a → 0 < b → a - b < a + | 0 b h1 h2 := absurd h1 (nat.lt_irrefl 0) + | (a+1) 0 h1 h2 := absurd h2 (nat.lt_irrefl 0) + | (a+1) (b+1) h1 h2 := + eq.symm (succ_sub_succ_eq_sub a b) ▸ + show a - b < succ a, from + lt_succ_of_le (sub_le a b) + + theorem sub_lt_succ (a b : ℕ) : a - b < succ a := + lt_succ_of_le (sub_le a b) + + attribute [simp] + theorem sub_lt_succ_iff_true (a b : ℕ) : a - b < succ a ↔ true := + iff_true_intro (sub_lt_succ a b) + + theorem le_add_right : ∀ (n k : ℕ), n ≤ n + k + | n 0 := nat.le_refl n + | n (k+1) := le_succ_of_le (le_add_right n k) + + theorem le_add_left (n m : ℕ): n ≤ m + n := + nat.add_comm n m ▸ le_add_right n m + + definition {u} repeat {A : Type u} (f : ℕ → A → A) : ℕ → A → A + | 0 a := a + | (succ n) a := f n (repeat n a) + + attribute [instance] + protected definition is_inhabited : inhabited ℕ := + ⟨nat.zero⟩ +end nat diff --git a/old_library/init/nat_div.lean b/old_library/init/nat_div.lean new file mode 100644 index 0000000000..2f2e0f3f2b --- /dev/null +++ b/old_library/init/nat_div.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.wf init.nat +namespace nat + +private definition div_rec_lemma {x y : nat} : 0 < y ∧ y ≤ x → x - y < x := +λ h, and.rec (λ ypos ylex, sub_lt (nat.lt_of_lt_of_le ypos ylex) ypos) h + +private definition div.F (x : nat) (f : Π x₁, x₁ < x → nat → nat) (y : nat) : nat := +if H : 0 < y ∧ y ≤ x then f (x - y) (div_rec_lemma H) y + 1 else zero + +protected definition div := well_founded.fix lt_wf div.F + +attribute[instance] +definition nat_has_divide : has_div nat := +⟨nat.div⟩ + +theorem div_def (x y : nat) : div x y = if H : 0 < y ∧ y ≤ x then div (x - y) y + 1 else 0 := +congr_fun (well_founded.fix_eq lt_wf div.F x) y + +private definition mod.F (x : nat) (f : Π x₁, x₁ < x → nat → nat) (y : nat) : nat := +if H : 0 < y ∧ y ≤ x then f (x - y) (div_rec_lemma H) y else x + +protected definition mod := well_founded.fix lt_wf mod.F + +attribute [instance] +definition nat_has_mod : has_mod nat := +⟨nat.mod⟩ + +theorem mod_def (x y : nat) : mod x y = if H : 0 < y ∧ y ≤ x then mod (x - y) y else x := +congr_fun (well_founded.fix_eq lt_wf mod.F x) y + +end nat diff --git a/old_library/init/num.lean b/old_library/init/num.lean new file mode 100644 index 0000000000..9a9194cb04 --- /dev/null +++ b/old_library/init/num.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.bool + +namespace pos_num + protected definition mul (a b : pos_num) : pos_num := + pos_num.rec_on a + b + (λ n r, bit0 r + b) + (λ n r, bit0 r) + + definition lt (a b : pos_num) : bool := + pos_num.rec_on a + (λ b, pos_num.cases_on b + ff + (λ m, tt) + (λ m, tt)) + (λ n f b, pos_num.cases_on b + ff + (λ m, f m) + (λ m, f m)) + (λ n f b, pos_num.cases_on b + ff + (λ m, f (succ m)) + (λ m, f m)) + b + + definition le (a b : pos_num) : bool := + pos_num.lt a (succ b) +end pos_num + +attribute [instance] +definition pos_num_has_mul : has_mul pos_num := +⟨pos_num.mul⟩ + +namespace num + open pos_num + + definition pred (a : num) : num := + num.rec_on a zero (λ p, bool.cond (is_one p) zero (pos (pred p))) + + definition size (a : num) : num := + num.rec_on a (pos pos_num.one) (λ p, pos (size p)) + + protected definition mul (a b : num) : num := + num.rec_on a zero (λ pa, num.rec_on b zero (λ pb, pos (pos_num.mul pa pb))) +end num + +attribute [instance] +definition num_has_mul : has_mul num := +⟨num.mul⟩ + +namespace num + protected definition le (a b : num) : bool := + num.rec_on a tt (λ pa, num.rec_on b ff (λ pb, pos_num.le pa pb)) + + private definition psub (a b : pos_num) : num := + pos_num.rec_on a + (λ b, zero) + (λ n f b, + bool.cond (pos_num.le (bit1 n) b) + zero + (pos_num.cases_on b + (pos (bit0 n)) + (λ m, 2 * f m) + (λ m, 2 * f m + 1))) + (λ n f b, + bool.cond (pos_num.le (bit0 n) b) + zero + (pos_num.cases_on b + (pos (pos_num.pred (bit0 n))) + (λ m, pred (2 * f m)) + (λ m, 2 * f m))) + b + + protected definition sub (a b : num) : num := + num.rec_on a zero (λ pa, num.rec_on b a (λ pb, psub pa pb)) +end num + +attribute [instance] +definition num_has_sub : has_sub num := +⟨num.sub⟩ diff --git a/old_library/init/option.lean b/old_library/init/option.lean new file mode 100644 index 0000000000..a926493c3e --- /dev/null +++ b/old_library/init/option.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.logic init.monad init.alternative +open decidable + +universe variables u v + +attribute [instance] +definition option_is_inhabited (A : Type u) : inhabited (option A) := +⟨none⟩ + +attribute [instance] +definition option_has_decidable_eq {A : Type u} [H : decidable_eq A] : ∀ o₁ o₂ : option A, decidable (o₁ = o₂) +| none none := is_true rfl +| none (some v₂) := is_false (λ H, option.no_confusion H) +| (some v₁) none := is_false (λ H, option.no_confusion H) +| (some v₁) (some v₂) := + match (H v₁ v₂) with + | (is_true e) := is_true (congr_arg (@some A) e) + | (is_false n) := is_false (λ H, option.no_confusion H (λ e, absurd e n)) + end + +attribute [inline] +definition option_fmap {A : Type u} {B : Type v} (f : A → B) : option A → option B +| none := none +| (some a) := some (f a) + +attribute [inline] +definition option_bind {A : Type u} {B : Type v} : option A → (A → option B) → option B +| none b := none +| (some a) b := b a + +attribute [instance] +definition option_is_monad : monad option := +monad.mk @option_fmap @some @option_bind + +definition option_orelse {A : Type u} : option A → option A → option A +| (some a) o := some a +| none (some a) := some a +| none none := none + +attribute [instance] +definition option_is_alternative {A : Type u} : alternative option := +alternative.mk @option_fmap @some (@fapp _ _) @none @option_orelse + +definition optionT (M : Type (max 1 u) → Type v) [monad M] (A : Type u) : Type v := +M (option A) + +attribute [inline] +definition optionT_fmap {M : Type (max 1 u) → Type v} [monad M] {A B : Type u} (f : A → B) (e : optionT M A) : optionT M B := +show M (option B), from +do o ← e, + match o with + | none := return none + | (some a) := return (some (f a)) + end + +attribute [inline] +definition optionT_bind {M : Type (max 1 u) → Type v} [monad M] {A B : Type u} (a : optionT M A) (b : A → optionT M B) + : optionT M B := +show M (option B), from +do o ← a, + match o with + | none := return none + | (some a) := b a + end + +attribute [inline] +definition optionT_return {M : Type (max 1 u) → Type v} [monad M] {A : Type u} (a : A) : optionT M A := +show M (option A), from +return (some a) + +attribute [instance] +definition optionT_is_monad {M : Type (max 1 u) → Type v} [monad M] {A : Type u} : monad (optionT M) := +monad.mk (@optionT_fmap M _) (@optionT_return M _) (@optionT_bind M _) + +definition optionT_orelse {M : Type (max 1 u) → Type v} [monad M] {A : Type u} (a : optionT M A) (b : optionT M A) : optionT M A := +show M (option A), from +do o ← a, + match o with + | none := b + | (some v) := return (some v) + end + +definition optionT_fail {M : Type (max 1 u) → Type v} [monad M] {A : Type u} : optionT M A := +show M (option A), from +return none + +attribute [instance] +definition optionT_is_alternative {M : Type (max 1 u) → Type v} [monad M] {A : Type u} : alternative (optionT M) := +alternative.mk + (@optionT_fmap M _) + (@optionT_return M _) + (@fapp (optionT M) (@optionT_is_monad M _ A)) + (@optionT_fail M _) + (@optionT_orelse M _) diff --git a/old_library/init/ordering.lean b/old_library/init/ordering.lean new file mode 100644 index 0000000000..e9ed163480 --- /dev/null +++ b/old_library/init/ordering.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.to_string init.prod init.sum + +inductive ordering +| lt | eq | gt + +open ordering + +attribute [instance] +definition ordering.has_to_string : has_to_string ordering := +has_to_string.mk (λ s, match s with | ordering.lt := "lt" | ordering.eq := "eq" | ordering.gt := "gt" end) + +structure [class] has_ordering (A : Type) := +(cmp : A → A → ordering) + +definition nat.cmp (a b : nat) : ordering := +if a < b then ordering.lt +else if a = b then ordering.eq +else ordering.gt + +attribute [instance] +definition nat_has_ordering : has_ordering nat := +⟨nat.cmp⟩ + +section +open prod + +variables {A B : Type} [has_ordering A] [has_ordering B] + +definition prod.cmp : A × B → A × B → ordering +| (a₁, b₁) (a₂, b₂) := + match (has_ordering.cmp a₁ a₂) with + | ordering.lt := lt + | ordering.eq := has_ordering.cmp b₁ b₂ + | ordering.gt := gt + end + +attribute [instance] +definition prod_has_ordering {A B : Type} [has_ordering A] [has_ordering B] : has_ordering (A × B) := +⟨prod.cmp⟩ +end + +section +open sum + +variables {A B : Type} [has_ordering A] [has_ordering B] + +definition sum.cmp : A ⊕ B → A ⊕ B → ordering +| (inl a₁) (inl a₂) := has_ordering.cmp a₁ a₂ +| (inr b₁) (inr b₂) := has_ordering.cmp b₁ b₂ +| (inl a₁) (inr b₂) := lt +| (inr b₁) (inl a₂) := gt + +attribute [instance] +definition sum_has_ordering {A B : Type} [has_ordering A] [has_ordering B] : has_ordering (A ⊕ B) := +⟨sum.cmp⟩ +end + +section +open option + +variables {A : Type} [has_ordering A] + +definition option.cmp : option A → option A → ordering +| (some a₁) (some a₂) := has_ordering.cmp a₁ a₂ +| (some a₁) none := gt +| none (some a₂) := lt +| none none := eq + +attribute [instance] +definition option_has_ordering {A : Type} [has_ordering A] : has_ordering (option A) := +⟨option.cmp⟩ +end diff --git a/old_library/init/prod.lean b/old_library/init/prod.lean new file mode 100644 index 0000000000..35d4136ceb --- /dev/null +++ b/old_library/init/prod.lean @@ -0,0 +1,28 @@ +/- +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 +-/ +prelude +import init.num init.relation +notation A × B := prod A B +-- notation for n-ary tuples +notation `(` h `, ` t:(foldr `, ` (e r, prod.mk e r)) `)` := prod.mk h t + +universe variables u v + +attribute [instance] +protected definition prod.is_inhabited {A : Type u} {B : Type v} [inhabited A] [inhabited B] : inhabited (prod A B) := +⟨(default A, default B)⟩ + +attribute [instance] +protected definition prod.has_decidable_eq {A : Type u} {B : Type v} [h₁ : decidable_eq A] [h₂ : decidable_eq B] : ∀ p₁ p₂ : A × B, decidable (p₁ = p₂) +| (a, b) (a', b') := + match (h₁ a a') with + | (is_true e₁) := + match (h₂ b b') with + | (is_true e₂) := is_true (eq.rec_on e₁ (eq.rec_on e₂ rfl)) + | (is_false n₂) := is_false (assume h, prod.no_confusion h (λ e₁' e₂', absurd e₂' n₂)) + end + | (is_false n₁) := is_false (assume h, prod.no_confusion h (λ e₁' e₂', absurd e₁' n₁)) + end diff --git a/old_library/init/quot.lean b/old_library/init/quot.lean new file mode 100644 index 0000000000..4a53b494f3 --- /dev/null +++ b/old_library/init/quot.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Quotient types. +-/ +prelude +import init.sigma init.setoid init.logic +open setoid + +universe variables u v + +constant quot : Π {A : Type u}, setoid A → Type u +-- Remark: if we do not use propext here, then we would need a quot.lift for propositions. +constant propext {a b : Prop} : (a ↔ b) → a = b + +-- iff can now be used to do substitutions in a calculation +attribute [subst] +theorem iff_subst {a b : Prop} {P : Prop → Prop} (H₁ : a ↔ b) (H₂ : P a) : P b := +eq.subst (propext H₁) H₂ + +namespace quot + protected constant mk : Π {A : Type u} [s : setoid A], A → quot s + notation `⟦`:max a `⟧`:0 := quot.mk a + + constant sound : Π {A : Type u} [s : setoid A] {a b : A}, a ≈ b → ⟦a⟧ = ⟦b⟧ + constant lift : Π {A : Type u} {B : Type v} [s : setoid A] (f : A → B), (∀ a b, a ≈ b → f a = f b) → quot s → B + constant ind : ∀ {A : Type u} [s : setoid A] {B : quot s → Prop}, (∀ a, B ⟦a⟧) → ∀ q, B q + + attribute [elab_as_eliminator] lift ind + + init_quotient + + protected theorem lift_beta {A : Type u} {B : Type v} [setoid A] (f : A → B) (c : ∀ a b, a ≈ b → f a = f b) (a : A) : lift f c ⟦a⟧ = f a := + rfl + + protected theorem ind_beta {A : Type u} [s : setoid A] {B : quot s → Prop} (p : ∀ a, B ⟦a⟧) (a : A) : (ind p ⟦a⟧ : B ⟦a⟧) = p a := + rfl + + attribute [reducible, elab_as_eliminator] + protected definition lift_on {A : Type u} {B : Type v} [s : setoid A] (q : quot s) (f : A → B) (c : ∀ a b, a ≈ b → f a = f b) : B := + lift f c q + + attribute [elab_as_eliminator] + protected theorem induction_on {A : Type u} [s : setoid A] {B : quot s → Prop} (q : quot s) (H : ∀ a, B ⟦a⟧) : B q := + ind H q + + theorem exists_rep {A : Type u} [s : setoid A] (q : quot s) : ∃ a : A, ⟦a⟧ = q := + quot.induction_on q (λ a, ⟨a, rfl⟩) + + section + variable {A : Type u} + variable [s : setoid A] + variable {B : quot s → Type v} + include s + + attribute [reducible] + protected definition indep (f : Π a, B ⟦a⟧) (a : A) : Σ q, B q := + ⟨⟦a⟧, f a⟩ + + protected lemma indep_coherent (f : Π a, B ⟦a⟧) + (H : ∀ (a b : A) (p : a ≈ b), (eq.rec (f a) (sound p) : B ⟦b⟧) = f b) + : ∀ a b, a ≈ b → quot.indep f a = quot.indep f b := + λ a b e, sigma.eq (sound e) (H a b e) + + protected lemma lift_indep_pr1 + (f : Π a, B ⟦a⟧) (H : ∀ (a b : A) (p : a ≈ b), (eq.rec (f a) (sound p) : B ⟦b⟧) = f b) + (q : quot s) : (lift (quot.indep f) (quot.indep_coherent f H) q).1 = q := + quot.ind (λ (a : A), eq.refl (quot.indep f a).1) q + + attribute [reducible, elab_as_eliminator] + protected definition rec + (f : Π a, B ⟦a⟧) (H : ∀ (a b : A) (p : a ≈ b), (eq.rec (f a) (sound p) : B ⟦b⟧) = f b) + (q : quot s) : B q := + eq.rec_on (quot.lift_indep_pr1 f H q) ((lift (quot.indep f) (quot.indep_coherent f H) q).2) + + attribute [reducible, elab_as_eliminator] + protected definition rec_on + (q : quot s) (f : Π a, B ⟦a⟧) (H : ∀ (a b : A) (p : a ≈ b), (eq.rec (f a) (sound p) : B ⟦b⟧) = f b) : B q := + quot.rec f H q + + attribute [reducible, elab_as_eliminator] + protected definition rec_on_subsingleton + [H : ∀ a, subsingleton (B ⟦a⟧)] (q : quot s) (f : Π a, B ⟦a⟧) : B q := + quot.rec f (λ a b h, subsingleton.elim _ (f b)) q + + attribute [reducible, elab_as_eliminator] + protected definition hrec_on + (q : quot s) (f : Π a, B ⟦a⟧) (c : ∀ (a b : A) (p : a ≈ b), f a == f b) : B q := + quot.rec_on q f + (λ a b p, eq_of_heq (calc + (eq.rec (f a) (sound p) : B ⟦b⟧) == f a : eq_rec_heq (sound p) (f a) + ... == f b : c a b p)) + end + + section + universe variables u_a u_b u_c + variables {A : Type u_a} {B : Type u_b} {C : Type u_c} + variables [s₁ : setoid A] [s₂ : setoid B] + include s₁ s₂ + + attribute [reducible, elab_as_eliminator] + protected definition lift₂ + (f : A → B → C)(c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) + (q₁ : quot s₁) (q₂ : quot s₂) : C := + quot.lift + (λ (a₁ : A), quot.lift (f a₁) (λ (a b : B), c a₁ a a₁ b (setoid.refl a₁)) q₂) + (λ (a b : A) (H : a ≈ b), + @quot.ind B s₂ + (λ (a_1 : quot s₂), + (quot.lift (f a) (λ (a_1 b : B), c a a_1 a b (setoid.refl a)) a_1) + = + (quot.lift (f b) (λ (a b_1 : B), c b a b b_1 (setoid.refl b)) a_1)) + (λ (a' : B), c a a' b a' H (setoid.refl a')) + q₂) + q₁ + + attribute [reducible, elab_as_eliminator] + protected definition lift_on₂ + (q₁ : quot s₁) (q₂ : quot s₂) (f : A → B → C) (c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) : C := + quot.lift₂ f c q₁ q₂ + + attribute [elab_as_eliminator] + protected theorem ind₂ {C : quot s₁ → quot s₂ → Prop} (H : ∀ a b, C ⟦a⟧ ⟦b⟧) (q₁ : quot s₁) (q₂ : quot s₂) : C q₁ q₂ := + quot.ind (λ a₁, quot.ind (λ a₂, H a₁ a₂) q₂) q₁ + + attribute [elab_as_eliminator] + protected theorem induction_on₂ + {C : quot s₁ → quot s₂ → Prop} (q₁ : quot s₁) (q₂ : quot s₂) (H : ∀ a b, C ⟦a⟧ ⟦b⟧) : C q₁ q₂ := + quot.ind (λ a₁, quot.ind (λ a₂, H a₁ a₂) q₂) q₁ + + attribute [elab_as_eliminator] + protected theorem induction_on₃ + [s₃ : setoid C] + {D : quot s₁ → quot s₂ → quot s₃ → Prop} (q₁ : quot s₁) (q₂ : quot s₂) (q₃ : quot s₃) (H : ∀ a b c, D ⟦a⟧ ⟦b⟧ ⟦c⟧) + : D q₁ q₂ q₃ := + quot.ind (λ a₁, quot.ind (λ a₂, quot.ind (λ a₃, H a₁ a₂ a₃) q₃) q₂) q₁ + end + + section exact + variable {A : Type u} + variable [s : setoid A] + include s + + private definition rel (q₁ q₂ : quot s) : Prop := + quot.lift_on₂ q₁ q₂ + (λ a₁ a₂, a₁ ≈ a₂) + (λ a₁ a₂ b₁ b₂ a₁b₁ a₂b₂, + propext (iff.intro + (λ a₁a₂, setoid.trans (setoid.symm a₁b₁) (setoid.trans a₁a₂ a₂b₂)) + (λ b₁b₂, setoid.trans a₁b₁ (setoid.trans b₁b₂ (setoid.symm a₂b₂))))) + + local infix `~` := rel + + private lemma rel.refl : ∀ q : quot s, q ~ q := + λ q, quot.induction_on q (λ a, setoid.refl a) + + private lemma eq_imp_rel {q₁ q₂ : quot s} : q₁ = q₂ → q₁ ~ q₂ := + assume h, eq.rec_on h (rel.refl q₁) + + theorem exact {a b : A} : ⟦a⟧ = ⟦b⟧ → a ≈ b := + assume h, eq_imp_rel h + end exact + + section + universe variables u_a u_b u_c + variables {A : Type u_a} {B : Type u_b} + variables [s₁ : setoid A] [s₂ : setoid B] + include s₁ s₂ + + attribute [reducible, elab_as_eliminator] + protected definition rec_on_subsingleton₂ + {C : quot s₁ → quot s₂ → Type u_c} [H : ∀ a b, subsingleton (C ⟦a⟧ ⟦b⟧)] + (q₁ : quot s₁) (q₂ : quot s₂) (f : Π a b, C ⟦a⟧ ⟦b⟧) : C q₁ q₂:= + @quot.rec_on_subsingleton _ s₁ (λ q, C q q₂) (λ a, quot.ind (λ b, H a b) q₂) q₁ + (λ a, quot.rec_on_subsingleton q₂ (λ b, f a b)) + + end +end quot + +attribute quot.mk + +open decidable +attribute [instance] +definition quot.has_decidable_eq {A : Type u} {s : setoid A} [decR : ∀ a b : A, decidable (a ≈ b)] : decidable_eq (quot s) := +λ q₁ q₂ : quot s, + quot.rec_on_subsingleton₂ q₁ q₂ + (λ a₁ a₂, + match (decR a₁ a₂) with + | (is_true h₁) := is_true (quot.sound h₁) + | (is_false h₂) := is_false (λ h, absurd (quot.exact h) h₂) + end) diff --git a/old_library/init/relation.lean b/old_library/init/relation.lean new file mode 100644 index 0000000000..8a4e7ba4a2 --- /dev/null +++ b/old_library/init/relation.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Module init.relation +Authors: Leonardo de Moura +-/ +prelude +import init.logic + +-- TODO(Leo): remove duplication between this file and algebra/relation.lean +-- We need some of the following definitions asap when "initializing" Lean. +universe variables u v +variables {A : Type u} {B : Type v} (R : B → B → Prop) +local infix `≺`:50 := R + +definition reflexive := ∀ x, x ≺ x + +definition symmetric := ∀ ⦃x y⦄, x ≺ y → y ≺ x + +definition transitive := ∀ ⦃x y z⦄, x ≺ y → y ≺ z → x ≺ z + +definition equivalence := reflexive R ∧ symmetric R ∧ transitive R + +definition total := ∀ x y, x ≺ y ∨ y ≺ x + +definition mk_equivalence (r : reflexive R) (s : symmetric R) (t : transitive R) : equivalence R := +⟨r, s, t⟩ + +definition irreflexive := ∀ x, ¬ x ≺ x + +definition anti_symmetric := ∀ ⦃x y⦄, x ≺ y → y ≺ x → x = y + +definition empty_relation := λ a₁ a₂ : A, false + +definition subrelation (Q R : B → B → Prop) := ∀ ⦃x y⦄, Q x y → R x y + +definition inv_image (f : A → B) : A → A → Prop := +λ a₁ a₂, f a₁ ≺ f a₂ + +theorem inv_image.trans (f : A → B) (H : transitive R) : transitive (inv_image R f) := +λ (a₁ a₂ a₃ : A) (H₁ : inv_image R f a₁ a₂) (H₂ : inv_image R f a₂ a₃), H H₁ H₂ + +theorem inv_image.irreflexive (f : A → B) (H : irreflexive R) : irreflexive (inv_image R f) := +λ (a : A) (H₁ : inv_image R f a a), H (f a) H₁ + +inductive tc {A : Type u} (R : A → A → Prop) : A → A → Prop +| base : ∀ a b, R a b → tc a b +| trans : ∀ a b c, tc a b → tc b c → tc a c diff --git a/old_library/init/setoid.lean b/old_library/init/setoid.lean new file mode 100644 index 0000000000..61e4b3407d --- /dev/null +++ b/old_library/init/setoid.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Authors: Leonardo de Moura +-/ +prelude +import init.relation +universe variables u +structure [class] setoid (A : Type u) := +(r : A → A → Prop) (iseqv : equivalence r) + +namespace setoid + infix ` ≈ ` := setoid.r + + variable {A : Type u} + variable [s : setoid A] + include s + + attribute [refl] + theorem refl (a : A) : a ≈ a := + match setoid.iseqv A with + | ⟨H_refl, H_symm, H_trans⟩ := H_refl a + end + + attribute [symm] + theorem symm {a b : A} (Hab : a ≈ b) : b ≈ a := + match setoid.iseqv A with + | ⟨H_refl, H_symm, H_trans⟩ := H_symm Hab + end + + attribute [trans] + theorem trans {a b c : A} (Hab : a ≈ b) (Hbc : b ≈ c) : a ≈ c := + match setoid.iseqv A with + | ⟨H_refl, H_symm, H_trans⟩ := H_trans Hab Hbc + end +end setoid diff --git a/old_library/init/sigma.lean b/old_library/init/sigma.lean new file mode 100644 index 0000000000..86bfdd5f06 --- /dev/null +++ b/old_library/init/sigma.lean @@ -0,0 +1,23 @@ +/- +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, Floris van Doorn +-/ +prelude +import init.datatypes init.num init.wf init.logic + +definition dpair := @sigma.mk +notation `Σ` binders `, ` r:(scoped P, sigma P) := r + +universe variables u v + +lemma ex_of_sig {A : Type u} {P : A → Prop} : (Σ x, P x) → ∃ x, P x +| ⟨x, hx⟩ := ⟨x, hx⟩ + +namespace sigma + variables {A : Type u} {B : A → Type v} + + protected theorem eq : ∀ {p₁ p₂ : Σ a : A, B a} (H₁ : p₁.1 = p₂.1), (eq.rec_on H₁ p₁.2 : B p₂.1) = p₂.2 → p₁ = p₂ + | ⟨a, b⟩ ⟨.a, .b⟩ rfl rfl := rfl + +end sigma diff --git a/old_library/init/sigma_lex.lean b/old_library/init/sigma_lex.lean new file mode 100644 index 0000000000..5aa6ae1849 --- /dev/null +++ b/old_library/init/sigma_lex.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.sigma init.meta init.combinator +universe variables u v +namespace sigma +section + variables {A : Type u} {B : A → Type v} + variable (Ra : A → A → Prop) + variable (Rb : ∀ a, B a → B a → Prop) + + -- Lexicographical order based on Ra and Rb + inductive lex : sigma B → sigma B → Prop + | left : ∀ {a₁ : A} (b₁ : B a₁) {a₂ : A} (b₂ : B a₂), Ra a₁ a₂ → lex (sigma.mk a₁ b₁) (sigma.mk a₂ b₂) + | right : ∀ (a : A) {b₁ b₂ : B a}, Rb a b₁ b₂ → lex (sigma.mk a b₁) (sigma.mk a b₂) +end + + +section + open well_founded tactic + parameters {A : Type u} {B : A → Type v} + parameters {Ra : A → A → Prop} {Rb : Π a : A, B a → B a → Prop} + local infix `≺`:50 := lex Ra Rb + + definition lex_accessible {a} (aca : acc Ra a) (acb : ∀ a, well_founded (Rb a)) + : ∀ (b : B a), acc (lex Ra Rb) (sigma.mk a b) := + acc.rec_on aca + (λ xa aca (iHa : ∀ y, Ra y xa → ∀ b : B y, acc (lex Ra Rb) (sigma.mk y b)), + λ b : B xa, acc.rec_on (well_founded.apply (acb xa) b) + (λ xb acb + (iHb : ∀ (y : B xa), Rb xa y xb → acc (lex Ra Rb) (sigma.mk xa y)), + acc.intro (sigma.mk xa xb) (λ p (lt : p ≺ (sigma.mk xa xb)), + have aux : xa = xa → xb == xb → acc (lex Ra Rb) p, from + @sigma.lex.rec_on A B Ra Rb (λ p₁ p₂, p₂.1 = xa → p₂.2 == xb → acc (lex Ra Rb) p₁) + p (sigma.mk xa xb) lt + (λ (a₁ : A) (b₁ : B a₁) (a₂ : A) (b₂ : B a₂) (H : Ra a₁ a₂) (eq₂ : a₂ = xa) (eq₃ : b₂ == xb), + by do + get_local `eq₂ >>= subst, + to_expr `(iHa a₁ H b₁) >>= exact) + (λ (a : A) (b₁ b₂ : B a) (H : Rb a b₁ b₂) (eq₂ : a = xa) (eq₃ : b₂ == xb), + by do + get_local `eq₂ >>= subst, + to_expr `(eq_of_heq eq₃) >>= note `new_eq₃, + get_local `new_eq₃ >>= subst, + to_expr `(iHb b₁ H) >>= exact), + aux rfl (heq.refl xb)))) + + -- The lexicographical order of well founded relations is well-founded + definition lex_wf (Ha : well_founded Ra) (Hb : ∀ x, well_founded (Rb x)) : well_founded (lex Ra Rb) := + well_founded.intro (λ p, destruct p (λ a b, lex_accessible (well_founded.apply Ha a) Hb b)) +end + +section + parameters {A : Type u} {B : Type v} + + definition lex_ndep (Ra : A → A → Prop) (Rb : B → B → Prop) := + lex Ra (λ a : A, Rb) + + definition lex_ndep_wf {Ra : A → A → Prop} {Rb : B → B → Prop} (Ha : well_founded Ra) (Hb : well_founded Rb) + : well_founded (lex_ndep Ra Rb) := + well_founded.intro (λ p, destruct p (λ a b, lex_accessible (well_founded.apply Ha a) (λ x, Hb) b)) +end + +section + variables {A : Type u} {B : Type v} + variable (Ra : A → A → Prop) + variable (Rb : B → B → Prop) + + -- Reverse lexicographical order based on Ra and Rb + inductive rev_lex : @sigma A (λ a, B) → @sigma A (λ a, B) → Prop + | left : ∀ {a₁ a₂ : A} (b : B), Ra a₁ a₂ → rev_lex (sigma.mk a₁ b) (sigma.mk a₂ b) + | right : ∀ (a₁ : A) {b₁ : B} (a₂ : A) {b₂ : B}, Rb b₁ b₂ → rev_lex (sigma.mk a₁ b₁) (sigma.mk a₂ b₂) +end + +section + open well_founded tactic + parameters {A : Type u} {B : Type v} + parameters {Ra : A → A → Prop} {Rb : B → B → Prop} + local infix `≺`:50 := rev_lex Ra Rb + + definition rev_lex_accessible {b} (acb : acc Rb b) (aca : ∀ a, acc Ra a): ∀ a, acc (rev_lex Ra Rb) (sigma.mk a b) := + acc.rec_on acb + (λ xb acb (iHb : ∀ y, Rb y xb → ∀ a, acc (rev_lex Ra Rb) (sigma.mk a y)), + λ a, acc.rec_on (aca a) + (λ xa aca (iHa : ∀ y, Ra y xa → acc (rev_lex Ra Rb) (mk y xb)), + acc.intro (sigma.mk xa xb) (λ p (lt : p ≺ (sigma.mk xa xb)), + have aux : xa = xa → xb = xb → acc (rev_lex Ra Rb) p, from + @rev_lex.rec_on A B Ra Rb (λ p₁ p₂, fst p₂ = xa → snd p₂ = xb → acc (rev_lex Ra Rb) p₁) + p (sigma.mk xa xb) lt + (λ a₁ a₂ b (H : Ra a₁ a₂) (eq₂ : a₂ = xa) (eq₃ : b = xb), + show acc (rev_lex Ra Rb) (sigma.mk a₁ b), from + have Ra₁ : Ra a₁ xa, from eq.rec_on eq₂ H, + have aux : acc (rev_lex Ra Rb) (sigma.mk a₁ xb), from iHa a₁ Ra₁, + eq.rec_on (eq.symm eq₃) aux) + (λ a₁ b₁ a₂ b₂ (H : Rb b₁ b₂) (eq₂ : a₂ = xa) (eq₃ : b₂ = xb), + show acc (rev_lex Ra Rb) (mk a₁ b₁), from + have Rb₁ : Rb b₁ xb, from eq.rec_on eq₃ H, + iHb b₁ Rb₁ a₁), + aux rfl rfl))) + + definition rev_lex_wf (Ha : well_founded Ra) (Hb : well_founded Rb) : well_founded (rev_lex Ra Rb) := + well_founded.intro (λ p, destruct p (λ a b, rev_lex_accessible (apply Hb b) (well_founded.apply Ha) a)) +end + +section + definition skip_left (A : Type u) {B : Type v} (Rb : B → B → Prop) : @sigma A (λ a, B) → @sigma A (λ a, B) → Prop := + rev_lex empty_relation Rb + + definition skip_left_wf (A : Type u) {B : Type v} {Rb : B → B → Prop} (Hb : well_founded Rb) : well_founded (skip_left A Rb) := + rev_lex_wf empty_wf Hb + + definition mk_skip_left {A : Type u} {B : Type v} {b₁ b₂ : B} {Rb : B → B → Prop} + (a₁ a₂ : A) (H : Rb b₁ b₂) : skip_left A Rb (sigma.mk a₁ b₁) (sigma.mk a₂ b₂) := + rev_lex.right _ _ _ H +end +end sigma diff --git a/old_library/init/simplifier.lean b/old_library/init/simplifier.lean new file mode 100644 index 0000000000..b445b7ebb4 --- /dev/null +++ b/old_library/init/simplifier.lean @@ -0,0 +1,47 @@ +prelude +import init.logic init.classical + +universe variables u + +-- For n-ary support +structure [class] is_associative {A : Type u} (op : A → A → A) := +(op_assoc : ∀ x y z : A, op (op x y) z = op x (op y z)) + +attribute [instance] +definition and_is_associative : is_associative and := +is_associative.mk (λ x y z, propext (@and.assoc x y z)) + +attribute [instance] +definition or_is_associative : is_associative or := +is_associative.mk (λ x y z, propext (@or.assoc x y z)) + +-- Basic congruence theorems over equality (using propext) +attribute [congr] +theorem imp_congr_ctx_eq {P₁ P₂ Q₁ Q₂ : Prop} (H₁ : P₁ = P₂) (H₂ : P₂ → (Q₁ = Q₂)) : (P₁ → Q₁) = (P₂ → Q₂) := +propext (imp_congr_ctx (iff.of_eq H₁) (assume p₂, iff.of_eq (H₂ p₂))) + +attribute [congr] +theorem forall_congr_eq {A : Type u} (P Q : A → Prop) (H : ∀ a, P a = Q a) : ((∀ a, P a) = (∀ a, Q a)) := +propext (forall_congr (assume a, iff.of_eq (H a))) + +-- Congruence theorems for flattening +namespace simplifier +variables {A : Type u} + +theorem congr_bin_op {op op' : A → A → A} (H : op = op') (x y : A) : op x y = op' x y := +congr_fun (congr_fun H x) y + +theorem congr_bin_arg1 {op : A → A → A} {x x' y : A} (Hx : x = x') : op x y = op x' y := +congr_fun (congr_arg op Hx) y + +theorem congr_bin_arg2 {op : A → A → A} {x y y' : A} (Hy : y = y') : op x y = op x y' := +congr_arg (op x) Hy + +theorem congr_bin_args {op : A → A → A} {x x' y y' : A} (Hx : x = x') (Hy : y = y') : op x y = op x' y' := +congr (congr_arg op Hx) Hy + +theorem assoc_subst {op op' : A → A → A} (H : op = op') (H_assoc : ∀ x y z, op (op x y) z = op x (op y z)) + : (∀ x y z, op' (op' x y) z = op' x (op' y z)) := +H ▸ H_assoc + +end simplifier diff --git a/old_library/init/state.lean b/old_library/init/state.lean new file mode 100644 index 0000000000..08ed7347c1 --- /dev/null +++ b/old_library/init/state.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.logic init.monad init.alternative init.prod + +definition state (S : Type) (A : Type) : Type := +S → A × S + +section +set_option pp.all true +variables {S : Type} {A B : Type} + +attribute [inline] +definition state_fmap (f : A → B) (a : state S A) : state S B := +λ s, match (a s) with (a', s') := (f a', s') end + +attribute [inline] +definition state_return (a : A) : state S A := +λ s, (a, s) + +attribute [inline] +definition state_bind (a : state S A) (b : A → state S B) : state S B := +λ s, match (a s) with (a', s') := b a' s' end + +attribute [instance] +definition state_is_monad (S : Type) : monad (state S) := +monad.mk (@state_fmap S) (@state_return S) (@state_bind S) +end + +namespace state +attribute [inline] +definition read {S : Type} : state S S := +λ s, (s, s) + +attribute [inline] +definition write {S : Type} : S → state S unit := +λ s' s, ((), s') +end state + +definition stateT (S : Type) (M : Type → Type) [monad M] (A : Type) : Type := +S → M (A × S) + +section + variable {S : Type} + variable {M : Type → Type} + variable [monad M] + variables {A B : Type} + + definition stateT_fmap (f : A → B) (act : stateT S M A) : stateT S M B := + λ s, show M (B × S), from + do (a, new_s) ← act s, + return (f a, new_s) + + definition stateT_return (a : A) : stateT S M A := + λ s, show M (A × S), from + return (a, s) + + definition stateT_bind (act₁ : stateT S M A) (act₂ : A → stateT S M B) : stateT S M B := + λ s, show M (B × S), from + do (a, new_s) ← act₁ s, + act₂ a new_s +end + +attribute [instance] +definition stateT_is_monad (S : Type) (M : Type → Type) [monad M] : monad (stateT S M) := +monad.mk (@stateT_fmap S M _) (@stateT_return S M _) (@stateT_bind S M _) + +namespace stateT +definition read {S : Type} {M : Type → Type} [monad M] : stateT S M S := +λ s, return (s, s) + +definition write {S : Type} {M : Type → Type} [monad M] : S → stateT S M unit := +λ s' s, return ((), s') +end stateT diff --git a/old_library/init/string.lean b/old_library/init/string.lean new file mode 100644 index 0000000000..b9b536a732 --- /dev/null +++ b/old_library/init/string.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.char init.list +attribute [reducible] +definition string := list char + +namespace string + +attribute [pattern] +definition empty : string := list.nil + +attribute [pattern] +definition str : char → string → string := list.cons + +definition concat (a b : string) : string := +list.append b a +end string + +attribute [instance] +definition string.has_append : has_append string := +⟨string.concat⟩ + +open list + +private definition utf8_length_aux : nat → nat → string → nat +| 0 r (c::s) := + let n := char.to_nat c in + if n < 0x80 then utf8_length_aux 0 (r+1) s + else if 0xC0 ≤ n ∧ n < 0xE0 then utf8_length_aux 1 (r+1) s + else if 0xE0 ≤ n ∧ n < 0xF0 then utf8_length_aux 2 (r+1) s + else if 0xF0 ≤ n ∧ n < 0xF8 then utf8_length_aux 3 (r+1) s + else if 0xF8 ≤ n ∧ n < 0xFC then utf8_length_aux 4 (r+1) s + else if 0xFC ≤ n ∧ n < 0xFE then utf8_length_aux 5 (r+1) s + else utf8_length_aux 0 (r+1) s +| (n+1) r (c::s) := utf8_length_aux n r s +| n r [] := r + +definition utf8_length : string → nat +| s := utf8_length_aux 0 0 (reverse s) diff --git a/old_library/init/subtype.lean b/old_library/init/subtype.lean new file mode 100644 index 0000000000..6bd3b6e6b4 --- /dev/null +++ b/old_library/init/subtype.lean @@ -0,0 +1,38 @@ +/- +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 +-/ +prelude +import init.datatypes init.logic +open decidable + +universe variables u + +structure subtype {A : Type u} (P : A → Prop) := +tag :: (elt_of : A) (has_property : P elt_of) + +notation `{` binder ` \ `:0 r:(scoped:1 P, subtype P) `}` := r + +namespace subtype + + definition exists_of_subtype {A : Type u} {P : A → Prop} : { x \ P x } → ∃ x, P x + | ⟨a, h⟩ := ⟨a, h⟩ + + variables {A : Type u} {P : A → Prop} + + theorem tag_irrelevant {a : A} (h1 h2 : P a) : tag a h1 = tag a h2 := + rfl + + protected theorem eq : ∀ {a1 a2 : {x \ P x}}, elt_of a1 = elt_of a2 → a1 = a2 + | ⟨x, h1⟩ ⟨.x, h2⟩ rfl := rfl + +end subtype + +open subtype + +variables {A : Type u} {P : A → Prop} + +attribute [instance] +protected definition subtype.is_inhabited {a : A} (h : P a) : inhabited {x \ P x} := +⟨⟨a, h⟩⟩ diff --git a/old_library/init/sum.lean b/old_library/init/sum.lean new file mode 100644 index 0000000000..5bcdc1c424 --- /dev/null +++ b/old_library/init/sum.lean @@ -0,0 +1,23 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad + +The sum type, aka disjoint union. +-/ +prelude +import init.logic + +notation A ⊕ B := sum A B + +universe variables u v + +variables {A : Type u} {B : Type v} + +attribute [instance] +protected definition is_inhabited_left [h : inhabited A] : inhabited (A ⊕ B) := +⟨sum.inl (default A)⟩ + +attribute [instance] +protected definition is_inhabited_right [h : inhabited B] : inhabited (A ⊕ B) := +⟨sum.inr (default B)⟩ diff --git a/old_library/init/timeit.lean b/old_library/init/timeit.lean new file mode 100644 index 0000000000..0d44b5674b --- /dev/null +++ b/old_library/init/timeit.lean @@ -0,0 +1,9 @@ +-- Copyright (c) 2016 Microsoft Corporation. All rights reserved. +-- Released under Apache 2.0 license as described in the file LICENSE. +-- Author: Leonardo de Moura +prelude +import init.string + +/- This function has a native implementation that tracks time. -/ +definition timeit {A : Type} (s : string) (f : unit → A) : A := +f () diff --git a/old_library/init/to_string.lean b/old_library/init/to_string.lean new file mode 100644 index 0000000000..7a34e396da --- /dev/null +++ b/old_library/init/to_string.lean @@ -0,0 +1,101 @@ +-- Copyright (c) 2016 Microsoft Corporation. All rights reserved. +-- Released under Apache 2.0 license as described in the file LICENSE. +-- Author: Leonardo de Moura +prelude +import init.string init.bool init.subtype init.unsigned init.prod init.sum +open bool list sum prod sigma subtype nat + +universe variables u v + +structure [class] has_to_string (A : Type u) := +(to_string : A → string) + +definition to_string {A : Type u} [has_to_string A] : A → string := +has_to_string.to_string + +attribute [instance] +definition bool.has_to_string : has_to_string bool := +⟨λ b, cond b "tt" "ff"⟩ + +attribute [instance] +definition decidable.has_to_string {p : Prop} : has_to_string (decidable p) := +-- Remark: type class inference will not consider local instance `b` in the new elaborator +⟨λ b : decidable p, @ite p b _ "tt" "ff"⟩ + +definition list.to_string_aux {A : Type u} [has_to_string A] : bool → list A → string +| b [] := "" +| tt (x::xs) := to_string x ++ list.to_string_aux ff xs +| ff (x::xs) := ", " ++ to_string x ++ list.to_string_aux ff xs + +definition list.to_string {A : Type u} [has_to_string A] : list A → string +| [] := "[]" +| (x::xs) := "[" ++ list.to_string_aux tt (x::xs) ++ "]" + +attribute [instance] +definition list.has_to_string {A : Type u} [has_to_string A] : has_to_string (list A) := +⟨list.to_string⟩ + +attribute [instance] +definition unit.has_to_string : has_to_string unit := +⟨λ u, "star"⟩ + +attribute [instance] +definition option.has_to_string {A : Type u} [has_to_string A] : has_to_string (option A) := +⟨λ o, match o with | none := "none" | (some a) := "(some " ++ to_string a ++ ")" end⟩ + +attribute [instance] +definition sum.has_to_string {A : Type u} {B : Type v} [has_to_string A] [has_to_string B] : has_to_string (A ⊕ B) := +⟨λ s, match s with | (inl a) := "(inl " ++ to_string a ++ ")" | (inr b) := "(inr " ++ to_string b ++ ")" end⟩ + +attribute [instance] +definition prod.has_to_string {A : Type u} {B : Type v} [has_to_string A] [has_to_string B] : has_to_string (A × B) := +⟨λ p, "(" ++ to_string (fst p) ++ ", " ++ to_string (snd p) ++ ")"⟩ + +attribute [instance] +definition sigma.has_to_string {A : Type u} {B : A → Type v} [has_to_string A] [s : ∀ x, has_to_string (B x)] + : has_to_string (sigma B) := +⟨λ p, "⟨" ++ to_string (fst p) ++ ", " ++ to_string (snd p) ++ "⟩"⟩ + +attribute [instance] +definition subtype.has_to_string {A : Type u} {P : A → Prop} [has_to_string A] : has_to_string (subtype P) := +⟨λ s, to_string (elt_of s)⟩ + +definition char.quote_core (c : char) : string := +if c = '\n' then "\\n" +else if c = '\\' then "\\\\" +else if c = '\"' then "\\\"" +else if c = '\'' then "\\\'" +else c::nil + +attribute [instance] +definition char.has_to_sting : has_to_string char := +⟨λ c, "'" ++ char.quote_core c ++ "'"⟩ + +definition string.quote_aux : string → string +| [] := "" +| (x::xs) := string.quote_aux xs ++ char.quote_core x + +definition string.quote : string → string +| [] := "\"\"" +| (x::xs) := "\"" ++ string.quote_aux (x::xs) ++ "\"" + +attribute [instance] +definition string.has_to_string : has_to_string string := +⟨string.quote⟩ + +/- Remark: the code generator replaces this definition with one that display natural numbers in decimal notation -/ +definition nat.to_string : nat → string +| 0 := "zero" +| (succ a) := "(succ " ++ nat.to_string a ++ ")" + +attribute [instance] +definition nat.has_to_string : has_to_string nat := +⟨nat.to_string⟩ + +attribute [instance] +definition fin.has_to_string (n : nat) : has_to_string (fin n) := +⟨λ f, to_string (fin.val f)⟩ + +attribute [instance] +definition unsigned.has_to_string : has_to_string unsigned := +⟨λ n, to_string (fin.val n)⟩ diff --git a/old_library/init/trace.lean b/old_library/init/trace.lean new file mode 100644 index 0000000000..9519ec16e6 --- /dev/null +++ b/old_library/init/trace.lean @@ -0,0 +1,9 @@ +-- Copyright (c) 2016 Microsoft Corporation. All rights reserved. +-- Released under Apache 2.0 license as described in the file LICENSE. +-- Author: Leonardo de Moura +prelude +import init.string + +/- This function has a native implementation that displays the given string in the regular output stream. -/ +definition trace {A : Type} (s : string) (f : unit → A) : A := +f () diff --git a/old_library/init/unit.lean b/old_library/init/unit.lean new file mode 100644 index 0000000000..8a69ec30ab --- /dev/null +++ b/old_library/init/unit.lean @@ -0,0 +1,21 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.logic + +theorem unit_eq (a b : unit) : a = b := +unit.rec_on a (unit.rec_on b rfl) + +theorem unit_eq_unit (a : unit) : a = () := +unit_eq a () + +attribute [instance] +definition unit_subsingleton : subsingleton unit := +subsingleton.intro unit_eq + +attribute [instance] +definition unit_is_inhabited : inhabited unit := +⟨()⟩ diff --git a/old_library/init/unsigned.lean b/old_library/init/unsigned.lean new file mode 100644 index 0000000000..6f84808582 --- /dev/null +++ b/old_library/init/unsigned.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura +-/ +prelude +import init.fin + +open nat +definition unsigned_sz : nat := succ 4294967295 + +attribute [reducible] +definition unsigned := fin unsigned_sz + +namespace unsigned +/- We cannot use tactic dec_trivial here because the tactic framework has not been defined yet. -/ +private lemma zero_lt_unsigned_sz : 0 < unsigned_sz := +zero_lt_succ _ + +definition of_nat (n : nat) : unsigned := +if H : n < unsigned_sz then fin.mk n H else fin.mk 0 zero_lt_unsigned_sz + +definition to_nat (c : unsigned) : nat := +fin.val c +end unsigned + +attribute [instance] +definition unsigned.has_decidable_eq : decidable_eq unsigned := +have decidable_eq (fin unsigned_sz), from fin.has_decidable_eq _, +this diff --git a/old_library/init/wf.lean b/old_library/init/wf.lean new file mode 100644 index 0000000000..d4845d530a --- /dev/null +++ b/old_library/init/wf.lean @@ -0,0 +1,240 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +prelude +import init.relation init.nat init.prod + +universe variables u v + +inductive acc {A : Type u} (R : A → A → Prop) : A → Prop +| intro : ∀ x, (∀ y, R y x → acc y) → acc x + +namespace acc + variables {A : Type u} {R : A → A → Prop} + + definition inv {x y : A} (H₁ : acc R x) (H₂ : R y x) : acc R y := + acc.rec_on H₁ (λ x₁ ac₁ iH H₂, ac₁ y H₂) H₂ + + -- dependent elimination for acc + attribute [recursor] + protected definition drec + {C : Π (a : A), acc R a → Type v} + (h₁ : Π (x : A) (acx : Π (y : A), R y x → acc R y), + (Π (y : A) (ryx : R y x), C y (acx y ryx)) → C x (acc.intro x acx)) + {a : A} (h₂ : acc R a) : C a h₂ := + @acc.rec _ _ (λ (a : A), Π (x : @acc A R a), C a x) + (λ x acx ih h₂, h₁ x acx (λ y ryx, ih y ryx (acx y ryx))) + _ + h₂ + h₂ +end acc + +inductive well_founded {A : Type u} (R : A → A → Prop) : Prop +| intro : (∀ a, acc R a) → well_founded + +namespace well_founded + definition apply {A : Type u} {R : A → A → Prop} (wf : well_founded R) : ∀ a, acc R a := + take a, well_founded.rec_on wf (λ p, p) a + + section + parameters {A : Type u} {R : A → A → Prop} + local infix `≺`:50 := R + + hypothesis Hwf : well_founded R + + theorem recursion {C : A → Type v} (a : A) (H : Π x, (Π y, y ≺ x → C y) → C x) : C a := + acc.rec_on (apply Hwf a) (λ x₁ ac₁ iH, H x₁ iH) + + theorem induction {C : A → Prop} (a : A) (H : ∀ x, (∀ y, y ≺ x → C y) → C x) : C a := + recursion a H + + variable {C : A → Type v} + variable F : Π x, (Π y, y ≺ x → C y) → C x + + definition fix_F (x : A) (a : acc R x) : C x := + acc.rec_on a (λ x₁ ac₁ iH, F x₁ iH) + + theorem fix_F_eq (x : A) (r : acc R x) : + fix_F F x r = F x (λ (y : A) (p : y ≺ x), fix_F F y (acc.inv r p)) := + acc.drec (λ x r ih, rfl) r + end + + variables {A : Type u} {C : A → Type v} {R : A → A → Prop} + + -- Well-founded fixpoint + definition fix (Hwf : well_founded R) (F : Π x, (Π y, R y x → C y) → C x) (x : A) : C x := + fix_F F x (apply Hwf x) + + -- Well-founded fixpoint satisfies fixpoint equation + theorem fix_eq (Hwf : well_founded R) (F : Π x, (Π y, R y x → C y) → C x) (x : A) : + fix Hwf F x = F x (λ y h, fix Hwf F y) := + fix_F_eq F x (apply Hwf x) +end well_founded + +open well_founded + +-- Empty relation is well-founded +definition empty_wf {A : Type u} : well_founded empty_relation := +well_founded.intro (λ (a : A), + acc.intro a (λ (b : A) (lt : false), false.rec _ lt)) + +-- Subrelation of a well-founded relation is well-founded +namespace subrelation +section + parameters {A : Type u} {R Q : A → A → Prop} + parameters (H₁ : subrelation Q R) + parameters (H₂ : well_founded R) + + definition accessible {a : A} (ac : acc R a) : acc Q a := + acc.rec_on ac (λ x ax ih, + acc.intro x (λ (y : A) (lt : Q y x), ih y (H₁ lt))) + + definition wf : well_founded Q := + well_founded.intro (λ a, accessible (apply H₂ a)) +end +end subrelation + +-- The inverse image of a well-founded relation is well-founded +namespace inv_image +section + parameters {A : Type u} {B : Type v} {R : B → B → Prop} + parameters (f : A → B) + parameters (H : well_founded R) + + private definition acc_aux : ∀ {b : B}, @acc B R b → (∀ (x : A), @eq B (f x) b → @acc A (@inv_image A B R f) x) := + @acc.rec B R (λ (b : B), ∀ (x : A), f x = b → acc (inv_image R f) x) + (λ (x : B) + (acx : ∀ (y : B), R y x → acc R y) + (ih : ∀ (y : B), R y x → (λ (b : B), ∀ (x : A), f x = b → acc (inv_image R f) x) y) + (z : A) (e : f z = x), + acc.intro z + (λ (y : A) (lt : inv_image R f y z), + @eq.rec B (f z) + (λ (x : B), + (∀ (y : B), R y x → acc R y) → + (∀ (y : B), R y x → (λ (b : B), ∀ (x : A), f x = b → acc (inv_image R f) x) y) → acc (inv_image R f) y) + (λ (acx : ∀ (y : B), R y (f z) → @acc B R y) + (ih : ∀ (y : B), R y (f z) → (λ (b : B), ∀ (x : A), f x = b → acc (inv_image R f) x) y), + ih (f y) lt y (@rfl B (f y))) + x + e + acx + ih)) + + definition accessible {a : A} (ac : acc R (f a)) : acc (inv_image R f) a := + acc_aux ac a rfl + + definition wf : well_founded (inv_image R f) := + well_founded.intro (λ a, accessible (apply H (f a))) +end +end inv_image + +-- The transitive closure of a well-founded relation is well-founded +namespace tc +section + parameters {A : Type u} {R : A → A → Prop} + local notation `R⁺` := tc R + + definition accessible : ∀ {z : A}, acc R z → acc (tc R) z := + @acc.rec A R (acc (tc R)) + (λ (x : A) (acx : ∀ (y : A), R y x → acc R y) (ih : ∀ (y : A), R y x → acc (tc R) y), + @acc.intro A (tc R) x + (λ (y : A) (rel : tc R y x), + @tc.rec A R + (λ (y x : A), + (∀ (y : A), R y x → acc R y) → + (∀ (y : A), R y x → acc (tc R) y) → acc (tc R) y) + (λ (a b : A) (rab : R a b) (acx : ∀ (y : A), R y b → acc R y) + (ih : ∀ (y : A), R y b → acc (tc R) y), + ih a rab) + (λ (a b c : A) (rab : tc R a b) (rbc : tc R b c) + (ih₁ : (∀ (y : A), R y b → acc R y) → (∀ (y : A), R y b → acc (tc R) y) → acc (tc R) a) + (ih₂ : (∀ (y : A), R y c → acc R y) → (∀ (y : A), R y c → acc (tc R) y) → acc (tc R) b) + (acx : ∀ (y : A), R y c → acc R y) (ih : ∀ (y : A), R y c → acc (tc R) y), + @acc.inv A (@tc A R) b a (ih₂ acx ih) rab) + y + x + rel + acx + ih)) + + definition wf (H : well_founded R) : well_founded R⁺ := + well_founded.intro (λ a, accessible (apply H a)) +end +end tc + +-- less-than is well-founded +definition nat.lt_wf : well_founded nat.lt := +well_founded.intro (nat.rec + (acc.intro 0 (λ n H, absurd H (nat.not_lt_zero n))) + (λ n IH, acc.intro (nat.succ n) (λ m H, + or.elim (nat.eq_or_lt_of_le (nat.le_of_succ_le_succ H)) + (λ e, eq.substr e IH) (acc.inv IH)))) + +definition measure {A : Type u} : (A → ℕ) → A → A → Prop := +inv_image lt + +definition measure_wf {A : Type u} (f : A → ℕ) : well_founded (measure f) := +inv_image.wf f nat.lt_wf + +namespace prod + open well_founded + + section + variables {A : Type u} {B : Type v} + variable (Ra : A → A → Prop) + variable (Rb : B → B → Prop) + + -- Lexicographical order based on Ra and Rb + inductive lex : A × B → A × B → Prop + | left : ∀ {a₁ b₁} a₂ b₂, Ra a₁ a₂ → lex (a₁, b₁) (a₂, b₂) + | right : ∀ a {b₁ b₂}, Rb b₁ b₂ → lex (a, b₁) (a, b₂) + + -- Relational product based on Ra and Rb + inductive rprod : A × B → A × B → Prop + | intro : ∀ {a₁ b₁ a₂ b₂}, Ra a₁ a₂ → Rb b₁ b₂ → rprod (a₁, b₁) (a₂, b₂) + end + + section + parameters {A : Type u} {B : Type v} + parameters {Ra : A → A → Prop} {Rb : B → B → Prop} + local infix `≺`:50 := lex Ra Rb + + definition lex_accessible {a} (aca : acc Ra a) (acb : ∀ b, acc Rb b): ∀ b, acc (lex Ra Rb) (a, b) := + acc.rec_on aca + (λ xa aca (iHa : ∀ y, Ra y xa → ∀ b, acc (lex Ra Rb) (y, b)), + λ b, acc.rec_on (acb b) + (λ xb acb + (iHb : ∀ y, Rb y xb → acc (lex Ra Rb) (xa, y)), + acc.intro (xa, xb) (λ p (lt : p ≺ (xa, xb)), + have aux : xa = xa → xb = xb → acc (lex Ra Rb) p, from + @prod.lex.rec_on A B Ra Rb (λ p₁ p₂, fst p₂ = xa → snd p₂ = xb → acc (lex Ra Rb) p₁) + p (xa, xb) lt + (λ a₁ b₁ a₂ b₂ (H : Ra a₁ a₂) (eq₂ : a₂ = xa) (eq₃ : b₂ = xb), + show acc (lex Ra Rb) (a₁, b₁), from + have Ra₁ : Ra a₁ xa, from eq.rec_on eq₂ H, + iHa a₁ Ra₁ b₁) + (λ a b₁ b₂ (H : Rb b₁ b₂) (eq₂ : a = xa) (eq₃ : b₂ = xb), + show acc (lex Ra Rb) (a, b₁), from + have Rb₁ : Rb b₁ xb, from eq.rec_on eq₃ H, + have eq₂' : xa = a, from eq.rec_on eq₂ rfl, + eq.rec_on eq₂' (iHb b₁ Rb₁)), + aux rfl rfl))) + + -- The lexicographical order of well founded relations is well-founded + definition lex_wf (Ha : well_founded Ra) (Hb : well_founded Rb) : well_founded (lex Ra Rb) := + well_founded.intro (λ p, destruct p (λ a b, lex_accessible (apply Ha a) (well_founded.apply Hb) b)) + + -- Relational product is a subrelation of the lex + definition rprod_sub_lex : ∀ a b, rprod Ra Rb a b → lex Ra Rb a b := + λ a b H, prod.rprod.rec_on H (λ a₁ b₁ a₂ b₂ H₁ H₂, lex.left Rb a₂ b₂ H₁) + + -- The relational product of well founded relations is well-founded + definition rprod_wf (Ha : well_founded Ra) (Hb : well_founded Rb) : well_founded (rprod Ra Rb) := + subrelation.wf (rprod_sub_lex) (lex_wf Ha Hb) + + end + +end prod diff --git a/old_library/init/wf_k.lean b/old_library/init/wf_k.lean new file mode 100644 index 0000000000..482e41fba2 --- /dev/null +++ b/old_library/init/wf_k.lean @@ -0,0 +1,17 @@ +-- Copyright (c) 2014 Microsoft Corporation. All rights reserved. +-- Released under Apache 2.0 license as described in the file LICENSE. +-- Author: Leonardo de Moura +prelude +import init.wf +universe variables u +namespace well_founded + -- This is an auxiliary definition that useful for generating a new "proof" for (well_founded R) + -- that allows us to use well_founded.fix and execute the definitions up to k nested recursive + -- calls without "computing" with the proofs in Hwf. + definition intro_k {A : Type u} {R : A → A → Prop} (Hwf : well_founded R) (k : nat) : well_founded R := + well_founded.intro + (nat.rec_on k + (λ n : A, well_founded.apply Hwf n) + (λ (k' : nat) (f : Π a, acc R a), (λ n : A, acc.intro n (λ y H, f y)))) + +end well_founded diff --git a/old_library/library.md b/old_library/library.md new file mode 100644 index 0000000000..47a9d917a6 --- /dev/null +++ b/old_library/library.md @@ -0,0 +1,52 @@ +The Lean Standard Library +========================= + +The Lean standard library is contained in the following files and directories: + +* [init](init/init.md) : constants and theorems needed for low-level system operations +* [logic](logic/logic.md) : logical constructs and axioms +* [data](data/data.md) : concrete datatypes and type constructors +* [algebra](algebra/algebra.md) : algebraic structures +* [theories](theories/theories.md) : more domain-specific theories +* [tools](tools/tools.md) : additional tools + +The files in `init` are loaded by default, and hence do not need to be +imported manually. Other files can be imported individually, but the +following is designed to load most of the standard library: + +* [standard](standard.lean) : constructive logic and datatypes + +Lean's default logical framework is a version of the Calculus of +Constructions with: + +* an impredicative, proof-irrelevant type `Prop` of propositions +* universe polymorphism +* a non-cumulative hierarchy of universes, `Type 1`, `Type 2`, ... above `Prop` +* inductively defined types +* quotient types + +Most of the `standard` library does not rely on any axioms beyond this +framework, and is hence fully constructive. + +The following additional axioms are defined in `init`: + +* quotients and propositional extensionality (in `quot`) +* Hilbert choice (in `classical`) + +Function extensionality is derived from the quotient construction, and +excluded middle is derived from Hilbert choice. For Hilbert choice and +excluded middle, use `open classical`. The additional axioms are used +sparingly. For example: + +* The constructions of finite sets and the rationals use quotients. +* The set library uses propext and funext, as well as excluded middle to prove + some classical identities. +* Hilbert choice is used to define the multiplicative inverse on the reals, and + also to define function inverses classically. + +You can use `print axioms foo` to see which axioms `foo` depends +on. Many of the theories in the `theories` folder are unreservedly +classical. + +See also the [hott library](../hott/hott.md), a library for homotopy +type theory based on a predicative foundation. diff --git a/old_library/logic/cast.lean b/old_library/logic/cast.lean new file mode 100644 index 0000000000..a08fbaf862 --- /dev/null +++ b/old_library/logic/cast.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +Casts and heterogeneous equality. See also init.datatypes and init.logic. +-/ +import logic.eq logic.quantifiers + +namespace heq + universe variable u + variables {A B C : Type.{u}} {a a' : A} {b b' : B} {c : C} + + theorem drec_on {C : Π {B : Type} (b : B), a == b → Type} (H₁ : a == b) (H₂ : C a (refl a)) : + C b H₁ := + heq.rec (λ H₁ : a == a, show C a H₁, from H₂) H₁ H₁ + + theorem to_cast_eq (H : a == b) : cast (type_eq_of_heq H) a = b := + drec_on H (cast_eq _ _) +end heq + +section + universe variables u v + variables {A A' B C : Type.{u}} {P P' : A → Type.{v}} {a a' : A} {b : B} + + theorem hcongr_fun {f : Π x, P x} {f' : Π x, P' x} (a : A) (H₁ : f == f') (H₂ : P = P') : + f a == f' a := + sorry + /- + begin + cases H₂, cases H₁, reflexivity + end + -/ + + theorem hcongr {P' : A' → Type} {f : Π a, P a} {f' : Π a', P' a'} {a : A} {a' : A'} + (Hf : f == f') (HP : P == P') (Ha : a == a') : f a == f' a' := + sorry + /- + begin + cases Ha, cases HP, cases Hf, reflexivity + end + -/ + + theorem hcongr_arg (f : Πx, P x) {a b : A} (H : a = b) : f a == f b := + H ▸ (heq.refl (f a)) +end + +section + variables {A : Type} {B : A → Type} {C : Πa, B a → Type} {D : Πa b, C a b → Type} + variables {a a' : A} {b : B a} {b' : B a'} {c : C a b} {c' : C a' b'} + + theorem hcongr_arg2 (f : Πa b, C a b) (Ha : a = a') (Hb : b == b') : f a b == f a' b' := + hcongr (hcongr_arg f Ha) (hcongr_arg C Ha) Hb + + theorem hcongr_arg3 (f : Πa b c, D a b c) (Ha : a = a') (Hb : b == b') (Hc : c == c') + : f a b c == f a' b' c' := + hcongr (hcongr_arg2 f Ha Hb) (hcongr_arg2 D Ha Hb) Hc +end + +section + universe variables u v + variables {A A' B C : Type.{u}} {P P' : A → Type.{v}} {a a' : A} {b : B} + + -- should H₁ be explicit (useful in e.g. hproof_irrel) + theorem eq_rec_to_heq {H₁ : a = a'} {p : P a} {p' : P a'} (H₂ : eq.rec_on H₁ p = p') : p == p' := + sorry -- by subst H₁; subst H₂ + + theorem cast_to_heq {H₁ : A = B} (H₂ : cast H₁ a = b) : a == b := + eq_rec_to_heq H₂ + + theorem hproof_irrel {a b : Prop} (H : a = b) (H₁ : a) (H₂ : b) : H₁ == H₂ := + eq_rec_to_heq (proof_irrel (cast H H₁) H₂) + + --TODO: generalize to eq.rec. This is a special case of rec_on_comp in eq.lean + theorem cast_trans (Hab : A = B) (Hbc : B = C) (a : A) : + cast Hbc (cast Hab a) = cast (eq.trans Hab Hbc) a := + sorry -- by subst Hab + + theorem pi_eq (H : P = P') : (Π x, P x) = (Π x, P' x) := + sorry -- by subst H + + theorem rec_on_app (H : P = P') (f : Π x, P x) (a : A) : eq.rec_on H f a == f a := + sorry -- by subst H + + theorem rec_on_pull (H : P = P') (f : Π x, P x) (a : A) : + eq.rec_on H f a = eq.rec_on (congr_fun H a) (f a) := + eq_of_heq (calc + eq.rec_on H f a == f a : rec_on_app H f a + ... == eq.rec_on (congr_fun H a) (f a) : heq.symm (eq_rec_heq (congr_fun H a) (f a))) + + theorem cast_app (H : P = P') (f : Π x, P x) (a : A) : cast (pi_eq H) f a == f a := + sorry -- by subst H +end + +-- function extensionality wrt heterogeneous equality +theorem hfunext {A : Type} {B : A → Type} {B' : A → Type} {f : Π x, B x} {g : Π x, B' x} + (H : ∀ a, f a == g a) : f == g := +cast_to_heq (funext (λ a, eq_of_heq (heq.trans (cast_app (funext (λ x, type_eq_of_heq (H x))) f a) (H a)))) + +section + variables {A : Type} {B : A → Type} {C : Πa, B a → Type} {D : Πa b, C a b → Type} + {E : Πa b c, D a b c → Type} {F : Type} + variables {a a' : A} + {b : B a} {b' : B a'} + {c : C a b} {c' : C a' b'} + {d : D a b c} {d' : D a' b' c'} + + theorem hcongr_arg4 (f : Πa b c d, E a b c d) + (Ha : a = a') (Hb : b == b') (Hc : c == c') (Hd : d == d') : f a b c d == f a' b' c' d' := + hcongr (hcongr_arg3 f Ha Hb Hc) (hcongr_arg3 E Ha Hb Hc) Hd + + theorem dcongr_arg2 (f : Πa, B a → F) (Ha : a = a') (Hb : eq.rec_on Ha b = b') + : f a b = f a' b' := + eq_of_heq (hcongr_arg2 f Ha (eq_rec_to_heq Hb)) + + theorem dcongr_arg3 (f : Πa b, C a b → F) (Ha : a = a') (Hb : eq.rec_on Ha b = b') + (Hc : cast (dcongr_arg2 C Ha Hb) c = c') : f a b c = f a' b' c' := + eq_of_heq (hcongr_arg3 f Ha (eq_rec_to_heq Hb) (eq_rec_to_heq Hc)) + + theorem dcongr_arg4 (f : Πa b c, D a b c → F) (Ha : a = a') (Hb : eq.rec_on Ha b = b') + (Hc : cast (dcongr_arg2 C Ha Hb) c = c') + (Hd : cast (dcongr_arg3 D Ha Hb Hc) d = d') : f a b c d = f a' b' c' d' := + eq_of_heq (hcongr_arg4 f Ha (eq_rec_to_heq Hb) (eq_rec_to_heq Hc) (eq_rec_to_heq Hd)) + + -- mixed versions (we want them for example if C a' b' is a subsingleton, like a proposition. + -- Then proving eq is easier than proving heq) + theorem hdcongr_arg3 (f : Πa b, C a b → F) (Ha : a = a') (Hb : b == b') + (Hc : cast (eq_of_heq (hcongr_arg2 C Ha Hb)) c = c') + : f a b c = f a' b' c' := + eq_of_heq (hcongr_arg3 f Ha Hb (eq_rec_to_heq Hc)) +end diff --git a/old_library/logic/connectives.lean b/old_library/logic/connectives.lean new file mode 100644 index 0000000000..e0e1bd101b --- /dev/null +++ b/old_library/logic/connectives.lean @@ -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. See also init.datatypes and init.logic. +-/ +variables {a b c d : Prop} + +/- implies -/ + +definition imp (a b : Prop) : Prop := a → b + +theorem imp.id (H : a) : a := H + +theorem imp.intro (H : a) (H₂ : b) : a := H + +theorem imp.mp (H : a) (H₂ : a → b) : b := +H₂ H + +theorem imp.syl (H : a → b) (H₂ : c → a) (Hc : c) : b := +H (H₂ Hc) + +theorem imp.left (H : a → b) (H₂ : b → c) (Ha : a) : c := +H₂ (H Ha) + +theorem imp_true (a : Prop) : (a → true) ↔ true := +iff_true_intro (imp.intro trivial) + +theorem true_imp (a : Prop) : (true → a) ↔ a := +iff.intro (assume H, H trivial) imp.intro + +theorem imp_false (a : Prop) : (a → false) ↔ ¬ a := iff.rfl + +theorem false_imp (a : Prop) : (false → a) ↔ true := +iff_true_intro false.elim + +/- not -/ + +theorem not.elim {A : Type} (H1 : ¬a) (H2 : a) : A := absurd H2 H1 + +theorem not.mto {a b : Prop} : (a → b) → ¬b → ¬a := imp.left + +theorem not_imp_not_of_imp {a b : Prop} : (a → b) → ¬b → ¬a := not.mto + +theorem not_not_of_not_implies : ¬(a → b) → ¬¬a := +not.mto not.elim + +theorem not_of_not_implies : ¬(a → b) → ¬b := +not.mto imp.intro + +theorem not_not_em : ¬¬(a ∨ ¬a) := +assume not_em : ¬(a ∨ ¬a), +not_em (or.inr (not.mto or.inl not_em)) + +theorem not_iff_not (H : a ↔ b) : ¬a ↔ ¬b := +iff.intro (not.mto (iff.mpr H)) (not.mto (iff.mp H)) + +/- and -/ + +definition not_and_of_not_left (b : Prop) : ¬a → ¬(a ∧ b) := +not.mto and.left + +definition not_and_of_not_right (a : Prop) {b : Prop} : ¬b → ¬(a ∧ b) := +not.mto and.right + +theorem and.imp_left (H : a → b) : a ∧ c → b ∧ c := +and.imp H imp.id + +theorem and.imp_right (H : a → b) : c ∧ a → c ∧ b := +and.imp imp.id H + +theorem and_of_and_of_imp_of_imp (H₁ : a ∧ b) (H₂ : a → c) (H₃ : b → d) : c ∧ d := +and.imp H₂ H₃ H₁ + +theorem and_of_and_of_imp_left (H₁ : a ∧ c) (H : a → b) : b ∧ c := +and.imp_left H H₁ + +theorem and_of_and_of_imp_right (H₁ : c ∧ a) (H : a → b) : c ∧ b := +and.imp_right H H₁ + +theorem and_imp_iff (a b c : Prop) : (a ∧ b → c) ↔ (a → b → c) := +iff.intro (λH a b, H (and.intro a b)) and.rec + +theorem and_imp_eq (a b c : Prop) : (a ∧ b → c) = (a → b → c) := +propext (and_imp_iff a b c) + +/- or -/ + +definition not_or : ¬a → ¬b → ¬(a ∨ b) := or.rec + +theorem or_of_or_of_imp_of_imp (H₁ : a ∨ b) (H₂ : a → c) (H₃ : b → d) : c ∨ d := +or.imp H₂ H₃ H₁ + +theorem or_of_or_of_imp_left (H₁ : a ∨ c) (H : a → b) : b ∨ c := +or.imp_left H H₁ + +theorem or_of_or_of_imp_right (H₁ : c ∨ a) (H : a → b) : c ∨ b := +or.imp_right H H₁ + +theorem or.elim3 (H : a ∨ b ∨ c) (Ha : a → d) (Hb : b → d) (Hc : c → d) : d := +or.elim H Ha (assume H₂, or.elim H₂ Hb Hc) + +theorem or_resolve_right (H₁ : a ∨ b) (H₂ : ¬a) : b := +or.elim H₁ (not.elim H₂) imp.id + +theorem or_resolve_left (H₁ : a ∨ b) : ¬b → a := +or_resolve_right (or.swap H₁) + +theorem or.imp_distrib : ((a ∨ b) → c) ↔ ((a → c) ∧ (b → c)) := +iff.intro + (λH, and.intro (imp.syl H or.inl) (imp.syl H or.inr)) + (and.rec or.rec) + +theorem or_iff_right_of_imp {a b : Prop} (Ha : a → b) : (a ∨ b) ↔ b := +iff.intro (or.rec Ha imp.id) or.inr + +theorem or_iff_left_of_imp {a b : Prop} (Hb : b → a) : (a ∨ b) ↔ a := +iff.intro (or.rec imp.id Hb) or.inl + +theorem or_iff_or (H1 : a ↔ c) (H2 : b ↔ d) : (a ∨ b) ↔ (c ∨ d) := +iff.intro (or.imp (iff.mp H1) (iff.mp H2)) (or.imp (iff.mpr H1) (iff.mpr H2)) + +/- distributivity -/ + +theorem and.left_distrib (a b c : Prop) : a ∧ (b ∨ c) ↔ (a ∧ b) ∨ (a ∧ c) := +iff.intro + (and.rec (λH, or.imp (and.intro H) (and.intro H))) + (or.rec (and.imp_right or.inl) (and.imp_right or.inr)) + +theorem and.right_distrib (a b c : Prop) : (a ∨ b) ∧ c ↔ (a ∧ c) ∨ (b ∧ c) := +iff.trans (iff.trans and.comm (and.left_distrib c a b)) (or_iff_or and.comm and.comm) + +theorem or.left_distrib (a b c : Prop) : a ∨ (b ∧ c) ↔ (a ∨ b) ∧ (a ∨ c) := +iff.intro + (or.rec (λH, and.intro (or.inl H) (or.inl H)) (and.imp or.inr or.inr)) + (and.rec (or.rec (imp.syl imp.intro or.inl) (imp.syl or.imp_right and.intro))) + +theorem or.right_distrib (a b c : Prop) : (a ∧ b) ∨ c ↔ (a ∨ c) ∧ (b ∨ c) := +iff.trans (iff.trans or.comm (or.left_distrib c a b)) (and_congr or.comm or.comm) + +/- iff -/ + +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 := +(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 diff --git a/old_library/logic/default.lean b/old_library/logic/default.lean new file mode 100644 index 0000000000..21d615c022 --- /dev/null +++ b/old_library/logic/default.lean @@ -0,0 +1,7 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad +-/ +import logic.eq logic.connectives logic.cast +import logic.quantifiers logic.identities diff --git a/old_library/logic/eq.lean b/old_library/logic/eq.lean new file mode 100644 index 0000000000..46e46b0ace --- /dev/null +++ b/old_library/logic/eq.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad, Floris van Doorn + +Additional declarations/theorems about equality. See also init.datatypes and init.logic. +-/ +namespace eq + variables {A B : Type} {a a' a₁ a₂ a₃ a₄ : A} + + theorem irrel (H₁ H₂ : a = a') : H₁ = H₂ := + proof_irrel H₁ H₂ + + theorem id_refl (H₁ : a = a) : H₁ = (eq.refl a) := + rfl + + theorem rec_on_id {B : A → Type} (H : a = a) (b : B a) : eq.rec_on H b = b := + rfl + + theorem rec_on_constant (H : a = a') {B : Type} (b : B) : eq.rec_on H b = b := + eq.drec_on H rfl + + theorem rec_on_constant2 (H₁ : a₁ = a₂) (H₂ : a₃ = a₄) (b : B) : eq.rec_on H₁ b = eq.rec_on H₂ b := + trans (rec_on_constant H₁ b) (symm (rec_on_constant H₂ b)) + + theorem rec_on_irrel {a a' : A} {D : A → Type} (H H' : a = a') (b : D a) : + eq.drec_on H b = eq.drec_on H' b := + proof_irrel H H' ▸ rfl + + theorem rec_on_comp {a b c : A} {P : A → Type} (H₁ : a = b) (H₂ : b = c) + (u : P a) : eq.rec_on H₂ (eq.rec_on H₁ u) = eq.rec_on (trans H₁ H₂) u := + (show ∀ H₂ : b = c, eq.rec_on H₂ (eq.rec_on H₁ u) = eq.rec_on (trans H₁ H₂) u, + from eq.drec_on H₂ (take (H₂ : b = b), rec_on_id H₂ _)) + H₂ +end eq + +open eq + +section + variables {A B C D E F : Type} + variables {a a' : A} {b b' : B} {c c' : C} {d d' : D} {e e' : E} + + theorem congr_arg2 (f : A → B → C) (Ha : a = a') (Hb : b = b') : f a b = f a' b' := + sorry -- by substvars + + theorem congr_arg3 (f : A → B → C → D) (Ha : a = a') (Hb : b = b') (Hc : c = c') + : f a b c = f a' b' c' := + sorry -- by substvars + + theorem congr_arg4 (f : A → B → C → D → E) (Ha : a = a') (Hb : b = b') (Hc : c = c') (Hd : d = d') + : f a b c d = f a' b' c' d' := + sorry -- by substvars + + theorem congr_arg5 (f : A → B → C → D → E → F) + (Ha : a = a') (Hb : b = b') (Hc : c = c') (Hd : d = d') (He : e = e') + : f a b c d e = f a' b' c' d' e' := + sorry -- by substvars + + theorem congr2 (f f' : A → B → C) (Hf : f = f') (Ha : a = a') (Hb : b = b') : f a b = f' a' b' := + sorry -- by substvars + + theorem congr3 (f f' : A → B → C → D) (Hf : f = f') (Ha : a = a') (Hb : b = b') (Hc : c = c') + : f a b c = f' a' b' c' := + sorry -- by substvars + + theorem congr4 (f f' : A → B → C → D → E) + (Hf : f = f') (Ha : a = a') (Hb : b = b') (Hc : c = c') (Hd : d = d') + : f a b c d = f' a' b' c' d' := + sorry -- by substvars + + theorem congr5 (f f' : A → B → C → D → E → F) + (Hf : f = f') (Ha : a = a') (Hb : b = b') (Hc : c = c') (Hd : d = d') (He : e = e') + : f a b c d e = f' a' b' c' d' e' := + sorry -- by substvars +end + +theorem equal_f {A : Type} {B : A → Type} {f g : Π x, B x} (H : f = g) : ∀x, f x = g x := +take x, congr_fun H x + +section + variables {a b c : Prop} + + theorem eqmp (H₁ : a = b) (H₂ : a) : b := + H₁ ▸ H₂ + + theorem eqmpr (H₁ : a = b) (H₂ : b) : a := + symm H₁ ▸ H₂ + + theorem imp_trans (H₁ : a → b) (H₂ : b → c) : a → c := + assume Ha, H₂ (H₁ Ha) + + theorem imp_eq_trans (H₁ : a → b) (H₂ : b = c) : a → c := + assume Ha, H₂ ▸ (H₁ Ha) + + theorem eq_imp_trans (H₁ : a = b) (H₂ : b → c) : a → c := + assume Ha, H₂ (H₁ ▸ Ha) +end diff --git a/old_library/logic/examples/colog88.lean b/old_library/logic/examples/colog88.lean new file mode 100644 index 0000000000..469be3e754 --- /dev/null +++ b/old_library/logic/examples/colog88.lean @@ -0,0 +1,92 @@ +/- +Example from "Inductively defined types", +from Thierry Coquand and Christine Paulin, +COLOG-88. + +It shows it is inconsistent to allow inductive datatypes such as + +inductive A : Type := +| intro : ((A → Prop) → Prop) → A + +-/ + +/- Phi is a positive, but not strictly positive, operator. -/ +definition Phi (A : Type) := (A → Prop) → Prop + +/- If we were allowed to form the inductive type + + inductive A: Type := + | introA : Phi A -> A + + we would get the following +-/ + +universe l +-- The new type A +axiom A : Type.{l} +-- The constructor +axiom introA : Phi A → A +-- The eliminator +axiom recA : Π {C : A → Type}, (Π (p : Phi A), C (introA p)) → (Π (a : A), C a) +-- The "computational rule" +axiom recA_comp : Π {C : A → Type} (H : Π (p : Phi A), C (introA p)) (p : Phi A), recA H (introA p) = H p + +-- The recursor could be used to define matchA +noncomputable definition matchA (a : A) : Phi A := +recA (λ p, p) a + +-- and the computation rule would allows us to define +lemma betaA (p : Phi A) : matchA (introA p) = p := +!recA_comp + +-- As in all inductive datatypes, we would be able to prove that constructors are injective. +lemma introA_injective : ∀ {p p' : Phi A}, introA p = introA p' → p = p' := +λ p p' h, + have aux : matchA (introA p) = matchA (introA p'), by rewrite h, + by rewrite [*betaA at aux]; exact aux + +-- For any type T, there is an injection from T to (T → Prop) +definition i {T : Type} : T → (T → Prop) := +λ x y, x = y + +lemma i_injective {T : Type} {a b : T} : i a = i b → a = b := +λ h, + have e₁ : i a a = i b a, by rewrite [h], + have e₂ : (a = a) = (b = a), from e₁, + have e₃ : b = a, from eq.subst e₂ rfl, + eq.symm e₃ + +-- Hence, by composition, we get an injection f from (A → Prop) to A +noncomputable definition f : (A → Prop) → A := +λ p, introA (i p) + +lemma f_injective : ∀ {p p' : A → Prop}, f p = f p' → p = p':= +λ (p p' : A → Prop) (h : introA (i p) = introA (i p')), + i_injective (introA_injective h) + +/- + We are now back to the usual Cantor-Russel paradox. + We can define +-/ +noncomputable definition P0 (a : A) : Prop := +∃ (P : A → Prop), f P = a ∧ ¬ P a +-- i.e., P0 a := codes a set P such that x∉P + +noncomputable definition x0 : A := f P0 + +lemma fP0_eq : f P0 = x0 := +rfl + +lemma not_P0_x0 : ¬ P0 x0 := +λ h : P0 x0, + obtain (P : A → Prop) (hp : f P = x0 ∧ ¬ P x0), from h, + have fp_eq : f P = f P0, from and.elim_left hp, + have p_eq : P = P0, from f_injective fp_eq, + have nh : ¬ P0 x0, by rewrite [p_eq at hp]; exact (and.elim_right hp), + absurd h nh + +lemma P0_x0 : P0 x0 := +exists.intro P0 (and.intro fP0_eq not_P0_x0) + +theorem inconsistent : false := +absurd P0_x0 not_P0_x0 diff --git a/old_library/logic/examples/cont.lean b/old_library/logic/examples/cont.lean new file mode 100644 index 0000000000..9e4db4b600 --- /dev/null +++ b/old_library/logic/examples/cont.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author: Leonardo de Moura + +Formalization of Theorem 1 from the following paper: +"The inconsistency of a Brouwerian continuity +principle with the Curry–Howard interpretation" +by Martín Escardó and Chuangjie Xu +-/ +import data.nat +open nat sigma.ops + +/- Bounded equality: α and β agree in the first n positions. -/ +definition beq (α β : nat → nat) (n : nat) : Prop := +∀ a, a < n → α a = β a + +notation α `=[`:50 n:50 `]` β:50 := beq α β n + +lemma pred_beq {α β : nat → nat} {n : nat} : α =[n+1] β → α =[n] β := +λ h a altn, h a (lt.step altn) + +definition continuous (f : (nat → nat) → nat) : Type₁ := +∀ α, Σ n, ∀ β, α =[n] β → f α = f β + +definition zω : nat → nat := +λ x, zero + +definition znkω (n : nat) (k : nat) : nat → nat := +λ x, if x < n then 0 else k + +lemma znkω_succ (n : nat) (k : nat) : znkω (n+1) k 0 = 0 := +rfl + +lemma znkω_bound (n : nat) (k : nat) : znkω n k n = k := +if_neg !nat.lt_irrefl + +lemma zω_eq_znkω (n : nat) (k : nat) : zω =[n] znkω n k := +λ a altn, begin esimp [zω, znkω], rewrite [if_pos altn] end + +section +hypothesis all_continuous : ∀ f, continuous f + +definition M (f : (nat → nat) → nat) : nat := +(all_continuous f zω).1 + +lemma M_spec (f : (nat → nat) → nat) : ∀ β, zω =[M f] β → f zω = f β := +(all_continuous f zω).2 + +definition m := M (λα, zero) + +definition f β := M (λα, β (α m)) + +lemma β0_eq (β : nat → nat) : ∀ α, zω =[f β] α → β 0 = β (α m) := +λ α, M_spec (λα, β (α m)) α + +lemma not_all_continuous : false := +let β := znkω (M f + 1) 1 in +let α := znkω m (M f + 1) in +have βeq₁ : zω =[M f + 1] β, from + λ (a : nat) (h : a < M f + 1), begin unfold zω, unfold znkω, rewrite [if_pos h] end, +have βeq₂ : zω =[M f] β, from pred_beq βeq₁, +have m_eq_fβ : m = f β, from M_spec f β βeq₂, +have aux : ∀ α, zω =[m] α → β 0 = β (α m), by rewrite m_eq_fβ at {1}; exact (β0_eq β), +have zero_eq_one : 0 = 1, from calc + 0 = β 0 : by rewrite znkω_succ + ... = β (α m) : aux α (zω_eq_znkω m (M f + 1)) + ... = β (M f + 1) : by rewrite znkω_bound + ... = 1 : by rewrite znkω_bound, +by contradiction +end + +/- +Additional remarks: +By using the slightly different definition of continuous + ∀ α, ∃ n, ∀ β, α =[n] β → f α = f β +i.e., using ∃ instead of Σ, we can assume the following axiom + all_continuous : ∀ f, continuous f +However, the system becomes inconsistent again if we also assume Hilbert's choice, +because with Hilbert's choice we can convert ∃ into Σ +-/ diff --git a/old_library/logic/examples/double_negation_translation.lean b/old_library/logic/examples/double_negation_translation.lean new file mode 100644 index 0000000000..487df20736 --- /dev/null +++ b/old_library/logic/examples/double_negation_translation.lean @@ -0,0 +1,112 @@ +/- +Simulating classical reasoning without assuming excluded middle. +The idea is to use the double-negation translation. +We define several "helper" theorems for double negated formulas. +-/ +variables {p q r : Prop} + +theorem not_and_of_or_not : ¬p ∨ ¬q → ¬(p ∧ q) := +λ h hpq, or.elim h + (λ hnp : ¬p, absurd (and.elim_left hpq) hnp) + (λ hnq : ¬q, absurd (and.elim_right hpq) hnq) + +theorem not_or_elim_left : ¬(p ∨ q) → ¬p := +λ hpq hp, absurd (or.inl hp) hpq + +theorem not_or_elim_right : ¬(p ∨ q) → ¬q := +λ hpq hq, absurd (or.inr hq) hpq + +theorem not_imp_elim_right : ¬(p → q) → ¬q := +λ h₁ hq, absurd (λ h, hq) h₁ + +theorem not_imp_elim_left : ¬(p → q) → ¬¬p := +λ h₁ hnp, absurd (λ hp, by contradiction) h₁ + +theorem not_imp_intro : ¬¬p → ¬q → ¬(p → q) := +λ hnnp hnq hpq, + have hnp : ¬ p, from λ hp, absurd (hpq hp) hnq, + absurd hnp hnnp + +/- Double negation introduction -/ +theorem nn_intro : p → ¬¬p := +λ hp hnp, absurd hp hnp + +/- Double negated implication -/ +-- Introduction +theorem nn_imp_intro : (¬¬p → ¬¬q) → ¬¬(p → q) := +λ h hnpq, + have hnnp : ¬¬p, from not_imp_elim_left hnpq, + have hnq : ¬q, from not_imp_elim_right hnpq, + have hnnq : ¬¬q, from h hnnp, + absurd hnq hnnq + +-- Elimination (modus ponens) +theorem nn_mp : ¬¬(p → q) → p → ¬¬q := +λ hpq hp hnq, + have aux : ¬(p → q), from not_imp_intro (nn_intro hp) hnq, + absurd aux hpq + +-- Double negated modus tollens +theorem nn_mt : ¬¬(p → q) → ¬q → ¬p := +λ hpq hnq hp, absurd hnq (nn_mp hpq hp) + +/- Double negated disjuction -/ +lemma not_or_of_not_of_not : ¬p → ¬q → ¬(p ∨ q) := +λ hnp hnq hpq, or.elim hpq (λ hp, absurd hp hnp) (λ hq, absurd hq hnq) + +-- Elimination +theorem nn_or_elim : ¬¬(p ∨ q) → (p → ¬¬r) → (q → ¬¬r) → ¬¬r := +λ hpq hpr hqr hnr, + have hnp : ¬p, from λhp, absurd hnr (hpr hp), + have hnq : ¬q, from λhq, absurd hnr (hqr hq), + have aux : ¬(p ∨ q), from not_or_of_not_of_not hnp hnq, + absurd aux hpq + +-- Introduction +theorem nn_or_inl : ¬¬p → ¬¬(p ∨ q) := +λ h hnpq, absurd (not_or_elim_left hnpq) h + +theorem nn_or_inr : ¬¬q → ¬¬(p ∨ q) := +λ h hnpq, absurd (not_or_elim_right hnpq) h + +/- Double negated conjunction -/ + +-- Elimination +theorem nn_and_elim_left : ¬¬(p ∧ q) → ¬¬p := +λ h hnp, absurd (not_and_of_or_not (or.inl hnp)) h + +theorem nn_and_elim_right : ¬¬(p ∧ q) → ¬¬q := +λ h hnq, absurd (not_and_of_or_not (or.inr hnq)) h + +-- Introduction +theorem nn_and_intro : ¬¬p → ¬¬q → ¬¬(p ∧ q) := +λ hnnp hnnq hnpq, + have h₁ : ¬(p → ¬q), from not_imp_intro hnnp hnnq, + have h₂ : p → ¬q, from λ hp hq, absurd (and.intro hp hq) hnpq, + absurd h₂ h₁ + +/- Double negated excluded middle -/ +theorem nn_em : ¬¬(p ∨ ¬p) := +λ hn, + have hnp : ¬p, from not_or_elim_left hn, + have hnnp : ¬¬p, from not_or_elim_right hn, + absurd hnp hnnp + +/- Examples: the following two examples are classically valid. + We can "simulate" the classical proofs using double negation. +-/ +example : ¬¬((p → q) → (¬p ∨ q)) := +nn_imp_intro (λ h, nn_or_elim (@nn_em p) + (λ hp : p, + have hnnq : ¬¬q, from nn_mp h hp, + nn_or_inr hnnq) + (λ hnp : ¬p, nn_intro (or.inl hnp))) + +/- "Prove" Peirce's law -/ +example : ¬¬(((p → q) → p) → p) := +nn_imp_intro (λ h, nn_or_elim (@nn_em p) + (λ hp : p, nn_intro hp) + (λ hnp : ¬p, + have h₁ : ¬(p → q), from nn_mt h hnp, + have hnnp : ¬¬p, from not_imp_elim_left h₁, + absurd hnp hnnp)) diff --git a/old_library/logic/examples/examples.md b/old_library/logic/examples/examples.md new file mode 100644 index 0000000000..8cf5cdde41 --- /dev/null +++ b/old_library/logic/examples/examples.md @@ -0,0 +1,4 @@ +logic.examples +============== + +* [nuprl_examples](nuprl_examples.lean) : examples from "Logical investigations with the Nuprl Proof Assistant" diff --git a/old_library/logic/examples/leftinv_of_inj.lean b/old_library/logic/examples/leftinv_of_inj.lean new file mode 100644 index 0000000000..df816efcda --- /dev/null +++ b/old_library/logic/examples/leftinv_of_inj.lean @@ -0,0 +1,30 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Authors: Leonardo de Moura + +Classical proof that if f is injective, then f has a left inverse (if domain is not empty). +The proof uses the classical axioms: choice and excluded middle. +The excluded middle is being used "behind the scenes" to allow us to write the if-then-else expression +with (∃ a : A, f a = b). +-/ +open function classical + +noncomputable definition mk_left_inv {A B : Type} [h : nonempty A] (f : A → B) : B → A := +λ b : B, if ex : (∃ a : A, f a = b) then some ex else inhabited.value (inhabited_of_nonempty h) + +theorem has_left_inverse_of_injective {A B : Type} {f : A → B} : nonempty A → injective f → has_left_inverse f := +assume h : nonempty A, +assume inj : ∀ a₁ a₂, f a₁ = f a₂ → a₁ = a₂, +let finv : B → A := mk_left_inv f in +have linv : left_inverse finv f, from + λ a, + have ex : ∃ a₁ : A, f a₁ = f a, from exists.intro a rfl, + have h₁ : f (some ex) = f a, from !some_spec, + begin + esimp [mk_left_inv, comp, id], + rewrite [dif_pos ex], + exact (!inj h₁) + end, +exists.intro finv linv diff --git a/old_library/logic/examples/negative.lean b/old_library/logic/examples/negative.lean new file mode 100644 index 0000000000..e62fdf1343 --- /dev/null +++ b/old_library/logic/examples/negative.lean @@ -0,0 +1,30 @@ +/- +This example demonstrates why allowing types such as + +inductive D : Type := +| intro : (D → D) → D + +would make the system inconsistent +-/ + +/- If we were allowed to form the inductive type + + inductive D : Type := + | intro : (D → D) → D + + we would get the following +-/ +universe l +-- The new type A +axiom D : Type.{l} +-- The constructor +axiom introD : (D → D) → D +-- The eliminator +axiom recD : Π {C : D → Type}, (Π (f : D → D) (r : Π d, C (f d)), C (introD f)) → (Π (d : D), C d) +-- We would also get a computational rule for the eliminator, but we don't need it for deriving the inconsistency. + +noncomputable definition id' : D → D := λd, d +noncomputable definition v : D := introD id' + +theorem inconsistent : false := +recD (λ f ih, ih v) v diff --git a/old_library/logic/examples/nuprl_examples.lean b/old_library/logic/examples/nuprl_examples.lean new file mode 100644 index 0000000000..f2eea6ade6 --- /dev/null +++ b/old_library/logic/examples/nuprl_examples.lean @@ -0,0 +1,215 @@ +-- Theorems/Exercises from "Logical Investigations, with the Nuprl Proof Assistant" +-- by Robert L. Constable and Anne Trostle +-- http://www.nuprl.org/MathLibrary/LogicalInvestigations/ +import logic + +-- 2. The Minimal Implicational Calculus +theorem thm1 {A B : Prop} : A → B → A := +assume Ha Hb, Ha + +theorem thm2 {A B C : Prop} : (A → B) → (A → B → C) → (A → C) := +assume Hab Habc Ha, + Habc Ha (Hab Ha) + +theorem thm3 {A B C : Prop} : (A → B) → (B → C) → (A → C) := +assume Hab Hbc Ha, + Hbc (Hab Ha) + +-- 3. False Propositions and Negation +theorem thm4 {P Q : Prop} : ¬P → P → Q := +assume Hnp Hp, + absurd Hp Hnp + +theorem thm5 {P : Prop} : P → ¬¬P := +assume (Hp : P) (HnP : ¬P), + absurd Hp HnP + +theorem thm6 {P Q : Prop} : (P → Q) → (¬Q → ¬P) := +assume (Hpq : P → Q) (Hnq : ¬Q) (Hp : P), + have Hq : Q, from Hpq Hp, + show false, from absurd Hq Hnq + +theorem thm7 {P Q : Prop} : (P → ¬P) → (P → Q) := +assume Hpnp Hp, + absurd Hp (Hpnp Hp) + +theorem thm8 {P Q : Prop} : ¬(P → Q) → (P → ¬Q) := +assume (Hn : ¬(P → Q)) (Hp : P) (Hq : Q), + -- Rermak we don't even need the hypothesis Hp + have H : P → Q, from assume H', Hq, + absurd H Hn + +-- 4. Conjunction and Disjunction +theorem thm9 {P : Prop} : (P ∨ ¬P) → (¬¬P → P) := +assume (em : P ∨ ¬P) (Hnn : ¬¬P), + or.elim em + (assume Hp, Hp) + (assume Hn, absurd Hn Hnn) + +theorem thm10 {P : Prop} : ¬¬(P ∨ ¬P) := +assume Hnem : ¬(P ∨ ¬P), + have Hnp : ¬P, from + assume Hp : P, + have Hem : P ∨ ¬P, from or.inl Hp, + absurd Hem Hnem, + have Hem : P ∨ ¬P, from or.inr Hnp, + absurd Hem Hnem + +theorem thm11 {P Q : Prop} : ¬P ∨ ¬Q → ¬(P ∧ Q) := +assume (H : ¬P ∨ ¬Q) (Hn : P ∧ Q), + or.elim H + (assume Hnp : ¬P, absurd (and.elim_left Hn) Hnp) + (assume Hnq : ¬Q, absurd (and.elim_right Hn) Hnq) + +theorem thm12 {P Q : Prop} : ¬(P ∨ Q) → ¬P ∧ ¬Q := +assume H : ¬(P ∨ Q), + have Hnp : ¬P, from assume Hp : P, absurd (or.inl Hp) H, + have Hnq : ¬Q, from assume Hq : Q, absurd (or.inr Hq) H, + and.intro Hnp Hnq + +theorem thm13 {P Q : Prop} : ¬P ∧ ¬Q → ¬(P ∨ Q) := +assume (H : ¬P ∧ ¬Q) (Hn : P ∨ Q), + or.elim Hn + (assume Hp : P, absurd Hp (and.elim_left H)) + (assume Hq : Q, absurd Hq (and.elim_right H)) + +theorem thm14 {P Q : Prop} : ¬P ∨ Q → P → Q := +assume (Hor : ¬P ∨ Q) (Hp : P), + or.elim Hor + (assume Hnp : ¬P, absurd Hp Hnp) + (assume Hq : Q, Hq) + +theorem thm15 {P Q : Prop} : (P → Q) → ¬¬(¬P ∨ Q) := +assume (Hpq : P → Q) (Hn : ¬(¬P ∨ Q)), + have H1 : ¬¬P ∧ ¬Q, from thm12 Hn, + have Hnp : ¬P, from mt Hpq (and.elim_right H1), + absurd Hnp (and.elim_left H1) + +theorem thm16 {P Q : Prop} : (P → Q) ∧ ((P ∨ ¬P) ∨ (Q ∨ ¬Q)) → ¬P ∨ Q := +assume H : (P → Q) ∧ ((P ∨ ¬P) ∨ (Q ∨ ¬Q)), + have Hpq : P → Q, from and.elim_left H, + or.elim (and.elim_right H) + (assume Hem1 : P ∨ ¬P, or.elim Hem1 + (assume Hp : P, or.inr (Hpq Hp)) + (assume Hnp : ¬P, or.inl Hnp)) + (assume Hem2 : Q ∨ ¬Q, or.elim Hem2 + (assume Hq : Q, or.inr Hq) + (assume Hnq : ¬Q, or.inl (mt Hpq Hnq))) + +-- 5. First-Order Logic: All and Exists +section +variables {T : Type} {C : Prop} {P : T → Prop} +theorem thm17a : (C → ∀x, P x) → (∀x, C → P x) := +assume H : C → ∀x, P x, + take x : T, assume Hc : C, + H Hc x + +theorem thm17b : (∀x, C → P x) → (C → ∀x, P x) := +assume (H : ∀x, C → P x) (Hc : C), + take x : T, + H x Hc + +theorem thm18a : ((∃x, P x) → C) → (∀x, P x → C) := +assume H : (∃x, P x) → C, + take x, assume Hp : P x, + have Hex : ∃x, P x, from exists.intro x Hp, + H Hex + +theorem thm18b : (∀x, P x → C) → (∃x, P x) → C := +assume (H1 : ∀x, P x → C) (H2 : ∃x, P x), + obtain (w : T) (Hw : P w), from H2, + H1 w Hw + +theorem thm19a : (C ∨ ¬C) → (∃x : T, true) → (C → (∃x, P x)) → (∃x, C → P x) := +assume (Hem : C ∨ ¬C) (Hin : ∃x : T, true) (H1 : C → ∃x, P x), + or.elim Hem + (assume Hc : C, + obtain (w : T) (Hw : P w), from H1 Hc, + have Hr : C → P w, from assume Hc, Hw, + exists.intro w Hr) + (assume Hnc : ¬C, + obtain (w : T) (Hw : true), from Hin, + have Hr : C → P w, from assume Hc, absurd Hc Hnc, + exists.intro w Hr) + +theorem thm19b : (∃x, C → P x) → C → (∃x, P x) := +assume (H : ∃x, C → P x) (Hc : C), + obtain (w : T) (Hw : C → P w), from H, + exists.intro w (Hw Hc) + +theorem thm20a : (C ∨ ¬C) → (∃x : T, true) → ((¬∀x, P x) → ∃x, ¬P x) → ((∀x, P x) → C) → (∃x, P x → C) := +assume Hem Hin Hnf H, + or.elim Hem + (assume Hc : C, + obtain (w : T) (Hw : true), from Hin, + exists.intro w (assume H : P w, Hc)) + (assume Hnc : ¬C, + have H1 : ¬(∀x, P x), from mt H Hnc, + have H2 : ∃x, ¬P x, from Hnf H1, + obtain (w : T) (Hw : ¬P w), from H2, + exists.intro w (assume H : P w, absurd H Hw)) + +theorem thm20b : (∃x, P x → C) → (∀ x, P x) → C := +assume Hex Hall, + obtain (w : T) (Hw : P w → C), from Hex, + Hw (Hall w) + +theorem thm21a : (∃x : T, true) → ((∃x, P x) ∨ C) → (∃x, P x ∨ C) := +assume Hin H, + or.elim H + (assume Hex : ∃x, P x, + obtain (w : T) (Hw : P w), from Hex, + exists.intro w (or.inl Hw)) + (assume Hc : C, + obtain (w : T) (Hw : true), from Hin, + exists.intro w (or.inr Hc)) + +theorem thm21b : (∃x, P x ∨ C) → ((∃x, P x) ∨ C) := +assume H, + obtain (w : T) (Hw : P w ∨ C), from H, + or.elim Hw + (assume H : P w, or.inl (exists.intro w H)) + (assume Hc : C, or.inr Hc) + +theorem thm22a : (∀x, P x) ∨ C → ∀x, P x ∨ C := +assume H, take x, + or.elim H + (assume Hl, or.inl (Hl x)) + (assume Hr, or.inr Hr) + +theorem thm22b : (C ∨ ¬C) → (∀x, P x ∨ C) → ((∀x, P x) ∨ C) := +assume Hem H1, + or.elim Hem + (assume Hc : C, or.inr Hc) + (assume Hnc : ¬C, + have Hx : ∀x, P x, from + take x, + have H1 : P x ∨ C, from H1 x, + or_resolve_left H1 Hnc, + or.inl Hx) + +theorem thm23a : (∃x, P x) ∧ C → (∃x, P x ∧ C) := +assume H, + have Hex : ∃x, P x, from and.elim_left H, + have Hc : C, from and.elim_right H, + obtain (w : T) (Hw : P w), from Hex, + exists.intro w (and.intro Hw Hc) + +theorem thm23b : (∃x, P x ∧ C) → (∃x, P x) ∧ C := +assume H, + obtain (w : T) (Hw : P w ∧ C), from H, + have Hex : ∃x, P x, from exists.intro w (and.elim_left Hw), + and.intro Hex (and.elim_right Hw) + +theorem thm24a : (∀x, P x) ∧ C → (∀x, P x ∧ C) := +assume H, take x, + and.intro (and.elim_left H x) (and.elim_right H) + +theorem thm24b : (∃x : T, true) → (∀x, P x ∧ C) → (∀x, P x) ∧ C := +assume Hin H, + obtain (w : T) (Hw : true), from Hin, + have Hc : C, from and.elim_right (H w), + have Hx : ∀x, P x, from take x, and.elim_left (H x), + and.intro Hx Hc + +end -- of section diff --git a/old_library/logic/examples/propositional/deceq.lean b/old_library/logic/examples/propositional/deceq.lean new file mode 100644 index 0000000000..08b1443a29 --- /dev/null +++ b/old_library/logic/examples/propositional/deceq.lean @@ -0,0 +1,45 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author: Leonardo de Moura + +PropF has decidable equality +-/ +import .soundness +open bool decidable nat + +namespace PropF + -- Show that PropF has decidable equality + + definition equal : PropF → PropF → bool + | (Var x) (Var y) := if x = y then tt else ff + | Bot Bot := tt + | (Conj p₁ p₂) (Conj q₁ q₂) := equal p₁ q₁ && equal p₂ q₂ + | (Disj p₁ p₂) (Disj q₁ q₂) := equal p₁ q₁ && equal p₂ q₂ + | (Impl p₁ p₂) (Impl q₁ q₂) := equal p₁ q₁ && equal p₂ q₂ + | _ _ := ff + + lemma equal_refl : ∀ p, equal p p = tt + | (Var x) := if_pos rfl + | Bot := rfl + | (Conj p₁ p₂) := begin change (equal p₁ p₁ && equal p₂ p₂ = tt), rewrite *equal_refl end + | (Disj p₁ p₂) := begin change (equal p₁ p₁ && equal p₂ p₂ = tt), rewrite *equal_refl end + | (Impl p₁ p₂) := begin change (equal p₁ p₁ && equal p₂ p₂ = tt), rewrite *equal_refl end + + lemma equal_to_eq : ∀ ⦃p q⦄, equal p q = tt → p = q + | (Var x) (Var y) H := + if H₁ : x = y then congr_arg Var H₁ + else by rewrite [▸ (if x = y then tt else ff) = tt at H, if_neg H₁ at H]; exact (absurd H ff_ne_tt) + | Bot Bot H := rfl + | (Conj p₁ p₂) (Conj q₁ q₂) H := + by rewrite [equal_to_eq (band_elim_left H), equal_to_eq (band_elim_right H)] + | (Disj p₁ p₂) (Disj q₁ q₂) H := + by rewrite [equal_to_eq (band_elim_left H), equal_to_eq (band_elim_right H)] + | (Impl p₁ p₂) (Impl q₁ q₂) H := + by rewrite [equal_to_eq (band_elim_left H), equal_to_eq (band_elim_right H)] + + attribute [instance] + lemma has_decidable_eq : decidable_eq PropF := + decidable_eq_of_bool_pred equal_to_eq equal_refl +end PropF diff --git a/old_library/logic/examples/propositional/soundness.lean b/old_library/logic/examples/propositional/soundness.lean new file mode 100644 index 0000000000..a8e7ae84c7 --- /dev/null +++ b/old_library/logic/examples/propositional/soundness.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author: Leonardo de Moura + +Define propositional calculus, valuation, provability, validity, prove soundness. + +This file is based on Floris van Doorn Coq files. +-/ +import data.nat data.list +open nat bool list decidable + +attribute [reducible] +definition PropVar := nat + +inductive PropF := +| Var : PropVar → PropF +| Bot : PropF +| Conj : PropF → PropF → PropF +| Disj : PropF → PropF → PropF +| Impl : PropF → PropF → PropF + +namespace PropF + notation `#`:max P:max := Var P + notation A ∨ B := Disj A B + notation A ∧ B := Conj A B + infixr `⇒`:27 := Impl + notation `⊥` := Bot + + definition Neg A := A ⇒ ⊥ + notation ~ A := Neg A + definition Top := ~⊥ + notation `⊤` := Top + definition BiImpl A B := A ⇒ B ∧ B ⇒ A + infixr `⇔`:27 := BiImpl + + definition valuation := PropVar → bool + + definition TrueQ (v : valuation) : PropF → bool + | TrueQ (# P) := v P + | TrueQ ⊥ := ff + | TrueQ (A ∨ B) := TrueQ A || TrueQ B + | TrueQ (A ∧ B) := TrueQ A && TrueQ B + | TrueQ (A ⇒ B) := bnot (TrueQ A) || TrueQ B + + attribute [reducible] + definition is_true (b : bool) := b = tt + + -- the valuation v satisfies a list of PropF, if forall (A : PropF) in Γ, + -- (TrueQ v A) is tt (the Boolean true) + definition Satisfies v Γ := ∀ A, A ∈ Γ → is_true (TrueQ v A) + definition Models Γ A := ∀ v, Satisfies v Γ → is_true (TrueQ v A) + + infix `⊨`:80 := Models + + definition Valid p := [] ⊨ p + reserve infix `⊢`:26 + + /- Provability -/ + + inductive Nc : list PropF → PropF → Prop := + infix ⊢ := Nc + | Nax : ∀ Γ A, A ∈ Γ → Γ ⊢ A + | ImpI : ∀ Γ A B, A::Γ ⊢ B → Γ ⊢ A ⇒ B + | ImpE : ∀ Γ A B, Γ ⊢ A ⇒ B → Γ ⊢ A → Γ ⊢ B + | BotC : ∀ Γ A, (~A)::Γ ⊢ ⊥ → Γ ⊢ A + | AndI : ∀ Γ A B, Γ ⊢ A → Γ ⊢ B → Γ ⊢ A ∧ B + | AndE₁ : ∀ Γ A B, Γ ⊢ A ∧ B → Γ ⊢ A + | AndE₂ : ∀ Γ A B, Γ ⊢ A ∧ B → Γ ⊢ B + | OrI₁ : ∀ Γ A B, Γ ⊢ A → Γ ⊢ A ∨ B + | OrI₂ : ∀ Γ A B, Γ ⊢ B → Γ ⊢ A ∨ B + | OrE : ∀ Γ A B C, Γ ⊢ A ∨ B → A::Γ ⊢ C → B::Γ ⊢ C → Γ ⊢ C + + infix ⊢ := Nc + + definition Provable A := [] ⊢ A + + definition Prop_Soundness := ∀ A, Provable A → Valid A + + definition Prop_Completeness := ∀ A, Valid A → Provable A + + open Nc + + lemma weakening2 : ∀ Γ A, Γ ⊢ A → ∀ Δ, Γ ⊆ Δ → Δ ⊢ A := + λ Γ A H, Nc.induction_on H + (λ Γ A Hin Δ Hs, !Nax (Hs A Hin)) + (λ Γ A B H w Δ Hs, !ImpI (w _ (cons_sub_cons A Hs))) + (λ Γ A B H₁ H₂ w₁ w₂ Δ Hs, !ImpE (w₁ _ Hs) (w₂ _ Hs)) + (λ Γ A H w Δ Hs, !BotC (w _ (cons_sub_cons (~A) Hs))) + (λ Γ A B H₁ H₂ w₁ w₂ Δ Hs, !AndI (w₁ _ Hs) (w₂ _ Hs)) + (λ Γ A B H w Δ Hs, !AndE₁ (w _ Hs)) + (λ Γ A B H w Δ Hs, !AndE₂ (w _ Hs)) + (λ Γ A B H w Δ Hs, !OrI₁ (w _ Hs)) + (λ Γ A B H w Δ Hs, !OrI₂ (w _ Hs)) + (λ Γ A B C H₁ H₂ H₃ w₁ w₂ w₃ Δ Hs, !OrE (w₁ _ Hs) (w₂ _ (cons_sub_cons A Hs)) (w₃ _ (cons_sub_cons B Hs))) + + lemma weakening : ∀ Γ Δ A, Γ ⊢ A → Γ++Δ ⊢ A := + λ Γ Δ A H, weakening2 Γ A H (Γ++Δ) (sub_append_left Γ Δ) + + lemma deduction : ∀ Γ A B, Γ ⊢ A ⇒ B → A::Γ ⊢ B := + λ Γ A B H, ImpE _ A _ (!weakening2 H _ (sub_cons A Γ)) (!Nax (mem_cons A Γ)) + + lemma prov_impl : ∀ A B, Provable (A ⇒ B) → ∀ Γ, Γ ⊢ A → Γ ⊢ B := + λ A B Hp Γ Ha, + have wHp : Γ ⊢ (A ⇒ B), from !weakening Hp, + !ImpE wHp Ha + + lemma Satisfies_cons : ∀ {A Γ v}, Satisfies v Γ → is_true (TrueQ v A) → Satisfies v (A::Γ) := + λ A Γ v s t B BinAG, + or.elim BinAG + (λ e : B = A, by rewrite e; exact t) + (λ i : B ∈ Γ, s _ i) + + theorem Soundness_general : ∀ A Γ, Γ ⊢ A → Γ ⊨ A := + λ A Γ H, Nc.induction_on H + (λ Γ A Hin v s, (s _ Hin)) + (λ Γ A B H r v s, + by_cases + (λ t : is_true (TrueQ v A), + have aux₁ : Satisfies v (A::Γ), from Satisfies_cons s t, + have aux₂ : is_true (TrueQ v B), from r v aux₁, + bor_inr aux₂) + (λ f : ¬ is_true (TrueQ v A), + have aux : bnot (TrueQ v A) = tt, by rewrite (eq_ff_of_ne_tt f), + bor_inl aux)) + (λ Γ A B H₁ H₂ r₁ r₂ v s, + have aux₁ : bnot (TrueQ v A) || TrueQ v B = tt, from r₁ v s, + have aux₂ : TrueQ v A = tt, from r₂ v s, + by rewrite [aux₂ at aux₁, bnot_true at aux₁, ff_bor at aux₁]; exact aux₁) + (λ Γ A H r v s, by_contradiction + (λ n : TrueQ v A ≠ tt, + have aux₁ : TrueQ v A = ff, from eq_ff_of_ne_tt n, + have aux₂ : TrueQ v (~A) = tt, begin change (bnot (TrueQ v A) || ff = tt), rewrite aux₁ end, + have aux₃ : Satisfies v ((~A)::Γ), from Satisfies_cons s aux₂, + have aux₄ : TrueQ v ⊥ = tt, from r v aux₃, + absurd aux₄ ff_ne_tt)) + (λ Γ A B H₁ H₂ r₁ r₂ v s, + have aux₁ : TrueQ v A = tt, from r₁ v s, + have aux₂ : TrueQ v B = tt, from r₂ v s, + band_intro aux₁ aux₂) + (λ Γ A B H r v s, + have aux : TrueQ v (A ∧ B) = tt, from r v s, + band_elim_left aux) + (λ Γ A B H r v s, + have aux : TrueQ v (A ∧ B) = tt, from r v s, + band_elim_right aux) + (λ Γ A B H r v s, + have aux : TrueQ v A = tt, from r v s, + bor_inl aux) + (λ Γ A B H r v s, + have aux : TrueQ v B = tt, from r v s, + bor_inr aux) + (λ Γ A B C H₁ H₂ H₃ r₁ r₂ r₃ v s, + have aux : TrueQ v A || TrueQ v B = tt, from r₁ v s, + or.elim (or_of_bor_eq aux) + (λ At : TrueQ v A = tt, + have aux : Satisfies v (A::Γ), from Satisfies_cons s At, + r₂ v aux) + (λ Bt : TrueQ v B = tt, + have aux : Satisfies v (B::Γ), from Satisfies_cons s Bt, + r₃ v aux)) + + theorem Soundness : Prop_Soundness := + λ A, Soundness_general A [] + +end PropF diff --git a/old_library/logic/examples/propositional/soundness_type.lean b/old_library/logic/examples/propositional/soundness_type.lean new file mode 100644 index 0000000000..ecdb7db426 --- /dev/null +++ b/old_library/logic/examples/propositional/soundness_type.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author: Leonardo de Moura + +Define propositional calculus, valuation, provability, validity, prove soundness. + +This file is based on Floris van Doorn Coq files. + +Similar to soundness.lean, but defines Nc in Type. +The idea is to be able to prove soundness using recursive equations. +-/ +import data.nat data.list +open nat bool list decidable + +attribute [reducible] +definition PropVar := nat + +inductive PropF := +| Var : PropVar → PropF +| Bot : PropF +| Conj : PropF → PropF → PropF +| Disj : PropF → PropF → PropF +| Impl : PropF → PropF → PropF + +namespace PropF + notation `#`:max P:max := Var P + notation A ∨ B := Disj A B + notation A ∧ B := Conj A B + infixr `⇒`:27 := Impl + notation `⊥` := Bot + + definition Neg A := A ⇒ ⊥ + notation ~ A := Neg A + definition Top := ~⊥ + notation `⊤` := Top + definition BiImpl A B := A ⇒ B ∧ B ⇒ A + infixr `⇔`:27 := BiImpl + + definition valuation := PropVar → bool + + definition TrueQ (v : valuation) : PropF → bool + | TrueQ (# P) := v P + | TrueQ ⊥ := ff + | TrueQ (A ∨ B) := TrueQ A || TrueQ B + | TrueQ (A ∧ B) := TrueQ A && TrueQ B + | TrueQ (A ⇒ B) := bnot (TrueQ A) || TrueQ B + + attribute [reducible] + definition is_true (b : bool) := b = tt + + -- the valuation v satisfies a list of PropF, if forall (A : PropF) in Γ, + -- (TrueQ v A) is tt (the Boolean true) + definition Satisfies v Γ := ∀ A, A ∈ Γ → is_true (TrueQ v A) + definition Models Γ A := ∀ v, Satisfies v Γ → is_true (TrueQ v A) + + infix `⊨`:80 := Models + + definition Valid p := [] ⊨ p + reserve infix `⊢`:26 + + /- Provability -/ + + inductive Nc : list PropF → PropF → Type := + infix ⊢ := Nc + | Nax : ∀ Γ A, A ∈ Γ → Γ ⊢ A + | ImpI : ∀ Γ A B, A::Γ ⊢ B → Γ ⊢ A ⇒ B + | ImpE : ∀ Γ A B, Γ ⊢ A ⇒ B → Γ ⊢ A → Γ ⊢ B + | BotC : ∀ Γ A, (~A)::Γ ⊢ ⊥ → Γ ⊢ A + | AndI : ∀ Γ A B, Γ ⊢ A → Γ ⊢ B → Γ ⊢ A ∧ B + | AndE₁ : ∀ Γ A B, Γ ⊢ A ∧ B → Γ ⊢ A + | AndE₂ : ∀ Γ A B, Γ ⊢ A ∧ B → Γ ⊢ B + | OrI₁ : ∀ Γ A B, Γ ⊢ A → Γ ⊢ A ∨ B + | OrI₂ : ∀ Γ A B, Γ ⊢ B → Γ ⊢ A ∨ B + | OrE : ∀ Γ A B C, Γ ⊢ A ∨ B → A::Γ ⊢ C → B::Γ ⊢ C → Γ ⊢ C + + infix ⊢ := Nc + + definition Provable A := [] ⊢ A + + definition Prop_Soundness := ∀ A, Provable A → Valid A + + definition Prop_Completeness := ∀ A, Valid A → Provable A + + open Nc + + -- Remark ⌞t⌟ indicates we should not pattern match on t. + -- In the following lemma, we only need to pattern match on Γ ⊢ A, + -- by pattern matching on A, we would be creating 10*6 cases instead of 10. + + lemma weakening2 : ∀ {Γ A Δ}, Γ ⊢ A → Γ ⊆ Δ → Δ ⊢ A + | Γ ⌞A⌟ Δ (Nax Γ A Hin) Hs := !Nax (Hs A Hin) + | Γ ⌞A ⇒ B⌟ Δ (ImpI Γ A B H) Hs := !ImpI (weakening2 H (cons_sub_cons A Hs)) + | Γ ⌞B⌟ Δ (ImpE Γ A B H₁ H₂) Hs := !ImpE (weakening2 H₁ Hs) (weakening2 H₂ Hs) + | Γ ⌞A⌟ Δ (BotC Γ A H) Hs := !BotC (weakening2 H (cons_sub_cons (~A) Hs)) + | Γ ⌞A ∧ B⌟ Δ (AndI Γ A B H₁ H₂) Hs := !AndI (weakening2 H₁ Hs) (weakening2 H₂ Hs) + | Γ ⌞A⌟ Δ (AndE₁ Γ A B H) Hs := !AndE₁ (weakening2 H Hs) + | Γ ⌞B⌟ Δ (AndE₂ Γ A B H) Hs := !AndE₂ (weakening2 H Hs) + | Γ ⌞A ∨ B⌟ Δ (OrI₁ Γ A B H) Hs := !OrI₁ (weakening2 H Hs) + | Γ ⌞A ∨ B⌟ Δ (OrI₂ Γ A B H) Hs := !OrI₂ (weakening2 H Hs) + | Γ ⌞C⌟ Δ (OrE Γ A B C H₁ H₂ H₃) Hs := + !OrE (weakening2 H₁ Hs) (weakening2 H₂ (cons_sub_cons A Hs)) (weakening2 H₃ (cons_sub_cons B Hs)) + + lemma weakening : ∀ Γ Δ A, Γ ⊢ A → Γ++Δ ⊢ A := + λ Γ Δ A H, weakening2 H (sub_append_left Γ Δ) + + lemma deduction : ∀ Γ A B, Γ ⊢ A ⇒ B → A::Γ ⊢ B := + λ Γ A B H, !ImpE (weakening2 H (sub_cons A Γ)) (!Nax (mem_cons A Γ)) + + lemma prov_impl : ∀ A B, Provable (A ⇒ B) → ∀ Γ, Γ ⊢ A → Γ ⊢ B := + λ A B Hp Γ Ha, + have wHp : Γ ⊢ (A ⇒ B), from !weakening Hp, + !ImpE wHp Ha + + lemma Satisfies_cons : ∀ {A Γ v}, Satisfies v Γ → is_true (TrueQ v A) → Satisfies v (A::Γ) := + λ A Γ v s t B BinAG, + or.elim BinAG + (λ e : B = A, by rewrite e; exact t) + (λ i : B ∈ Γ, s _ i) + + theorem Soundness_general {v : valuation} : ∀ {A Γ}, Γ ⊢ A → Satisfies v Γ → is_true (TrueQ v A) + | ⌞A⌟ Γ (Nax Γ A Hin) s := s _ Hin + | ⌞A ⇒ B⌟ Γ (ImpI Γ A B H) s := + by_cases + (λ t : is_true (TrueQ v A), + have aux₁ : Satisfies v (A::Γ), from Satisfies_cons s t, + have aux₂ : is_true (TrueQ v B), from Soundness_general H aux₁, + bor_inr aux₂) + (λ f : ¬ is_true (TrueQ v A), + have aux : bnot (TrueQ v A) = tt, by rewrite (eq_ff_of_ne_tt f), + bor_inl aux) + | ⌞B⌟ Γ (ImpE Γ A B H₁ H₂) s := + have aux₁ : bnot (TrueQ v A) || TrueQ v B = tt, from Soundness_general H₁ s, + have aux₂ : TrueQ v A = tt, from Soundness_general H₂ s, + by rewrite [aux₂ at aux₁, bnot_true at aux₁, ff_bor at aux₁]; exact aux₁ + | ⌞A⌟ Γ (BotC Γ A H) s := by_contradiction + (λ n : TrueQ v A ≠ tt, + have aux₁ : TrueQ v A = ff, from eq_ff_of_ne_tt n, + have aux₂ : TrueQ v (~A) = tt, begin change (bnot (TrueQ v A) || ff = tt), rewrite aux₁ end, + have aux₃ : Satisfies v ((~A)::Γ), from Satisfies_cons s aux₂, + have aux₄ : TrueQ v ⊥ = tt, from Soundness_general H aux₃, + absurd aux₄ ff_ne_tt) + | ⌞A ∧ B⌟ Γ (AndI Γ A B H₁ H₂) s := + have aux₁ : TrueQ v A = tt, from Soundness_general H₁ s, + have aux₂ : TrueQ v B = tt, from Soundness_general H₂ s, + band_intro aux₁ aux₂ + | ⌞A⌟ Γ (AndE₁ Γ A B H) s := + have aux : TrueQ v (A ∧ B) = tt, from Soundness_general H s, + band_elim_left aux + | ⌞B⌟ Γ (AndE₂ Γ A B H) s := + have aux : TrueQ v (A ∧ B) = tt, from Soundness_general H s, + band_elim_right aux + | ⌞A ∨ B⌟ Γ (OrI₁ Γ A B H) s := + have aux : TrueQ v A = tt, from Soundness_general H s, + bor_inl aux + | ⌞A ∨ B⌟ Γ (OrI₂ Γ A B H) s := + have aux : TrueQ v B = tt, from Soundness_general H s, + bor_inr aux + | ⌞C⌟ Γ (OrE Γ A B C H₁ H₂ H₃) s := + have aux : TrueQ v A || TrueQ v B = tt, from Soundness_general H₁ s, + or.elim (or_of_bor_eq aux) + (λ At : TrueQ v A = tt, + have aux : Satisfies v (A::Γ), from Satisfies_cons s At, + Soundness_general H₂ aux) + (λ Bt : TrueQ v B = tt, + have aux : Satisfies v (B::Γ), from Satisfies_cons s Bt, + Soundness_general H₃ aux) + + theorem Soundness : Prop_Soundness := + λ A H v s, Soundness_general H s + +end PropF diff --git a/old_library/logic/identities.lean b/old_library/logic/identities.lean new file mode 100644 index 0000000000..ed2f790a72 --- /dev/null +++ b/old_library/logic/identities.lean @@ -0,0 +1,105 @@ +/- +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 + +Useful logical identities. Since we are not using propositional extensionality, some of the +calculations use the type class support provided by logic.instances. +-/ +import logic.connectives logic.quantifiers logic.cast +open decidable + +theorem or.right_comm (a b c : Prop) : (a ∨ b) ∨ c ↔ (a ∨ c) ∨ b := +calc + (a ∨ b) ∨ c ↔ a ∨ (b ∨ c) : or.assoc + ... ↔ a ∨ (c ∨ b) : sorry -- by rewrite (@or.comm b c) + ... ↔ (a ∨ c) ∨ b : iff.symm or.assoc + +theorem and.right_comm (a b c : Prop) : (a ∧ b) ∧ c ↔ (a ∧ c) ∧ b := +calc + (a ∧ b) ∧ c ↔ a ∧ (b ∧ c) : and.assoc + ... ↔ a ∧ (c ∧ b) : sorry -- by rewrite (@and.comm b c) + ... ↔ (a ∧ c) ∧ b : iff.symm and.assoc + +theorem or_not_self_iff (a : Prop) [D : decidable a] : a ∨ ¬ a ↔ true := +iff.intro (assume H, trivial) (assume H, em a) + +theorem not_or_self_iff (a : Prop) [D : decidable a] : ¬ a ∨ a ↔ true := +iff.intro (λ H, trivial) (λ H, or.swap (em a)) + +theorem and_not_self_iff (a : Prop) : a ∧ ¬ a ↔ false := +iff.intro (assume H, (and.right H) (and.left H)) (assume H, false.elim H) + +theorem not_and_self_iff (a : Prop) : ¬ a ∧ a ↔ false := +sorry +-- iff.intro (λ H, and.elim H (by contradiction)) (λ H, false.elim H) + +theorem not_not_iff (a : Prop) [D : decidable a] : ¬¬a ↔ a := +iff.intro by_contradiction not_not_intro + +theorem not_not_elim {a : Prop} [D : decidable a] : ¬¬a → a := +by_contradiction + +theorem not_or_iff_not_and_not (a b : Prop) : ¬(a ∨ b) ↔ ¬a ∧ ¬b := +or.imp_distrib + +theorem not_or_not_of_not_and {a b : Prop} [Da : decidable a] (H : ¬ (a ∧ b)) : ¬ a ∨ ¬ b := +by_cases (λHa, or.inr (not.mto (and.intro Ha) H)) or.inl + +theorem not_or_not_of_not_and' {a b : Prop} [Db : decidable b] (H : ¬ (a ∧ b)) : ¬ a ∨ ¬ b := +by_cases (λHb, or.inl (λHa, H (and.intro Ha Hb))) or.inr + +theorem not_and_iff_not_or_not (a b : Prop) [Da : decidable a] : + ¬(a ∧ b) ↔ ¬a ∨ ¬b := +iff.intro + not_or_not_of_not_and + (or.rec (not.mto and.left) (not.mto and.right)) + +theorem or_iff_not_and_not (a b : Prop) [Da : decidable a] [Db : decidable b] : + a ∨ b ↔ ¬ (¬a ∧ ¬b) := +sorry -- by rewrite [-not_or_iff_not_and_not, not_not_iff] + +theorem and_iff_not_or_not (a b : Prop) [Da : decidable a] [Db : decidable b] : + a ∧ b ↔ ¬ (¬ a ∨ ¬ b) := +sorry -- by rewrite [-not_and_iff_not_or_not, not_not_iff] + +theorem imp_iff_not_or (a b : Prop) [Da : decidable a] : (a → b) ↔ ¬a ∨ b := +iff.intro + (by_cases (λHa H, or.inr (H Ha)) (λHa H, or.inl Ha)) + (or.rec not.elim imp.intro) + +theorem not_implies_iff_and_not (a b : Prop) [Da : decidable a] : + ¬(a → b) ↔ a ∧ ¬b := +calc + ¬(a → b) ↔ ¬(¬a ∨ b) : sorry -- by rewrite (imp_iff_not_or a b) + ... ↔ ¬¬a ∧ ¬b : not_or_iff_not_and_not _ _ + ... ↔ a ∧ ¬b : sorry -- by rewrite (not_not_iff a) + +theorem and_not_of_not_implies {a b : Prop} [Da : decidable a] (H : ¬ (a → b)) : a ∧ ¬ b := +iff.mp (not_implies_iff_and_not a b) H + +theorem not_implies_of_and_not {a b : Prop} [Da : decidable a] (H : a ∧ ¬ b) : ¬ (a → b) := +iff.mpr (not_implies_iff_and_not a b) H + +theorem peirce (a b : Prop) [D : decidable a] : ((a → b) → a) → a := +by_cases imp.intro (imp.syl imp.mp not.elim) + +theorem forall_not_of_not_exists {A : Type} {p : A → Prop} [D : ∀x, decidable (p x)] + (H : ¬∃x, p x) : ∀x, ¬p x := +take x, by_cases + (assume Hp : p x, absurd (exists.intro x Hp) H) + imp.id + +theorem forall_of_not_exists_not {A : Type} {p : A → Prop} [D : decidable_pred p] : + ¬(∃ x, ¬p x) → ∀ x, p x := +imp.syl (forall_imp_forall (λa, not_not_elim)) forall_not_of_not_exists + +theorem exists_not_of_not_forall {A : Type} {p : A → Prop} [D : ∀x, decidable (p x)] + [D' : decidable (∃x, ¬p x)] (H : ¬∀x, p x) : + ∃x, ¬p x := +by_contradiction (λH1, absurd (λx, not_not_elim (forall_not_of_not_exists H1 x)) H) + +theorem exists_of_not_forall_not {A : Type} {p : A → Prop} [D : ∀x, decidable (p x)] + [D' : decidable (∃x, p x)] (H : ¬∀x, ¬ p x) : + ∃x, p x := +by_contradiction (imp.syl H forall_not_of_not_exists) diff --git a/old_library/logic/logic.md b/old_library/logic/logic.md new file mode 100644 index 0000000000..f055689be2 --- /dev/null +++ b/old_library/logic/logic.md @@ -0,0 +1,18 @@ +logic +===== + +Logical constructions and theorems, beyond what has already been +declared in init.datatypes and init.logic. + +The command `import logic` does not import any axioms by default. + +* [connectives](connectives.lean) : the propositional connectives +* [eq](eq.lean) : additional theorems for equality and disequality +* [cast](cast.lean) : casts and heterogeneous equality +* [quantifiers](quantifiers.lean) : existential and universal quantifiers +* [identities](identities.lean) : some useful identities +* [default](default.lean) + +Subfolders: + +* [examples](examples/examples.md) diff --git a/old_library/logic/quantifiers.lean b/old_library/logic/quantifiers.lean new file mode 100644 index 0000000000..1d23cb6e06 --- /dev/null +++ b/old_library/logic/quantifiers.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad + +Universal and existential quantifiers. See also init.logic. +-/ +import .connectives +open inhabited nonempty + +theorem exists_imp_distrib {A : Type} {B : Prop} {P : A → Prop} : ((∃ a : A, P a) → B) ↔ (∀ a : A, P a → B) := +iff.intro (λ e x H, e (exists.intro x H)) Exists.rec + +theorem forall_iff_not_exists {A : Type} {P : A → Prop} : (¬ ∃ a : A, P a) ↔ ∀ a : A, ¬ P a := +exists_imp_distrib + +theorem not_forall_not_of_exists {A : Type} {p : A → Prop} (H : ∃ x, p x) : ¬ ∀ x, ¬ p x := +sorry +/- +assume H1 : ∀ x, ¬ p x, + obtain (w : A) (Hw : p w), from H, + absurd Hw (H1 w) +-/ + +theorem not_exists_not_of_forall {A : Type} {p : A → Prop} (H2 : ∀ x, p x) : ¬ ∃ x, ¬p x := +sorry +/- +assume H1 : ∃ x, ¬ p x, + obtain (w : A) (Hw : ¬ p w), from H1, + absurd (H2 w) Hw +-/ + +theorem not_forall_of_exists_not {A : Type} {P : A → Prop} (H : ∃ a : A, ¬ P a) : ¬ ∀ a : A, P a := +assume H', not_exists_not_of_forall H' H + +theorem forall_true_iff_true (A : Type) : (∀ x : A, true) ↔ true := +iff_true_intro (λH, trivial) + +theorem forall_p_iff_p (A : Type) [H : inhabited A] (p : Prop) : (∀ x : A, p) ↔ p := +iff.intro (inhabited.destruct H) (λ Hr x, Hr) + +theorem exists_p_iff_p (A : Type) [H : inhabited A] (p : Prop) : (∃ x : A, p) ↔ p := +iff.intro (Exists.rec (λ x Hp, Hp)) (inhabited.destruct H exists.intro) + +theorem forall_and_distribute {A : Type} (φ ψ : A → Prop) : + (∀ x, φ x ∧ ψ x) ↔ (∀ x, φ x) ∧ (∀ x, ψ x) := +iff.intro + (assume H, and.intro (take x, and.left (H x)) (take x, and.right (H x))) + (assume H x, and.intro (and.left H x) (and.right H x)) + +theorem exists_or_distribute {A : Type} (φ ψ : A → Prop) : + (∃ x, φ x ∨ ψ x) ↔ (∃ x, φ x) ∨ (∃ x, ψ x) := +iff.intro + (Exists.rec (λ x, or.imp (exists.intro x) (exists.intro x))) + (or.rec (exists_imp_exists (λ x, or.inl)) + (exists_imp_exists (λ x, or.inr))) + +section + open decidable + + variables {A : Type} (P : A → Prop) (a : A) [H : decidable (P a)] + include H + + attribute [instance] + definition decidable_forall_eq : decidable (∀ x, x = a → P x) := + if pa : P a then tt (λ x heq, eq.substr heq pa) + else ff (not.mto (λH, H a rfl) pa) + + attribute [instance] + definition decidable_exists_eq : decidable (∃ x, x = a ∧ P x) := + if pa : P a then tt (exists.intro a (and.intro rfl pa)) + else ff (Exists.rec (λh, and.rec (λheq, eq.substr heq pa))) +end + +/- definite description -/ + +section + local attribute classical.prop_decidable [instance] + + noncomputable definition the {A : Type} {p : A → Prop} (H : ∃! x, p x) : A := + classical.some (exists_of_exists_unique H) + + theorem the_spec {A : Type} {p : A → Prop} (H : ∃! x, p x) : p (the H) := + classical.some_spec (exists_of_exists_unique H) + + theorem eq_the {A : Type} {p : A → Prop} (H : ∃! x, p x) {y : A} (Hy : p y) : + y = the H := + unique_of_exists_unique H Hy (the_spec H) +end diff --git a/old_library/logic/weak_fan.lean b/old_library/logic/weak_fan.lean new file mode 100644 index 0000000000..4987067cf6 --- /dev/null +++ b/old_library/logic/weak_fan.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura + +This file is based on Coq's WeakFan.v file + +A constructive proof of a non-standard version of the weak Fan Theorem +in the formulation of which infinite paths are treated as +predicates. The representation of paths as relations avoid the +need for classical logic and unique choice. The idea of the proof +comes from the proof of the weak König's lemma from separation in +second-order arithmetic: + + Stephen G. Simpson. Subsystems of second order + arithmetic, Cambridge University Press, 1999 +-/ +import data.list +open bool nat list + +namespace weak_fan +-- inductively_barred P l means that P eventually holds above l +inductive inductively_barred (P : list bool → Prop) : list bool → Prop := +| base : ∀ l, P l → inductively_barred P l +| propagate : ∀ l, + inductively_barred P (tt::l) → + inductively_barred P (ff::l) → + inductively_barred P l + +-- approx X l says that l is a boolean representation of a prefix of X +definition approx : (nat → Prop) → (list bool) → Prop +| X [] := true +| X (b::l) := approx X l ∧ (cond b (X (length l)) (¬ (X (length l)))) + +-- barred P means that for any infinite path represented as a predicate, the property P holds for some prefix of the path +definition barred P := ∀ X, ∃ l, approx X l ∧ P l + +/- +The proof proceeds by building a set Y of finite paths +approximating either the smallest unbarred infinite path in P, if +there is one (taking tt > ff), or the path tt::tt::... +if P happens to be inductively_barred +-/ +private definition Y : (list bool → Prop) → list bool → Prop +| P [] := true +| P (b::l) := Y P l ∧ (cond b (inductively_barred P (ff::l)) (¬(inductively_barred P (ff::l)))) + +private lemma Y_unique : ∀ {P l₁ l₂}, length l₁ = length l₂ → Y P l₁ → Y P l₂ → l₁ = l₂ +:= sorry +/- +| P [] [] h₁ h₂ h₃ := rfl +| P [] (a₂::l₂) h₁ h₂ h₃ := by contradiction +| P (a₁::l₁) [] h₁ h₂ h₃ := by contradiction +| P (a₁::l₁) (a₂::l₂) h₁ h₂ h₃ := + have n₁ : length l₁ = length l₂, by rewrite [*length_cons at h₁]; apply nat.add_right_cancel h₁, + have n₂ : Y P l₁, from and.elim_left h₂, + have n₃ : Y P l₂, from and.elim_left h₃, + have ih : l₁ = l₂, from Y_unique n₁ n₂ n₃, + begin + clear Y_unique, subst l₂, congruence, + show a₁ = a₂, + begin + cases a₁, + {cases a₂, reflexivity, exact absurd (and.elim_right h₃) (and.elim_right h₂)}, + {cases a₂, exact absurd (and.elim_right h₂) (and.elim_right h₃), reflexivity} + end + end +-/ + +-- X is the translation of Y as a predicate +private definition X P n := ∃ l, length l = n ∧ Y P (tt::l) + +private lemma Y_approx : ∀ {P l}, approx (X P) l → Y P l +| P [] h := trivial +| P (a::l) h := + sorry + /- + begin + have ypl : Y P l, from Y_approx (and.elim_left h), + unfold Y, split, + {exact ypl}, + {cases a, + {have nxp : ¬X P (length l), begin unfold approx at h, rewrite cond_ff at h, exact and.elim_right h end, + rewrite cond_ff, intro ib, + have xp : X P (length l), begin existsi l, split, reflexivity, unfold Y, split, exact ypl, rewrite cond_tt, exact ib end, + contradiction}, + {rewrite cond_tt, + have xp : X P (length l), begin unfold approx at h, rewrite cond_tt at h, exact and.elim_right h end, + obtain l₁ hl yptt, from xp, + begin + unfold Y at yptt, rewrite cond_tt at yptt, + have ypl₁ : Y P l₁, from and.elim_left yptt, + have ib₁ : inductively_barred P (ff::l₁), from and.elim_right yptt, + have ll₁ : l₁ = l, from Y_unique hl ypl₁ ypl, + subst l, exact ib₁ + end}} + end + -/ + +theorem weak_fan : ∀ {P}, barred P → inductively_barred P [] := +λ P Hbar, +sorry +/- +obtain l Hd HP, from Hbar (X P), +have ib : inductively_barred P l, from inductively_barred.base l HP, +begin + clear Hbar HP, + induction l with a l ih, + {exact ib}, + {unfold approx at Hd, cases Hd with Hd HX, + have ypl : Y P l, from Y_approx Hd, + cases a, + {rewrite cond_ff at HX, + have xpl : X P (length l), begin unfold X, existsi l, split, reflexivity, + unfold Y, rewrite cond_tt, split, repeat eassumption end, + exact absurd xpl HX}, + {rewrite cond_tt at HX, + obtain l₁ hl yptt, from HX, + begin + unfold Y at yptt, rewrite cond_tt at yptt, + have ll₁ : l₁ = l, from Y_unique hl (and.elim_left yptt) ypl, + subst l₁, + have ibl : inductively_barred P l, from inductively_barred.propagate l ib (and.elim_right yptt), + exact ih Hd ibl, + end}} +end +-/ +end weak_fan diff --git a/old_library/smt/arith.lean b/old_library/smt/arith.lean new file mode 100644 index 0000000000..7a2eaf8e44 --- /dev/null +++ b/old_library/smt/arith.lean @@ -0,0 +1,30 @@ +import algebra.ordered_field + +-- Arithmetic +constants (int real : Type.{1}) +constants (int_has_zero : has_zero int) +constants (int_has_one : has_one int) +constants (int_has_add : has_add int) +constants (int_has_mul : has_mul int) +constants (int_has_sub : has_sub int) +constants (int_has_neg : has_neg int) +constants (int_has_div : has_div int) +constants (int_has_lt : has_lt int) +constants (int_has_le : has_le int) +constants (int_has_mod : has_mod int) +constants (int_decidable_linear_ordered_comm_group : decidable_linear_ordered_comm_group int) +attribute [instance] int_has_zero int_has_one int_has_add int_has_mul int_has_sub int_has_div int_has_neg int_has_le int_has_lt int_has_mod int_decidable_linear_ordered_comm_group + +constants (real_has_zero : has_zero real) +constants (real_has_one : has_one real) +constants (real_has_add : has_add real) +constants (real_has_mul : has_mul real) +constants (real_has_sub : has_sub real) +constants (real_has_neg : has_neg real) +constants (real_has_div : has_div real) +constants (real_has_lt : has_lt real) +constants (real_has_le : has_le real) + +attribute [instance] real_has_zero real_has_one real_has_add real_has_mul real_has_sub real_has_neg real_has_div real_has_le real_has_lt + +constants (real.of_int : int → real) (real.to_int : real → int) (real.is_int : real → Prop) diff --git a/old_library/smt/array.lean b/old_library/smt/array.lean new file mode 100644 index 0000000000..05f2e83c4f --- /dev/null +++ b/old_library/smt/array.lean @@ -0,0 +1,29 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Leonardo de Moura +-/ +namespace smt +definition array (A B : Type) := A → B + +variables {A B : Type} +open tactic + +definition select (a : array A B) (i : A) : B := +a i + +theorem arrayext (a₁ a₂ : array A B) : (∀ i, select a₁ i = select a₂ i) → a₁ = a₂ := +funext + +variable [decidable_eq A] + +definition store (a : array A B) (i : A) (v : B) : array A B := +λ j, if j = i then v else select a j + +theorem select_store [simp] (a : array A B) (i : A) (v : B) : select (store a i v) i = v := +by unfold [`smt.store, `smt.select] >> dsimp >> rewrite `if_pos >> reflexivity + +theorem select_store_ne [simp] (a : array A B) (i j : A) (v : B) : j ≠ i → select (store a i v) j = select a j := +by intros >> unfold [`smt.store, `smt.select] >> dsimp >> rewrite `if_neg >> assumption + +end smt diff --git a/old_library/smt/default.lean b/old_library/smt/default.lean new file mode 100644 index 0000000000..b8b2afb7bd --- /dev/null +++ b/old_library/smt/default.lean @@ -0,0 +1,6 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Daniel Selsam +-/ +import smt.arith smt.array smt.prove diff --git a/old_library/smt/prove.lean b/old_library/smt/prove.lean new file mode 100644 index 0000000000..e97b62059c --- /dev/null +++ b/old_library/smt/prove.lean @@ -0,0 +1,15 @@ +namespace smt +open tactic + +private meta_definition collect_props : list expr → tactic (list expr) +| [] := return [] +| (H :: Hs) := do + Eqs ← collect_props Hs, + Htype ← infer_type H >>= whnf, + return $ if Htype = expr.prop then H :: Eqs else Eqs + +meta_definition prove : tactic unit := +do local_context >>= collect_props >>= revert_lst, + simplify_goal failed [] + +end smt diff --git a/old_library/standard.lean b/old_library/standard.lean new file mode 100644 index 0000000000..637572bb7e --- /dev/null +++ b/old_library/standard.lean @@ -0,0 +1,9 @@ +/- +Copyright (c) 2014 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad + +The constructive core of Lean's library. +-/ + +-- import logic data diff --git a/old_library/system/IO.lean b/old_library/system/IO.lean new file mode 100644 index 0000000000..280ee7975d --- /dev/null +++ b/old_library/system/IO.lean @@ -0,0 +1,25 @@ +/- +Copyright (c) 2016 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Luke Nelson, Jared Roesch and Leonardo de Moura +-/ +constant {u} IO : Type u → Type u +constant functorIO : functor IO +constant monadIO : monad IO + +attribute [instance] functorIO monadIO + +constant put_str : string → IO unit +constant put_nat : nat → IO unit +constant get_line : IO string + +meta_constant format.print_using : format → options → IO unit + +meta_definition format.print (fmt : format) : IO unit := +format.print_using fmt options.mk + +meta_definition pp_using {A : Type} [has_to_format A] (a : A) (o : options) : IO unit := +format.print_using (to_fmt a) o + +meta_definition pp {A : Type} [has_to_format A] (a : A) : IO unit := +format.print (to_fmt a) diff --git a/old_library/theories/analysis/analysis.md b/old_library/theories/analysis/analysis.md new file mode 100644 index 0000000000..ad0a2f3283 --- /dev/null +++ b/old_library/theories/analysis/analysis.md @@ -0,0 +1,10 @@ +theories.analysis +================= + +* [metric_space](metric_space.lean) +* [normed_space](normed_space.lean) : real normed spaces +* [real_limit](real_limit.lean) +* [ivt](ivt.lean) : the intermediate value theorem +* [sqrt](sqrt.lean) : the sqrt function on the reals +* [inner_product](inner_product.lean) : real inner product spaces +* [complex_norm](complex_norm.lean) : the complex numbers as a real normed vector space diff --git a/old_library/theories/analysis/complex_norm.lean b/old_library/theories/analysis/complex_norm.lean new file mode 100644 index 0000000000..97a60298d2 --- /dev/null +++ b/old_library/theories/analysis/complex_norm.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2016 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Instantiate the complex numbers as a normed space, by temporarily making it an inner product space +over the reals. +-/ +import theories.analysis.inner_product data.complex +open nat real complex analysis classical +noncomputable theory + +namespace complex + namespace real_inner_product_space + definition smul (a : ℝ) (z : ℂ) : ℂ := complex.mk (a * re z) (a * im z) + + definition ip (z w : ℂ) : ℝ := re z * re w + im z * im w + + proposition smul_left_distrib (a : ℝ) (z w : ℂ) : smul a (z + w) = smul a z + smul a w := + by rewrite [↑smul, *re_add, *im_add, *left_distrib] + + proposition smul_right_distrib (a b : ℝ) (z : ℂ) : smul (a + b) z = smul a z + smul b z := + by rewrite [↑smul, *right_distrib] + + proposition mul_smul (a b : ℝ) (z : ℂ) : smul (a * b) z = smul a (smul b z) := + by rewrite [↑smul, *mul.assoc] + + proposition one_smul (z : ℂ) : smul 1 z = z := by rewrite [↑smul, *one_mul, complex.eta] + + proposition inner_add_left (x y z : ℂ) : ip (x + y) z = ip x z + ip y z := + by rewrite [↑ip, re_add, im_add, *right_distrib, *add.assoc, add.left_comm (re y * re z)] + + proposition inner_smul_left (a : ℝ) (x y : ℂ) : ip (smul a x) y = a * ip x y := + by rewrite [↑ip, ↑smul, left_distrib, *mul.assoc] + + proposition inner_comm (x y : ℂ) : ip x y = ip y x := + by rewrite [↑ip, mul.comm, mul.comm (im x)] + + proposition inner_self_nonneg (x : ℂ) : ip x x ≥ 0 := + add_nonneg (mul_self_nonneg (re x)) (mul_self_nonneg (im x)) + + proposition eq_zero_of_inner_self_eq_zero {x : ℂ} (H : ip x x = 0) : x = 0 := + have re x = 0, from eq_zero_of_mul_self_add_mul_self_eq_zero H, + have im x = 0, from eq_zero_of_mul_self_add_mul_self_eq_zero + (by rewrite [↑ip at H, add.comm at H]; exact H), + by rewrite [-complex.eta, `re x = 0`, `im x = 0`] + end real_inner_product_space + + attribute [reducible] + protected definition real_inner_product_space : inner_product_space ℂ := + ⦃ inner_product_space, complex.discrete_field, + smul := real_inner_product_space.smul, + inner := real_inner_product_space.ip, + smul_left_distrib := real_inner_product_space.smul_left_distrib, + smul_right_distrib := real_inner_product_space.smul_right_distrib, + mul_smul := real_inner_product_space.mul_smul, + one_smul := real_inner_product_space.one_smul, + inner_add_left := real_inner_product_space.inner_add_left, + inner_smul_left := real_inner_product_space.inner_smul_left, + inner_comm := real_inner_product_space.inner_comm, + inner_self_nonneg := real_inner_product_space.inner_self_nonneg, + eq_zero_of_inner_self_eq_zero := @real_inner_product_space.eq_zero_of_inner_self_eq_zero + ⦄ + + local attribute complex.real_inner_product_space [trans_instance] + + attribute [trans_instance] + protected definition normed_vector_space : normed_vector_space ℂ := + _ + + theorem norm_squared_eq_cmod (z : ℂ) : ∥ z ∥^2 = cmod z := by rewrite norm_squared +end complex diff --git a/old_library/theories/analysis/inner_product.lean b/old_library/theories/analysis/inner_product.lean new file mode 100644 index 0000000000..9156bd0c7b --- /dev/null +++ b/old_library/theories/analysis/inner_product.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2016 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Real inner product spaces. + +Note: We can enter ⟨v, w⟩ as \. This file overwrites the notation for dependent pairs. +-/ +import theories.analysis.normed_space theories.analysis.sqrt +open nat real classical +noncomputable theory + +structure inner_product_space [class] (V : Type) extends real_vector_space V := +(inner : V → V → ℝ) +(inner_add_left : ∀ u v w, inner (add u v) w = inner u w + inner v w) +(inner_smul_left : ∀ r v w, inner (smul r v) w = r * inner v w) +(inner_comm : ∀ v w, inner v w = inner w v) +(inner_self_nonneg : ∀ v, inner v v ≥ 0) +(eq_zero_of_inner_self_eq_zero : ∀ {v}, inner v v = 0 → v = zero) + +namespace analysis + +variables {V : Type} [inner_product_space V] + +definition inner (v w : V) : ℝ := inner_product_space.inner v w + +notation `⟨` v `, ` w `⟩` := inner v w + +proposition inner_comm (v w : V) : ⟨v, w⟩ = ⟨w, v⟩ := inner_product_space.inner_comm v w + +proposition inner_add_left (u v w : V) : ⟨u + v, w⟩ = ⟨u, w⟩ + ⟨v, w⟩ := +inner_product_space.inner_add_left u v w + +proposition inner_add_right (u v w : V) : ⟨u, v + w⟩ = ⟨u, v⟩ + ⟨u, w⟩ := +by rewrite [inner_comm, inner_add_left, inner_comm, inner_comm w] + +proposition inner_smul_left (r : ℝ) (v w : V) : ⟨r • v, w⟩ = r * ⟨v, w⟩ := +inner_product_space.inner_smul_left r v w + +proposition inner_smul_right (r : ℝ) (v w : V) : ⟨v, r • w⟩ = r * ⟨v, w⟩ := +by rewrite [inner_comm, inner_smul_left, inner_comm] + +proposition inner_self_nonneg (v : V) : ⟨v, v⟩ ≥ 0 := inner_product_space.inner_self_nonneg v + +proposition eq_zero_of_inner_self_eq_zero {v : V} (H : ⟨v, v⟩ = 0) : v = 0 := +inner_product_space.eq_zero_of_inner_self_eq_zero H + +proposition inner_neg_left (u v : V) : ⟨-u, v⟩ = -⟨u, v⟩ := +by rewrite [-neg_one_smul_real, inner_smul_left, -neg_eq_neg_one_mul] + +proposition inner_neg_right (u v : V) : ⟨u, -v⟩ = -⟨u, v⟩ := +by rewrite [inner_comm, inner_neg_left, inner_comm] + +proposition inner_sub_left (u v w : V) : ⟨u - v, w⟩ = ⟨u, w⟩ - ⟨v, w⟩ := +by rewrite [*sub_eq_add_neg, inner_add_left, inner_neg_left] + +proposition inner_sub_right (u v w : V) : ⟨u, v - w⟩ = ⟨u, v⟩ - ⟨u, w⟩ := +by rewrite [*sub_eq_add_neg, inner_add_right, inner_neg_right] + +proposition inner_zero_left (v : V) : ⟨0, v⟩ = 0 := +have (0 : ℝ) • v = 0, from zero_smul v, +using this, by rewrite [-this, inner_smul_left, zero_mul] + +proposition inner_zero_right (v : V) : ⟨v, 0⟩ = 0 := +by rewrite [inner_comm, inner_zero_left] + +definition orthogonal (u v : V) : Prop := ⟨u, v⟩ = 0 + +infix ` ⊥ `:50 := orthogonal + +proposition orthogonal_comm {u v : V} (H : u ⊥ v) : v ⊥ u := +by unfold orthogonal at *; rewrite [inner_comm, H] + +/- first, we define norm internally, to show that an inner product space is a normed space -/ + +private definition ip_norm (v : V) : ℝ := sqrt ⟨v, v⟩ + +private proposition ip_norm_zero : ip_norm (0 : V) = 0 := +by rewrite [↑ip_norm, inner_zero_left, sqrt_zero] + +private proposition ip_norm_squared (v : V) : (ip_norm v)^2 = ⟨v, v⟩ := +sqrt_squared (inner_self_nonneg v) + +private proposition ip_norm_nonneg (v : V) : ip_norm v ≥ 0 := !sqrt_nonneg + +private proposition eq_zero_of_ip_norm_eq_zero {v : V} (H : ip_norm v = 0) : v = 0 := +have ⟨v, v⟩ = 0, by rewrite [-ip_norm_squared, H, pow_two, zero_mul], +eq_zero_of_inner_self_eq_zero this + +private proposition ip_norm_smul (r : ℝ) (v : V) : ip_norm (r • v) = abs r * ip_norm v := +begin + rewrite [↑ip_norm, inner_smul_left, inner_smul_right, -mul.assoc], + rewrite [sqrt_mul (mul_self_nonneg r) (inner_self_nonneg v), -pow_two, sqrt_squared'] +end + +private proposition ip_norm_pythagorean {u v : V} (ortho : u ⊥ v) : + (ip_norm (u + v))^2 = (ip_norm u)^2 + (ip_norm v)^2 := +by rewrite [↑orthogonal at ortho, *ip_norm_squared, inner_add_right, *inner_add_left, + inner_comm v u, *ortho, zero_add, add_zero] + +private definition ip_proj_on (u : V) {v : V} (H : v ≠ 0) : V := +(⟨u, v⟩ / (ip_norm v)^2) • v + +private proposition ip_proj_on_orthogonal (u : V) {v : V} (H : v ≠ 0) : + ip_proj_on u H ⊥ (u - ip_proj_on u H) := +begin + rewrite [↑ip_proj_on, ↑orthogonal, inner_sub_right, +inner_smul_left, inner_smul_right], + rewrite [ip_norm_squared at {3}], + rewrite [div_mul_cancel _ (assume H', H (eq_zero_of_inner_self_eq_zero H'))], + rewrite [inner_comm v u, sub_self] +end + +private proposition ip_norm_proj_on_eq (u : V) {v : V} (H : v ≠ 0) : + ip_norm (ip_proj_on u H) = abs ⟨u, v⟩ / ip_norm v := +have H1 : ip_norm v ≠ 0, from assume H', H (eq_zero_of_ip_norm_eq_zero H'), +begin + rewrite [↑ip_proj_on, ip_norm_smul, abs_div, abs_of_nonneg (squared_nonneg (ip_norm v)), pow_two], + rewrite [div_mul_eq_mul_div, -div_mul_div, div_self H1, mul_one] +end + +private proposition ip_norm_squared_pythagorean (u : V) {v : V} (H : v ≠ 0) : + (ip_norm u)^2 = (ip_norm (u - ip_proj_on u H))^2 + (ip_norm (ip_proj_on u H))^2 := +calc + (ip_norm u)^2 = (ip_norm (u - ip_proj_on u H + ip_proj_on u H))^2 : + sub_add_cancel + ... = (ip_norm (u - ip_proj_on u H))^2 + (ip_norm (ip_proj_on u H))^2 : + ip_norm_pythagorean (orthogonal_comm (ip_proj_on_orthogonal u H)) + +private proposition ip_norm_proj_on_le (u : V) {v : V} (H : v ≠ 0) : + ip_norm (ip_proj_on u H) ≤ ip_norm u := +have (ip_norm u)^2 ≥ (ip_norm (ip_proj_on u H))^2, + begin + rewrite [ip_norm_squared_pythagorean u H], + apply le_add_of_nonneg_left (squared_nonneg (ip_norm (u - ip_proj_on u H))) + end, +le_of_squared_le_squared !ip_norm_nonneg this + +private proposition ip_cauchy_schwartz (u v : V) : abs ⟨u, v⟩ ≤ ip_norm u * ip_norm v := +by_cases + (suppose v = (0 : V), + begin + rewrite [this, inner_zero_right, abs_zero, ip_norm_zero, mul_zero], + exact le.refl (0 : ℝ) + end) + (assume vnz : v ≠ 0, + have ip_norm v ≠ 0, from assume H, vnz (eq_zero_of_ip_norm_eq_zero H), + have ip_norm v > 0, from lt_of_le_of_ne !sqrt_nonneg (ne.symm this), + using this, begin + note H := ip_norm_proj_on_le u vnz, + rewrite [ip_norm_proj_on_eq u vnz at H], + exact le_mul_of_div_le this H + end) + +private proposition ip_cauchy_schwartz' (u v : V) : ⟨u, v⟩ ≤ ip_norm u * ip_norm v := +le.trans !le_abs_self !ip_cauchy_schwartz + +private proposition ip_norm_triangle (u v : V) : ip_norm (u + v) ≤ ip_norm u + ip_norm v := +have H : ⟨u, v⟩ ≤ ip_norm u * ip_norm v, from ip_cauchy_schwartz' u v, +have (ip_norm (u + v))^2 ≤ (ip_norm u + ip_norm v)^2, from + calc + (ip_norm (u + v))^2 = (ip_norm u)^2 + (ip_norm v)^2 + ⟨u, v⟩ + ⟨u, v⟩ : + by rewrite [↑ip_norm, *sqrt_squared !inner_self_nonneg, inner_add_left, + *inner_add_right, *inner_comm v u, -add.assoc, -*add.right_comm _ _ ⟨v, v⟩] + ... ≤ (ip_norm u)^2 + (ip_norm v)^2 + ip_norm u * ip_norm v + ⟨u, v⟩ : + add_le_add_right (add_le_add_left H _) _ + ... ≤ (ip_norm u)^2 + (ip_norm v)^2 + ip_norm u * ip_norm v + ip_norm u * ip_norm v : + add_le_add_left H _ + ... = (ip_norm u + ip_norm v)^2 : + by rewrite [*pow_two, right_distrib, *left_distrib, -add.assoc, + *add.right_comm _ (ip_norm v * ip_norm v), + mul.comm (ip_norm v) (ip_norm u)], +le_of_squared_le_squared (add_nonneg !ip_norm_nonneg !ip_norm_nonneg) this + +attribute [trans_instance] +definition inner_product_space.to_normed_space : + normed_vector_space V := +⦃ normed_vector_space, _inst_1, + norm := ip_norm, + norm_zero := ip_norm_zero, + eq_zero_of_norm_eq_zero := @eq_zero_of_ip_norm_eq_zero V _, + norm_triangle := ip_norm_triangle, + norm_smul := ip_norm_smul +⦄ + +/- now we restate the new theorems using the norm notation -/ + +proposition norm_squared (v : V) : ∥ v ∥^2 = ⟨v, v⟩ := ip_norm_squared v + +proposition norm_pythagorean {u v : V} (ortho : u ⊥ v) : ∥ u + v ∥^2 = ∥ u ∥^2 + ∥ v ∥^2 := +ip_norm_pythagorean ortho + +definition proj_on (u : V) {v : V} (H : v ≠ 0) : V := (⟨u, v⟩ / ∥ v ∥^2) • v + +proposition proj_on_orthogonal (u : V) {v : V} (H : v ≠ 0) : + proj_on u H ⊥ (u - proj_on u H) := +ip_proj_on_orthogonal u H + +proposition norm_proj_on_eq (u : V) {v : V} (H : v ≠ 0) : + ∥ proj_on u H ∥ = abs ⟨u, v⟩ / ∥ v ∥ := +ip_norm_proj_on_eq u H + +proposition norm_squared_pythagorean (u : V) {v : V} (H : v ≠ 0) : + ∥ u ∥^2 = ∥ u - proj_on u H ∥^2 + ∥ proj_on u H ∥^2 := +ip_norm_squared_pythagorean u H + +proposition norm_proj_on_le (u : V) {v : V} (H : v ≠ 0) : + ∥ proj_on u H ∥ ≤ ∥ u ∥ := ip_norm_proj_on_le u H + +theorem cauchy_schwartz (u v : V) : abs ⟨u, v⟩ ≤ ∥ u ∥ * ∥ v ∥ := ip_cauchy_schwartz u v + +theorem cauchy_schwartz' (u v : V) : ⟨u, v⟩ ≤ ∥ u ∥ * ∥ v ∥ := ip_cauchy_schwartz' u v + +theorem eq_proj_on_cauchy_schwartz {u v : V} (H : v ≠ 0) (H₁ : abs ⟨u, v⟩ = ∥ u ∥ * ∥ v ∥) : + u = proj_on u H := +have ∥ v ∥ ≠ 0, from assume H', H (eq_zero_of_norm_eq_zero H'), +have ∥ u ∥ = ∥ proj_on u H ∥, by rewrite [norm_proj_on_eq, H₁, mul_div_cancel _ this], +have ∥ u - proj_on u H ∥^2 + ∥ u ∥^2 = 0 + ∥ u ∥^2, + by rewrite [zero_add, norm_squared_pythagorean u H at {2}, this], +have ∥ u - proj_on u H ∥^2 = 0, from eq_of_add_eq_add_right this, +show u = proj_on u H, + from eq_of_sub_eq_zero (eq_zero_of_norm_eq_zero (eq_zero_of_squared_eq_zero this)) + +end analysis diff --git a/old_library/theories/analysis/ivt.lean b/old_library/theories/analysis/ivt.lean new file mode 100644 index 0000000000..24d8890ee5 --- /dev/null +++ b/old_library/theories/analysis/ivt.lean @@ -0,0 +1,273 @@ +/- +Copyright (c) 2015 Robert Y. Lewis. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Robert Y. Lewis + +The intermediate value theorem. +-/ +import .real_limit +open real analysis set classical +noncomputable theory + +private definition inter_sup (a b : ℝ) (f : ℝ → ℝ) := sup {x | x < b ∧ f x < 0} + +section +parameters {f : ℝ → ℝ} (Hf : continuous f) {a b : ℝ} (Hab : a < b) (Ha : f a < 0) (Hb : f b > 0) +include Hf Ha Hb Hab + +private theorem Hinh : ∃ x, x ∈ {x | x < b ∧ f x < 0} := exists.intro a (and.intro Hab Ha) + +private theorem Hmem : ∀ x, x ∈ {x | x < b ∧ f x < 0} → x ≤ b := λ x Hx, le_of_lt (and.left Hx) + +private theorem Hsupleb : inter_sup a b f ≤ b := sup_le (Hinh) Hmem + +local notation 2 := of_num 1 + of_num 1 + +private theorem ex_delta_lt {x : ℝ} (Hx : f x < 0) (Hxb : x < b) : ∃ δ : ℝ, δ > 0 ∧ x + δ < b ∧ f (x + δ) < 0 := + begin + let Hcont := neg_on_nbhd_of_cts_of_neg Hf Hx, + cases Hcont with δ Hδ, + {cases em (x + δ < b) with Haδ Haδ, + existsi δ / 2, + split, + {exact div_pos_of_pos_of_pos (and.left Hδ) two_pos}, + split, + {apply lt.trans, + apply add_lt_add_left, + exact div_two_lt_of_pos (and.left Hδ), + exact Haδ}, + {apply and.right Hδ, + krewrite [abs_sub, sub_add_eq_sub_sub, sub_self, zero_sub, abs_neg, + abs_of_pos (div_pos_of_pos_of_pos (and.left Hδ) two_pos)], + exact div_two_lt_of_pos (and.left Hδ)}, + existsi (b - x) / 2, + split, + {apply div_pos_of_pos_of_pos, + exact sub_pos_of_lt Hxb, + exact two_pos}, + split, + {apply add_midpoint Hxb}, + {apply and.right Hδ, + krewrite [abs_sub, sub_add_eq_sub_sub, sub_self, zero_sub, abs_neg, + abs_of_pos (div_pos_of_pos_of_pos (sub_pos_of_lt Hxb) two_pos)], + apply lt_of_lt_of_le, + apply div_two_lt_of_pos (sub_pos_of_lt Hxb), + apply sub_left_le_of_le_add, + apply le_of_not_gt Haδ}} + end + +private lemma sup_near_b {δ : ℝ} (Hpos : 0 < δ) + (Hgeb : inter_sup a b f + δ / 2 ≥ b) : abs (inter_sup a b f - b) < δ := + begin + apply abs_lt_of_lt_of_neg_lt, + apply sub_lt_left_of_lt_add, + apply lt_of_le_of_lt, + apply Hsupleb, + apply lt_add_of_pos_right Hpos, + rewrite neg_sub, + apply sub_lt_left_of_lt_add, + apply lt_of_le_of_lt, + apply Hgeb, + apply add_lt_add_left, + apply div_two_lt_of_pos Hpos + end + +private lemma delta_of_lt (Hflt : f (inter_sup a b f) < 0) : + ∃ δ : ℝ, δ > 0 ∧ inter_sup a b f + δ < b ∧ f (inter_sup a b f + δ) < 0 := + if Hlt : inter_sup a b f < b then ex_delta_lt Hflt Hlt else + begin + let Heq := eq_of_le_of_ge Hsupleb (le_of_not_gt Hlt), + apply absurd Hflt, + apply not_lt_of_ge, + apply le_of_lt, + rewrite Heq, + exact Hb + end + +private theorem sup_fn_interval_aux1 : f (inter_sup a b f) ≥ 0 := + have ¬ f (inter_sup a b f) < 0, from + (suppose f (inter_sup a b f) < 0, + obtain δ Hδ, from delta_of_lt this, + have inter_sup a b f + δ ∈ {x | x < b ∧ f x < 0}, + from and.intro (and.left (and.right Hδ)) (and.right (and.right Hδ)), + have ¬ inter_sup a b f < inter_sup a b f + δ, + from not_lt_of_ge (le_sup this Hmem), + show false, from this (lt_add_of_pos_right (and.left Hδ))), + le_of_not_gt this + +private theorem sup_fn_interval_aux2 : f (inter_sup a b f) ≤ 0 := + have ¬ f (inter_sup a b f) > 0, from + (assume Hfsup : f (inter_sup a b f) > 0, + obtain δ Hδ, from pos_on_nbhd_of_cts_of_pos Hf Hfsup, + have ∀ x, x ∈ {x | x < b ∧ f x < 0} → x ≤ inter_sup a b f - δ / 2, from + (take x, assume Hxset : x ∈ {x | x < b ∧ f x < 0}, + have ¬ x > inter_sup a b f - δ / 2, from + (assume Hngt, + have Habs : abs (x - inter_sup a b f) < δ, begin + rewrite abs_sub, + apply abs_lt_of_lt_of_neg_lt, + apply sub_lt_of_sub_lt, + apply gt.trans, + exact Hngt, + apply sub_lt_sub_left, + exact div_two_lt_of_pos (and.left Hδ), + rewrite neg_sub, + apply lt_of_le_of_lt, + rotate 1, + apply and.left Hδ, + apply sub_nonpos_of_le, + apply le_sup, + exact Hxset, + exact Hmem + end, + have f x > 0, from and.right Hδ x Habs, + show false, from (not_lt_of_gt this) (and.right Hxset)), + le_of_not_gt this), + have Hle : inter_sup a b f ≤ inter_sup a b f - δ / 2, from sup_le Hinh this, + show false, from not_le_of_gt + (sub_lt_of_pos _ (div_pos_of_pos_of_pos (and.left Hδ) (two_pos))) Hle), + le_of_not_gt this + +private theorem sup_fn_interval : f (inter_sup a b f) = 0 := + eq_of_le_of_ge sup_fn_interval_aux2 sup_fn_interval_aux1 + + +private theorem intermediate_value_incr_aux2 : ∃ δ : ℝ, δ > 0 ∧ a + δ < b ∧ f (a + δ) < 0 := + begin + let Hcont := neg_on_nbhd_of_cts_of_neg Hf Ha, + cases Hcont with δ Hδ, + {cases em (a + δ < b) with Haδ Haδ, + existsi δ / 2, + split, + {exact div_pos_of_pos_of_pos (and.left Hδ) two_pos}, + split, + {apply lt.trans, + apply add_lt_add_left, + exact div_two_lt_of_pos (and.left Hδ), + exact Haδ}, + {apply and.right Hδ, + krewrite [abs_sub, sub_add_eq_sub_sub, sub_self, zero_sub, abs_neg, + abs_of_pos (div_pos_of_pos_of_pos (and.left Hδ) two_pos)], + exact div_two_lt_of_pos (and.left Hδ)}, + existsi (b - a) / 2, + split, + {apply div_pos_of_pos_of_pos, + exact sub_pos_of_lt Hab, + exact two_pos}, + split, + {apply add_midpoint Hab}, + {apply and.right Hδ, + krewrite [abs_sub, sub_add_eq_sub_sub, sub_self, zero_sub, abs_neg, + abs_of_pos (div_pos_of_pos_of_pos (sub_pos_of_lt Hab) two_pos)], + apply lt_of_lt_of_le, + apply div_two_lt_of_pos (sub_pos_of_lt Hab), + apply sub_left_le_of_le_add, + apply le_of_not_gt Haδ}} + end + +theorem intermediate_value_incr_zero : ∃ c, a < c ∧ c < b ∧ f c = 0 := + begin + existsi inter_sup a b f, + split, + {cases intermediate_value_incr_aux2 with δ Hδ, + apply lt_of_lt_of_le, + apply lt_add_of_pos_right, + exact and.left Hδ, + apply le_sup, + exact and.right Hδ, + intro x Hx, + apply le_of_lt, + exact and.left Hx}, + split, + {cases pos_on_nbhd_of_cts_of_pos Hf Hb with δ Hδ, + apply lt_of_le_of_lt, + rotate 1, + apply sub_lt_of_pos, + exact and.left Hδ, + rotate_right 1, + apply sup_le, + exact exists.intro a (and.intro Hab Ha), + intro x Hx, + apply le_of_not_gt, + intro Hxgt, + have Hxgt' : b - x < δ, from sub_lt_of_sub_lt Hxgt, + krewrite [-(abs_of_pos (sub_pos_of_lt (and.left Hx))) at Hxgt', abs_sub at Hxgt'], + note Hxgt'' := and.right Hδ _ Hxgt', + exact not_lt_of_ge (le_of_lt Hxgt'') (and.right Hx)}, + {exact sup_fn_interval} + end + +end + +theorem intermediate_value_decr_zero {f : ℝ → ℝ} (Hf : continuous f) {a b : ℝ} (Hab : a < b) + (Ha : f a > 0) (Hb : f b < 0) : ∃ c, a < c ∧ c < b ∧ f c = 0 := + begin + have Ha' : - f a < 0, from neg_neg_of_pos Ha, + have Hb' : - f b > 0, from neg_pos_of_neg Hb, + have Hcon : continuous (λ x, - f x), from continuous_neg_of_continuous Hf, + let Hiv := intermediate_value_incr_zero Hcon Hab Ha' Hb', + cases Hiv with c Hc, + existsi c, + split, + exact and.left Hc, + split, + exact and.left (and.right Hc), + apply eq_zero_of_neg_eq_zero, + apply and.right (and.right Hc) + end + +theorem intermediate_value_incr {f : ℝ → ℝ} (Hf : continuous f) {a b : ℝ} (Hab : a < b) {v : ℝ} + (Hav : f a < v) (Hbv : f b > v) : ∃ c, a < c ∧ c < b ∧ f c = v := + have Hav' : f a - v < 0, from sub_neg_of_lt Hav, + have Hbv' : f b - v > 0, from sub_pos_of_lt Hbv, + have Hcon : continuous (λ x, f x - v), from continuous_offset_of_continuous Hf _, + have Hiv : ∃ c, a < c ∧ c < b ∧ f c - v = 0, from intermediate_value_incr_zero Hcon Hab Hav' Hbv', + obtain c Hc, from Hiv, + exists.intro c + (and.intro (and.left Hc) (and.intro (and.left (and.right Hc)) (eq_of_sub_eq_zero (and.right (and.right Hc))))) + +theorem intermediate_value_decr {f : ℝ → ℝ} (Hf : continuous f) {a b : ℝ} (Hab : a < b) {v : ℝ} + (Hav : f a > v) (Hbv : f b < v) : ∃ c, a < c ∧ c < b ∧ f c = v := + have Hav' : f a - v > 0, from sub_pos_of_lt Hav, + have Hbv' : f b - v < 0, from sub_neg_of_lt Hbv, + have Hcon : continuous (λ x, f x - v), from continuous_offset_of_continuous Hf _, + have Hiv : ∃ c, a < c ∧ c < b ∧ f c - v = 0, from intermediate_value_decr_zero Hcon Hab Hav' Hbv', + obtain c Hc, from Hiv, + exists.intro c + (and.intro (and.left Hc) (and.intro (and.left (and.right Hc)) (eq_of_sub_eq_zero (and.right (and.right Hc))))) + +theorem intermediate_value_incr_weak {f : ℝ → ℝ} (Hf : continuous f) {a b : ℝ} (Hab : a ≤ b) {v : ℝ} + (Hav : f a ≤ v) (Hbv : f b ≥ v) : ∃ c, a ≤ c ∧ c ≤ b ∧ f c = v := + begin + cases lt_or_eq_of_le Hab with Hlt Heq, + cases lt_or_eq_of_le Hav with Hlt' Heq', + cases lt_or_eq_of_le Hbv with Hlt'' Heq'', + cases intermediate_value_incr Hf Hlt Hlt' Hlt'' with c Hc, + cases Hc with Hc1 Hc2, + cases Hc2 with Hc2 Hc3, + existsi c, + repeat (split; apply le_of_lt; assumption), + assumption, + existsi b, + split, + apply le_of_lt, + assumption, + split, + apply le.refl, + rewrite Heq'', + existsi a, + split, + apply le.refl, + split, + apply le_of_lt, + repeat assumption, + existsi a, + split, + apply le.refl, + split, + assumption, + apply eq_of_le_of_ge, + apply Hav, + rewrite Heq, + apply Hbv + end diff --git a/old_library/theories/analysis/metric_space.lean b/old_library/theories/analysis/metric_space.lean new file mode 100644 index 0000000000..e5c2911f4c --- /dev/null +++ b/old_library/theories/analysis/metric_space.lean @@ -0,0 +1,807 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Metric spaces. +-/ +import data.real.complete data.pnat data.list.sort ..topology.basic data.set +open nat real eq.ops classical + +structure metric_space [class] (M : Type) : Type := + (dist : M → M → ℝ) + (dist_self : ∀ x : M, dist x x = 0) + (eq_of_dist_eq_zero : ∀ {x y : M}, dist x y = 0 → x = y) + (dist_comm : ∀ x y : M, dist x y = dist y x) + (dist_triangle : ∀ x y z : M, dist x z ≤ dist x y + dist y z) + +namespace analysis + +section metric_space_M +variables {M : Type} [metric_space M] + +definition dist (x y : M) : ℝ := metric_space.dist x y + +proposition dist_self (x : M) : dist x x = 0 := metric_space.dist_self x + +proposition eq_of_dist_eq_zero {x y : M} (H : dist x y = 0) : x = y := +metric_space.eq_of_dist_eq_zero H + +proposition dist_comm (x y : M) : dist x y = dist y x := metric_space.dist_comm x y + +proposition dist_eq_zero_iff (x y : M) : dist x y = 0 ↔ x = y := +iff.intro eq_of_dist_eq_zero (suppose x = y, this ▸ !dist_self) + +proposition dist_triangle (x y z : M) : dist x z ≤ dist x y + dist y z := +metric_space.dist_triangle x y z + +proposition dist_nonneg (x y : M) : 0 ≤ dist x y := +have dist x y + dist y x ≥ 0, by rewrite -(dist_self x); apply dist_triangle, +have 2 * dist x y ≥ 0, + by krewrite [-real.one_add_one, right_distrib, +one_mul, dist_comm at {2}]; apply this, +nonneg_of_mul_nonneg_left this two_pos + +proposition dist_pos_of_ne {x y : M} (H : x ≠ y) : dist x y > 0 := +lt_of_le_of_ne !dist_nonneg (suppose 0 = dist x y, H (iff.mp !dist_eq_zero_iff this⁻¹)) + +proposition ne_of_dist_pos {x y : M} (H : dist x y > 0) : x ≠ y := +suppose x = y, +have H1 : dist x x > 0, by rewrite this at {2}; exact H, +by rewrite dist_self at H1; apply not_lt_self _ H1 + +proposition eq_of_forall_dist_le {x y : M} (H : ∀ ε, ε > 0 → dist x y ≤ ε) : x = y := +eq_of_dist_eq_zero (eq_zero_of_nonneg_of_forall_le !dist_nonneg H) + +/- convergence of a sequence -/ + +definition converges_to_seq (X : ℕ → M) (y : M) : Prop := +∀ ⦃ε : ℝ⦄, ε > 0 → ∃ N : ℕ, ∀ ⦃n⦄, n ≥ N → dist (X n) y < ε + +-- the same, with ≤ in place of <; easier to prove, harder to use +definition converges_to_seq.intro {X : ℕ → M} {y : M} + (H : ∀ ⦃ε : ℝ⦄, ε > 0 → ∃ N : ℕ, ∀ {n}, n ≥ N → dist (X n) y ≤ ε) : + converges_to_seq X y := +take ε, assume epos : ε > 0, + have e2pos : ε / 2 > 0, from div_pos_of_pos_of_pos `ε > 0` two_pos, + obtain N HN, from H e2pos, + exists.intro N + (take n, suppose n ≥ N, + calc + dist (X n) y ≤ ε / 2 : HN _ `n ≥ N` + ... < ε : div_two_lt_of_pos epos) + +notation X `⟶` y `in` `ℕ` := converges_to_seq X y + +attribute [class] +definition converges_seq (X : ℕ → M) : Prop := ∃ y, X ⟶ y in ℕ + +noncomputable definition limit_seq (X : ℕ → M) [H : converges_seq X] : M := some H + +proposition converges_to_limit_seq (X : ℕ → M) [H : converges_seq X] : + (X ⟶ limit_seq X in ℕ) := +some_spec H + +proposition converges_to_seq_unique {X : ℕ → M} {y₁ y₂ : M} + (H₁ : X ⟶ y₁ in ℕ) (H₂ : X ⟶ y₂ in ℕ) : y₁ = y₂ := +eq_of_forall_dist_le + (take ε, suppose ε > 0, + have e2pos : ε / 2 > 0, from div_pos_of_pos_of_pos `ε > 0` two_pos, + obtain N₁ (HN₁ : ∀ {n}, n ≥ N₁ → dist (X n) y₁ < ε / 2), from H₁ e2pos, + obtain N₂ (HN₂ : ∀ {n}, n ≥ N₂ → dist (X n) y₂ < ε / 2), from H₂ e2pos, + let N := max N₁ N₂ in + have dN₁ : dist (X N) y₁ < ε / 2, from HN₁ !le_max_left, + have dN₂ : dist (X N) y₂ < ε / 2, from HN₂ !le_max_right, + have dist y₁ y₂ < ε, from calc + dist y₁ y₂ ≤ dist y₁ (X N) + dist (X N) y₂ : dist_triangle + ... = dist (X N) y₁ + dist (X N) y₂ : dist_comm + ... < ε / 2 + ε / 2 : add_lt_add dN₁ dN₂ + ... = ε : add_halves, + show dist y₁ y₂ ≤ ε, from le_of_lt this) + +proposition eq_limit_of_converges_to_seq {X : ℕ → M} {y : M} (H : X ⟶ y in ℕ) : + y = @limit_seq M _ X (exists.intro y H) := +converges_to_seq_unique H (@converges_to_limit_seq M _ X (exists.intro y H)) + +proposition converges_to_seq_constant (y : M) : (λn, y) ⟶ y in ℕ := +take ε, assume egt0 : ε > 0, +exists.intro 0 + (take n, suppose n ≥ 0, + calc + dist y y = 0 : !dist_self + ... < ε : egt0) + +proposition converges_to_seq_offset {X : ℕ → M} {y : M} (k : ℕ) (H : X ⟶ y in ℕ) : + (λ n, X (n + k)) ⟶ y in ℕ := +take ε, suppose ε > 0, +obtain N HN, from H `ε > 0`, +exists.intro N + (take n : ℕ, assume ngtN : n ≥ N, + show dist (X (n + k)) y < ε, from HN (n + k) (le.trans ngtN !le_add_right)) + +proposition converges_to_seq_offset_left {X : ℕ → M} {y : M} (k : ℕ) (H : X ⟶ y in ℕ) : + (λ n, X (k + n)) ⟶ y in ℕ := +have aux : (λ n, X (k + n)) = (λ n, X (n + k)), from funext (take n, by rewrite add.comm), +by rewrite aux; exact converges_to_seq_offset k H + +proposition converges_to_seq_offset_succ {X : ℕ → M} {y : M} (H : X ⟶ y in ℕ) : + (λ n, X (succ n)) ⟶ y in ℕ := +converges_to_seq_offset 1 H + +proposition converges_to_seq_of_converges_to_seq_offset + {X : ℕ → M} {y : M} {k : ℕ} (H : (λ n, X (n + k)) ⟶ y in ℕ) : + X ⟶ y in ℕ := +take ε, suppose ε > 0, +obtain N HN, from H `ε > 0`, +exists.intro (N + k) + (take n : ℕ, assume nge : n ≥ N + k, + have n - k ≥ N, from nat.le_sub_of_add_le nge, + have dist (X (n - k + k)) y < ε, from HN (n - k) this, + show dist (X n) y < ε, + by rewrite [(nat.sub_add_cancel (le.trans !le_add_left nge)) at this]; exact this) + +proposition converges_to_seq_of_converges_to_seq_offset_left + {X : ℕ → M} {y : M} {k : ℕ} (H : (λ n, X (k + n)) ⟶ y in ℕ) : + X ⟶ y in ℕ := +have aux : (λ n, X (k + n)) = (λ n, X (n + k)), from funext (take n, by rewrite add.comm), +by rewrite aux at H; exact converges_to_seq_of_converges_to_seq_offset H + +proposition converges_to_seq_of_converges_to_seq_offset_succ + {X : ℕ → M} {y : M} (H : (λ n, X (succ n)) ⟶ y in ℕ) : + X ⟶ y in ℕ := +@converges_to_seq_of_converges_to_seq_offset M _ X y 1 H + +proposition converges_to_seq_offset_iff (X : ℕ → M) (y : M) (k : ℕ) : + ((λ n, X (n + k)) ⟶ y in ℕ) ↔ (X ⟶ y in ℕ) := +iff.intro converges_to_seq_of_converges_to_seq_offset !converges_to_seq_offset + +proposition converges_to_seq_offset_left_iff (X : ℕ → M) (y : M) (k : ℕ) : + ((λ n, X (k + n)) ⟶ y in ℕ) ↔ (X ⟶ y in ℕ) := +iff.intro converges_to_seq_of_converges_to_seq_offset_left !converges_to_seq_offset_left + +proposition converges_to_seq_offset_succ_iff (X : ℕ → M) (y : M) : + ((λ n, X (succ n)) ⟶ y in ℕ) ↔ (X ⟶ y in ℕ) := +iff.intro converges_to_seq_of_converges_to_seq_offset_succ !converges_to_seq_offset_succ + +section +open list +definition r_trans : transitive (@le ℝ _) := λ a b c, !le.trans +definition r_refl : reflexive (@le ℝ _) := λ a, !le.refl + +theorem dec_prf_eq (P : Prop) (H1 H2 : decidable P) : H1 = H2 := + begin + induction H1, + induction H2, + reflexivity, + apply absurd a a_1, + induction H2, + apply absurd a_1 a, + reflexivity + end + +-- there's a very ugly part of this proof. + +proposition bounded_of_converges_seq {X : ℕ → M} {x : M} (H : X ⟶ x in ℕ) : + ∃ K : ℝ, ∀ n : ℕ, dist (X n) x ≤ K := + begin + cases H zero_lt_one with N HN, + cases em (N = 0), + existsi 1, + intro n, + apply le_of_lt, + apply HN, + rewrite a, + apply zero_le, + let l := map (λ n : ℕ, -dist (X n) x) (upto N), + have Hnenil : l ≠ nil, from (map_ne_nil_of_ne_nil _ (upto_ne_nil_of_ne_zero a)), + existsi max (-list.min (λ a b : ℝ, le a b) l Hnenil) 1, + intro n, + have Hsmn : ∀ m : ℕ, m < N → dist (X m) x ≤ max (-list.min (λ a b : ℝ, le a b) l Hnenil) 1, begin + intro m Hm, + apply le.trans, + rotate 1, + apply le_max_left, + note Hall := min_lemma real.le_total r_trans r_refl Hnenil, + have Hmem : -dist (X m) x ∈ (map (λ (n : ℕ), -dist (X n) x) (upto N)), from mem_map _ (mem_upto_of_lt Hm), + note Hallm' := of_mem_of_all Hmem Hall, + apply le_neg_of_le_neg, + esimp, esimp at Hallm', +/- + have Heqs : (λ (a b : real), classical.prop_decidable (@le.{1} real real.real_has_le a b)) + = + (@decidable_le.{1} real + (@decidable_linear_ordered_comm_group.to_decidable_linear_order.{1} real + (@decidable_linear_ordered_comm_ring.to_decidable_linear_ordered_comm_group.{1} real + (@discrete_linear_ordered_field.to_decidable_linear_ordered_comm_ring.{1} real + real.discrete_linear_ordered_field)))), + begin + apply funext, intro, apply funext, intro, + apply dec_prf_eq + end, + rewrite -Heqs, +-/ + exact Hallm' + end, + cases em (n < N) with Elt Ege, + apply Hsmn, + exact Elt, + apply le_of_lt, + apply lt_of_lt_of_le, + apply HN, + apply le_of_not_gt Ege, + apply le_max_right + end +end + +/- cauchy sequences -/ + +definition cauchy (X : ℕ → M) : Prop := +∀ ε : ℝ, ε > 0 → ∃ N, ∀ m n, m ≥ N → n ≥ N → dist (X m) (X n) < ε + +proposition cauchy_of_converges_seq (X : ℕ → M) [H : converges_seq X] : cauchy X := +take ε, suppose ε > 0, + obtain y (Hy : converges_to_seq X y), from H, + have e2pos : ε / 2 > 0, from div_pos_of_pos_of_pos `ε > 0` two_pos, + obtain N₁ (HN₁ : ∀ {n}, n ≥ N₁ → dist (X n) y < ε / 2), from Hy e2pos, + obtain N₂ (HN₂ : ∀ {n}, n ≥ N₂ → dist (X n) y < ε / 2), from Hy e2pos, + let N := max N₁ N₂ in + exists.intro N + (take m n, suppose m ≥ N, suppose n ≥ N, + have m ≥ N₁, from le.trans !le_max_left `m ≥ N`, + have n ≥ N₂, from le.trans !le_max_right `n ≥ N`, + have dN₁ : dist (X m) y < ε / 2, from HN₁ `m ≥ N₁`, + have dN₂ : dist (X n) y < ε / 2, from HN₂ `n ≥ N₂`, + show dist (X m) (X n) < ε, from calc + dist (X m) (X n) ≤ dist (X m) y + dist y (X n) : dist_triangle + ... = dist (X m) y + dist (X n) y : dist_comm + ... < ε / 2 + ε / 2 : add_lt_add dN₁ dN₂ + ... = ε : add_halves) + +end metric_space_M + +/- convergence of a function at a point -/ + +section metric_space_M_N +variables {M N : Type} [strucM : metric_space M] [strucN : metric_space N] +include strucM strucN + +definition converges_to_at (f : M → N) (y : N) (x : M) := +∀ ⦃ε⦄, ε > 0 → ∃ δ, δ > 0 ∧ ∀ ⦃x'⦄, x' ≠ x ∧ dist x' x < δ → dist (f x') y < ε + +notation f `⟶` y `at` x := converges_to_at f y x + +attribute [class] +definition converges_at (f : M → N) (x : M) := +∃ y, converges_to_at f y x + +noncomputable definition limit_at (f : M → N) (x : M) [H : converges_at f x] : N := +some H + +proposition converges_to_limit_at (f : M → N) (x : M) [H : converges_at f x] : + (f ⟶ limit_at f x at x) := +some_spec H + +section +omit strucN +-- set_option pp.coercions true +--set_option pp.all true + +open pnat rat + +section +omit strucM + +private lemma of_rat_rat_of_pnat_eq_of_nat_nat_of_pnat (p : pnat) : + of_rat (rat_of_pnat p) = of_nat (nat_of_pnat p) := + rfl + +end + +theorem cnv_real_of_cnv_nat {X : ℕ → M} {c : M} (H : ∀ n : ℕ, dist (X n) c < 1 / (real.of_nat n + 1)) : + ∀ ε : ℝ, ε > 0 → ∃ N : ℕ, ∀ n : ℕ, n ≥ N → dist (X n) c < ε := + begin + intros ε Hε, + cases ex_rat_pos_lower_bound_of_pos Hε with q Hq, + cases Hq with Hq1 Hq2, + cases pnat_bound Hq1 with p Hp, + existsi nat_of_pnat p, + intros n Hn, + apply lt_of_lt_of_le, + apply H, + apply le.trans, + rotate 1, + apply Hq2, + have Hrat : of_rat (inv p) ≤ of_rat q, from of_rat_le_of_rat_of_le Hp, + apply le.trans, + rotate 1, + exact Hrat, + change 1 / (of_nat n + 1) ≤ of_rat ((1 : ℚ) / (rat_of_pnat p)), + rewrite [of_rat_divide, of_rat_one], + eapply one_div_le_one_div_of_le, + krewrite -of_rat_zero, + apply of_rat_lt_of_rat_of_lt, + apply rat_of_pnat_is_pos, + krewrite [of_rat_rat_of_pnat_eq_of_nat_nat_of_pnat, -real.of_nat_add], + apply real.of_nat_le_of_nat_of_le, + apply le_add_of_le_right, + assumption + end +end + +theorem all_conv_seqs_of_converges_to_at {f : M → N} {c : M} {l : N} (Hconv : f ⟶ l at c) : + ∀ X : ℕ → M, ((∀ n : ℕ, ((X n) ≠ c) ∧ (X ⟶ c in ℕ)) → ((λ n : ℕ, f (X n)) ⟶ l in ℕ)) := + begin + intros X HX, + rewrite [↑converges_to_at at Hconv, ↑converges_to_seq], + intros ε Hε, + cases Hconv Hε with δ Hδ, + cases Hδ with Hδ1 Hδ2, + cases HX 0 with _ HXlim, + cases HXlim Hδ1 with N1 HN1, + existsi N1, + intro n Hn, + apply Hδ2, + split, + apply and.left (HX _), + exact HN1 Hn + end + +theorem converges_to_at_of_all_conv_seqs {f : M → N} (c : M) (l : N) + (Hseq : ∀ X : ℕ → M, ((∀ n : ℕ, ((X n) ≠ c) ∧ (X ⟶ c in ℕ)) → ((λ n : ℕ, f (X n)) ⟶ l in ℕ))) + : f ⟶ l at c := + by_contradiction + (assume Hnot : ¬ (f ⟶ l at c), + obtain ε Hε, from exists_not_of_not_forall Hnot, + let Hε' := and_not_of_not_implies Hε in + obtain (H1 : ε > 0) H2, from Hε', + have H3 : ∀ δ : ℝ, (δ > 0 → ∃ x' : M, x' ≠ c ∧ dist x' c < δ ∧ dist (f x') l ≥ ε), begin -- tedious!! + intros δ Hδ, + note Hε'' := forall_not_of_not_exists H2, + note H4 := forall_not_of_not_exists H2 δ, + have ¬ (∀ x' : M, x' ≠ c ∧ dist x' c < δ → dist (f x') l < ε), from λ H', H4 (and.intro Hδ H'), + note H5 := exists_not_of_not_forall this, + cases H5 with x' Hx', + existsi x', + note H6 := and_not_of_not_implies Hx', + rewrite and.assoc at H6, + cases H6, + split, + assumption, + cases a_1, + split, + assumption, + apply le_of_not_gt, + assumption + end, + let S : ℕ → M → Prop := λ n x, 0 < dist x c ∧ dist x c < 1 / (of_nat n + 1) ∧ dist (f x) l ≥ ε in + have HS : ∀ n : ℕ, ∃ m : M, S n m, begin + intro k, + have Hpos : 0 < of_nat k + 1, from of_nat_succ_pos k, + cases H3 (1 / (k + 1)) (one_div_pos_of_pos Hpos) with x' Hx', + cases Hx' with Hne Hx', + cases Hx' with Hdistl Hdistg, + existsi x', + esimp, + split, + apply dist_pos_of_ne, + assumption, + split, + repeat assumption + end, + let X : ℕ → M := λ n, some (HS n) in + have H4 : ∀ n : ℕ, ((X n) ≠ c) ∧ (X ⟶ c in ℕ), from + (take n, and.intro + (begin + note Hspec := some_spec (HS n), + esimp, esimp at Hspec, + cases Hspec, + apply ne_of_dist_pos, + assumption + end) + (begin + apply cnv_real_of_cnv_nat, + intro m, + note Hspec := some_spec (HS m), + esimp, esimp at Hspec, + cases Hspec with Hspec1 Hspec2, + cases Hspec2, + assumption + end)), + have H5 : (λ n : ℕ, f (X n)) ⟶ l in ℕ, from Hseq X H4, + begin + note H6 := H5 H1, + cases H6 with Q HQ, + note HQ' := HQ !le.refl, + esimp at HQ', + apply absurd HQ', + apply not_lt_of_ge, + note H7 := some_spec (HS Q), + esimp at H7, + cases H7 with H71 H72, + cases H72, + assumption + end) + + +end metric_space_M_N + +section topology +/- A metric space is a topological space. -/ + +open set prod topology + +variables {V : Type} [Vmet : metric_space V] +include Vmet + +definition open_ball (x : V) (ε : ℝ) := {y ∈ univ | dist x y < ε} + +theorem open_ball_empty_of_nonpos (x : V) {ε : ℝ} (Hε : ε ≤ 0) : open_ball x ε = ∅ := + begin + apply eq_empty_of_forall_not_mem, + intro y Hy, + note Hlt := and.right Hy, + apply not_lt_of_ge (dist_nonneg x y), + apply lt_of_lt_of_le Hlt Hε + end + +theorem radius_pos_of_nonempty {x : V} {ε : ℝ} {u : V} (Hu : u ∈ open_ball x ε) : ε > 0 := + begin + apply lt_of_not_ge, + intro Hge, + note Hop := open_ball_empty_of_nonpos x Hge, + rewrite Hop at Hu, + apply not_mem_empty _ Hu + end + +theorem mem_open_ball (x : V) {ε : ℝ} (H : ε > 0) : x ∈ open_ball x ε := + suffices x ∈ univ ∧ dist x x < ε, from this, + and.intro !mem_univ (by rewrite dist_self; assumption) + +definition closed_ball (x : V) (ε : ℝ) := {y ∈ univ | dist x y ≤ ε} + +theorem closed_ball_eq_compl (x : V) (ε : ℝ) : closed_ball x ε = -{y ∈ univ | dist x y > ε} := + begin + apply ext, + intro y, + apply iff.intro, + intro Hx, + apply mem_compl, + intro Hxmem, + cases Hxmem with _ Hgt, + cases Hx with _ Hle, + apply not_le_of_gt Hgt Hle, + intro Hx, + note Hx' := not_mem_of_mem_compl Hx, + split, + apply mem_univ, + apply le_of_not_gt, + intro Hgt, + apply Hx', + split, + apply mem_univ, + assumption + end + +omit Vmet + +definition open_sets_basis (V : Type) [metric_space V] := + image (λ pair : V × ℝ, open_ball (pr1 pair) (pr2 pair)) univ + +attribute [instance] +definition metric_topology (V : Type) [metric_space V] : topology V := + topology.generated_by (open_sets_basis V) + +include Vmet + +theorem open_ball_mem_open_sets_basis (x : V) (ε : ℝ) : (open_ball x ε) ∈ (open_sets_basis V) := + mem_image !mem_univ rfl + +theorem open_ball_open (x : V) (ε : ℝ) : Open (open_ball x ε) := + by apply generators_mem_topology_generated_by; apply open_ball_mem_open_sets_basis + +theorem closed_ball_closed (x : V) {ε : ℝ} (H : ε > 0) : closed (closed_ball x ε) := + begin + apply iff.mpr !closed_iff_Open_compl, + rewrite closed_ball_eq_compl, + rewrite compl_compl, + apply Open_of_forall_exists_Open_nbhd, + intro y Hy, + cases Hy with _ Hxy, + existsi open_ball y (dist x y - ε), + split, + apply open_ball_open, + split, + apply mem_open_ball, + apply sub_pos_of_lt Hxy, + intros y' Hy', + cases Hy' with _ Hxy'd, + rewrite dist_comm at Hxy'd, + split, + apply mem_univ, + apply lt_of_not_ge, + intro Hxy', + apply not_lt_self (dist x y), + exact calc + dist x y ≤ dist x y' + dist y' y : dist_triangle + ... ≤ ε + dist y' y : add_le_add_right Hxy' + ... < ε + (dist x y - ε) : add_lt_add_left Hxy'd + ... = dist x y : by rewrite [add.comm, sub_add_cancel] + end + +private theorem not_mem_open_basis_of_boundary_pt {s : set V} (a : s ∈ open_sets_basis V) {x : V} + (Hbd : ∀ ε : ℝ, ε > 0 → ∃ v : V, v ∉ s ∧ dist x v < ε) : ¬ x ∈ s := + begin + intro HxU, + cases a with pr Hpr, + cases pr with y r, + cases Hpr with _ Hs, + rewrite -Hs at HxU, + have H : dist y x < r, from and.right HxU, + cases Hbd _ (sub_pos_of_lt H) with v Hv, + cases Hv with Hv Hvdist, + apply Hv, + rewrite -Hs, + apply and.intro, + apply mem_univ, + apply lt_of_le_of_lt, + apply dist_triangle, + exact x, + esimp, + exact calc + dist y x + dist x v < dist y x + (r - dist y x) : add_lt_add_left Hvdist + ... = r : by rewrite [add.comm, sub_add_cancel] + end + +private theorem not_mem_intersect_of_boundary_pt {s t : set V} (a : Open s) (a_1 : Open t) {x : V} + (v_0 : (x ∈ s → ¬ (∀ (ε : ℝ), ε > 0 → (∃ (v : V), v ∉ s ∧ dist x v < ε)))) + (v_1 : (x ∈ t → ¬ (∀ (ε : ℝ), ε > 0 → (∃ (v : V), v ∉ t ∧ dist x v < ε)))) + (Hbd : ∀ (ε : ℝ), ε > 0 → (∃ (v : V), v ∉ s ∩ t ∧ dist x v < ε)) : ¬ (x ∈ s ∩ t) := + begin + intro HxU, + have Hxs : x ∈ s, from mem_of_mem_inter_left HxU, + have Hxt : x ∈ t, from mem_of_mem_inter_right HxU, + note Hsih := exists_not_of_not_forall (v_0 Hxs), + note Htih := exists_not_of_not_forall (v_1 Hxt), + cases Hsih with ε1 Hε1, + cases Htih with ε2 Hε2, + note Hε1' := and_not_of_not_implies Hε1, + note Hε2' := and_not_of_not_implies Hε2, + cases Hε1' with Hε1p Hε1', + cases Hε2' with Hε2p Hε2', + note Hε1'' := forall_not_of_not_exists Hε1', + note Hε2'' := forall_not_of_not_exists Hε2', + have Hmin : min ε1 ε2 > 0, from lt_min Hε1p Hε2p, + cases Hbd _ Hmin with v Hv, + cases Hv with Hvint Hvdist, + note Hε1v := Hε1'' v, + note Hε2v := Hε2'' v, + cases em (v ∉ s) with Hnm Hmem, + apply Hε1v, + split, + exact Hnm, + apply lt_of_lt_of_le Hvdist, + apply min_le_left, + apply Hε2v, + have Hmem' : v ∈ s, from not_not_elim Hmem, + note Hnm := not_mem_of_mem_of_not_mem_inter_left Hmem' Hvint, + split, + exact Hnm, + apply lt_of_lt_of_le Hvdist, + apply min_le_right + end + +private theorem not_mem_sUnion_of_boundary_pt {S : set (set V)} (a : ∀₀ s ∈ S, Open s) {x : V} + (v_0 : ∀ ⦃x_1 : set V⦄, + x_1 ∈ S → x ∈ x_1 → ¬ (∀ (ε : ℝ), ε > 0 → (∃ (v : V), v ∉ x_1 ∧ dist x v < ε))) + (Hbd : ∀ (ε : ℝ), ε > 0 → (∃ (v : V), v ∉ ⋃₀ S ∧ dist x v < ε)) : ¬ x ∈ ⋃₀ S := + begin + intro HxU, + have Hex : ∃₀ s ∈ S, x ∈ s, from HxU, + cases Hex with s Hs, + cases Hs with Hs Hxs, + cases exists_not_of_not_forall (v_0 Hs Hxs) with ε Hε, + cases and_not_of_not_implies Hε with Hεp Hv, + cases Hbd _ Hεp with v Hv', + cases Hv' with Hvnm Hdist, + apply Hv, + existsi v, + split, + apply not_mem_of_not_mem_sUnion Hvnm Hs, + exact Hdist + end + + +/- + this should be doable by showing that the open-ball boundary definition + is equivalent to topology.on_boundary, and applying topology.not_open_of_on_boundary. + But the induction hypotheses don't work out nicely. +-/ + +theorem not_open_of_ex_boundary_pt {U : set V} {x : V} (HxU : x ∈ U) + (Hbd : ∀ ε : ℝ, ε > 0 → ∃ v : V, v ∉ U ∧ dist x v < ε) : ¬ Open U := + begin + intro HUopen, + induction HUopen, + {apply not_mem_open_basis_of_boundary_pt a Hbd HxU}, + {cases Hbd 1 zero_lt_one with v Hv, + cases Hv with Hv _, + exact Hv !mem_univ}, + {apply not_mem_intersect_of_boundary_pt a a_1 v_0 v_1 Hbd HxU}, + {apply not_mem_sUnion_of_boundary_pt a v_0 Hbd HxU} + end + +theorem ex_Open_ball_subset_of_Open_of_nonempty {U : set V} (HU : Open U) {x : V} (Hx : x ∈ U) : + ∃ (r : ℝ), r > 0 ∧ open_ball x r ⊆ U := + begin + let balloon := {r ∈ univ | r > 0 ∧ open_ball x r ⊆ U}, + cases em (balloon = ∅), + have H : ∀ r : ℝ, r > 0 → ∃ v : V, v ∉ U ∧ dist x v < r, begin + intro r Hr, + note Hor := not_or_not_of_not_and (forall_not_of_sep_empty a (mem_univ r)), + note Hor' := or.neg_resolve_left Hor Hr, + apply exists_of_not_forall_not, + intro Hall, + apply Hor', + intro y Hy, + cases not_or_not_of_not_and (Hall y) with Hmem Hge, + apply not_not_elim Hmem, + apply absurd (and.right Hy) Hge + end, + apply absurd HU, + apply not_open_of_ex_boundary_pt Hx H, + cases exists_mem_of_ne_empty a with r Hr, + cases Hr with _ Hr, + cases Hr with Hrpos HxrU, + existsi r, + split, + repeat assumption + end + +end topology + +section continuity +variables {M N : Type} [Hm : metric_space M] [Hn : metric_space N] +include Hm Hn +open topology set +/- continuity at a point -/ + +-- the ε - δ definition of continuity is equivalent to the topological definition +theorem continuous_at_intro {f : M → N} {x : M} + (H : ∀ ⦃ε⦄, ε > 0 → ∃ δ, δ > 0 ∧ ∀ ⦃x'⦄, dist x' x < δ → dist (f x') (f x) < ε) : + continuous_at f x := + begin + rewrite ↑continuous_at, + intros U HfU Uopen, + cases ex_Open_ball_subset_of_Open_of_nonempty Uopen HfU with r Hr, + cases Hr with Hr HUr, + cases H Hr with δ Hδ, + cases Hδ with Hδ Hx'δ, + existsi open_ball x δ, + split, + apply mem_open_ball, + exact Hδ, + split, + apply open_ball_open, + intro y Hy, + apply HUr, + cases Hy with y' Hy', + cases Hy' with Hy' Hfy', + cases Hy' with _ Hy', + rewrite dist_comm at Hy', + note Hy'' := Hx'δ Hy', + apply and.intro !mem_univ, + rewrite [-Hfy', dist_comm], + exact Hy'' + end + +theorem continuous_at_elim {f : M → N} {x : M} (Hfx : continuous_at f x) : + ∀ ⦃ε⦄, ε > 0 → ∃ δ, δ > 0 ∧ ∀ ⦃x'⦄, dist x' x < δ → dist (f x') (f x) < ε := + begin + intros ε Hε, + rewrite [↑continuous_at at Hfx], + cases Hfx (open_ball (f x) ε) (mem_open_ball _ Hε) !open_ball_open with V HV, + cases HV with HVx HV, + cases HV with HV HVf, + cases ex_Open_ball_subset_of_Open_of_nonempty HV HVx with δ Hδ, + cases Hδ with Hδ Hδx, + existsi δ, + split, + exact Hδ, + intro x' Hx', + rewrite dist_comm, + apply and.right, + apply HVf, + existsi x', + split, + apply Hδx, + apply and.intro !mem_univ, + rewrite dist_comm, + apply Hx', + apply rfl + end + +theorem continuous_at_of_converges_to_at {f : M → N} {x : M} (Hf : f ⟶ f x at x) : + continuous_at f x := +continuous_at_intro +(take ε, suppose ε > 0, +obtain δ Hδ, from Hf this, +exists.intro δ (and.intro + (and.left Hδ) + (take x', suppose dist x' x < δ, + if Heq : x' = x then + by rewrite [-Heq, dist_self]; assumption + else + (suffices dist x' x < δ, from and.right Hδ x' (and.intro Heq this), + this)))) + +theorem converges_to_at_of_continuous_at {f : M → N} {x : M} (Hf : continuous_at f x) : + f ⟶ f x at x := +take ε, suppose ε > 0, +obtain δ Hδ, from continuous_at_elim Hf this, +exists.intro δ (and.intro + (and.left Hδ) + (take x', + assume H : x' ≠ x ∧ dist x' x < δ, + show dist (f x') (f x) < ε, from and.right Hδ x' (and.right H))) + + +definition continuous (f : M → N) : Prop := ∀ x, continuous_at f x + +attribute [instance] +theorem converges_seq_comp_of_converges_seq_of_cts (X : ℕ → M) [HX : converges_seq X] {f : M → N} + (Hf : continuous f) : + converges_seq (λ n, f (X n)) := + begin + cases HX with xlim Hxlim, + existsi f xlim, + rewrite ↑converges_to_seq at *, + intros ε Hε, + let Hcont := (continuous_at_elim (Hf xlim)) Hε, + cases Hcont with δ Hδ, + cases Hxlim (and.left Hδ) with B HB, + existsi B, + intro n Hn, + apply and.right Hδ, + apply HB Hn + end + +omit Hn +theorem id_continuous : continuous (λ x : M, x) := + begin + intros x, + apply continuous_at_intro, + intro ε Hε, + existsi ε, + split, + assumption, + intros, + assumption + end + +end continuity + +end analysis + +/- complete metric spaces -/ + +structure complete_metric_space [class] (M : Type) extends metricM : metric_space M : Type := +(complete : ∀ X, @analysis.cauchy M metricM X → @analysis.converges_seq M metricM X) + +namespace analysis + +proposition complete (M : Type) [cmM : complete_metric_space M] {X : ℕ → M} (H : cauchy X) : + converges_seq X := +complete_metric_space.complete X H + +end analysis + +/- the reals form a metric space -/ + +attribute [instance] +noncomputable definition metric_space_real : metric_space ℝ := +⦃ metric_space, + dist := λ x y, abs (x - y), + dist_self := λ x, abstract by rewrite [sub_self, abs_zero] end, + eq_of_dist_eq_zero := λ x y, eq_of_abs_sub_eq_zero, + dist_comm := abs_sub, + dist_triangle := abs_sub_le +⦄ diff --git a/old_library/theories/analysis/normed_space.lean b/old_library/theories/analysis/normed_space.lean new file mode 100644 index 0000000000..40eccfb6be --- /dev/null +++ b/old_library/theories/analysis/normed_space.lean @@ -0,0 +1,240 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Normed spaces. +-/ +import algebra.module .metric_space +open real nat classical +noncomputable theory + +structure has_norm [class] (M : Type) : Type := +(norm : M → ℝ) + +namespace analysis + definition norm {M : Type} [has_normM : has_norm M] (v : M) : ℝ := has_norm.norm v + + notation `∥`v`∥` := norm v +end analysis + +/- real vector spaces -/ +-- where is the right place to put this? +structure real_vector_space [class] (V : Type) extends vector_space ℝ V + +section + variables {V : Type} [real_vector_space V] + + -- these specializations help the elaborator when it is hard to infer the ring, e.g. with numerals + + proposition smul_left_distrib_real (a : ℝ) (u v : V) : a • (u + v) = a • u + a • v := + smul_left_distrib a u v + + proposition smul_right_distrib_real (a b : ℝ) (u : V) : (a + b) • u = a • u + b • u := + smul_right_distrib a b u + + proposition mul_smul_real (a : ℝ) (b : ℝ) (u : V) : (a * b) • u = a • (b • u) := + mul_smul a b u + + proposition one_smul_real (u : V) : (1 : ℝ) • u = u := one_smul u + + proposition zero_smul_real (u : V) : (0 : ℝ) • u = 0 := zero_smul u + + proposition smul_zero_real (a : ℝ) : a • (0 : V) = 0 := smul_zero a + + proposition neg_smul_real (a : ℝ) (u : V) : (-a) • u = - (a • u) := neg_smul a u + + proposition neg_one_smul_real (u : V) : -(1 : ℝ) • u = -u := neg_one_smul u + + proposition smul_neg_real (a : ℝ) (u : V) : a • (-u) = -(a • u) := smul_neg a u +end + +/- real normed vector spaces -/ + +structure normed_vector_space [class] (V : Type) extends real_vector_space V, has_norm V := +(norm_zero : norm zero = 0) +(eq_zero_of_norm_eq_zero : ∀ u : V, norm u = 0 → u = zero) +(norm_triangle : ∀ u v, norm (add u v) ≤ norm u + norm v) +(norm_smul : ∀ (a : ℝ) (v : V), norm (smul a v) = abs a * norm v) + +namespace analysis + variable {V : Type} + variable [normed_vector_space V] + + proposition norm_zero : ∥ (0 : V) ∥ = 0 := !normed_vector_space.norm_zero + + proposition eq_zero_of_norm_eq_zero {u : V} (H : ∥ u ∥ = 0) : u = 0 := + !normed_vector_space.eq_zero_of_norm_eq_zero H + + proposition norm_triangle (u v : V) : ∥ u + v ∥ ≤ ∥ u ∥ + ∥ v ∥ := + !normed_vector_space.norm_triangle + + proposition norm_smul (a : ℝ) (v : V) : ∥ a • v ∥ = abs a * ∥ v ∥ := + !normed_vector_space.norm_smul + + proposition norm_neg (v : V) : ∥ -v ∥ = ∥ v ∥ := + have abs (1 : ℝ) = 1, from abs_of_nonneg zero_le_one, + by rewrite [-@neg_one_smul ℝ V, norm_smul, abs_neg, this, one_mul] + + proposition norm_sub (u v : V) : ∥u - v∥ = ∥v - u∥ := + by rewrite [-norm_neg, neg_sub] + +end analysis + +section + open analysis + variable {V : Type} + variable [normed_vector_space V] + + attribute [reducible] + private definition nvs_dist (u v : V) := ∥ u - v ∥ + + private lemma nvs_dist_self (u : V) : nvs_dist u u = 0 := + by rewrite [↑nvs_dist, sub_self, norm_zero] + + private lemma eq_of_nvs_dist_eq_zero (u v : V) (H : nvs_dist u v = 0) : u = v := + have u - v = 0, from eq_zero_of_norm_eq_zero H, + eq_of_sub_eq_zero this + + private lemma nvs_dist_triangle (u v w : V) : nvs_dist u w ≤ nvs_dist u v + nvs_dist v w := + calc + nvs_dist u w = ∥ (u - v) + (v - w) ∥ : by rewrite [↑nvs_dist, *sub_eq_add_neg, add.assoc, + neg_add_cancel_left] + ... ≤ ∥ u - v ∥ + ∥ v - w ∥ : norm_triangle + private lemma nvs_dist_comm (u v : V) : nvs_dist u v = nvs_dist v u := + by rewrite [↑nvs_dist, -norm_neg, neg_sub] + + attribute [trans_instance] + definition normed_vector_space_to_metric_space + (V : Type) [nvsV : normed_vector_space V] : + metric_space V := + ⦃ metric_space, + dist := nvs_dist, + dist_self := nvs_dist_self, + eq_of_dist_eq_zero := eq_of_nvs_dist_eq_zero, + dist_comm := nvs_dist_comm, + dist_triangle := nvs_dist_triangle + ⦄ + + open nat + + proposition converges_to_seq_norm_elim {X : ℕ → V} {x : V} (H : X ⟶ x in ℕ) : + ∀ {ε : ℝ}, ε > 0 → ∃ N₁ : ℕ, ∀ {n : ℕ}, n ≥ N₁ → ∥ X n - x ∥ < ε := H + + proposition dist_eq_norm_sub (u v : V) : dist u v = ∥ u - v ∥ := rfl + + proposition norm_eq_dist_zero (u : V) : ∥ u ∥ = dist u 0 := + by rewrite [dist_eq_norm_sub, sub_zero] + + proposition norm_nonneg (u : V) : ∥ u ∥ ≥ 0 := + by rewrite norm_eq_dist_zero; apply !dist_nonneg +end + +structure banach_space [class] (V : Type) extends nvsV : normed_vector_space V := +(complete : ∀ X, @analysis.cauchy V (@normed_vector_space_to_metric_space V nvsV) X → + @analysis.converges_seq V (@normed_vector_space_to_metric_space V nvsV) X) + +attribute [trans_instance] +definition banach_space_to_metric_space (V : Type) [bsV : banach_space V] : + complete_metric_space V := +⦃ complete_metric_space, normed_vector_space_to_metric_space V, + complete := banach_space.complete +⦄ + +namespace analysis +variable {V : Type} +variable [normed_vector_space V] + +variables {X Y : ℕ → V} +variables {x y : V} + +proposition add_converges_to_seq (HX : X ⟶ x in ℕ) (HY : Y ⟶ y in ℕ) : + (λ n, X n + Y n) ⟶ x + y in ℕ := +take ε : ℝ, suppose ε > 0, +have e2pos : ε / 2 > 0, from div_pos_of_pos_of_pos `ε > 0` two_pos, +obtain (N₁ : ℕ) (HN₁ : ∀ {n}, n ≥ N₁ → ∥ X n - x ∥ < ε / 2), + from converges_to_seq_norm_elim HX e2pos, +obtain (N₂ : ℕ) (HN₂ : ∀ {n}, n ≥ N₂ → ∥ Y n - y ∥ < ε / 2), + from converges_to_seq_norm_elim HY e2pos, +let N := max N₁ N₂ in +exists.intro N + (take n, + suppose n ≥ N, + have ngtN₁ : n ≥ N₁, from nat.le_trans !le_max_left `n ≥ N`, + have ngtN₂ : n ≥ N₂, from nat.le_trans !le_max_right `n ≥ N`, + show ∥ (X n + Y n) - (x + y) ∥ < ε, from calc + ∥ (X n + Y n) - (x + y) ∥ + = ∥ (X n - x) + (Y n - y) ∥ : by rewrite [sub_add_eq_sub_sub, *sub_eq_add_neg, + *add.assoc, add.left_comm (-x)] + ... ≤ ∥ X n - x ∥ + ∥ Y n - y ∥ : norm_triangle + ... < ε / 2 + ε / 2 : add_lt_add (HN₁ ngtN₁) (HN₂ ngtN₂) + ... = ε : add_halves) + +private lemma smul_converges_to_seq_aux {c : ℝ} (cnz : c ≠ 0) (HX : X ⟶ x in ℕ) : + (λ n, c • X n) ⟶ c • x in ℕ := +take ε : ℝ, suppose ε > 0, +have abscpos : abs c > 0, from abs_pos_of_ne_zero cnz, +have epos : ε / abs c > 0, from div_pos_of_pos_of_pos `ε > 0` abscpos, +obtain N (HN : ∀ {n}, n ≥ N → norm (X n - x) < ε / abs c), from converges_to_seq_norm_elim HX epos, +exists.intro N + (take n, + suppose n ≥ N, + have H : norm (X n - x) < ε / abs c, from HN this, + show norm (c • X n - c • x) < ε, from calc + norm (c • X n - c • x) + = abs c * norm (X n - x) : by rewrite [-smul_sub_left_distrib, norm_smul] + ... < abs c * (ε / abs c) : mul_lt_mul_of_pos_left H abscpos + ... = ε : mul_div_cancel' (ne_of_gt abscpos)) + +proposition smul_converges_to_seq (c : ℝ) (HX : X ⟶ x in ℕ) : + (λ n, c • X n) ⟶ c • x in ℕ := +by_cases + (assume cz : c = 0, + have (λ n, c • X n) = (λ n, 0), from funext (take x, by rewrite [cz, zero_smul]), + begin rewrite [this, cz, zero_smul], apply converges_to_seq_constant end) + (suppose c ≠ 0, smul_converges_to_seq_aux this HX) + +proposition neg_converges_to_seq (HX : X ⟶ x in ℕ) : + (λ n, - X n) ⟶ - x in ℕ := +take ε, suppose ε > 0, +obtain N (HN : ∀ {n}, n ≥ N → norm (X n - x) < ε), from converges_to_seq_norm_elim HX this, +exists.intro N + (take n, + suppose n ≥ N, + show norm (- X n - (- x)) < ε, + by rewrite [-neg_neg_sub_neg, *neg_neg, norm_neg]; exact HN `n ≥ N`) + +proposition neg_converges_to_seq_iff : ((λ n, - X n) ⟶ - x in ℕ) ↔ (X ⟶ x in ℕ) := +have aux : X = λ n, (- (- X n)), from funext (take n, by rewrite neg_neg), +iff.intro + (assume H : (λ n, -X n)⟶ -x in ℕ, + show X ⟶ x in ℕ, by rewrite [aux, -neg_neg x]; exact neg_converges_to_seq H) + neg_converges_to_seq + +proposition norm_converges_to_seq_zero (HX : X ⟶ 0 in ℕ) : (λ n, norm (X n)) ⟶ 0 in ℕ := +take ε, suppose ε > 0, +obtain N (HN : ∀ n, n ≥ N → norm (X n - 0) < ε), from HX `ε > 0`, +exists.intro N + (take n, assume Hn : n ≥ N, + have norm (X n) < ε, begin rewrite -(sub_zero (X n)), apply HN n Hn end, + show abs (norm (X n) - 0) < ε, + by rewrite [sub_zero, abs_of_nonneg !norm_nonneg]; apply this) + +proposition converges_to_seq_zero_of_norm_converges_to_seq_zero + (HX : (λ n, norm (X n)) ⟶ 0 in ℕ) : + X ⟶ 0 in ℕ := +take ε, suppose ε > 0, +obtain N (HN : ∀ n, n ≥ N → abs (norm (X n) - 0) < ε), from HX `ε > 0`, +exists.intro (N : ℕ) + (take n : ℕ, assume Hn : n ≥ N, + have HN' : abs (norm (X n) - 0) < ε, from HN n Hn, + have norm (X n) < ε, + by rewrite [sub_zero at HN', abs_of_nonneg !norm_nonneg at HN']; apply HN', + show norm (X n - 0) < ε, + by rewrite sub_zero; apply this) + +proposition norm_converges_to_seq_zero_iff (X : ℕ → V) : + ((λ n, norm (X n)) ⟶ 0 in ℕ) ↔ (X ⟶ 0 in ℕ) := +iff.intro converges_to_seq_zero_of_norm_converges_to_seq_zero norm_converges_to_seq_zero + +end analysis diff --git a/old_library/theories/analysis/real_limit.lean b/old_library/theories/analysis/real_limit.lean new file mode 100644 index 0000000000..b97c1969dc --- /dev/null +++ b/old_library/theories/analysis/real_limit.lean @@ -0,0 +1,590 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad, Robert Y. Lewis + +Instantiates the reals as a Banach space. +-/ +import .metric_space data.real.complete data.set .normed_space +open real classical analysis nat +noncomputable theory + +/- sup and inf -/ + +-- Expresses completeness, sup, and inf in a manner that is less constructive, but more convenient, +-- than the way it is done in data.real.complete. + +-- Issue: real.sup and real.inf conflict with sup and inf in lattice. +-- Perhaps put algebra sup and inf into a namespace? + +namespace real +open set + +private definition exists_is_sup {X : set ℝ} (H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → x ≤ b)) : + ∃ y, is_sup X y := +let x := some (and.left H), b := some (and.right H) in + exists_is_sup_of_inh_of_bdd X x (some_spec (and.left H)) b (some_spec (and.right H)) + +private definition sup_aux {X : set ℝ} (H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → x ≤ b)) := +some (exists_is_sup H) + +private definition sup_aux_spec {X : set ℝ} (H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → x ≤ b)) : + is_sup X (sup_aux H) := +some_spec (exists_is_sup H) + +definition sup (X : set ℝ) : ℝ := +if H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → x ≤ b) then sup_aux H else 0 + +proposition le_sup {x : ℝ} {X : set ℝ} (Hx : x ∈ X) {b : ℝ} (Hb : ∀ x, x ∈ X → x ≤ b) : + x ≤ sup X := +have H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → x ≤ b), + from and.intro (exists.intro x Hx) (exists.intro b Hb), +by rewrite [↑sup, dif_pos H]; exact and.left (sup_aux_spec H) x Hx + +proposition sup_le {X : set ℝ} (HX : ∃ x, x ∈ X) {b : ℝ} (Hb : ∀ x, x ∈ X → x ≤ b) : + sup X ≤ b := +have H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → x ≤ b), + from and.intro HX (exists.intro b Hb), +by rewrite [↑sup, dif_pos H]; exact and.right (sup_aux_spec H) b Hb + +proposition exists_mem_and_lt_of_lt_sup {X : set ℝ} (HX : ∃ x, x ∈ X) {b : ℝ} (Hb : b < sup X) : +∃ x, x ∈ X ∧ b < x := +have ¬ ∀ x, x ∈ X → x ≤ b, from assume H, not_le_of_gt Hb (sup_le HX H), +obtain x (Hx : ¬ (x ∈ X → x ≤ b)), from exists_not_of_not_forall this, +exists.intro x + (have x ∈ X ∧ ¬ x ≤ b, by rewrite [-not_implies_iff_and_not]; apply Hx, + and.intro (and.left this) (lt_of_not_ge (and.right this))) + +private definition exists_is_inf {X : set ℝ} (H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → b ≤ x)) : + ∃ y, is_inf X y := +let x := some (and.left H), b := some (and.right H) in + exists_is_inf_of_inh_of_bdd X x (some_spec (and.left H)) b (some_spec (and.right H)) + +private definition inf_aux {X : set ℝ} (H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → b ≤ x)) := +some (exists_is_inf H) + +private definition inf_aux_spec {X : set ℝ} (H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → b ≤ x)) : + is_inf X (inf_aux H) := +some_spec (exists_is_inf H) + +definition inf (X : set ℝ) : ℝ := +if H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → b ≤ x) then inf_aux H else 0 + +proposition inf_le {x : ℝ} {X : set ℝ} (Hx : x ∈ X) {b : ℝ} (Hb : ∀ x, x ∈ X → b ≤ x) : + inf X ≤ x := +have H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → b ≤ x), + from and.intro (exists.intro x Hx) (exists.intro b Hb), +by rewrite [↑inf, dif_pos H]; exact and.left (inf_aux_spec H) x Hx + +proposition le_inf {X : set ℝ} (HX : ∃ x, x ∈ X) {b : ℝ} (Hb : ∀ x, x ∈ X → b ≤ x) : + b ≤ inf X := +have H : (∃ x, x ∈ X) ∧ (∃ b, ∀ x, x ∈ X → b ≤ x), + from and.intro HX (exists.intro b Hb), +by rewrite [↑inf, dif_pos H]; exact and.right (inf_aux_spec H) b Hb + +proposition exists_mem_and_lt_of_inf_lt {X : set ℝ} (HX : ∃ x, x ∈ X) {b : ℝ} (Hb : inf X < b) : +∃ x, x ∈ X ∧ x < b := +have ¬ ∀ x, x ∈ X → b ≤ x, from assume H, not_le_of_gt Hb (le_inf HX H), +obtain x (Hx : ¬ (x ∈ X → b ≤ x)), from exists_not_of_not_forall this, +exists.intro x + (have x ∈ X ∧ ¬ b ≤ x, by rewrite [-not_implies_iff_and_not]; apply Hx, + and.intro (and.left this) (lt_of_not_ge (and.right this))) + +section +local attribute mem [reducible] +-- TODO: is there a better place to put this? +proposition image_neg_eq (X : set ℝ) : (λ x, -x) ' X = {x | -x ∈ X} := +set.ext (take x, iff.intro + (assume H, obtain y [(Hy₁ : y ∈ X) (Hy₂ : -y = x)], from H, + show -x ∈ X, by rewrite [-Hy₂, neg_neg]; exact Hy₁) + (assume H : -x ∈ X, exists.intro (-x) (and.intro H !neg_neg))) + +proposition sup_neg {X : set ℝ} (nonempty_X : ∃ x, x ∈ X) {b : ℝ} (Hb : ∀ x, x ∈ X → b ≤ x) : + sup {x | -x ∈ X} = - inf X := +let negX := {x | -x ∈ X} in +have nonempty_negX : ∃ x, x ∈ negX, from + obtain x Hx, from nonempty_X, + have -(-x) ∈ X, + by rewrite neg_neg; apply Hx, + exists.intro (-x) this, +have H₁ : ∀ x, x ∈ negX → x ≤ - inf X, from + take x, + assume H, + have inf X ≤ -x, + from inf_le H Hb, + show x ≤ - inf X, + from le_neg_of_le_neg this, +have H₂ : ∀ x, x ∈ X → -sup negX ≤ x, from + take x, + assume H, + have -(-x) ∈ X, by rewrite neg_neg; apply H, + have -x ≤ sup negX, from le_sup this H₁, + show -sup negX ≤ x, + from !neg_le_of_neg_le this, +eq_of_le_of_ge + (show sup negX ≤ - inf X, + from sup_le nonempty_negX H₁) + (show -inf X ≤ sup negX, + from !neg_le_of_neg_le (le_inf nonempty_X H₂)) + +proposition inf_neg {X : set ℝ} (nonempty_X : ∃ x, x ∈ X) {b : ℝ} (Hb : ∀ x, x ∈ X → x ≤ b) : + inf {x | -x ∈ X} = - sup X := +let negX := {x | -x ∈ X} in +have nonempty_negX : ∃ x, x ∈ negX, from + obtain x Hx, from nonempty_X, + have -(-x) ∈ X, + by rewrite neg_neg; apply Hx, + exists.intro (-x) this, +have Hb' : ∀ x, x ∈ negX → -b ≤ x, + from take x, assume H, !neg_le_of_neg_le (Hb _ H), +have HX : X = {x | -x ∈ negX}, + from set.ext (take x, by rewrite [↑set_of, ↑mem, +neg_neg]), +show inf {x | -x ∈ X} = - sup X, + by rewrite [HX at {2}, sup_neg nonempty_negX Hb', neg_neg] +end +end real + +/- the reals form a complete metric space -/ + +namespace analysis + +theorem dist_eq_abs (x y : real) : dist x y = abs (x - y) := rfl + +proposition converges_to_seq_real_intro {X : ℕ → ℝ} {y : ℝ} + (H : ∀ ⦃ε : ℝ⦄, ε > 0 → ∃ N : ℕ, ∀ {n}, n ≥ N → abs (X n - y) < ε) : + (X ⟶ y in ℕ) := H + +proposition converges_to_seq_real_elim {X : ℕ → ℝ} {y : ℝ} (H : X ⟶ y in ℕ) : + ∀ ⦃ε : ℝ⦄, ε > 0 → ∃ N : ℕ, ∀ {n}, n ≥ N → abs (X n - y) < ε := H + +proposition converges_to_seq_real_intro' {X : ℕ → ℝ} {y : ℝ} + (H : ∀ ⦃ε : ℝ⦄, ε > 0 → ∃ N : ℕ, ∀ {n}, n ≥ N → abs (X n - y) ≤ ε) : + converges_to_seq X y := +converges_to_seq.intro H + +open pnat subtype +local postfix ⁻¹ := pnat.inv + +private definition pnat.succ (n : ℕ) : ℕ+ := tag (succ n) !succ_pos + +private definition r_seq_of (X : ℕ → ℝ) : r_seq := λ n, X (elt_of n) + +private lemma rate_of_cauchy_aux {X : ℕ → ℝ} (H : cauchy X) : + ∀ k : ℕ+, ∃ N : ℕ+, ∀ m n : ℕ+, + m ≥ N → n ≥ N → abs (X (elt_of m) - X (elt_of n)) ≤ of_rat k⁻¹ := +take k : ℕ+, +have H1 : (k⁻¹ >[rat] (rat.of_num 0)), from !pnat.inv_pos, +have H2 : (of_rat k⁻¹ > of_rat (rat.of_num 0)), from !of_rat_lt_of_rat_of_lt H1, +obtain (N : ℕ) (H : ∀ m n, m ≥ N → n ≥ N → abs (X m - X n) < of_rat k⁻¹), from H _ H2, +exists.intro (pnat.succ N) + (take m n : ℕ+, + assume Hm : m ≥ (pnat.succ N), + assume Hn : n ≥ (pnat.succ N), + have Hm' : elt_of m ≥ N, begin apply le.trans, apply le_succ, apply Hm end, + have Hn' : elt_of n ≥ N, begin apply le.trans, apply le_succ, apply Hn end, + show abs (X (elt_of m) - X (elt_of n)) ≤ of_rat k⁻¹, from le_of_lt (H _ _ Hm' Hn')) + +private definition rate_of_cauchy {X : ℕ → ℝ} (H : cauchy X) (k : ℕ+) : ℕ+ := +some (rate_of_cauchy_aux H k) + +private lemma cauchy_with_rate_of_cauchy {X : ℕ → ℝ} (H : cauchy X) : + cauchy_with_rate (r_seq_of X) (rate_of_cauchy H) := +take k : ℕ+, +some_spec (rate_of_cauchy_aux H k) + +private lemma converges_to_with_rate_of_cauchy {X : ℕ → ℝ} (H : cauchy X) : + ∃ l Nb, converges_to_with_rate (r_seq_of X) l Nb := +begin + apply exists.intro, + apply exists.intro, + apply converges_to_with_rate_of_cauchy_with_rate, + exact cauchy_with_rate_of_cauchy H +end + +theorem converges_seq_of_cauchy {X : ℕ → ℝ} (H : cauchy X) : converges_seq X := +obtain l Nb (conv : converges_to_with_rate (r_seq_of X) l Nb), + from converges_to_with_rate_of_cauchy H, +exists.intro l + (take ε : ℝ, + suppose ε > 0, + obtain (k' : ℕ) (Hn : 1 / succ k' < ε), from archimedean_small `ε > 0`, + let k : ℕ+ := tag (succ k') !succ_pos, + N : ℕ+ := Nb k in + have Hk : real.of_rat k⁻¹ < ε, + by rewrite [↑pnat.inv, of_rat_divide]; exact Hn, + exists.intro (elt_of N) + (take n : ℕ, + assume Hn : n ≥ elt_of N, + let n' : ℕ+ := tag n (nat.lt_of_lt_of_le (has_property N) Hn) in + have abs (X n - l) ≤ real.of_rat k⁻¹, by apply conv k n' Hn, + show abs (X n - l) < ε, from lt_of_le_of_lt this Hk)) + +end analysis + +attribute [trans_instance] +definition complete_metric_space_real : + complete_metric_space ℝ := +⦃complete_metric_space, metric_space_real, + complete := @analysis.converges_seq_of_cauchy +⦄ + +/- the real numbers can be viewed as a banach space -/ + +definition real_vector_space_real : real_vector_space ℝ := +⦃ real_vector_space, real.discrete_linear_ordered_field, + smul := mul, + smul_left_distrib := left_distrib, + smul_right_distrib := right_distrib, + mul_smul := mul.assoc, + one_smul := one_mul +⦄ + +attribute [trans_instance] +definition banach_space_real : banach_space ℝ := +⦃ banach_space, real_vector_space_real, + norm := abs, + norm_zero := abs_zero, + eq_zero_of_norm_eq_zero := λ a H, eq_zero_of_abs_eq_zero H, + norm_triangle := abs_add_le_abs_add_abs, + norm_smul := abs_mul, + complete := λ X H, analysis.complete ℝ H +⦄ + +/- limits under pointwise operations -/ + +section limit_operations +variables {X Y : ℕ → ℝ} +variables {x y : ℝ} + +proposition mul_left_converges_to_seq (c : ℝ) (HX : X ⟶ x in ℕ) : + (λ n, c * X n) ⟶ c * x in ℕ := +smul_converges_to_seq c HX + +proposition mul_right_converges_to_seq (c : ℝ) (HX : X ⟶ x in ℕ) : + (λ n, X n * c) ⟶ x * c in ℕ := +have (λ n, X n * c) = (λ n, c * X n), from funext (take x, !mul.comm), +by rewrite [this, mul.comm]; apply mul_left_converges_to_seq c HX + +theorem converges_to_seq_squeeze (HX : X ⟶ x in ℕ) (HY : Y ⟶ x in ℕ) {Z : ℕ → ℝ} (HZX : ∀ n, X n ≤ Z n) + (HZY : ∀ n, Z n ≤ Y n) : Z ⟶ x in ℕ := + begin + intros ε Hε, + have Hε4 : ε / 4 > 0, from div_pos_of_pos_of_pos Hε four_pos, + cases HX Hε4 with N1 HN1, + cases HY Hε4 with N2 HN2, + existsi max N1 N2, + intro n Hn, + have HXY : abs (Y n - X n) < ε / 2, begin + apply lt_of_le_of_lt, + apply abs_sub_le _ x, + have Hε24 : ε / 2 = ε / 4 + ε / 4, from eq.symm !add_quarters, + rewrite Hε24, + apply add_lt_add, + apply HN2, + apply ge.trans Hn !le_max_right, + rewrite abs_sub, + apply HN1, + apply ge.trans Hn !le_max_left + end, + have HZX : abs (Z n - X n) < ε / 2, begin + have HZXnp : Z n - X n ≥ 0, from sub_nonneg_of_le !HZX, + have HXYnp : Y n - X n ≥ 0, from sub_nonneg_of_le (le.trans !HZX !HZY), + rewrite [abs_of_nonneg HZXnp, abs_of_nonneg HXYnp at HXY], + note Hgt := lt_add_of_sub_lt_right HXY, + have Hlt : Z n < ε / 2 + X n, from calc + Z n ≤ Y n : HZY + ... < ε / 2 + X n : Hgt, + apply sub_lt_right_of_lt_add Hlt + end, + have H : abs (Z n - x) < ε, begin + apply lt_of_le_of_lt, + apply abs_sub_le _ (X n), + apply lt.trans, + apply add_lt_add, + apply HZX, + apply HN1, + apply ge.trans Hn !le_max_left, + apply div_two_add_div_four_lt Hε + end, + exact H + end + +proposition converges_to_seq_of_abs_sub_converges_to_seq (Habs : (λ n, abs (X n - x)) ⟶ 0 in ℕ) : + X ⟶ x in ℕ := + begin + intros ε Hε, + cases Habs Hε with N HN, + existsi N, + intro n Hn, + have Hn' : abs (abs (X n - x) - 0) < ε, from HN Hn, + rewrite [sub_zero at Hn', abs_abs at Hn'], + exact Hn' + end + +proposition abs_sub_converges_to_seq_of_converges_to_seq (HX : X ⟶ x in ℕ) : + (λ n, abs (X n - x)) ⟶ 0 in ℕ := + begin + intros ε Hε, + cases HX Hε with N HN, + existsi N, + intro n Hn, + have Hn' : abs (abs (X n - x) - 0) < ε, by rewrite [sub_zero, abs_abs]; apply HN Hn, + exact Hn' + end + +proposition mul_converges_to_seq (HX : X ⟶ x in ℕ) (HY : Y ⟶ y in ℕ) : + (λ n, X n * Y n) ⟶ x * y in ℕ := + have Hbd : ∃ K : ℝ, ∀ n : ℕ, abs (X n) ≤ K, begin + cases bounded_of_converges_seq HX with K HK, + existsi K + abs x, + intro n, + note Habs := le.trans (abs_abs_sub_abs_le_abs_sub (X n) x) !HK, + apply le_add_of_sub_right_le, + apply le.trans, + apply le_abs_self, + assumption + end, + obtain K HK, from Hbd, + have Habsle : ∀ n, abs (X n * Y n - x * y) ≤ K * abs (Y n - y) + abs y * abs (X n - x), begin + intro, + have Heq : X n * Y n - x * y = (X n * Y n - X n * y) + (X n * y - x * y), by + rewrite [-sub_add_cancel (X n * Y n) (X n * y) at {1}, sub_eq_add_neg, *add.assoc], + apply le.trans, + rewrite Heq, + apply abs_add_le_abs_add_abs, + apply add_le_add, + rewrite [-mul_sub_left_distrib, abs_mul], + apply mul_le_mul_of_nonneg_right, + apply HK, + apply abs_nonneg, + rewrite [-mul_sub_right_distrib, abs_mul, mul.comm], + apply le.refl + end, + have Hdifflim : (λ n, abs (X n * Y n - x * y)) ⟶ 0 in ℕ, begin + apply converges_to_seq_squeeze, + rotate 2, + intro, apply abs_nonneg, + apply Habsle, + apply converges_to_seq_constant, + rewrite -{0}zero_add, + apply add_converges_to_seq, + krewrite -(mul_zero K), + apply mul_left_converges_to_seq, + apply abs_sub_converges_to_seq_of_converges_to_seq, + exact HY, + krewrite -(mul_zero (abs y)), + apply mul_left_converges_to_seq, + apply abs_sub_converges_to_seq_of_converges_to_seq, + exact HX + end, + converges_to_seq_of_abs_sub_converges_to_seq Hdifflim + + +-- TODO: converges_to_seq_div, converges_to_seq_mul_left_iff, etc. + +proposition abs_converges_to_seq_zero (HX : X ⟶ 0 in ℕ) : (λ n, abs (X n)) ⟶ 0 in ℕ := +norm_converges_to_seq_zero HX + +proposition converges_to_seq_zero_of_abs_converges_to_seq_zero (HX : (λ n, abs (X n)) ⟶ 0 in ℕ) : + X ⟶ 0 in ℕ := +converges_to_seq_zero_of_norm_converges_to_seq_zero HX + +proposition abs_converges_to_seq_zero_iff (X : ℕ → ℝ) : + ((λ n, abs (X n)) ⟶ 0 in ℕ) ↔ (X ⟶ 0 in ℕ) := +iff.intro converges_to_seq_zero_of_abs_converges_to_seq_zero abs_converges_to_seq_zero + +-- TODO: products of two sequences, converges_seq, limit_seq + +end limit_operations + +/- properties of converges_to_at -/ + +section limit_operations_continuous +variables {f g : ℝ → ℝ} +variables {a b x y : ℝ} + +theorem mul_converges_to_at (Hf : f ⟶ a at x) (Hg : g ⟶ b at x) : (λ z, f z * g z) ⟶ a * b at x := + begin + apply converges_to_at_of_all_conv_seqs, + intro X HX, + apply mul_converges_to_seq, + note Hfc := all_conv_seqs_of_converges_to_at Hf, + apply Hfc _ HX, + note Hgb := all_conv_seqs_of_converges_to_at Hg, + apply Hgb _ HX + end + +end limit_operations_continuous + +/- monotone sequences -/ + +section monotone_sequences +open real set +variable {X : ℕ → ℝ} + +proposition converges_to_seq_sup_of_nondecreasing (nondecX : nondecreasing X) {b : ℝ} + (Hb : ∀ i, X i ≤ b) : X ⟶ sup (X ' univ) in ℕ := +let sX := sup (X ' univ) in +have Xle : ∀ i, X i ≤ sX, from + take i, + have ∀ x, x ∈ X ' univ → x ≤ b, from + (take x, assume H, + obtain i [H' (Hi : X i = x)], from H, + by rewrite -Hi; exact Hb i), + show X i ≤ sX, from le_sup (mem_image_of_mem X !mem_univ) this, +have exX : ∃ x, x ∈ X ' univ, + from exists.intro (X 0) (mem_image_of_mem X !mem_univ), +take ε, assume epos : ε > 0, +have sX - ε < sX, from !sub_lt_of_pos epos, +obtain x' [(H₁x' : x' ∈ X ' univ) (H₂x' : sX - ε < x')], + from exists_mem_and_lt_of_lt_sup exX this, +obtain i [H' (Hi : X i = x')], from H₁x', +have Hi' : ∀ j, j ≥ i → sX - ε < X j, from + take j, assume Hj, lt_of_lt_of_le (by rewrite Hi; apply H₂x') (nondecX Hj), +exists.intro i + (take j, assume Hj : j ≥ i, + have X j - sX ≤ 0, from sub_nonpos_of_le (Xle j), + have eq₁ : abs (X j - sX) = sX - X j, by rewrite [abs_of_nonpos this, neg_sub], + have sX - ε < X j, from lt_of_lt_of_le (by rewrite Hi; apply H₂x') (nondecX Hj), + have sX < X j + ε, from lt_add_of_sub_lt_right this, + have sX - X j < ε, from sub_lt_left_of_lt_add this, + show (abs (X j - sX)) < ε, by rewrite eq₁; exact this) + +proposition converges_to_seq_inf_of_nonincreasing (nonincX : nonincreasing X) {b : ℝ} + (Hb : ∀ i, b ≤ X i) : X ⟶ inf (X ' univ) in ℕ := +have H₁ : ∃ x, x ∈ X ' univ, from exists.intro (X 0) (mem_image_of_mem X !mem_univ), +have H₂ : ∀ x, x ∈ X ' univ → b ≤ x, from + (take x, assume H, + obtain i [Hi₁ (Hi₂ : X i = x)], from H, + show b ≤ x, by rewrite -Hi₂; apply Hb i), +have H₃ : {x : ℝ | -x ∈ X ' univ} = {x : ℝ | x ∈ (λ n, -X n) ' univ}, from calc + {x : ℝ | -x ∈ X ' univ} = (λ y, -y) ' (X ' univ) : by rewrite image_neg_eq + ... = {x : ℝ | x ∈ (λ n, -X n) ' univ} : image_comp, +have H₄ : ∀ i, - X i ≤ - b, from take i, neg_le_neg (Hb i), +begin + -- need krewrite here + krewrite [-neg_converges_to_seq_iff, -sup_neg H₁ H₂, H₃, -nondecreasing_neg_iff at nonincX], + apply converges_to_seq_sup_of_nondecreasing nonincX H₄ +end + +end monotone_sequences + +/- x^n converges to 0 if abs x < 1 -/ + +section xn +open nat set + +theorem pow_converges_to_seq_zero {x : ℝ} (H : abs x < 1) : + (λ n, x^n) ⟶ 0 in ℕ := +suffices H' : (λ n, (abs x)^n) ⟶ 0 in ℕ, from + have (λ n, (abs x)^n) = (λ n, abs (x^n)), from funext (take n, eq.symm !abs_pow), + by rewrite this at H'; exact converges_to_seq_zero_of_abs_converges_to_seq_zero H', +let aX := (λ n, (abs x)^n), + iaX := real.inf (aX ' univ), + asX := (λ n, (abs x)^(succ n)) in +have noninc_aX : nonincreasing aX, from + nonincreasing_of_forall_ge_succ + (take i, + have (abs x) * (abs x)^i ≤ 1 * (abs x)^i, + from mul_le_mul_of_nonneg_right (le_of_lt H) (!pow_nonneg_of_nonneg !abs_nonneg), + have (abs x) * (abs x)^i ≤ (abs x)^i, by krewrite one_mul at this; exact this, + show (abs x) ^ (succ i) ≤ (abs x)^i, by rewrite pow_succ; apply this), +have bdd_aX : ∀ i, 0 ≤ aX i, from take i, !pow_nonneg_of_nonneg !abs_nonneg, +have aXconv : aX ⟶ iaX in ℕ, proof converges_to_seq_inf_of_nonincreasing noninc_aX bdd_aX qed, +have asXconv : asX ⟶ iaX in ℕ, from converges_to_seq_offset_succ aXconv, +have asXconv' : asX ⟶ (abs x) * iaX in ℕ, from mul_left_converges_to_seq (abs x) aXconv, +have iaX = (abs x) * iaX, from converges_to_seq_unique asXconv asXconv', +have iaX = 0, from eq_zero_of_mul_eq_self_left (ne_of_lt H) (eq.symm this), +show aX ⟶ 0 in ℕ, begin rewrite -this, exact aXconv end --from this ▸ aXconv + +end xn + +/- continuity on the reals -/ + +section continuous + +theorem continuous_real_elim {f : ℝ → ℝ} (H : continuous f) : + ∀ x : ℝ, ∀ ⦃ε : ℝ⦄, ε > 0 → ∃ δ : ℝ, δ > 0 ∧ ∀ x' : ℝ, + abs (x' - x) < δ → abs (f x' - f x) < ε := +take x, continuous_at_elim (H x) + +theorem continuous_real_intro {f : ℝ → ℝ} + (H : ∀ x : ℝ, ∀ ⦃ε : ℝ⦄, ε > 0 → ∃ δ : ℝ, δ > 0 ∧ ∀ x' : ℝ, + abs (x' - x) < δ → abs (f x' - f x) < ε) : + continuous f := +take x, continuous_at_intro (H x) + +theorem pos_on_nbhd_of_cts_of_pos {f : ℝ → ℝ} (Hf : continuous f) {b : ℝ} (Hb : f b > 0) : + ∃ δ : ℝ, δ > 0 ∧ ∀ y, abs (y - b) < δ → f y > 0 := + begin + let Hcont := continuous_real_elim Hf b Hb, + cases Hcont with δ Hδ, + existsi δ, + split, + exact and.left Hδ, + intro y Hy, + let Hy' := and.right Hδ y Hy, + note Hlt := sub_lt_of_abs_sub_lt_left Hy', + rewrite sub_self at Hlt, + assumption + end + +theorem neg_on_nbhd_of_cts_of_neg {f : ℝ → ℝ} (Hf : continuous f) {b : ℝ} (Hb : f b < 0) : + ∃ δ : ℝ, δ > 0 ∧ ∀ y, abs (y - b) < δ → f y < 0 := + begin + let Hcont := continuous_real_elim Hf b (neg_pos_of_neg Hb), + cases Hcont with δ Hδ, + existsi δ, + split, + exact and.left Hδ, + intro y Hy, + let Hy' := and.right Hδ y Hy, + let Hlt := sub_lt_of_abs_sub_lt_right Hy', + note Hlt' := lt_add_of_sub_lt_left Hlt, + rewrite [add.comm at Hlt', -sub_eq_add_neg at Hlt', sub_self at Hlt'], + assumption + end + +theorem continuous_neg_of_continuous {f : ℝ → ℝ} (Hcon : continuous f) : continuous (λ x, - f x) := + begin + apply continuous_real_intro, + intros x ε Hε, + cases continuous_real_elim Hcon x Hε with δ Hδ, + cases Hδ with Hδ₁ Hδ₂, + existsi δ, + split, + assumption, + intros x' Hx', + let HD := Hδ₂ x' Hx', + rewrite [-abs_neg, neg_neg_sub_neg], + exact HD + end + +theorem continuous_offset_of_continuous {f : ℝ → ℝ} (Hcon : continuous f) (a : ℝ) : + continuous (λ x, (f x) + a) := + begin + apply continuous_real_intro, + intros x ε Hε, + cases continuous_real_elim Hcon x Hε with δ Hδ, + cases Hδ with Hδ₁ Hδ₂, + existsi δ, + split, + assumption, + intros x' Hx', + rewrite [add_sub_comm, sub_self, add_zero], + apply Hδ₂, + assumption + end + +theorem continuous_mul_of_continuous {f g : ℝ → ℝ} (Hconf : continuous f) (Hcong : continuous g) : + continuous (λ x, f x * g x) := + begin + intro x, + apply continuous_at_of_converges_to_at, + apply mul_converges_to_at, + all_goals apply converges_to_at_of_continuous_at, + apply Hconf, + apply Hcong + end + +end continuous diff --git a/old_library/theories/analysis/sqrt.lean b/old_library/theories/analysis/sqrt.lean new file mode 100644 index 0000000000..027e6870ad --- /dev/null +++ b/old_library/theories/analysis/sqrt.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2015 Robert Y. Lewis. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Robert Y. Lewis, Jeremy Avigad + +The square root function. +-/ +import .ivt +open analysis real classical +noncomputable theory + +private definition sqr_lb (x : ℝ) : ℝ := 0 + +private theorem sqr_lb_is_lb (x : ℝ) (H : x ≥ 0) : (sqr_lb x) * (sqr_lb x) ≤ x := + by rewrite [↑sqr_lb, zero_mul]; assumption + +private definition sqr_ub (x : ℝ) : ℝ := x + 1 + +private theorem sqr_ub_is_ub (x : ℝ) (H : x ≥ 0) : (sqr_ub x) * (sqr_ub x) ≥ x := + begin + rewrite [↑sqr_ub, left_distrib, mul_one, right_distrib, one_mul, {x + 1}add.comm, -*add.assoc], + apply le_add_of_nonneg_left, + repeat apply add_nonneg, + apply mul_nonneg, + repeat assumption, + apply zero_le_one + end + +private theorem lb_le_ub (x : ℝ) (H : x ≥ 0) : sqr_lb x ≤ sqr_ub x := + begin + rewrite [↑sqr_lb, ↑sqr_ub], + apply add_nonneg, + assumption, + apply zero_le_one + end + +private lemma sqr_cts : continuous (λ x : ℝ, x * x) := continuous_mul_of_continuous id_continuous id_continuous + +definition sqrt (x : ℝ) : ℝ := + if H : x ≥ 0 then + some (intermediate_value_incr_weak sqr_cts (lb_le_ub x H) (sqr_lb_is_lb x H) (sqr_ub_is_ub x H)) + else 0 + +private theorem sqrt_spec {x : ℝ} (H : x ≥ 0) : sqrt x * sqrt x = x ∧ sqrt x ≥ 0 := + begin + rewrite [↑sqrt, dif_pos H], + note Hs := some_spec (intermediate_value_incr_weak sqr_cts (lb_le_ub x H) + (sqr_lb_is_lb x H) (sqr_ub_is_ub x H)), + cases Hs with Hs1 Hs2, + cases Hs2 with Hs2a Hs2b, + exact and.intro Hs2b Hs1 + end + +theorem sqrt_mul_self {x : ℝ} (H : x ≥ 0) : sqrt x * sqrt x = x := and.left (sqrt_spec H) + +theorem sqrt_nonneg (x : ℝ) : sqrt x ≥ 0 := +if H : x ≥ 0 then and.right (sqrt_spec H) else by rewrite [↑sqrt, dif_neg H]; exact le.refl 0 + +theorem sqrt_squared {x : ℝ} (H : x ≥ 0) : (sqrt x)^2 = x := +by krewrite [pow_two, sqrt_mul_self H] + +theorem sqrt_zero : sqrt (0 : ℝ) = 0 := +have sqrt 0 * sqrt 0 = 0, from sqrt_mul_self !le.refl, +or.elim (eq_zero_or_eq_zero_of_mul_eq_zero this) (λ H, H) (λ H, H) + +theorem sqrt_squared_of_nonneg {x : ℝ} (H : x ≥ 0) : sqrt (x^2) = x := +have sqrt (x^2)^2 = x^2, from sqrt_squared (squared_nonneg x), +eq_of_squared_eq_squared_of_nonneg (sqrt_nonneg (x^2)) H this + +theorem sqrt_squared' (x : ℝ) : sqrt (x^2) = abs x := +have x^2 = (abs x)^2, by krewrite [+pow_two, -abs_mul, abs_mul_self], +using this, by rewrite [this, sqrt_squared_of_nonneg (abs_nonneg x)] + +theorem sqrt_mul {x y : ℝ} (Hx : x ≥ 0) (Hy : y ≥ 0) : sqrt (x * y) = sqrt x * sqrt y := +have (sqrt (x * y))^2 = (sqrt x * sqrt y)^2, from calc + (sqrt (x * y))^2 = x * y : by rewrite [sqrt_squared (mul_nonneg Hx Hy)] + ... = (sqrt x)^2 * (sqrt y)^2 : by rewrite [sqrt_squared Hx, sqrt_squared Hy] + ... = (sqrt x * sqrt y)^2 : by krewrite [*pow_two]; rewrite [*mul.assoc, + mul.left_comm (sqrt y)], +eq_of_squared_eq_squared_of_nonneg !sqrt_nonneg (mul_nonneg !sqrt_nonneg !sqrt_nonneg) this diff --git a/old_library/theories/combinatorics/choose.lean b/old_library/theories/combinatorics/choose.lean new file mode 100644 index 0000000000..c3ac5076bb --- /dev/null +++ b/old_library/theories/combinatorics/choose.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +Binomial coefficients, "n choose k". +-/ +import data.nat.div data.nat.fact data.finset +open decidable + +namespace nat + +/- choose -/ + +definition choose : ℕ → ℕ → ℕ +| 0 0 := 1 +| 0 (succ k) := 0 +| (succ n) 0 := 1 +| (succ n) (succ k) := choose n (succ k) + choose n k + +theorem choose_zero_right (n : ℕ) : choose n 0 = 1 := +nat.cases_on n rfl (take m, rfl) + +theorem choose_zero_succ (k : ℕ) : choose 0 (succ k) = 0 := rfl + +theorem choose_succ_succ (n k : ℕ) : choose (succ n) (succ k) = choose n (succ k) + choose n k := +rfl + +theorem choose_eq_zero_of_lt {n : ℕ} : ∀{k : ℕ}, n < k → choose n k = 0 := +nat.induction_on n + (take k, assume H : 0 < k, + obtain k' (H : k = succ k'), from exists_eq_succ_of_pos H, + by rewrite H) + (take n', + assume IH: ∀ k, n' < k → choose n' k = 0, + take k, + suppose succ n' < k, + obtain k' (keq : k = succ k'), from exists_eq_succ_of_lt this, + have n' < k', by rewrite keq at this; apply lt_of_succ_lt_succ this, + by rewrite [keq, choose_succ_succ, IH _ this, IH _ (lt.trans this !lt_succ_self)]) + +theorem choose_self (n : ℕ) : choose n n = 1 := +begin + induction n with [n, ih], + {apply rfl}, + rewrite [choose_succ_succ, ih, choose_eq_zero_of_lt !lt_succ_self] +end + +theorem choose_succ_self (n : ℕ) : choose (succ n) n = succ n := +begin + induction n with [n, ih], + {apply rfl}, + rewrite [choose_succ_succ, ih, choose_self, add.comm] +end + +theorem choose_one_right (n : ℕ) : choose n 1 = n := +begin + induction n with [n, ih], + {apply rfl}, + change choose (succ n) (succ 0) = succ n, + krewrite [choose_succ_succ, ih, choose_zero_right] +end + +theorem choose_pos {n : ℕ} : ∀ {k : ℕ}, k ≤ n → choose n k > 0 := +begin + induction n with [n, ih], + {intros [k, H], + have k = 0, from eq_of_le_of_ge H !zero_le, + subst k, rewrite choose_zero_right; apply zero_lt_one}, + intro k, + cases k with k, + {intros, rewrite [choose_zero_right], apply zero_lt_one}, + suppose succ k ≤ succ n, + have k ≤ n, from le_of_succ_le_succ this, + by rewrite [choose_succ_succ]; apply add_pos_right (ih this) +end + +-- A key identity. The proof is subtle. +theorem succ_mul_choose_eq (n : ℕ) : + ∀ k, succ n * (choose n k) = choose (succ n) (succ k) * succ k := +begin + induction n with [n, ih], + {intro k, + cases k with k', + {krewrite [*choose_self, one_mul, mul_one]}, + {have H : 1 < succ (succ k'), from succ_lt_succ !zero_lt_succ, + krewrite [one_mul, choose_zero_succ, choose_eq_zero_of_lt H, zero_mul]}}, + intro k, + cases k with k', + {krewrite [choose_zero_right, choose_one_right]}, + rewrite [choose_succ_succ (succ n), right_distrib, -ih (succ k')], + rewrite [choose_succ_succ at {1}, left_distrib, *succ_mul (succ n), mul_succ, -ih k'], + rewrite [*add.assoc, add.left_comm (choose n _)] +end + +theorem choose_mul_fact_mul_fact {n : ℕ} : + ∀ {k : ℕ}, k ≤ n → choose n k * fact k * fact (n - k) = fact n := +begin + induction n using nat.strong_induction_on with [n, ih], + cases n with n, + {intro k H, have k = 0, from eq_zero_of_le_zero H, rewrite this}, + intro k, + intro H, -- k ≤ n, + cases k with k, + {rewrite [choose_zero_right, fact_zero, *one_mul]}, + have k ≤ n, from le_of_succ_le_succ H, + show choose (succ n) (succ k) * fact (succ k) * fact (succ n - succ k) = fact (succ n), from + begin + rewrite [succ_sub_succ, fact_succ, -mul.assoc, -succ_mul_choose_eq], + rewrite [fact_succ n, -ih n !lt_succ_self this, *mul.assoc] + end +end + +theorem choose_def_alt {n k : ℕ} (H : k ≤ n) : choose n k = fact n / (fact k * fact (n -k)) := +eq.symm (nat.div_eq_of_eq_mul_left (mul_pos !fact_pos !fact_pos) + (by rewrite [-mul.assoc, choose_mul_fact_mul_fact H])) + +theorem fact_mul_fact_dvd_fact {n k : ℕ} (H : k ≤ n) : fact k * fact (n - k) ∣ fact n := +by rewrite [-choose_mul_fact_mul_fact H, mul.assoc]; apply dvd_mul_left + +open finset + +/- the number of subsets of s of size k is n choose k -/ + +section card_subsets +variables {A : Type} [deceqA : decidable_eq A] +include deceqA + +private theorem aux₀ (s : finset A) : {t ∈ powerset s | card t = 0} = '{∅} := +ext (take t, iff.intro + (assume H, + have t = ∅, from eq_empty_of_card_eq_zero (of_mem_sep H), + show t ∈ '{ ∅ }, by rewrite [this, mem_singleton_iff]) + (assume H, + have t = ∅, by rewrite mem_singleton_iff at H; assumption, + by substvars; exact mem_sep_of_mem !empty_mem_powerset rfl)) + +private theorem aux₁ (k : ℕ) : {t ∈ powerset (∅ : finset A) | card t = succ k} = ∅ := +eq_empty_of_forall_not_mem (take t, assume H, + have t ∈ powerset ∅, from mem_of_mem_sep H, + have t = ∅, by rewrite [powerset_empty at this, mem_singleton_iff at this]; assumption, + have card (∅ : finset A) = succ k, by rewrite -this; apply of_mem_sep H, + nat.no_confusion this) + +private theorem aux₂ {a : A} {s t : finset A} (anins : a ∉ s) (tpows : t ∈ powerset s) : a ∉ t := +suppose a ∈ t, +have a ∈ s, from mem_of_subset_of_mem (subset_of_mem_powerset tpows) this, +anins this + +private theorem aux₃ {a : A} {s t : finset A} (anins : a ∉ s) (k : ℕ) : + t ∈ (insert a) ' (powerset s) ∧ card t = succ k ↔ + t ∈ (insert a) ' {t' ∈ powerset s | card t' = k} := +iff.intro + (assume H, + obtain H' cardt, from H, + obtain t' [(t'pows : t' ∈ powerset s) (teq : insert a t' = t)], from exists_of_mem_image H', + have aint : a ∈ t, by rewrite -teq; apply mem_insert, + have anint' : a ∉ t', from + (assume aint', + have a ∈ s, from mem_of_subset_of_mem (subset_of_mem_powerset t'pows) aint', + anins this), + have t' = erase a t, by rewrite [-teq, erase_insert (aux₂ anins t'pows)], + have card t' = k, by rewrite [this, card_erase_of_mem aint, cardt], + mem_image (mem_sep_of_mem t'pows this) teq) + (assume H, + obtain t' [Ht' (teq : insert a t' = t)], from exists_of_mem_image H, + have t'pows : t' ∈ powerset s, from mem_of_mem_sep Ht', + have cardt' : card t' = k, from of_mem_sep Ht', + and.intro + (show t ∈ (insert a) ' (powerset s), from mem_image t'pows teq) + (show card t = succ k, + by rewrite [-teq, card_insert_of_not_mem (aux₂ anins t'pows), cardt'])) + +private theorem aux₄ {a : A} {s : finset A} (anins : a ∉ s) (k : ℕ) : + {t ∈ powerset (insert a s)| card t = succ k} = + {t ∈ powerset s | card t = succ k} ∪ (insert a) ' {t ∈ powerset s | card t = k} := +begin + apply ext, intro t, + rewrite [powerset_insert anins, mem_union_iff, *mem_sep_iff, mem_union_iff, and.right_distrib, + aux₃ anins] +end + +private theorem aux₅ {a : A} {s : finset A} (anins : a ∉ s) (k : ℕ) : + {t ∈ powerset s | card t = succ k} ∩ (insert a) ' {t ∈ powerset s | card t = k} = ∅ := +inter_eq_empty + (take t, assume Ht₁ Ht₂, + have tpows : t ∈ powerset s, from mem_of_mem_sep Ht₁, + have anint : a ∉ t, from aux₂ anins tpows, + obtain t' [Ht' (teq : insert a t' = t)], from exists_of_mem_image Ht₂, + have aint : a ∈ t, by rewrite -teq; apply mem_insert, + show false, from anint aint) + +private theorem aux₆ {a : A} {s : finset A} (anins : a ∉ s) (k : ℕ) : + card ((insert a) ' {t ∈ powerset s | card t = k}) = card {t ∈ powerset s | card t = k} := +have set.inj_on (insert a) (ts {t ∈ powerset s| card t = k}), from + take t₁ t₂, assume Ht₁ Ht₂, + assume Heq : insert a t₁ = insert a t₂, + have t₁ ∈ powerset s, from mem_of_mem_sep Ht₁, + have anint₁ : a ∉ t₁, from aux₂ anins this, + have t₂ ∈ powerset s, from mem_of_mem_sep Ht₂, + have anint₂ : a ∉ t₂, from aux₂ anins this, + calc + t₁ = erase a (insert a t₁) : by rewrite (erase_insert anint₁) + ... = erase a (insert a t₂) : Heq + ... = t₂ : by rewrite (erase_insert anint₂), +card_image_eq_of_inj_on this + +theorem card_subsets (s : finset A) : ∀k, card {t ∈ powerset s | card t = k} = choose (card s) k := +begin + induction s with a s anins ih, + {intro k, + cases k with k, + {rewrite aux₀}, + rewrite aux₁}, + intro k, + cases k with k, + {rewrite [aux₀, choose_zero_right]}, + rewrite [*(card_insert_of_not_mem anins), aux₄ anins, card_union_of_disjoint (aux₅ anins k), + aux₆ anins k, *ih] +end + +end card_subsets + +end nat diff --git a/old_library/theories/combinatorics/combinatorics.md b/old_library/theories/combinatorics/combinatorics.md new file mode 100644 index 0000000000..a57cf78a9d --- /dev/null +++ b/old_library/theories/combinatorics/combinatorics.md @@ -0,0 +1,4 @@ +theories.combinatorics +====================== + +* [choose](choose.lean) diff --git a/old_library/theories/group_theory/action.lean b/old_library/theories/group_theory/action.lean new file mode 100644 index 0000000000..12f72aa843 --- /dev/null +++ b/old_library/theories/group_theory/action.lean @@ -0,0 +1,559 @@ +/- +Copyright (c) 2015 Haitao Zhang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author : Haitao Zhang +-/ +import algebra.group data .hom .perm .finsubg + +namespace group_theory +open finset function + +-- local attribute perm.f [coercion] + +private lemma and_left_true {a b : Prop} (Pa : a) : a ∧ b ↔ b := +by rewrite [iff_true_intro Pa, true_and] + +section def +variables {G S : Type} [group G] [fintype S] + +definition is_fixed_point (hom : G → perm S) (H : finset G) (a : S) : Prop := +∀ h, h ∈ H → hom h a = a + +variables [decidable_eq S] + +definition orbit (hom : G → perm S) (H : finset G) (a : S) : finset S := + image (move_by a) (image hom H) + +attribute [reducible] +definition fixed_points (hom : G → perm S) (H : finset G) : finset S := +{a ∈ univ | orbit hom H a = '{a}} + +variable [decidable_eq G] -- required by {x ∈ H |p x} filtering + +definition moverset (hom : G → perm S) (H : finset G) (a b : S) : finset G := + {f ∈ H | hom f a = b} + +definition stab (hom : G → perm S) (H : finset G) (a : S) : finset G := + {f ∈ H | hom f a = a} + +end def + +section orbit_stabilizer + +variables {G S : Type} [group G] [decidable_eq G] [fintype S] [decidable_eq S] + +section + +variables {hom : G → perm S} {H : finset G} {a : S} [Hom : is_hom_class hom] +include Hom + +lemma exists_of_orbit {b : S} : b ∈ orbit hom H a → ∃ h, h ∈ H ∧ hom h a = b := + assume Pb, + obtain p (Pp₁ : p ∈ image hom H) (Pp₂ : move_by a p = b), from exists_of_mem_image Pb, + obtain h (Ph₁ : h ∈ H) (Ph₂ : hom h = p), from exists_of_mem_image Pp₁, + have Phab : hom h a = b, from calc + hom h a = p a : Ph₂ + ... = b : Pp₂, + exists.intro h (and.intro Ph₁ Phab) + +lemma orbit_of_exists {b : S} : (∃ h, h ∈ H ∧ hom h a = b) → b ∈ orbit hom H a := +assume Pex, obtain h PinH Phab, from Pex, +mem_image (mem_image_of_mem hom PinH) Phab + +lemma is_fixed_point_of_mem_fixed_points : + a ∈ fixed_points hom H → is_fixed_point hom H a := +assume Pain, take h, assume Phin, + eq_of_mem_singleton + (of_mem_sep Pain ▸ orbit_of_exists (exists.intro h (and.intro Phin rfl))) + +lemma mem_fixed_points_of_exists_of_is_fixed_point : + (∃ h, h ∈ H) → is_fixed_point hom H a → a ∈ fixed_points hom H := +assume Pex Pfp, mem_sep_of_mem !mem_univ + (ext take x, iff.intro + (assume Porb, obtain h Phin Pha, from exists_of_orbit Porb, + by rewrite [mem_singleton_iff, -Pha, Pfp h Phin]) + (obtain h Phin, from Pex, + by rewrite mem_singleton_iff; + intro Peq; rewrite Peq; + apply orbit_of_exists; + existsi h; apply and.intro Phin (Pfp h Phin))) + +lemma is_fixed_point_iff_mem_fixed_points_of_exists : + (∃ h, h ∈ H) → (a ∈ fixed_points hom H ↔ is_fixed_point hom H a) := +assume Pex, iff.intro is_fixed_point_of_mem_fixed_points (mem_fixed_points_of_exists_of_is_fixed_point Pex) + +lemma is_fixed_point_iff_mem_fixed_points [finsubgH : is_finsubg H] : + a ∈ fixed_points hom H ↔ is_fixed_point hom H a := +is_fixed_point_iff_mem_fixed_points_of_exists (exists.intro 1 !finsubg_has_one) + +lemma is_fixed_point_of_one : is_fixed_point hom ('{1}) a := +take h, assume Ph, by rewrite [eq_of_mem_singleton Ph, hom_map_one] + +lemma fixed_points_of_one : fixed_points hom ('{1}) = univ := +ext take s, iff.intro (assume Pl, mem_univ s) + (assume Pr, mem_fixed_points_of_exists_of_is_fixed_point + (exists.intro 1 !mem_singleton) is_fixed_point_of_one) + +open fintype +lemma card_fixed_points_of_one : card (fixed_points hom ('{1})) = card S := +by rewrite [fixed_points_of_one] + +end + +-- these are already specified by stab hom H a +variables {hom : G → perm S} {H : finset G} {a : S} + +variable [Hom : is_hom_class hom] +include Hom + +lemma perm_f_mul (f g : G): perm.f ((hom f) * (hom g)) a = ((hom f) ∘ (hom g)) a := +rfl + +lemma stab_lmul {f g : G} : g ∈ stab hom H a → hom (f*g) a = hom f a := +assume Pgstab, +have hom g a = a, from of_mem_sep Pgstab, calc + hom (f*g) a = perm.f ((hom f) * (hom g)) a : is_hom hom + ... = ((hom f) ∘ (hom g)) a : by rewrite perm_f_mul + ... = (hom f) a : by unfold comp; rewrite this + +lemma stab_subset : stab hom H a ⊆ H := + begin + apply subset_of_forall, intro f Pfstab, apply mem_of_mem_sep Pfstab + end + +lemma reverse_move {h g : G} : g ∈ moverset hom H a (hom h a) → hom (h⁻¹*g) a = a := +assume Pg, +have hom g a = hom h a, from of_mem_sep Pg, calc + hom (h⁻¹*g) a = perm.f ((hom h⁻¹) * (hom g)) a : by rewrite (is_hom hom) + ... = ((hom h⁻¹) ∘ hom g) a : by rewrite perm_f_mul + ... = perm.f ((hom h)⁻¹ * hom h) a : by unfold comp; rewrite [this, perm_f_mul, hom_map_inv hom h] + ... = perm.f (1 : perm S) a : by rewrite (mul.left_inv (hom h)) + ... = a : by esimp + +lemma moverset_inj_on_orbit : set.inj_on (moverset hom H a) (ts (orbit hom H a)) := + take b1 b2, + assume Pb1, obtain h1 Ph1₁ Ph1₂, from exists_of_orbit Pb1, + have Ph1b1 : h1 ∈ moverset hom H a b1, + from mem_sep_of_mem Ph1₁ Ph1₂, + assume Psetb2 Pmeq, begin + subst b1, + rewrite Pmeq at Ph1b1, + apply of_mem_sep Ph1b1 + end + +variable [finsubgH : is_finsubg H] +include finsubgH + +lemma subg_stab_of_move {h g : G} : + h ∈ H → g ∈ moverset hom H a (hom h a) → h⁻¹*g ∈ stab hom H a := + assume Ph Pg, + have Phinvg : h⁻¹*g ∈ H, from begin + apply finsubg_mul_closed H, + apply finsubg_has_inv H, assumption, + apply mem_of_mem_sep Pg + end, + mem_sep_of_mem Phinvg (reverse_move Pg) + +lemma subg_stab_closed : finset_mul_closed_on (stab hom H a) := + take f g, assume Pfstab, have Pf : hom f a = a, from of_mem_sep Pfstab, + assume Pgstab, + have Pfg : hom (f*g) a = a, from calc + hom (f*g) a = (hom f) a : stab_lmul Pgstab + ... = a : Pf, + have PfginH : (f*g) ∈ H, + from finsubg_mul_closed H (mem_of_mem_sep Pfstab) (mem_of_mem_sep Pgstab), + mem_sep_of_mem PfginH Pfg + +lemma subg_stab_has_one : 1 ∈ stab hom H a := + have P : hom 1 a = a, from calc + hom 1 a = perm.f (1 : perm S) a : {hom_map_one hom} + ... = a : rfl, + have PoneinH : 1 ∈ H, from finsubg_has_one H, + mem_sep_of_mem PoneinH P + +lemma subg_stab_has_inv : finset_has_inv (stab hom H a) := + take f, assume Pfstab, have Pf : hom f a = a, from of_mem_sep Pfstab, + have Pfinv : hom f⁻¹ a = a, from calc + hom f⁻¹ a = hom f⁻¹ ((hom f) a) : by rewrite Pf + ... = perm.f ((hom f⁻¹) * (hom f)) a : by rewrite perm_f_mul + ... = hom (f⁻¹ * f) a : by rewrite (is_hom hom) + ... = hom 1 a : by rewrite mul.left_inv + ... = perm.f (1 : perm S) a : by rewrite (hom_map_one hom), + have PfinvinH : f⁻¹ ∈ H, from finsubg_has_inv H (mem_of_mem_sep Pfstab), + mem_sep_of_mem PfinvinH Pfinv + +attribute [instance] +definition subg_stab_is_finsubg : + is_finsubg (stab hom H a) := + is_finsubg.mk subg_stab_has_one subg_stab_closed subg_stab_has_inv + +lemma subg_lcoset_eq_moverset {h : G} : + h ∈ H → fin_lcoset (stab hom H a) h = moverset hom H a (hom h a) := + assume Ph, ext (take g, iff.intro + (assume Pl, obtain f (Pf₁ : f ∈ stab hom H a) (Pf₂ : h*f = g), from exists_of_mem_image Pl, + have Pfstab : hom f a = a, from of_mem_sep Pf₁, + have PginH : g ∈ H, begin + subst Pf₂, + apply finsubg_mul_closed H, + assumption, + apply mem_of_mem_sep Pf₁ + end, + have Pga : hom g a = hom h a, from calc + hom g a = hom (h*f) a : by subst g + ... = hom h a : stab_lmul Pf₁, + mem_sep_of_mem PginH Pga) + (assume Pr, begin + rewrite [↑fin_lcoset, mem_image_iff], + existsi h⁻¹*g, + split, + exact subg_stab_of_move Ph Pr, + apply mul_inv_cancel_left + end)) + +lemma subg_moverset_of_orbit_is_lcoset_of_stab (b : S) : + b ∈ orbit hom H a → ∃ h, h ∈ H ∧ fin_lcoset (stab hom H a) h = moverset hom H a b := + assume Porb, + obtain p (Pp₁ : p ∈ image hom H) (Pp₂ : move_by a p = b), from exists_of_mem_image Porb, + obtain h (Ph₁ : h ∈ H) (Ph₂ : hom h = p), from exists_of_mem_image Pp₁, + have Phab : hom h a = b, from by subst p; assumption, + exists.intro h (and.intro Ph₁ (Phab ▸ subg_lcoset_eq_moverset Ph₁)) + +lemma subg_lcoset_of_stab_is_moverset_of_orbit (h : G) : + h ∈ H → ∃ b, b ∈ orbit hom H a ∧ moverset hom H a b = fin_lcoset (stab hom H a) h := + assume Ph, + have Pha : (hom h a) ∈ orbit hom H a, by + apply mem_image_of_mem; apply mem_image_of_mem; exact Ph, + exists.intro (hom h a) (and.intro Pha (eq.symm (subg_lcoset_eq_moverset Ph))) + +lemma subg_moversets_of_orbit_eq_stab_lcosets : + image (moverset hom H a) (orbit hom H a) = fin_lcosets (stab hom H a) H := + ext (take s, iff.intro + (assume Pl, obtain b Pb₁ Pb₂, from exists_of_mem_image Pl, + obtain h Ph, from subg_moverset_of_orbit_is_lcoset_of_stab b Pb₁, begin + rewrite [↑fin_lcosets, mem_image_eq], + existsi h, subst Pb₂, assumption + end) + (assume Pr, obtain h Ph₁ Ph₂, from exists_of_mem_image Pr, + obtain b Pb, from @subg_lcoset_of_stab_is_moverset_of_orbit G S _ _ _ _ hom H a Hom _ h Ph₁, begin + rewrite [mem_image_eq], + existsi b, subst Ph₂, assumption + end)) + +open nat + +theorem orbit_stabilizer_theorem : card H = card (orbit hom H a) * card (stab hom H a) := + calc card H = card (fin_lcosets (stab hom H a) H) * card (stab hom H a) : lagrange_theorem stab_subset + ... = card (image (moverset hom H a) (orbit hom H a)) * card (stab hom H a) : subg_moversets_of_orbit_eq_stab_lcosets + ... = card (orbit hom H a) * card (stab hom H a) : card_image_eq_of_inj_on moverset_inj_on_orbit + +end orbit_stabilizer + +section orbit_partition + +variables {G S : Type} [group G] [decidable_eq G] [fintype S] [decidable_eq S] +variables {hom : G → perm S} [Hom : is_hom_class hom] {H : finset G} [subgH : is_finsubg H] +include Hom subgH + +lemma in_orbit_refl {a : S} : a ∈ orbit hom H a := +mem_image (mem_image (finsubg_has_one H) (hom_map_one hom)) rfl + +lemma in_orbit_trans {a b c : S} : + a ∈ orbit hom H b → b ∈ orbit hom H c → a ∈ orbit hom H c := +assume Painb Pbinc, +obtain h PhinH Phba, from exists_of_orbit Painb, +obtain g PginH Pgcb, from exists_of_orbit Pbinc, +orbit_of_exists (exists.intro (h*g) (and.intro + (finsubg_mul_closed H PhinH PginH) + (calc hom (h*g) c = perm.f ((hom h) * (hom g)) c : is_hom hom + ... = ((hom h) ∘ (hom g)) c : by rewrite perm_f_mul + ... = (hom h) b : Pgcb + ... = a : Phba))) + +lemma in_orbit_symm {a b : S} : a ∈ orbit hom H b → b ∈ orbit hom H a := +assume Painb, obtain h PhinH Phba, from exists_of_orbit Painb, +have perm.f (hom h)⁻¹ a = b, by rewrite [-Phba, -perm_f_mul, mul.left_inv], +have (hom h⁻¹) a = b, by rewrite [hom_map_inv, this], +orbit_of_exists (exists.intro h⁻¹ (and.intro (finsubg_has_inv H PhinH) this)) + +lemma orbit_is_partition : is_partition (orbit hom H) := +take a b, propext (iff.intro + (assume Painb, obtain h PhinH Phba, from exists_of_orbit Painb, + ext take c, iff.intro + (assume Pcina, in_orbit_trans Pcina Painb) + (assume Pcinb, obtain g PginH Pgbc, from exists_of_orbit Pcinb, + in_orbit_trans Pcinb (in_orbit_symm Painb))) + (assume Peq, Peq ▸ in_orbit_refl)) + +variables (hom) (H) +open nat finset.partition fintype + +definition orbit_partition : @partition S _ := +mk univ (orbit hom H) orbit_is_partition + (restriction_imp_union (orbit hom H) orbit_is_partition (λ a Pa, !subset_univ)) + +definition orbits : finset (finset S) := equiv_classes (orbit_partition hom H) + +definition fixed_point_orbits : finset (finset S) := + {cls ∈ orbits hom H | card cls = 1} + +variables {hom} {H} + +lemma exists_iff_mem_orbits (orb : finset S) : + orb ∈ orbits hom H ↔ ∃ a : S, orbit hom H a = orb := +begin + esimp [orbits, equiv_classes, orbit_partition], + rewrite [mem_image_iff], + apply iff.intro, + intro Pl, + cases Pl with a Pa, + rewrite (and_left_true !mem_univ) at Pa, + existsi a, exact Pa, + intro Pr, + cases Pr with a Pa, + rewrite -true_and at Pa, rewrite -(iff_true_intro (mem_univ a)) at Pa, + existsi a, exact Pa +end + +lemma exists_of_mem_orbits {orb : finset S} : + orb ∈ orbits hom H → ∃ a : S, orbit hom H a = orb := +iff.elim_left (exists_iff_mem_orbits orb) + +lemma fixed_point_orbits_eq : fixed_point_orbits hom H = image (orbit hom H) (fixed_points hom H) := +ext take s, iff.intro + (assume Pin, + obtain Psin Ps, from iff.elim_left !mem_sep_iff Pin, + obtain a Pa, from exists_of_mem_orbits Psin, + mem_image + (mem_sep_of_mem !mem_univ (eq.symm + (eq_of_card_eq_of_subset (by rewrite [Pa, Ps]) + (subset_of_forall + take x, assume Pxin, eq_of_mem_singleton Pxin ▸ in_orbit_refl)))) + Pa) + (assume Pin, + obtain a Pain Porba, from exists_of_mem_image Pin, + mem_sep_of_mem + (begin esimp [orbits, equiv_classes, orbit_partition], rewrite [mem_image_iff], + existsi a, exact and.intro !mem_univ Porba end) + (begin substvars, rewrite [of_mem_sep Pain] end)) + +lemma orbit_inj_on_fixed_points : set.inj_on (orbit hom H) (ts (fixed_points hom H)) := +take a₁ a₂, begin + rewrite [-*mem_eq_mem_to_set, ↑fixed_points, *mem_sep_iff], + intro Pa₁ Pa₂, + rewrite [and.right Pa₁, and.right Pa₂], + exact eq_of_singleton_eq +end + +lemma card_fixed_point_orbits_eq : card (fixed_point_orbits hom H) = card (fixed_points hom H) := +by rewrite fixed_point_orbits_eq; apply card_image_eq_of_inj_on orbit_inj_on_fixed_points + +lemma orbit_class_equation : card S = Sum (orbits hom H) card := +class_equation (orbit_partition hom H) + +lemma card_fixed_point_orbits : Sum (fixed_point_orbits hom H) card = card (fixed_point_orbits hom H) := +calc Sum _ _ = Sum (fixed_point_orbits hom H) (λ x, 1) : Sum_ext (take c Pin, of_mem_sep Pin) + ... = card (fixed_point_orbits hom H) * 1 : Sum_const_eq_card_mul + ... = card (fixed_point_orbits hom H) : mul_one (card (fixed_point_orbits hom H)) + +local attribute nat.comm_semiring [instance] +lemma orbit_class_equation' : card S = card (fixed_points hom H) + Sum {cls ∈ orbits hom H | card cls ≠ 1} card := +calc card S = Sum (orbits hom H) finset.card : orbit_class_equation + ... = Sum (fixed_point_orbits hom H) finset.card + Sum {cls ∈ orbits hom H | card cls ≠ 1} card : Sum_binary_union + ... = card (fixed_point_orbits hom H) + Sum {cls ∈ orbits hom H | card cls ≠ 1} card : by rewrite -card_fixed_point_orbits + ... = card (fixed_points hom H) + Sum {cls ∈ orbits hom H | card cls ≠ 1} card : by rewrite card_fixed_point_orbits_eq + +end orbit_partition + +section cayley +variables {G : Type} [group G] [fintype G] + +definition action_by_lmul : G → perm G := +take g, perm.mk (lmul_by g) (lmul_inj g) + +variable [decidable_eq G] + +lemma action_by_lmul_hom : homomorphic (@action_by_lmul G _ _) := +take g₁ (g₂ : G), eq.symm (calc + action_by_lmul g₁ * action_by_lmul g₂ + = perm.mk ((lmul_by g₁)∘(lmul_by g₂)) _ : rfl +... = perm.mk (lmul_by (g₁*g₂)) _ : by congruence; apply coset.lmul_compose) + +lemma action_by_lmul_inj : injective (@action_by_lmul G _ _) := +take g₁ g₂, assume Peq, perm.no_confusion Peq + (λ Pfeq Pqeq, + have Pappeq : g₁*1 = g₂*1, from congr_fun Pfeq _, + calc g₁ = g₁ * 1 : mul_one + ... = g₂ * 1 : Pappeq + ... = g₂ : mul_one) + +attribute [instance] +definition action_by_lmul_is_iso : is_iso_class (@action_by_lmul G _ _) := +is_iso_class.mk action_by_lmul_hom action_by_lmul_inj + +end cayley + +section lcosets +open fintype subtype + +variables {G : Type} [group G] [fintype G] [decidable_eq G] + +variables H : finset G + +definition action_on_lcoset : G → perm (lcoset_type univ H) := +take g, perm.mk (lcoset_lmul (mem_univ g)) lcoset_lmul_inj + +private definition lcoset_of (g : G) : lcoset_type univ H := +tag (fin_lcoset H g) (exists.intro g (and.intro !mem_univ rfl)) + +variable {H} + +lemma action_on_lcoset_eq (g : G) (J : lcoset_type univ H) + : elt_of (action_on_lcoset H g J) = fin_lcoset (elt_of J) g := rfl + +lemma action_on_lcoset_hom : homomorphic (action_on_lcoset H) := +take g₁ g₂, eq_of_feq (funext take S, subtype.eq + (by rewrite [↑action_on_lcoset, ↑lcoset_lmul, -fin_lcoset_compose])) + +attribute [instance] +definition action_on_lcoset_is_hom : is_hom_class (action_on_lcoset H) := +is_hom_class.mk action_on_lcoset_hom + +variable [finsubgH : is_finsubg H] +include finsubgH + +lemma aol_fixed_point_subset_normalizer (J : lcoset_type univ H) : + is_fixed_point (action_on_lcoset H) H J → elt_of J ⊆ normalizer H := +obtain j Pjin Pj, from exists_of_lcoset_type J, +assume Pfp, +have PH : ∀ {h}, h ∈ H → fin_lcoset (fin_lcoset H j) h = fin_lcoset H j, + from take h, assume Ph, by rewrite [Pj, -action_on_lcoset_eq, Pfp h Ph], +subset_of_forall take g, begin + rewrite [-Pj, fin_lcoset_same, -inv_inv at {2}], + intro Pg, + rewrite -Pg at PH, + apply finsubg_has_inv, + apply mem_sep_of_mem !mem_univ, + intro h Ph, + have Phg : fin_lcoset (fin_lcoset H g) h = fin_lcoset H g, from PH Ph, + revert Phg, + rewrite [↑conj_by, inv_inv, mul.assoc, fin_lcoset_compose, -fin_lcoset_same, ↑fin_lcoset, mem_image_iff, ↑lmul_by], + intro Pex, cases Pex with k Pand, cases Pand with Pkin Pk, + rewrite [-Pk, inv_mul_cancel_left], exact Pkin +end + +lemma aol_fixed_point_of_mem_normalizer {g : G} : + g ∈ normalizer H → is_fixed_point (action_on_lcoset H) H (lcoset_of H g) := +assume Pgin, take h, assume Phin, subtype.eq + (by rewrite [action_on_lcoset_eq, ↑lcoset_of, lrcoset_same_of_mem_normalizer Pgin, fin_lrcoset_comm, finsubg_lcoset_id Phin]) + +lemma aol_fixed_points_eq_normalizer : + Union (fixed_points (action_on_lcoset H) H) elt_of = normalizer H := +ext take g, begin + rewrite [mem_Union_iff], + apply iff.intro, + intro Pl, + cases Pl with L PL, revert PL, + rewrite [is_fixed_point_iff_mem_fixed_points], + intro Pg, + apply mem_of_subset_of_mem, + apply aol_fixed_point_subset_normalizer L, exact and.left Pg, + exact and.right Pg, + intro Pr, + existsi (lcoset_of H g), apply and.intro, + rewrite [is_fixed_point_iff_mem_fixed_points], + exact aol_fixed_point_of_mem_normalizer Pr, + exact fin_mem_lcoset g +end + +open nat + +lemma card_aol_fixed_points_eq_card_cosets : + card (fixed_points (action_on_lcoset H) H) = card (lcoset_type (normalizer H) H) := +have Peq : card (fixed_points (action_on_lcoset H) H) * card H = card (lcoset_type (normalizer H) H) * card H, from calc + card _ * card H = card (Union (fixed_points (action_on_lcoset H) H) elt_of) : card_Union_lcosets + ... = card (normalizer H) : aol_fixed_points_eq_normalizer + ... = card (lcoset_type (normalizer H) H) * card H : lagrange_theorem' subset_normalizer, +eq_of_mul_eq_mul_right (card_pos_of_mem !finsubg_has_one) Peq + +end lcosets + +section perm_fin +open fin nat eq.ops + +variable {n : nat} + +definition lift_perm (p : perm (fin n)) : perm (fin (succ n)) := +perm.mk (lift_fun p) (lift_fun_of_inj (perm.inj p)) + +definition lower_perm (p : perm (fin (succ n))) (P : p maxi = maxi) : perm (fin n) := +perm.mk (lower_inj p (perm.inj p) P) + (take i j, begin + rewrite [-eq_iff_veq, *lower_inj_apply, eq_iff_veq], + apply injective_comp (perm.inj p) lift_succ_inj + end) + +lemma lift_lower_eq : ∀ {p : perm (fin (succ n))} (P : p maxi = maxi), + lift_perm (lower_perm p P) = p +| (perm.mk pf Pinj) := assume Pmax, begin + rewrite [↑lift_perm], congruence, + apply funext, intro i, + have Pfmax : pf maxi = maxi, by apply Pmax, + have Pd : decidable (i = maxi), from _, + cases Pd with Pe Pne, + rewrite [Pe, Pfmax], apply lift_fun_max, + rewrite [lift_fun_of_ne_max Pne, ↑lower_perm, ↑lift_succ], + rewrite [-eq_iff_veq, -val_lift, lower_inj_apply, eq_iff_veq], + congruence, rewrite [-eq_iff_veq] + end + +lemma lift_perm_inj : injective (@lift_perm n) := +take p1 p2, assume Peq, eq_of_feq (lift_fun_inj (feq_of_eq Peq)) + +lemma lift_perm_inj_on_univ : set.inj_on (@lift_perm n) (ts univ) := +eq.symm to_set_univ ▸ iff.elim_left set.injective_iff_inj_on_univ lift_perm_inj + +lemma lift_to_stab : image (@lift_perm n) univ = stab id univ maxi := +ext (take (pp : perm (fin (succ n))), iff.intro + (assume Pimg, obtain p P_ Pp, from exists_of_mem_image Pimg, + have Ppp : pp maxi = maxi, from calc + pp maxi = lift_perm p maxi : {eq.symm Pp} + ... = lift_fun p maxi : rfl + ... = maxi : lift_fun_max, + mem_sep_of_mem !mem_univ Ppp) + (assume Pstab, + have Ppp : pp maxi = maxi, from of_mem_sep Pstab, + mem_image !mem_univ (lift_lower_eq Ppp))) + +definition move_from_max_to (i : fin (succ n)) : perm (fin (succ n)) := +perm.mk (madd (i - maxi)) madd_inj + +lemma orbit_max : orbit (@id (perm (fin (succ n)))) univ maxi = univ := +ext (take i, iff.intro + (assume P, !mem_univ) + (assume P, begin + apply mem_image, + apply mem_image, + apply mem_univ (move_from_max_to i), apply rfl, + apply sub_add_cancel + end)) + +lemma card_orbit_max : card (orbit (@id (perm (fin (succ n)))) univ maxi) = succ n := +calc card (orbit (@id (perm (fin (succ n)))) univ maxi) = card univ : by rewrite orbit_max + ... = succ n : card_fin (succ n) + +open fintype + +lemma card_lift_to_stab : card (stab (@id (perm (fin (succ n)))) univ maxi) = card (perm (fin n)) := + calc finset.card (stab (@id (perm (fin (succ n)))) univ maxi) + = finset.card (image (@lift_perm n) univ) : by rewrite lift_to_stab +... = card univ : by rewrite (card_image_eq_of_inj_on lift_perm_inj_on_univ) + +lemma card_perm_step : card (perm (fin (succ n))) = (succ n) * card (perm (fin n)) := + calc card (perm (fin (succ n))) + = card (orbit id univ maxi) * card (stab id univ maxi) : orbit_stabilizer_theorem +... = (succ n) * card (stab id univ maxi) : {card_orbit_max} +... = (succ n) * card (perm (fin n)) : by rewrite -card_lift_to_stab + +end perm_fin +end group_theory diff --git a/old_library/theories/group_theory/cyclic.lean b/old_library/theories/group_theory/cyclic.lean new file mode 100644 index 0000000000..8b6d2539fe --- /dev/null +++ b/old_library/theories/group_theory/cyclic.lean @@ -0,0 +1,397 @@ +/- +Copyright (c) 2015 Haitao Zhang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author : Haitao Zhang +-/ + +import data algebra.group algebra.group_power .finsubg .hom .perm + +open function finset +open eq.ops + +namespace group_theory + +section cyclic +open nat fin list +local attribute madd [reducible] + +variable {A : Type} +variable [ambG : group A] +include ambG + +lemma pow_mod {a : A} {n m : nat} : a ^ m = 1 → a ^ n = a ^ (n % m) := +assume Pid, +have a ^ (n / m * m) = 1, from calc + a ^ (n / m * m) = a ^ (m * (n / m)) : by rewrite (mul.comm (n / m) m) + ... = (a ^ m) ^ (n / m) : by rewrite pow_mul + ... = 1 ^ (n / m) : by rewrite Pid + ... = 1 : one_pow (n / m), +calc a ^ n = a ^ (n / m * m + n % m) : by rewrite -(eq_div_mul_add_mod n m) + ... = a ^ (n / m * m) * a ^ (n % m) : by rewrite pow_add + ... = 1 * a ^ (n % m) : by rewrite this + ... = a ^ (n % m) : by rewrite one_mul + +lemma pow_sub_eq_one_of_pow_eq {a : A} {i j : nat} : + a^i = a^j → a^(i - j) = 1 := +assume Pe, or.elim (lt_or_ge i j) + (assume Piltj, begin rewrite [sub_eq_zero_of_le (nat.le_of_lt Piltj)] end) + (assume Pigej, begin rewrite [pow_sub a Pigej, Pe, mul.right_inv] end) + +lemma pow_dist_eq_one_of_pow_eq {a : A} {i j : nat} : + a^i = a^j → a^(dist i j) = 1 := +assume Pe, or.elim (lt_or_ge i j) + (suppose i < j, by rewrite [dist_eq_sub_of_lt this]; exact pow_sub_eq_one_of_pow_eq (eq.symm Pe)) + (suppose i ≥ j, by rewrite [dist_eq_sub_of_ge this]; exact pow_sub_eq_one_of_pow_eq Pe) + +lemma pow_madd {a : A} {n : nat} {i j : fin (succ n)} : + a^(succ n) = 1 → a^(val (i + j)) = a^i * a^j := +assume Pe, calc +a^(val (i + j)) = a^((i + j) % (succ n)) : rfl + ... = a^(val i + val j) : by rewrite [-pow_mod Pe] + ... = a^i * a^j : by rewrite pow_add + +lemma mk_pow_mod {a : A} {n m : nat} : a ^ (succ m) = 1 → a ^ n = a ^ (mk_mod m n) := +assume Pe, pow_mod Pe + +variable [finA : fintype A] +include finA + +open fintype + +variable [deceqA : decidable_eq A] +include deceqA + +lemma exists_pow_eq_one (a : A) : ∃ n, n < card A ∧ a ^ (succ n) = 1 := +let f := (λ i : fin (succ (card A)), a ^ i) in +have Pninj : ¬(injective f), from assume Pinj, + absurd (card_le_of_inj _ _ (exists.intro f Pinj)) + (begin rewrite [card_fin], apply not_succ_le_self end), +obtain i₁ P₁, from exists_not_of_not_forall Pninj, +obtain i₂ P₂, from exists_not_of_not_forall P₁, +obtain Pfe Pne, from and_not_of_not_implies P₂, +have Pvne : val i₁ ≠ val i₂, from assume Pveq, absurd (eq_of_veq Pveq) Pne, +exists.intro (pred (dist i₁ i₂)) (begin + rewrite [succ_pred_of_pos (dist_pos_of_ne Pvne)], apply and.intro, + apply lt_of_succ_lt_succ, + rewrite [succ_pred_of_pos (dist_pos_of_ne Pvne)], + apply nat.lt_of_le_of_lt dist_le_max (max_lt i₁ i₂), + apply pow_dist_eq_one_of_pow_eq Pfe + end) + +-- Another possibility is to generate a list of powers and use find to get the first +-- unity. +-- The bound on bex is arbitrary as long as it is large enough (at least card A). Making +-- it larger simplifies some proofs, such as a ∈ cyc a. +definition cyc (a : A) : finset A := {x ∈ univ | bex (succ (card A)) (λ n, a ^ n = x)} + +definition order (a : A) := card (cyc a) + +definition pow_fin (a : A) (n : nat) (i : fin (order a)) := a ^ (i + n) + +definition cyc_pow_fin (a : A) (n : nat) : finset A := image (pow_fin a n) univ + +lemma order_le_group_order {a : A} : order a ≤ card A := +card_le_card_of_subset !subset_univ + +lemma cyc_has_one (a : A) : 1 ∈ cyc a := +begin + apply mem_sep_of_mem !mem_univ, + existsi 0, apply and.intro, + apply zero_lt_succ, + apply pow_zero +end + +lemma order_pos (a : A) : 0 < order a := +length_pos_of_mem (cyc_has_one a) + +lemma cyc_mul_closed (a : A) : finset_mul_closed_on (cyc a) := +take g h, assume Pgin Phin, +obtain n Plt Pe, from exists_pow_eq_one a, +obtain i Pilt Pig, from of_mem_sep Pgin, +obtain j Pjlt Pjh, from of_mem_sep Phin, +begin + rewrite [-Pig, -Pjh, -pow_add, pow_mod Pe], + apply mem_sep_of_mem !mem_univ, + existsi ((i + j) % (succ n)), apply and.intro, + apply nat.lt_trans (mod_lt (i+j) !zero_lt_succ) (succ_lt_succ Plt), + apply rfl +end + +lemma cyc_has_inv (a : A) : finset_has_inv (cyc a) := +take g, assume Pgin, +obtain n Plt Pe, from exists_pow_eq_one a, +obtain i Pilt Pig, from of_mem_sep Pgin, +let ni := -(mk_mod n i) in +have Pinv : g*a^ni = 1, by + rewrite [-Pig, mk_pow_mod Pe, -(pow_madd Pe), add.right_inv], +begin + rewrite [inv_eq_of_mul_eq_one Pinv], + apply mem_sep_of_mem !mem_univ, + existsi ni, apply and.intro, + apply nat.lt_trans (is_lt ni) (succ_lt_succ Plt), + apply rfl +end + +lemma self_mem_cyc (a : A) : a ∈ cyc a := +mem_sep_of_mem !mem_univ + (exists.intro (1 : nat) (and.intro (succ_lt_succ card_pos) !pow_one)) + +lemma mem_cyc (a : A) : ∀ {n : nat}, a^n ∈ cyc a +| 0 := cyc_has_one a +| (succ n) := + begin rewrite pow_succ', apply cyc_mul_closed a, exact mem_cyc, apply self_mem_cyc end + +lemma order_le {a : A} {n : nat} : a^(succ n) = 1 → order a ≤ succ n := +assume Pe, let s := image (pow_nat a) (upto (succ n)) in +have Psub: cyc a ⊆ s, from subset_of_forall + (take g, assume Pgin, obtain i Pilt Pig, from of_mem_sep Pgin, begin + rewrite [-Pig, pow_mod Pe], + apply mem_image, + apply mem_upto_of_lt (mod_lt i !zero_lt_succ), + exact rfl end), +#nat calc order a ≤ card s : card_le_card_of_subset Psub + ... ≤ card (upto (succ n)) : !card_image_le + ... = succ n : card_upto (succ n) + +lemma pow_ne_of_lt_order {a : A} {n : nat} : succ n < order a → a^(succ n) ≠ 1 := +assume Plt, not_imp_not_of_imp order_le (not_le_of_gt Plt) + +lemma eq_zero_of_pow_eq_one {a : A} : ∀ {n : nat}, a^n = 1 → n < order a → n = 0 +| 0 := assume Pe Plt, rfl +| (succ n) := assume Pe Plt, absurd Pe (pow_ne_of_lt_order Plt) + +lemma pow_fin_inj (a : A) (n : nat) : injective (pow_fin a n) := +take i j : fin (order a), +suppose a^(i + n) = a^(j + n), +have a^(dist i j) = 1, begin apply !dist_add_add_right ▸ (pow_dist_eq_one_of_pow_eq this) end, +have dist i j = 0, from + eq_zero_of_pow_eq_one this (nat.lt_of_le_of_lt dist_le_max (max_lt i j)), +eq_of_veq (eq_of_dist_eq_zero this) + +lemma cyc_eq_cyc (a : A) (n : nat) : cyc_pow_fin a n = cyc a := +have Psub : cyc_pow_fin a n ⊆ cyc a, from subset_of_forall + (take g, assume Pgin, + obtain i Pin Pig, from exists_of_mem_image Pgin, by rewrite [-Pig]; apply mem_cyc), +eq_of_card_eq_of_subset (begin apply eq.trans, + apply card_image_eq_of_inj_on, + rewrite [to_set_univ, -set.injective_iff_inj_on_univ], exact pow_fin_inj a n, + rewrite [card_fin] end) Psub + +lemma pow_order (a : A) : a^(order a) = 1 := +obtain i Pin Pone, from exists_of_mem_image (eq.symm (cyc_eq_cyc a 1) ▸ cyc_has_one a), +or.elim (eq_or_lt_of_le (succ_le_of_lt (is_lt i))) + (assume P, P ▸ Pone) (assume P, absurd Pone (pow_ne_of_lt_order P)) + +lemma eq_one_of_order_eq_one {a : A} : order a = 1 → a = 1 := +assume Porder, +calc a = a^1 : by rewrite (pow_one a) + ... = a^(order a) : by rewrite Porder + ... = 1 : by rewrite pow_order + +lemma order_of_min_pow {a : A} {n : nat} + (Pone : a^(succ n) = 1) (Pmin : ∀ i, i < n → a^(succ i) ≠ 1) : order a = succ n := +or.elim (eq_or_lt_of_le (order_le Pone)) (λ P, P) + (λ P : order a < succ n, begin + have Pn : a^(order a) ≠ 1, + begin + rewrite [-(succ_pred_of_pos (order_pos a))], + apply Pmin, apply nat.lt_of_succ_lt_succ, + rewrite [succ_pred_of_pos !order_pos], assumption + end, + exact absurd (pow_order a) Pn end) + +lemma order_dvd_of_pow_eq_one {a : A} {n : nat} (Pone : a^n = 1) : order a ∣ n := +have Pe : a^(n % order a) = 1, from + begin + revert Pone, + rewrite [eq_div_mul_add_mod n (order a) at {1}, pow_add, mul.comm _ (order a), pow_mul, pow_order, one_pow, one_mul], + intros, assumption + end, +dvd_of_mod_eq_zero (eq_zero_of_pow_eq_one Pe (mod_lt n !order_pos)) + +attribute [instance] +definition cyc_is_finsubg (a : A) : is_finsubg (cyc a) := +is_finsubg.mk (cyc_has_one a) (cyc_mul_closed a) (cyc_has_inv a) + +lemma order_dvd_group_order (a : A) : order a ∣ card A := +dvd.intro (eq.symm (!mul.comm ▸ lagrange_theorem (subset_univ (cyc a)))) + +definition pow_fin' (a : A) (i : fin (succ (pred (order a)))) := pow_nat a i + +local attribute group_of_add_group [instance] + +lemma pow_fin_hom (a : A) : homomorphic (pow_fin' a) := +take i j : fin (succ (pred (order a))), +begin + rewrite [↑pow_fin'], + apply pow_madd, + rewrite [succ_pred_of_pos !order_pos], + exact pow_order a +end + +definition pow_fin_is_iso (a : A) : is_iso_class (pow_fin' a) := +is_iso_class.mk (pow_fin_hom a) + (have H : injective (λ (i : fin (order a)), a ^ (val i + 0)), from pow_fin_inj a 0, + begin rewrite [↑pow_fin', succ_pred_of_pos !order_pos]; exact H end) + +end cyclic + +section rot +open nat list +open fin fintype list + +section +local attribute group_of_add_group [instance] +lemma pow_eq_mul {n : nat} {i : fin (succ n)} : ∀ {k : nat}, i^k = mk_mod n (i*k) +| 0 := by rewrite [pow_zero] +| (succ k) := begin + have Psucc : i^(succ k) = madd (i^k) i, by apply pow_succ', + rewrite [Psucc, pow_eq_mul], + apply eq_of_veq, + rewrite [mul_succ, val_madd, ↑mk_mod, mod_add_mod] + end + +end + +definition rotl : ∀ {n : nat} m : nat, fin n → fin n +| 0 := take m i, elim0 i +| (succ n) := take m, madd (mk_mod n (n*m)) + +definition rotr : ∀ {n : nat} m : nat, fin n → fin n +| (0:nat) := take m i, elim0 i +| (nat.succ n) := take m, madd (-(mk_mod n (n*m))) + +lemma rotl_succ' {n m : nat} : rotl m = madd (mk_mod n (n*m)) := rfl + +lemma rotl_zero : ∀ {n : nat}, @rotl n 0 = id +| 0 := funext take i, elim0 i +| (nat.succ n) := funext take i, begin rewrite [↑rotl, mul_zero, mk_mod_zero_eq, zero_madd] end + +lemma rotl_id : ∀ {n : nat}, @rotl n n = id +| 0 := funext take i, elim0 i +| (nat.succ n) := + have P : mk_mod n (n * succ n) = mk_mod n 0, + from eq_of_veq (by rewrite [↑mk_mod, mul_mod_left]), + begin rewrite [rotl_succ', P], apply rotl_zero end + +lemma rotl_to_zero {n i : nat} : rotl i (mk_mod n i) = 0 := +eq_of_veq begin rewrite [↑rotl, val_madd], esimp [mk_mod], rewrite [ mod_add_mod, add_mod_mod, -succ_mul, mul_mod_right] end + +lemma rotl_compose : ∀ {n : nat} {j k : nat}, (@rotl n j) ∘ (rotl k) = rotl (j + k) +| 0 := take j k, funext take i, elim0 i +| (succ n) := take j k, funext take i, eq.symm begin + rewrite [*rotl_succ', left_distrib, -(@madd_mk_mod n (n*j)), madd_assoc], + end + +lemma rotr_rotl : ∀ {n : nat} (m : nat) {i : fin n}, rotr m (rotl m i) = i +| 0 := take m i, elim0 i +| (nat.succ n) := take m i, calc (-(mk_mod n (n*m))) + ((mk_mod n (n*m)) + i) = i : by rewrite neg_add_cancel_left + +lemma rotl_rotr : ∀ {n : nat} (m : nat), (@rotl n m) ∘ (rotr m) = id +| 0 := take m, funext take i, elim0 i +| (nat.succ n) := take m, funext take i, calc (mk_mod n (n*m)) + (-(mk_mod n (n*m)) + i) = i : add_neg_cancel_left + +lemma rotl_succ {n : nat} : (rotl 1) ∘ (@succ n) = lift_succ := +funext (take i, eq_of_veq (begin rewrite [↑comp, ↑rotl, ↑madd, mul_one n, ↑mk_mod, mod_add_mod, ↑lift_succ, val_succ, -succ_add_eq_succ_add, add_mod_self_left, mod_eq_of_lt (lt.trans (is_lt i) !lt_succ_self), -val_lift] end)) + +definition list.rotl {A : Type} : ∀ l : list A, list A +| [] := [] +| (a::l) := l++[a] + +lemma rotl_cons {A : Type} {a : A} {l} : list.rotl (a::l) = l++[a] := rfl + +lemma rotl_map {A B : Type} {f : A → B} : ∀ {l : list A}, list.rotl (map f l) = map f (list.rotl l) +| [] := rfl +| (a::l) := begin rewrite [map_cons, *rotl_cons, map_append] end + +lemma rotl_eq_rotl : ∀ {n : nat}, map (rotl 1) (upto n) = list.rotl (upto n) +| 0 := rfl +| (succ n) := begin + rewrite [upto_step at {1}, fin.upto_succ, rotl_cons, map_append], + congruence, + rewrite [map_map], congruence, exact rotl_succ, + rewrite [map_singleton], congruence, rewrite [↑rotl, mul_one n, ↑mk_mod, ↑maxi, ↑madd], + congruence, rewrite [ mod_add_mod, val_zero, add_zero, mod_eq_of_lt !lt_succ_self ] + end + +attribute [reducible] +definition seq (A : Type) (n : nat) := fin n → A + +variable {A : Type} + +definition rotl_fun {n : nat} (m : nat) (f : seq A n) : seq A n := f ∘ (rotl m) +definition rotr_fun {n : nat} (m : nat) (f : seq A n) : seq A n := f ∘ (rotr m) + +lemma rotl_seq_zero {n : nat} : rotl_fun 0 = @id (seq A n) := +funext take f, begin rewrite [↑rotl_fun, rotl_zero] end + +lemma rotl_seq_ne_id : ∀ {n : nat}, (∃ a b : A, a ≠ b) → ∀ i, i < n → rotl_fun (succ i) ≠ (@id (seq A (succ n))) +| 0 := assume Pex, take i, assume Piltn, absurd Piltn !not_lt_zero +| (nat.succ n) := assume Pex, obtain a b Pne, from Pex, take i, assume Pilt, + let f := (λ j : fin (succ (succ n)), if j = 0 then a else b), + fi := mk_mod (succ n) (succ i) in + have Pfne : rotl_fun (succ i) f fi ≠ f fi, + from begin rewrite [↑rotl_fun, rotl_to_zero, mk_mod_of_lt (succ_lt_succ Pilt), if_pos rfl, if_neg mk_succ_ne_zero], assumption end, + have P : rotl_fun (succ i) f ≠ f, from + assume Peq, absurd (congr_fun Peq fi) Pfne, + assume Peq, absurd (congr_fun Peq f) P + +lemma rotr_rotl_fun {n : nat} (m : nat) (f : seq A n) : rotr_fun m (rotl_fun m f) = f := +calc f ∘ (rotl m) ∘ (rotr m) = f ∘ ((rotl m) ∘ (rotr m)) : by rewrite -comp.assoc + ... = f ∘ id : by rewrite (rotl_rotr m) + +lemma rotl_fun_inj {n : nat} {m : nat} : @injective (seq A n) (seq A n) (rotl_fun m) := +injective_of_has_left_inverse (exists.intro (rotr_fun m) (rotr_rotl_fun m)) + +lemma seq_rotl_eq_list_rotl {n : nat} (f : seq A n) : + fun_to_list (rotl_fun 1 f) = list.rotl (fun_to_list f) := +begin + rewrite [↑fun_to_list, ↑rotl_fun, -map_map, rotl_map], + congruence, exact rotl_eq_rotl +end + +end rot + +section rotg +open nat fin fintype + +attribute [reducible] +definition rotl_perm (A : Type) [finA : fintype A] [deceqA : decidable_eq A] (n : nat) (m : nat) : perm (seq A n) := +perm.mk (rotl_fun m) rotl_fun_inj + +variable {A : Type} +variable [finA : fintype A] +variable [deceqA : decidable_eq A] +variable {n : nat} +include finA deceqA + +lemma rotl_perm_mul {i j : nat} : (rotl_perm A n i) * (rotl_perm A n j) = rotl_perm A n (j+i) := +eq_of_feq (funext take f, calc + f ∘ (rotl j) ∘ (rotl i) = f ∘ ((rotl j) ∘ (rotl i)) : by rewrite -comp.assoc + ... = f ∘ (rotl (j+i)) : by rewrite rotl_compose) + +lemma rotl_perm_pow_eq : ∀ {i : nat}, (rotl_perm A n 1) ^ i = rotl_perm A n i +| 0 := begin rewrite [pow_zero, ↑rotl_perm, perm_one, -eq_iff_feq], esimp, rewrite rotl_seq_zero end +| (succ i) := begin rewrite [pow_succ', rotl_perm_pow_eq, rotl_perm_mul, one_add] end + +lemma rotl_perm_pow_eq_one : (rotl_perm A n 1) ^ n = 1 := +eq.trans rotl_perm_pow_eq (eq_of_feq begin esimp [rotl_perm], rewrite [↑rotl_fun, rotl_id] end) + +lemma rotl_perm_mod {i : nat} : rotl_perm A n i = rotl_perm A n (i % n) := +calc rotl_perm A n i = (rotl_perm A n 1) ^ i : by rewrite rotl_perm_pow_eq + ... = (rotl_perm A n 1) ^ (i % n) : by rewrite (pow_mod rotl_perm_pow_eq_one) + ... = rotl_perm A n (i % n) : by rewrite rotl_perm_pow_eq + +-- needs A to have at least two elements! +lemma rotl_perm_pow_ne_one (Pex : ∃ a b : A, a ≠ b) : ∀ i, i < n → (rotl_perm A (succ n) 1)^(succ i) ≠ 1 := +take i, assume Piltn, begin + intro P, revert P, rewrite [rotl_perm_pow_eq, -eq_iff_feq, perm_one, *perm.f_mk], + intro P, exact absurd P (rotl_seq_ne_id Pex i Piltn) +end + +lemma rotl_perm_order (Pex : ∃ a b : A, a ≠ b) : order (rotl_perm A (succ n) 1) = (succ n) := +order_of_min_pow rotl_perm_pow_eq_one (rotl_perm_pow_ne_one Pex) + +end rotg +end group_theory diff --git a/old_library/theories/group_theory/finsubg.lean b/old_library/theories/group_theory/finsubg.lean new file mode 100644 index 0000000000..f8ff6d382f --- /dev/null +++ b/old_library/theories/group_theory/finsubg.lean @@ -0,0 +1,538 @@ +/- +Copyright (c) 2015 Haitao Zhang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author : Haitao Zhang +-/ + +-- develop the concept of finite subgroups based on finsets so that the properties +-- can be used directly without translating from the set based theory first + +import data algebra.group .subgroup +open function finset +-- ⁻¹ in eq.ops conflicts with group ⁻¹ +open eq.ops + +namespace group_theory +open ops + +section subg +-- we should be able to prove properties using finsets directly +variables {G : Type} [group G] +variable [decidable_eq G] + +attribute [reducible] +definition finset_mul_closed_on (H : finset G) : Prop := + ∀ x y : G, x ∈ H → y ∈ H → x * y ∈ H +definition finset_has_inv (H : finset G) : Prop := + ∀ a : G, a ∈ H → a⁻¹ ∈ H + +structure is_finsubg [class] (H : finset G) : Type := + (has_one : 1 ∈ H) + (mul_closed : finset_mul_closed_on H) + (has_inv : finset_has_inv H) + +attribute [instance] +definition univ_is_finsubg [finG : fintype G] : is_finsubg (@finset.univ G _) := +is_finsubg.mk !mem_univ (λ x y Px Py, !mem_univ) (λ a Pa, !mem_univ) + +attribute [instance] +definition one_is_finsubg : is_finsubg ('{(1:G)}) := +is_finsubg.mk !mem_singleton + (λ x y Px Py, by rewrite [eq_of_mem_singleton Px, eq_of_mem_singleton Py, one_mul]; apply mem_singleton) + (λ x Px, by rewrite [eq_of_mem_singleton Px, one_inv]; apply mem_singleton) + +lemma finsubg_has_one (H : finset G) [h : is_finsubg H] : 1 ∈ H := + @is_finsubg.has_one G _ _ H h +lemma finsubg_mul_closed (H : finset G) [h : is_finsubg H] {x y : G} : x ∈ H → y ∈ H → x * y ∈ H := + @is_finsubg.mul_closed G _ _ H h x y +lemma finsubg_has_inv (H : finset G) [h : is_finsubg H] {a : G} : a ∈ H → a⁻¹ ∈ H := + @is_finsubg.has_inv G _ _ H h a + +attribute [instance] +definition finsubg_to_subg {H : finset G} [h : is_finsubg H] + : is_subgroup (ts H) := + is_subgroup.mk + (mem_eq_mem_to_set H 1 ▸ finsubg_has_one H) + (take x y, begin repeat rewrite -mem_eq_mem_to_set, + apply finsubg_mul_closed H end) + (take a, begin repeat rewrite -mem_eq_mem_to_set, + apply finsubg_has_inv H end) + +open nat +lemma finsubg_eq_singleton_one_of_card_one {H : finset G} [h : is_finsubg H] : + card H = 1 → H = '{1} := +assume Pcard, eq.symm (eq_of_card_eq_of_subset (by rewrite [Pcard]) + (subset_of_forall take g, + by rewrite [mem_singleton_iff]; intro Pg; rewrite Pg; exact finsubg_has_one H)) + +end subg + +section fin_lcoset + +open set + +variables {A : Type} [decidable_eq A] [group A] + +definition fin_lcoset (H : finset A) (a : A) := finset.image (lmul_by a) H + +definition fin_rcoset (H : finset A) (a : A) : finset A := image (rmul_by a) H + +definition fin_lcosets (H G : finset A) := image (fin_lcoset H) G + +definition fin_inv : finset A → finset A := image inv + +variable {H : finset A} + +lemma lmul_rmul {a b : A} : (lmul_by a) ∘ (rmul_by b) = (rmul_by b) ∘ (lmul_by a) := +funext take c, calc a*(c*b) = (a*c)*b : mul.assoc + +lemma fin_lrcoset_comm {a b : A} : + fin_lcoset (fin_rcoset H b) a = fin_rcoset (fin_lcoset H a) b := +by esimp [fin_lcoset, fin_rcoset]; rewrite [-*image_comp, lmul_rmul] + +lemma inv_mem_fin_inv {a : A} : a ∈ H → a⁻¹ ∈ fin_inv H := +assume Pin, mem_image Pin rfl + +lemma fin_lcoset_eq (a : A) : ts (fin_lcoset H a) = a ∘> (ts H) := calc + ts (fin_lcoset H a) = coset.l a (ts H) : to_set_image + ... = a ∘> (ts H) : glcoset_eq_lcoset + +lemma fin_lcoset_id : fin_lcoset H 1 = H := +by rewrite [eq_eq_to_set_eq, fin_lcoset_eq, glcoset_id] + +lemma fin_lcoset_compose (a b : A) : fin_lcoset (fin_lcoset H b) a = fin_lcoset H (a*b) := +to_set.inj (by rewrite [*fin_lcoset_eq, glcoset_compose]) + +lemma fin_lcoset_inv (a : A) : fin_lcoset (fin_lcoset H a) a⁻¹ = H := +to_set.inj (by rewrite [*fin_lcoset_eq, glcoset_inv]) + +lemma fin_lcoset_card (a : A) : card (fin_lcoset H a) = card H := + card_image_eq_of_inj_on (lmul_inj_on a (ts H)) +lemma fin_lcosets_card_eq {G : finset A} : ∀ gH, gH ∈ fin_lcosets H G → card gH = card H := + take gH, assume Pcosets, obtain g Pg, from exists_of_mem_image Pcosets, + and.right Pg ▸ fin_lcoset_card g + +variable [is_finsubgH : is_finsubg H] +include is_finsubgH + +lemma fin_lcoset_same (x a : A) : x ∈ (fin_lcoset H a) = (fin_lcoset H x = fin_lcoset H a) := + begin + rewrite mem_eq_mem_to_set, + rewrite [eq_eq_to_set_eq, *(fin_lcoset_eq x), fin_lcoset_eq a], + exact (subg_lcoset_same x a) + end +lemma fin_mem_lcoset (g : A) : g ∈ fin_lcoset H g := + have P : g ∈ g ∘> ts H, from and.left (subg_in_coset_refl g), + have P1 : g ∈ ts (fin_lcoset H g), from eq.symm (fin_lcoset_eq g) ▸ P, + eq.symm (mem_eq_mem_to_set _ g) ▸ P1 +lemma fin_lcoset_subset {S : finset A} (Psub : S ⊆ H) : ∀ x, x ∈ H → fin_lcoset S x ⊆ H := + have Psubs : set.subset (ts S) (ts H), from subset_eq_to_set_subset S H ▸ Psub, + take x, assume Pxs : x ∈ ts H, + have Pcoset : set.subset (x ∘> ts S) (ts H), from subg_lcoset_subset_subg Psubs x Pxs, + by rewrite [subset_eq_to_set_subset, fin_lcoset_eq x]; exact Pcoset + +lemma finsubg_lcoset_id {a : A} : a ∈ H → fin_lcoset H a = H := +by rewrite [eq_eq_to_set_eq, fin_lcoset_eq, mem_eq_mem_to_set]; apply subgroup_lcoset_id + +lemma finsubg_inv_lcoset_eq_rcoset {a : A} : + fin_inv (fin_lcoset H a) = fin_rcoset H a⁻¹ := +begin + esimp [fin_inv, fin_lcoset, fin_rcoset], + rewrite [-image_comp], + apply ext, intro b, + rewrite [*mem_image_iff, ↑comp, ↑lmul_by, ↑rmul_by], + apply iff.intro, + intro Pl, cases Pl with h Ph, cases Ph with Pin Peq, + existsi h⁻¹, apply and.intro, + exact finsubg_has_inv H Pin, + rewrite [-mul_inv, Peq], + intro Pr, cases Pr with h Ph, cases Ph with Pin Peq, + existsi h⁻¹, apply and.intro, + exact finsubg_has_inv H Pin, + rewrite [mul_inv, inv_inv, Peq], +end + +lemma finsubg_conj_closed {g h : A} : g ∈ H → h ∈ H → g ∘c h ∈ H := +assume Pgin Phin, finsubg_mul_closed H (finsubg_mul_closed H Pgin Phin) (finsubg_has_inv H Pgin) + +variable {G : finset A} +variable [is_finsubgG : is_finsubg G] +include is_finsubgG + +open finset.partition + +definition fin_lcoset_partition_subg (Psub : H ⊆ G) := + partition.mk G (fin_lcoset H) fin_lcoset_same + (restriction_imp_union (fin_lcoset H) fin_lcoset_same (fin_lcoset_subset Psub)) + +open nat + +theorem lagrange_theorem (Psub : H ⊆ G) : card G = card (fin_lcosets H G) * card H := calc + card G = finset.Sum (fin_lcosets H G) card : class_equation (fin_lcoset_partition_subg Psub) + ... = finset.Sum (fin_lcosets H G) (λ x, card H) : finset.Sum_ext (take g P, fin_lcosets_card_eq g P) + ... = card (fin_lcosets H G) * card H : Sum_const_eq_card_mul + +end fin_lcoset + +section +open fintype list subtype + +lemma dinj_tag {A : Type} (P : A → Prop) : dinj P tag := +take a₁ a₂ Pa₁ Pa₂ Pteq, subtype.no_confusion Pteq (λ Pe Pqe, Pe) + +open nat + +lemma card_pos {A : Type} [ambientA : group A] [finA : fintype A] : 0 < card A := + length_pos_of_mem (mem_univ 1) + +end + +section lcoset_fintype +open fintype list subtype + +variables {A : Type} [group A] [fintype A] [decidable_eq A] + +variables G H : finset A + +attribute [reducible] +definition is_fin_lcoset (S : finset A) : Prop := + ∃ g, g ∈ G ∧ fin_lcoset H g = S + +definition to_list : list A := list.filter (λ g, g ∈ G) (elems A) + +definition list_lcosets : list (finset A) := erase_dup (map (fin_lcoset H) (to_list G)) + +attribute [reducible] +definition lcoset_type : Type := {S : finset A | is_fin_lcoset G H S} + +definition all_lcosets : list (lcoset_type G H) := +dmap (is_fin_lcoset G H) tag (list_lcosets G H) + +variables {G H} [finsubgG : is_finsubg G] + +include finsubgG + +lemma self_is_lcoset : is_fin_lcoset G H H := +exists.intro 1 (and.intro !finsubg_has_one fin_lcoset_id) + +lemma lcoset_subset_of_subset (J : lcoset_type G H) : H ⊆ G → elt_of J ⊆ G := +assume Psub, obtain j Pjin Pj, from has_property J, +by rewrite [-Pj]; apply fin_lcoset_subset Psub; exact Pjin + +variables (G H) + +definition lcoset_one : lcoset_type G H := tag H self_is_lcoset + +variables {G H} + +definition lcoset_lmul {g : A} (Pgin : g ∈ G) (S : lcoset_type G H) + : lcoset_type G H := +tag (fin_lcoset (elt_of S) g) + (obtain f Pfin Pf, from has_property S, + exists.intro (g*f) + (by apply and.intro; + exact finsubg_mul_closed G Pgin Pfin; + rewrite [-Pf, -fin_lcoset_compose])) + +definition lcoset_mul (S₁ S₂ : lcoset_type G H): finset A := +Union (elt_of S₁) (fin_lcoset (elt_of S₂)) + +lemma mul_mem_lcoset_mul (J K : lcoset_type G H) {g h} : + g ∈ elt_of J → h ∈ elt_of K → g*h ∈ lcoset_mul J K := +assume Pg, begin + rewrite [↑lcoset_mul, mem_Union_iff, ↑fin_lcoset], + intro Ph, existsi g, apply and.intro, exact Pg, + rewrite [mem_image_iff, ↑lmul_by], + existsi h, exact and.intro Ph rfl +end + +lemma is_lcoset_of_mem_list_lcosets {S : finset A} + : S ∈ list_lcosets G H → is_fin_lcoset G H S := +assume Pin, obtain g Pgin Pg, from exists_of_mem_map (mem_of_mem_erase_dup Pin), +exists.intro g (and.intro (of_mem_filter Pgin) Pg) + +lemma mem_list_lcosets_of_is_lcoset {S : finset A} + : is_fin_lcoset G H S → S ∈ list_lcosets G H := +assume Plcoset, obtain g Pgin Pg, from Plcoset, +Pg ▸ mem_erase_dup (mem_map _ (mem_filter_of_mem (complete g) Pgin)) + +lemma fin_lcosets_eq : + fin_lcosets H G = to_finset_of_nodup (list_lcosets G H) !nodup_erase_dup := +ext (take S, iff.intro + (λ Pimg, mem_list_lcosets_of_is_lcoset (exists_of_mem_image Pimg)) + (λ Pl, obtain g Pg, from is_lcoset_of_mem_list_lcosets Pl, + iff.elim_right !mem_image_iff (is_lcoset_of_mem_list_lcosets Pl))) + +lemma length_all_lcosets : length (all_lcosets G H) = card (fin_lcosets H G) := +eq.trans + (show length (all_lcosets G H) = length (list_lcosets G H), from + have Pmap : map elt_of (all_lcosets G H) = list_lcosets G H, from + map_dmap_of_inv_of_pos (λ S P, rfl) (λ S, is_lcoset_of_mem_list_lcosets), + by rewrite[-Pmap, length_map]) + (by rewrite fin_lcosets_eq) + +lemma lcoset_lmul_compose {f g : A} (Pf : f ∈ G) (Pg : g ∈ G) (S : lcoset_type G H) : +lcoset_lmul Pf (lcoset_lmul Pg S) = lcoset_lmul (finsubg_mul_closed G Pf Pg) S := +subtype.eq !fin_lcoset_compose + +lemma lcoset_lmul_one (S : lcoset_type G H) : lcoset_lmul !finsubg_has_one S = S := +subtype.eq fin_lcoset_id + +lemma lcoset_lmul_inv {g : A} {Pg : g ∈ G} (S : lcoset_type G H) : + lcoset_lmul (finsubg_has_inv G Pg) (lcoset_lmul Pg S) = S := +subtype.eq (to_set.inj begin + esimp [lcoset_lmul], + rewrite [fin_lcoset_compose, mul.left_inv, fin_lcoset_eq, glcoset_id] +end) + +lemma lcoset_lmul_inj {g : A} {Pg : g ∈ G}: + @injective (lcoset_type G H) _ (lcoset_lmul Pg) := +injective_of_has_left_inverse (exists.intro (lcoset_lmul (finsubg_has_inv G Pg)) lcoset_lmul_inv) + +lemma card_elt_of_lcoset_type (S : lcoset_type G H) : card (elt_of S) = card H := +obtain f Pfin Pf, from has_property S, Pf ▸ fin_lcoset_card f + +attribute [instance] +definition lcoset_fintype : fintype (lcoset_type G H) := +fintype.mk (all_lcosets G H) + (dmap_nodup_of_dinj (dinj_tag (is_fin_lcoset G H)) !nodup_erase_dup) + (take s, subtype.destruct s (take S, assume PS, mem_dmap PS (mem_list_lcosets_of_is_lcoset PS))) + +lemma card_lcoset_type : card (lcoset_type G H) = card (fin_lcosets H G) := +length_all_lcosets + +open nat +variable [finsubgH : is_finsubg H] +include finsubgH + +theorem lagrange_theorem' (Psub : H ⊆ G) : card G = card (lcoset_type G H) * card H := +calc card G = card (fin_lcosets H G) * card H : lagrange_theorem Psub + ... = card (lcoset_type G H) * card H : card_lcoset_type + +lemma lcoset_disjoint {S₁ S₂ : lcoset_type G H} : S₁ ≠ S₂ → elt_of S₁ ∩ elt_of S₂ = ∅ := +obtain f₁ Pfin₁ Pf₁, from has_property S₁, +obtain f₂ Pfin₂ Pf₂, from has_property S₂, +assume Pne, inter_eq_empty_of_disjoint (disjoint.intro + take g, begin + rewrite [-Pf₁, -Pf₂, *fin_lcoset_same], + intro Pgf₁, rewrite [Pgf₁, Pf₁, Pf₂], + intro Peq, exact absurd (subtype.eq Peq) Pne + end ) + +lemma card_Union_lcosets (lcs : finset (lcoset_type G H)) : + card (Union lcs elt_of) = card lcs * card H := +calc card (Union lcs elt_of) = ∑ lc ∈ lcs, card (elt_of lc) : card_Union_of_disjoint lcs elt_of (λ (S₁ S₂ : lcoset_type G H) P₁ P₂ Pne, lcoset_disjoint Pne) + ... = ∑ lc ∈ lcs, card H : Sum_ext (take lc P, card_elt_of_lcoset_type _) + ... = card lcs * card H : Sum_const_eq_card_mul + +lemma exists_of_lcoset_type (J : lcoset_type G H) : + ∃ j, j ∈ elt_of J ∧ fin_lcoset H j = elt_of J := +obtain j Pjin Pj, from has_property J, +exists.intro j (and.intro (Pj ▸ !fin_mem_lcoset) Pj) + +lemma lcoset_not_empty (J : lcoset_type G H) : elt_of J ≠ ∅ := +obtain j Pjin Pj, from has_property J, +assume Pempty, absurd (by rewrite [-Pempty, -Pj]; apply fin_mem_lcoset) (not_mem_empty j) + +end lcoset_fintype + +section normalizer +open subtype + +variables {G : Type} [ambientG : group G] [finG : fintype G] [deceqG : decidable_eq G] +include ambientG deceqG finG + +variable H : finset G + +definition normalizer : finset G := {g ∈ univ | ∀ h, h ∈ H → g ∘c h ∈ H} + +variable {H} + +variable [finsubgH : is_finsubg H] +include finsubgH + +lemma subset_normalizer : H ⊆ normalizer H := +subset_of_forall take g, assume PginH, mem_sep_of_mem !mem_univ + (take h, assume PhinH, finsubg_conj_closed PginH PhinH) + +lemma normalizer_has_one : 1 ∈ normalizer H := +mem_of_subset_of_mem subset_normalizer (finsubg_has_one H) + +lemma normalizer_mul_closed : finset_mul_closed_on (normalizer H) := +take f g, assume Pfin Pgin, +mem_sep_of_mem !mem_univ take h, assume Phin, begin + rewrite [-conj_compose], + apply of_mem_sep Pfin, + apply of_mem_sep Pgin, + exact Phin +end + +lemma conj_eq_of_mem_normalizer {g : G} : g ∈ normalizer H → image (conj_by g) H = H := +assume Pgin, +eq_of_card_eq_of_subset (card_image_eq_of_inj_on (take h j, assume P1 P2, !conj_inj)) + (subset_of_forall take h, assume Phin, + obtain j Pjin Pj, from exists_of_mem_image Phin, + begin substvars, apply of_mem_sep Pgin, exact Pjin end) + +lemma normalizer_has_inv : finset_has_inv (normalizer H) := +take g, assume Pgin, +mem_sep_of_mem !mem_univ take h, begin + rewrite [-(conj_eq_of_mem_normalizer Pgin) at {1}, mem_image_iff], + intro Pex, cases Pex with k Pk, + rewrite [-(and.right Pk), conj_compose, mul.left_inv, conj_id], + exact and.left Pk +end + +attribute [instance] +definition normalizer_is_finsubg : is_finsubg (normalizer H) := +is_finsubg.mk normalizer_has_one normalizer_mul_closed normalizer_has_inv + +lemma lcoset_subset_normalizer (J : lcoset_type (normalizer H) H) : + elt_of J ⊆ normalizer H := +lcoset_subset_of_subset J subset_normalizer + +lemma lcoset_subset_normalizer_of_mem {g : G} : + g ∈ normalizer H → fin_lcoset H g ⊆ normalizer H := +assume Pgin, fin_lcoset_subset subset_normalizer g Pgin + +lemma lrcoset_same_of_mem_normalizer {g : G} : + g ∈ normalizer H → fin_lcoset H g = fin_rcoset H g := +assume Pg, ext take h, iff.intro + (assume Pl, obtain j Pjin Pj, from exists_of_mem_image Pl, + mem_image (of_mem_sep Pg j Pjin) + (calc g*j*g⁻¹*g = g*j : inv_mul_cancel_right + ... = h : Pj)) + (assume Pr, obtain j Pjin Pj, from exists_of_mem_image Pr, + mem_image (of_mem_sep (finsubg_has_inv (normalizer H) Pg) j Pjin) + (calc g*(g⁻¹*j*g⁻¹⁻¹) = g*(g⁻¹*j*g) : inv_inv + ... = g*(g⁻¹*(j*g)) : mul.assoc + ... = j*g : mul_inv_cancel_left + ... = h : Pj)) + +lemma lcoset_mul_eq_lcoset (J K : lcoset_type (normalizer H) H) {g : G} : + g ∈ elt_of J → (lcoset_mul J K) = fin_lcoset (elt_of K) g := +assume Pgin, +obtain j Pjin Pj, from has_property J, +obtain k Pkin Pk, from has_property K, +Union_const (lcoset_not_empty J) begin + rewrite [-Pk], intro h Phin, + have Phinn : h ∈ normalizer H, + begin + apply mem_of_subset_of_mem (lcoset_subset_normalizer_of_mem Pjin), + rewrite Pj, assumption + end, + revert Phin Pgin, + rewrite [-Pj, *fin_lcoset_same], + intro Pheq Pgeq, + rewrite [*(lrcoset_same_of_mem_normalizer Pkin), *fin_lrcoset_comm, Pheq, Pgeq] +end + +lemma lcoset_mul_is_lcoset (J K : lcoset_type (normalizer H) H) : + is_fin_lcoset (normalizer H) H (lcoset_mul J K) := +obtain j Pjin Pj, from has_property J, +obtain k Pkin Pk, from has_property K, +exists.intro (j*k) (and.intro (finsubg_mul_closed _ Pjin Pkin) + begin rewrite [lcoset_mul_eq_lcoset J K (Pj ▸ fin_mem_lcoset j), -fin_lcoset_compose, Pk] end) + +lemma lcoset_inv_is_lcoset (J : lcoset_type (normalizer H) H) : + is_fin_lcoset (normalizer H) H (fin_inv (elt_of J)) := +obtain j Pjin Pj, from has_property J, exists.intro j⁻¹ +begin + rewrite [-Pj, finsubg_inv_lcoset_eq_rcoset], + apply and.intro, + apply normalizer_has_inv, assumption, + apply lrcoset_same_of_mem_normalizer, apply normalizer_has_inv, assumption +end + +definition fin_coset_mul (J K : lcoset_type (normalizer H) H) : lcoset_type (normalizer H) H := +tag (lcoset_mul J K) (lcoset_mul_is_lcoset J K) + +definition fin_coset_inv (J : lcoset_type (normalizer H) H) : lcoset_type (normalizer H) H := +tag (fin_inv (elt_of J)) (lcoset_inv_is_lcoset J) + +definition fin_coset_one : lcoset_type (normalizer H) H := +tag H self_is_lcoset + +local infix `^` := fin_coset_mul + +lemma fin_coset_mul_eq_lcoset (J K : lcoset_type (normalizer H) H) {g : G} : + g ∈ (elt_of J) → elt_of (J ^ K) = fin_lcoset (elt_of K) g := +assume Pgin, lcoset_mul_eq_lcoset J K Pgin + +lemma fin_coset_mul_assoc (J K L : lcoset_type (normalizer H) H) : + J ^ K ^ L = J ^ (K ^ L) := +obtain j Pjin Pj, from exists_of_lcoset_type J, +obtain k Pkin Pk, from exists_of_lcoset_type K, +have Pjk : j*k ∈ elt_of (J ^ K), from mul_mem_lcoset_mul J K Pjin Pkin, +obtain l Plin Pl, from has_property L, +subtype.eq (begin + rewrite [fin_coset_mul_eq_lcoset (J ^ K) _ Pjk, + fin_coset_mul_eq_lcoset J _ Pjin, + fin_coset_mul_eq_lcoset K _ Pkin, + -Pl, *fin_lcoset_compose] + end) + +lemma fin_coset_mul_one (J : lcoset_type (normalizer H) H) : + J ^ fin_coset_one = J := +obtain j Pjin Pj, from exists_of_lcoset_type J, +subtype.eq begin + rewrite [↑fin_coset_one, fin_coset_mul_eq_lcoset _ _ Pjin, -Pj] +end + +lemma fin_coset_one_mul (J : lcoset_type (normalizer H) H) : + fin_coset_one ^ J = J := +subtype.eq begin + rewrite [↑fin_coset_one, fin_coset_mul_eq_lcoset _ _ (finsubg_has_one H), fin_lcoset_id] +end + +lemma fin_coset_left_inv (J : lcoset_type (normalizer H) H) : + (fin_coset_inv J) ^ J = fin_coset_one := +obtain j Pjin Pj, from exists_of_lcoset_type J, +have Pjinv : j⁻¹ ∈ elt_of (fin_coset_inv J), from inv_mem_fin_inv Pjin, +subtype.eq begin + rewrite [↑fin_coset_one, fin_coset_mul_eq_lcoset _ _ Pjinv, -Pj, fin_lcoset_inv] +end + +variable (H) + +attribute [instance] +definition fin_coset_group : group (lcoset_type (normalizer H) H) := +group.mk fin_coset_mul fin_coset_mul_assoc fin_coset_one fin_coset_one_mul fin_coset_mul_one fin_coset_inv fin_coset_left_inv + +variables {H} (Hc : finset (lcoset_type (normalizer H) H)) + +definition fin_coset_Union : finset G := Union Hc elt_of + +variables {Hc} [finsubgHc : is_finsubg Hc] +include finsubgHc + +lemma mem_normalizer_of_mem_fcU {j : G} : j ∈ fin_coset_Union Hc → j ∈ normalizer H := +assume Pjin, obtain J PJ PjJ, from iff.elim_left !mem_Union_iff Pjin, +mem_of_subset_of_mem !lcoset_subset_normalizer PjJ + +lemma fcU_has_one : (1:G) ∈ fin_coset_Union Hc := +iff.elim_right (mem_Union_iff Hc elt_of (1:G)) + (exists.intro 1 (and.intro (finsubg_has_one Hc) (finsubg_has_one H))) + +lemma fcU_has_inv : finset_has_inv (fin_coset_Union Hc) := +take j, assume Pjin, obtain J PJ PjJ, from iff.elim_left !mem_Union_iff Pjin, +have PJinv : J⁻¹ ∈ Hc, from finsubg_has_inv Hc PJ, +have Pjinv : j⁻¹ ∈ elt_of J⁻¹, from inv_mem_fin_inv PjJ, +iff.elim_right !mem_Union_iff (exists.intro J⁻¹ (and.intro PJinv Pjinv)) + +lemma fcU_mul_closed : finset_mul_closed_on (fin_coset_Union Hc) := +take j k, assume Pjin Pkin, +obtain J PJ PjJ, from iff.elim_left !mem_Union_iff Pjin, +obtain K PK PkK, from iff.elim_left !mem_Union_iff Pkin, +have Pjk : j*k ∈ elt_of (J*K), from mul_mem_lcoset_mul J K PjJ PkK, +iff.elim_right !mem_Union_iff + (exists.intro (J*K) (and.intro (finsubg_mul_closed Hc PJ PK) Pjk)) + +attribute [instance] +definition fcU_is_finsubg : is_finsubg (fin_coset_Union Hc) := +is_finsubg.mk fcU_has_one fcU_mul_closed fcU_has_inv + +end normalizer + +end group_theory diff --git a/old_library/theories/group_theory/group_theory.md b/old_library/theories/group_theory/group_theory.md new file mode 100644 index 0000000000..bfa271c71b --- /dev/null +++ b/old_library/theories/group_theory/group_theory.md @@ -0,0 +1,12 @@ +theories.group_theory +===================== + +Group theory (especially finite group theory). + +* [subgroup](subgroup.lean) : general subgroup theories, quotient group using quot +* [finsubg](finsubg.lean) : finite subgroups (finset and fintype), Lagrange theorem, finite cosets and lcoset_type, normalizer for finite groups, coset product and quotient group based on lcoset_type, semidirect product +* [hom](hom.lean) : homomorphism and isomorphism, kernel, first isomorphism theorem +* [perm](perm.lean) : permutation group +* [cyclic](cyclic.lean) : cyclic subgroup, finite generator, order of generator, sequence and rotation +* [action](action.lean) : fixed point, action, stabilizer, orbit stabilizer theorem, orbit partition, Cayley theorem, action on lcoset, cardinality of permutation group +* [pgroup](pgroup.lean) : subgroup with order of prime power, Cauchy theorem, first Sylow theorem \ No newline at end of file diff --git a/old_library/theories/group_theory/hom.lean b/old_library/theories/group_theory/hom.lean new file mode 100644 index 0000000000..70883cc965 --- /dev/null +++ b/old_library/theories/group_theory/hom.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2015 Haitao Zhang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author : Haitao Zhang +-/ +import algebra.group data.set .subgroup + +namespace group_theory + +-- ⁻¹ in eq.ops conflicts with group ⁻¹ +-- open eq.ops +notation H1 ▸ H2 := eq.subst H1 H2 +open set +open function +open group_theory.ops +open quot +local attribute set [reducible] + +section defs + +variables {A B : Type} +variable [s1 : group A] +variable [s2 : group B] +include s1 +include s2 + +-- the Prop of being hom +attribute [reducible] +definition homomorphic (f : A → B) : Prop := ∀ a b, f (a*b) = (f a)*(f b) +-- type class for inference +structure is_hom_class [class] (f : A → B) : Type := + (is_hom : homomorphic f) +-- the proof of hom_prop if the class can be inferred +definition is_hom (f : A → B) [h : is_hom_class f] : homomorphic f := + @is_hom_class.is_hom A B s1 s2 f h + +definition ker (f : A → B) [h : is_hom_class f] : set A := {a : A | f a = 1} + +definition isomorphic (f : A → B) := injective f ∧ homomorphic f +structure is_iso_class [class] (f : A → B) extends is_hom_class f : Type := + (inj : injective f) +lemma iso_is_inj (f : A → B) [h : is_iso_class f] : injective f:= + @is_iso_class.inj A B s1 s2 f h +lemma iso_is_iso (f : A → B) [h : is_iso_class f] : isomorphic f:= + and.intro (iso_is_inj f) (is_hom f) + +end defs + +section +variables {A B : Type} +variable [s1 : group A] + +attribute [instance] +definition id_is_iso : @is_hom_class A A s1 s1 (@id A) := +is_hom_class.mk (take a b, rfl) + +variable [s2 : group B] +include s1 +include s2 + +variable f : A → B + +variable [h : is_hom_class f] +include h + +theorem hom_map_one : f 1 = 1 := + have P : f 1 = (f 1) * (f 1), from + calc f 1 = f (1*1) : mul_one + ... = (f 1) * (f 1) : is_hom f, + eq.symm (mul.right_inv (f 1) ▸ (mul_inv_eq_of_eq_mul P)) + +theorem hom_map_inv (a : A) : f a⁻¹ = (f a)⁻¹ := + have P : f 1 = 1, from hom_map_one f, + have P1 : f (a⁻¹ * a) = 1, from (eq.symm (mul.left_inv a)) ▸ P, + have P2 : (f a⁻¹) * (f a) = 1, from (is_hom f a⁻¹ a) ▸ P1, + have P3 : (f a⁻¹) * (f a) = (f a)⁻¹ * (f a), from eq.symm (mul.left_inv (f a)) ▸ P2, + mul_right_cancel P3 + +theorem hom_map_mul_closed (H : set A) : mul_closed_on H → mul_closed_on (f ' H) := + assume Pclosed, assume b1, assume b2, + assume Pb1 : b1 ∈ f ' H, assume Pb2 : b2 ∈ f ' H, + obtain a1 (Pa1 : a1 ∈ H ∧ f a1 = b1), from Pb1, + obtain a2 (Pa2 : a2 ∈ H ∧ f a2 = b2), from Pb2, + have Pa1a2 : a1 * a2 ∈ H, from Pclosed a1 a2 (and.left Pa1) (and.left Pa2), + have Pb1b2 : f (a1 * a2) = b1 * b2, from calc + f (a1 * a2) = f a1 * f a2 : is_hom f a1 a2 + ... = b1 * f a2 : {and.right Pa1} + ... = b1 * b2 : {and.right Pa2}, + mem_image Pa1a2 Pb1b2 + +lemma ker.has_one : 1 ∈ ker f := hom_map_one f + +lemma ker.has_inv : subgroup.has_inv (ker f) := + take a, assume Pa : f a = 1, calc + f a⁻¹ = (f a)⁻¹ : by rewrite (hom_map_inv f) + ... = 1⁻¹ : by rewrite Pa + ... = 1 : by rewrite one_inv + +lemma ker.mul_closed : mul_closed_on (ker f) := + take x y, assume (Px : f x = 1) (Py : f y = 1), calc + f (x*y) = (f x) * (f y) : by rewrite [is_hom f] + ... = 1 : by rewrite [Px, Py, mul_one] + +lemma ker.normal : same_left_right_coset (ker f) := + take a, funext (assume x, begin + esimp [ker, set_of, glcoset, grcoset], + rewrite [*(is_hom f), mul_eq_one_iff_mul_eq_one (f a⁻¹) (f x)] + end) + +definition ker_is_normal_subgroup : is_normal_subgroup (ker f) := + is_normal_subgroup.mk (ker.has_one f) (ker.mul_closed f) (ker.has_inv f) + (ker.normal f) + +-- additional subgroup variable +variable {H : set A} +variable [is_subgH : is_subgroup H] +include is_subgH + +theorem hom_map_subgroup : is_subgroup (f ' H) := + have Pone : 1 ∈ f ' H, from mem_image (@subg_has_one _ _ H _) (hom_map_one f), + have Pclosed : mul_closed_on (f ' H), from hom_map_mul_closed f H subg_mul_closed, + have Pinv : ∀ b, b ∈ f ' H → b⁻¹ ∈ f ' H, from + assume b, assume Pimg, + obtain a (Pa : a ∈ H ∧ f a = b), from Pimg, + have Painv : a⁻¹ ∈ H, from subg_has_inv a (and.left Pa), + have Pfainv : (f a)⁻¹ ∈ f ' H, from mem_image Painv (hom_map_inv f a), + and.right Pa ▸ Pfainv, + is_subgroup.mk Pone Pclosed Pinv +end + +section hom_theorem + +variables {A B : Type} +variable [s1 : group A] +variable [s2 : group B] +include s1 +include s2 + +variable {f : A → B} + +variable [h : is_hom_class f] +include h + +attribute [instance] +definition ker_nsubg : is_normal_subgroup (ker f) := + is_normal_subgroup.mk (ker.has_one f) (ker.mul_closed f) + (ker.has_inv f) (ker.normal f) + +attribute [instance] +definition quot_over_ker : group (coset_of (ker f)) := mk_quotient_group (ker f) +-- under the wrap the tower of concepts collapse to a simple condition +example (a x : A) : (x ∈ a ∘> ker f) = (f (a⁻¹*x) = 1) := rfl +lemma ker_coset_same_val (a b : A): same_lcoset (ker f) a b → f a = f b := + assume Psame, + have Pin : f (b⁻¹*a) = 1, from subg_same_lcoset_in_lcoset a b Psame, + have P : (f b)⁻¹ * (f a) = 1, from calc + (f b)⁻¹ * (f a) = (f b⁻¹) * (f a) : (hom_map_inv f) + ... = f (b⁻¹*a) : by rewrite [is_hom f] + ... = 1 : by rewrite Pin, + eq.symm (inv_inv (f b) ▸ inv_eq_of_mul_eq_one P) + +definition ker_natural_map : (coset_of (ker f)) → B := + quot.lift f ker_coset_same_val + +example (a : A) : ker_natural_map ⟦a⟧ = f a := rfl +lemma ker_coset_hom (a b : A) : + ker_natural_map (⟦a⟧*⟦b⟧) = (ker_natural_map ⟦a⟧) * (ker_natural_map ⟦b⟧) := calc + ker_natural_map (⟦a⟧*⟦b⟧) = ker_natural_map ⟦a*b⟧ : rfl + ... = f (a*b) : rfl + ... = (f a) * (f b) : by rewrite [is_hom f] + ... = (ker_natural_map ⟦a⟧) * (ker_natural_map ⟦b⟧) : rfl + +lemma ker_map_is_hom : homomorphic (ker_natural_map : coset_of (ker f) → B) := + take aK bK, + quot.ind (λ a, quot.ind (λ b, ker_coset_hom a b) bK) aK + +lemma ker_coset_inj (a b : A) : (ker_natural_map ⟦a⟧ = ker_natural_map ⟦b⟧) → ⟦a⟧ = ⟦b⟧ := + assume Pfeq : f a = f b, + have Painb : a ∈ b ∘> ker f, from calc + f (b⁻¹*a) = (f b⁻¹) * (f a) : by rewrite [is_hom f] + ... = (f b)⁻¹ * (f a) : by rewrite (hom_map_inv f) + ... = (f a)⁻¹ * (f a) : by rewrite Pfeq + ... = 1 : by rewrite (mul.left_inv (f a)), + quot.sound (@subg_in_lcoset_same_lcoset _ _ (ker f) _ a b Painb) + +lemma ker_map_is_inj : injective (ker_natural_map : coset_of (ker f) → B) := + take aK bK, + quot.ind (λ a, quot.ind (λ b, ker_coset_inj a b) bK) aK + +-- a special case of the fundamental homomorphism theorem or the first isomorphism theorem +theorem first_isomorphism_theorem : isomorphic (ker_natural_map : coset_of (ker f) → B) := + and.intro ker_map_is_inj ker_map_is_hom + +end hom_theorem +end group_theory diff --git a/old_library/theories/group_theory/perm.lean b/old_library/theories/group_theory/perm.lean new file mode 100644 index 0000000000..335e630a2d --- /dev/null +++ b/old_library/theories/group_theory/perm.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2015 Haitao Zhang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author : Haitao Zhang +-/ +import algebra.group data data.fintype.function + +open nat list function + +namespace group_theory +open fintype + +section perm +variables {A : Type} [fintype A] [decidable_eq A] +variable {f : A → A} + +lemma perm_surj : injective f → surjective f := + surj_of_inj_eq_card (eq.refl (card A)) + +variable (perm : injective f) + +definition perm_inv : A → A := + right_inv (perm_surj perm) + +lemma perm_inv_right : f ∘ (perm_inv perm) = id := + right_inv_of_surj (perm_surj perm) + +lemma perm_inv_left : (perm_inv perm) ∘ f = id := + have H : left_inverse f (perm_inv perm), from congr_fun (perm_inv_right perm), + funext (take x, right_inverse_of_injective_of_left_inverse perm H x) + +lemma perm_inv_inj : injective (perm_inv perm) := + injective_of_has_left_inverse (exists.intro f (congr_fun (perm_inv_right perm))) + +end perm + +structure perm (A : Type) [h : fintype A] : Type := + (f : A → A) (inj : injective f) +-- local attribute perm.f [coercion] + +section perm +variables {A : Type} [fintype A] + +lemma eq_of_feq : ∀ {p₁ p₂ : perm A}, (perm.f p₁) = p₂ → p₁ = p₂ +| (perm.mk f₁ P₁) (perm.mk f₂ P₂) := assume (feq : f₁ = f₂), by congruence; assumption + +lemma feq_of_eq : ∀ {p₁ p₂ : perm A}, p₁ = p₂ → (perm.f p₁) = p₂ +| (perm.mk f₁ P₁) (perm.mk f₂ P₂) := assume Peq, + have feq : f₁ = f₂, from perm.no_confusion Peq (λ Pe Pqe, Pe), feq + +lemma eq_iff_feq {p₁ p₂ : perm A} : (perm.f p₁) = p₂ ↔ p₁ = p₂ := +iff.intro eq_of_feq feq_of_eq + +lemma perm.f_mk {f : A → A} {Pinj : injective f} : perm.f (perm.mk f Pinj) = f := rfl + +attribute [reducible] +definition move_by (a : A) (f : perm A) : A := f a + +variable [decidable_eq A] + +attribute [instance] +lemma perm.has_decidable_eq : decidable_eq (perm A) := + take f g, + perm.destruct f (λ ff finj, perm.destruct g (λ gf ginj, + decidable.rec_on (decidable_eq_fun ff gf) + (λ Peq, decidable.inl (by substvars)) + (λ Pne, decidable.inr begin intro P, injection P, contradiction end))) + +lemma dinj_perm_mk : dinj (@injective A A) perm.mk := + take a₁ a₂ Pa₁ Pa₂ Pmkeq, perm.no_confusion Pmkeq (λ Pe Pqe, Pe) + +definition all_perms : list (perm A) := + dmap injective perm.mk (all_injs A) + +lemma nodup_all_perms : nodup (@all_perms A _ _) := + dmap_nodup_of_dinj dinj_perm_mk nodup_all_injs + +lemma all_perms_complete : ∀ p : perm A, p ∈ all_perms := + take p, perm.destruct p (take f Pinj, + have Pin : f ∈ all_injs A, from all_injs_complete Pinj, + mem_dmap Pinj Pin) + +attribute [instance] +definition perm_is_fintype : fintype (perm A) := + fintype.mk all_perms nodup_all_perms all_perms_complete + +definition perm.mul (f g : perm A) := + perm.mk (f∘g) (injective_comp (perm.inj f) (perm.inj g)) +attribute [reducible] +definition perm.one : perm A := perm.mk id injective_id +definition perm.inv (f : perm A) := let inj := perm.inj f in + perm.mk (perm_inv inj) (perm_inv_inj inj) + +local infix `^` := perm.mul +lemma perm.assoc (f g h : perm A) : f ^ g ^ h = f ^ (g ^ h) := rfl +lemma perm.one_mul (p : perm A) : perm.one ^ p = p := + perm.cases_on p (λ f inj, rfl) +lemma perm.mul_one (p : perm A) : p ^ perm.one = p := + perm.cases_on p (λ f inj, rfl) +lemma perm.left_inv (p : perm A) : (perm.inv p) ^ p = perm.one := + begin rewrite [↑perm.one], generalize @injective_id A, + rewrite [-perm_inv_left (perm.inj p)], intros, exact rfl + end +lemma perm.right_inv (p : perm A) : p ^ (perm.inv p) = perm.one := + begin rewrite [↑perm.one], generalize @injective_id A, + rewrite [-perm_inv_right (perm.inj p)], intros, exact rfl + end + +attribute [instance] +definition perm_group : group (perm A) := + group.mk perm.mul perm.assoc perm.one perm.one_mul perm.mul_one perm.inv perm.left_inv + +lemma perm_one : (1 : perm A) = perm.one := rfl + +end perm + +end group_theory diff --git a/old_library/theories/group_theory/pgroup.lean b/old_library/theories/group_theory/pgroup.lean new file mode 100644 index 0000000000..ada18aca10 --- /dev/null +++ b/old_library/theories/group_theory/pgroup.lean @@ -0,0 +1,399 @@ +/- +Copyright (c) 2015 Haitao Zhang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author : Haitao Zhang +-/ +import theories.number_theory.primes data algebra.group algebra.group_power algebra.group_bigops +import .cyclic .finsubg .hom .perm .action + +open nat fin list function subtype + +namespace group_theory + +section pgroup + +open finset fintype + +variables {G S : Type} [ambientG : group G] [deceqG : decidable_eq G] [finS : fintype S] [deceqS : decidable_eq S] +include ambientG + +definition psubg (H : finset G) (p m : nat) : Prop := prime p ∧ card H = p^m + +include deceqG finS deceqS +variables {H : finset G} [subgH : is_finsubg H] +include subgH + +variables {hom : G → perm S} [Hom : is_hom_class hom] +include Hom +open finset.partition + +lemma card_mod_eq_of_action_by_psubg {p : nat} : + ∀ {m : nat}, psubg H p m → (card S) % p = (card (fixed_points hom H)) % p +| 0 := by rewrite [↑psubg, pow_zero]; intro Psubg; + rewrite [finsubg_eq_singleton_one_of_card_one (and.right Psubg), fixed_points_of_one] +| (succ m) := take Ppsubg, begin + rewrite [@orbit_class_equation' G S ambientG _ finS deceqS hom Hom H subgH], + apply add_mod_eq_of_dvd, apply dvd_Sum_of_dvd, + intro s Psin, + rewrite mem_sep_iff at Psin, + cases Psin with Psinorbs Pcardne, + esimp [orbits, equiv_classes, orbit_partition] at Psinorbs, + rewrite mem_image_iff at Psinorbs, + cases Psinorbs with a Pa, + cases Pa with Pain Porb, + substvars, + cases Ppsubg with Pprime PcardH, + have Pdvd : card (orbit hom H a) ∣ p ^ (succ m), + begin + rewrite -PcardH, + apply dvd_of_eq_mul (finset.card (stab hom H a)), + apply orbit_stabilizer_theorem + end, + apply or.elim (eq_one_or_dvd_of_dvd_prime_pow Pprime Pdvd), + intro Pcardeq, contradiction, + intro Ppdvd, exact Ppdvd + end + +end pgroup + +section psubg_cosets +open finset fintype +variables {G : Type} [ambientG : group G] [finG : fintype G] [deceqG : decidable_eq G] +include ambientG deceqG finG + +variables {H : finset G} [finsubgH : is_finsubg H] +include finsubgH + +lemma card_psubg_cosets_mod_eq {p : nat} {m : nat} : + psubg H p m → (card (lcoset_type univ H)) % p = card (lcoset_type (normalizer H) H) % p := +assume Psubg, by rewrite [-card_aol_fixed_points_eq_card_cosets]; exact card_mod_eq_of_action_by_psubg Psubg + +end psubg_cosets + +section cauchy + +lemma prodl_rotl_eq_one_of_prodl_eq_one {A B : Type} [gB : group B] {f : A → B} : + ∀ {l : list A}, Prodl l f = 1 → Prodl (list.rotl l) f = 1 +| nil := assume Peq, rfl +| (a::l) := begin + rewrite [rotl_cons, Prodl_cons f, Prodl_append _ _ f, Prodl_singleton], + exact mul_eq_one_of_mul_eq_one + end + +section rotl_peo + +variables {A : Type} [ambA : group A] +include ambA + +variable [finA : fintype A] +include finA + +variable (A) + +definition all_prodl_eq_one (n : nat) : list (list A) := +map (λ l, cons (Prodl l id)⁻¹ l) (all_lists_of_len n) + +variable {A} + +lemma prodl_eq_one_of_mem_all_prodl_eq_one {n : nat} {l : list A} : l ∈ all_prodl_eq_one A n → Prodl l id = 1 := +assume Plin, obtain l' Pl' Pl, from exists_of_mem_map Plin, +by substvars; rewrite [Prodl_cons id _ l', mul.left_inv] + +lemma length_of_mem_all_prodl_eq_one {n : nat} {l : list A} : l ∈ all_prodl_eq_one A n → length l = succ n := +assume Plin, obtain l' Pl' Pl, from exists_of_mem_map Plin, +begin substvars, rewrite [length_cons, length_mem_all_lists Pl'] end + +lemma nodup_all_prodl_eq_one {n : nat} : nodup (all_prodl_eq_one A n) := +nodup_map (take l₁ l₂ Peq, tail_eq_of_cons_eq Peq) nodup_all_lists + +lemma all_prodl_eq_one_complete {n : nat} : ∀ {l : list A}, length l = succ n → Prodl l id = 1 → l ∈ all_prodl_eq_one A n +| nil := assume Pleq, by contradiction +| (a::l) := assume Pleq Pprod, + begin + rewrite length_cons at Pleq, + rewrite (Prodl_cons id a l) at Pprod, + rewrite [eq_inv_of_mul_eq_one Pprod], + apply mem_map, apply mem_all_lists, apply succ.inj Pleq + end + +open fintype +lemma length_all_prodl_eq_one {n : nat} : length (@all_prodl_eq_one A _ _ n) = (card A)^n := +eq.trans !length_map length_all_lists + +open fin + +definition prodseq {n : nat} (s : seq A n) : A := Prodl (upto n) s + +attribute [reducible] +definition peo {n : nat} (s : seq A n) := prodseq s = 1 + +definition constseq {n : nat} (s : seq A (succ n)) := ∀ i, s i = s !zero + +lemma prodseq_eq {n :nat} {s : seq A n} : prodseq s = Prodl (fun_to_list s) id := +Prodl_map + +lemma prodseq_eq_pow_of_constseq {n : nat} (s : seq A (succ n)) : + constseq s → prodseq s = (s !zero) ^ succ n := +assume Pc, have Pcl : ∀ i, i ∈ upto (succ n) → s i = s !zero, + from take i, assume Pin, Pc i, +by rewrite [↑prodseq, Prodl_eq_pow_of_const _ Pcl, fin.length_upto] + +lemma seq_eq_of_constseq_of_eq {n : nat} {s₁ s₂ : seq A (succ n)} : + constseq s₁ → constseq s₂ → s₁ !zero = s₂ !zero → s₁ = s₂ := +assume Pc₁ Pc₂ Peq, funext take i, by rewrite [Pc₁ i, Pc₂ i, Peq] + +lemma peo_const_one : ∀ {n : nat}, peo (λ i : fin n, (1 : A)) +| 0 := rfl +| (succ n) := let s := λ i : fin (succ n), (1 : A) in + have Pconst : constseq s, from take i, rfl, + calc prodseq s = (s !zero) ^ succ n : prodseq_eq_pow_of_constseq s Pconst + ... = (1 : A) ^ succ n : rfl + ... = 1 : one_pow + +variable [deceqA : decidable_eq A] +include deceqA + +variable (A) + +attribute [reducible] +definition peo_seq (n : nat) := {s : seq A (succ n) | peo s} + +definition peo_seq_one (n : nat) : peo_seq A n := +tag (λ i : fin (succ n), (1 : A)) peo_const_one + +definition all_prodseq_eq_one (n : nat) : list (seq A (succ n)) := +dmap (λ l, length l = card (fin (succ n))) list_to_fun (all_prodl_eq_one A n) + +definition all_peo_seqs (n : nat) : list (peo_seq A n) := +dmap peo tag (all_prodseq_eq_one A n) + +variable {A} + +lemma prodseq_eq_one_of_mem_all_prodseq_eq_one {n : nat} {s : seq A (succ n)} : + s ∈ all_prodseq_eq_one A n → prodseq s = 1 := +assume Psin, obtain l Pex, from exists_of_mem_dmap Psin, +obtain leq Pin Peq, from Pex, +by rewrite [prodseq_eq, Peq, list_to_fun_to_list, prodl_eq_one_of_mem_all_prodl_eq_one Pin] + +lemma all_prodseq_eq_one_complete {n : nat} {s : seq A (succ n)} : + prodseq s = 1 → s ∈ all_prodseq_eq_one A n := +assume Peq, +have Plin : map s (elems (fin (succ n))) ∈ all_prodl_eq_one A n, + from begin + apply all_prodl_eq_one_complete, + rewrite [length_map], exact length_upto (succ n), + rewrite prodseq_eq at Peq, exact Peq + end, +have Psin : list_to_fun (map s (elems (fin (succ n)))) (length_map_of_fintype s) ∈ all_prodseq_eq_one A n, + from mem_dmap _ Plin, +by rewrite [fun_eq_list_to_fun_map s (length_map_of_fintype s)]; apply Psin + +lemma nodup_all_prodseq_eq_one {n : nat} : nodup (all_prodseq_eq_one A n) := +dmap_nodup_of_dinj dinj_list_to_fun nodup_all_prodl_eq_one + +lemma rotl1_peo_of_peo {n : nat} {s : seq A n} : peo s → peo (rotl_fun 1 s) := +begin rewrite [↑peo, *prodseq_eq, seq_rotl_eq_list_rotl], apply prodl_rotl_eq_one_of_prodl_eq_one end + +section +-- local attribute perm.f [coercion] + +lemma rotl_perm_peo_of_peo {n : nat} : ∀ {m} {s : seq A n}, peo s → peo (rotl_perm A n m s) +| 0 := begin rewrite [↑rotl_perm, rotl_seq_zero], intros, assumption end +| (succ m) := take s, + have Pmul : rotl_perm A n (m + 1) s = rotl_fun 1 (rotl_perm A n m s), from + calc s ∘ (rotl (m + 1)) = s ∘ ((rotl m) ∘ (rotl 1)) : rotl_compose + ... = s ∘ (rotl m) ∘ (rotl 1) : comp.assoc, + begin + rewrite [-add_one, Pmul], intro P, + exact rotl1_peo_of_peo (rotl_perm_peo_of_peo P) + end + +end + +lemma nodup_all_peo_seqs {n : nat} : nodup (all_peo_seqs A n) := +dmap_nodup_of_dinj (dinj_tag peo) nodup_all_prodseq_eq_one + +lemma all_peo_seqs_complete {n : nat} : ∀ s : peo_seq A n, s ∈ all_peo_seqs A n := +take ps, subtype.destruct ps (take s, assume Ps, + have Pin : s ∈ all_prodseq_eq_one A n, from all_prodseq_eq_one_complete Ps, + mem_dmap Ps Pin) + +lemma length_all_peo_seqs {n : nat} : length (all_peo_seqs A n) = (card A)^n := +eq.trans (eq.trans + (show length (all_peo_seqs A n) = length (all_prodseq_eq_one A n), from + have Pmap : map elt_of (all_peo_seqs A n) = all_prodseq_eq_one A n, + from map_dmap_of_inv_of_pos (λ s P, rfl) + (λ s, prodseq_eq_one_of_mem_all_prodseq_eq_one), + by rewrite [-Pmap, length_map]) + (show length (all_prodseq_eq_one A n) = length (all_prodl_eq_one A n), from + have Pmap : map fun_to_list (all_prodseq_eq_one A n) = all_prodl_eq_one A n, + from map_dmap_of_inv_of_pos list_to_fun_to_list + (λ l Pin, by rewrite [length_of_mem_all_prodl_eq_one Pin, card_fin]), + by rewrite [-Pmap, length_map])) + length_all_prodl_eq_one + +attribute [instance] +definition peo_seq_is_fintype {n : nat} : fintype (peo_seq A n) := +fintype.mk (all_peo_seqs A n) nodup_all_peo_seqs all_peo_seqs_complete + +lemma card_peo_seq {n : nat} : card (peo_seq A n) = (card A)^n := +length_all_peo_seqs + +section + +variable (A) + +-- local attribute perm.f [coercion] + +definition rotl_peo_seq (n : nat) (m : nat) (s : peo_seq A n) : peo_seq A n := +tag (rotl_perm A (succ n) m (elt_of s)) (rotl_perm_peo_of_peo (has_property s)) + +variable {A} + +end + +lemma rotl_peo_seq_zero {n : nat} : rotl_peo_seq A n 0 = id := +funext take s, subtype.eq begin rewrite [↑rotl_peo_seq, ↑rotl_perm, rotl_seq_zero] end + +lemma rotl_peo_seq_id {n : nat} : rotl_peo_seq A n (succ n) = id := +funext take s, subtype.eq begin rewrite [↑rotl_peo_seq, -rotl_perm_pow_eq, rotl_perm_pow_eq_one] end + +lemma rotl_peo_seq_compose {n i j : nat} : + (rotl_peo_seq A n i) ∘ (rotl_peo_seq A n j) = rotl_peo_seq A n (j + i) := +funext take s, subtype.eq begin rewrite [↑rotl_peo_seq, ↑rotl_perm, ↑rotl_fun, comp.assoc, rotl_compose] end + +lemma rotl_peo_seq_mod {n i : nat} : rotl_peo_seq A n i = rotl_peo_seq A n (i % succ n) := +funext take s, subtype.eq begin rewrite [↑rotl_peo_seq, rotl_perm_mod] end + +lemma rotl_peo_seq_inj {n m : nat} : injective (rotl_peo_seq A n m) := +take ps₁ ps₂, subtype.destruct ps₁ (λ s₁ P₁, subtype.destruct ps₂ (λ s₂ P₂, + assume Peq, tag_eq (rotl_fun_inj (dinj_tag peo _ _ Peq)))) + +variable (A) + +attribute [reducible] +definition rotl_perm_ps (n : nat) (m : fin (succ n)) : perm (peo_seq A n) := +perm.mk (rotl_peo_seq A n m) rotl_peo_seq_inj + +variable {A} + +variable {n : nat} + +lemma rotl_perm_ps_eq {m : fin (succ n)} {s : peo_seq A n} : elt_of (perm.f (rotl_perm_ps A n m) s) = perm.f (rotl_perm A (succ n) m) (elt_of s) := rfl + +lemma rotl_perm_ps_eq_of_rotl_perm_eq {i j : fin (succ n)} : + (rotl_perm A (succ n) i) = (rotl_perm A (succ n) j) → (rotl_perm_ps A n i) = (rotl_perm_ps A n j) := +assume Peq, eq_of_feq (funext take s, subtype.eq (by rewrite [*rotl_perm_ps_eq, Peq])) + +lemma rotl_perm_ps_hom (i j : fin (succ n)) : + rotl_perm_ps A n (i+j) = (rotl_perm_ps A n i) * (rotl_perm_ps A n j) := +eq_of_feq (begin rewrite [↑rotl_perm_ps, {val (i+j)}val_madd, add.comm, -rotl_peo_seq_mod, -rotl_peo_seq_compose] end) + +section +local attribute group_of_add_group [instance] + +attribute [instance] +definition rotl_perm_ps_is_hom : is_hom_class (rotl_perm_ps A n) := +is_hom_class.mk rotl_perm_ps_hom + +open finset + +lemma const_of_is_fixed_point {s : peo_seq A n} : + is_fixed_point (rotl_perm_ps A n) univ s → constseq (elt_of s) := +assume Pfp, take i, begin + rewrite [-(Pfp i !mem_univ) at {1}, rotl_perm_ps_eq, ↑rotl_perm, ↑rotl_fun, {i}mk_mod_eq at {2}, rotl_to_zero] +end + +lemma const_of_rotl_fixed_point {s : peo_seq A n} : + s ∈ fixed_points (rotl_perm_ps A n) univ → constseq (elt_of s) := +assume Psin, take i, begin + apply const_of_is_fixed_point, exact is_fixed_point_of_mem_fixed_points Psin +end + +lemma pow_eq_one_of_mem_fixed_points {s : peo_seq A n} : + s ∈ fixed_points (rotl_perm_ps A n) univ → (elt_of s !zero)^(succ n) = 1 := +assume Psin, eq.trans + (eq.symm (prodseq_eq_pow_of_constseq (elt_of s) (const_of_rotl_fixed_point Psin))) + (has_property s) + +lemma peo_seq_one_is_fixed_point : is_fixed_point (rotl_perm_ps A n) univ (peo_seq_one A n) := +take h, assume Pin, by esimp [rotl_perm_ps] + +lemma peo_seq_one_mem_fixed_points : peo_seq_one A n ∈ fixed_points (rotl_perm_ps A n) univ := +mem_fixed_points_of_exists_of_is_fixed_point (exists.intro !zero !mem_univ) peo_seq_one_is_fixed_point + +lemma generator_of_prime_of_dvd_order {p : nat} + : prime p → p ∣ card A → ∃ g : A, g ≠ 1 ∧ g^p = 1 := +assume Pprime Pdvd, +let pp := nat.pred p, spp := nat.succ pp in +have Peq : spp = p, from succ_pred_prime Pprime, +have Ppsubg : psubg (@univ (fin spp) _) spp 1, + from and.intro (eq.symm Peq ▸ Pprime) (by rewrite [Peq, card_fin, pow_one]), +have (pow_nat (card A) pp) % spp = (card (fixed_points (rotl_perm_ps A pp) univ)) % spp, + by rewrite -card_peo_seq; apply card_mod_eq_of_action_by_psubg Ppsubg, +have Pcardmod : (pow_nat (card A) pp) % p = (card (fixed_points (rotl_perm_ps A pp) univ)) % p, + from Peq ▸ this, +have Pfpcardmod : (card (fixed_points (rotl_perm_ps A pp) univ)) % p = 0, + from eq.trans (eq.symm Pcardmod) (mod_eq_zero_of_dvd (dvd_pow_of_dvd_of_pos Pdvd (pred_prime_pos Pprime))), +have Pfpcardpos : card (fixed_points (rotl_perm_ps A pp) univ) > 0, + from card_pos_of_mem peo_seq_one_mem_fixed_points, +have Pfpcardgt1 : card (fixed_points (rotl_perm_ps A pp) univ) > 1, + from gt_one_of_pos_of_prime_dvd Pprime Pfpcardpos Pfpcardmod, +obtain s₁ s₂ Pin₁ Pin₂ Psnes, from exists_two_of_card_gt_one Pfpcardgt1, +decidable.by_cases + (λ Pe₁ : elt_of s₁ !zero = 1, + have Pne₂ : elt_of s₂ !zero ≠ 1, + from assume Pe₂, + absurd + (subtype.eq (seq_eq_of_constseq_of_eq + (const_of_rotl_fixed_point Pin₁) + (const_of_rotl_fixed_point Pin₂) + (eq.trans Pe₁ (eq.symm Pe₂)))) + Psnes, + exists.intro (elt_of s₂ !zero) + (and.intro Pne₂ (Peq ▸ pow_eq_one_of_mem_fixed_points Pin₂))) + (λ Pne, exists.intro (elt_of s₁ !zero) + (and.intro Pne (Peq ▸ pow_eq_one_of_mem_fixed_points Pin₁))) +end + +theorem cauchy_theorem {p : nat} : prime p → p ∣ card A → ∃ g : A, order g = p := +assume Pprime Pdvd, +obtain g Pne Pgpow, from generator_of_prime_of_dvd_order Pprime Pdvd, +have Porder : order g ∣ p, from order_dvd_of_pow_eq_one Pgpow, +or.elim (eq_one_or_eq_self_of_prime_of_dvd Pprime Porder) + (λ Pe, absurd (eq_one_of_order_eq_one Pe) Pne) + (λ Porderp, exists.intro g Porderp) + +end rotl_peo + +end cauchy + +section sylow + +open finset fintype + +variables {G : Type} [ambientG : group G] [finG : fintype G] [deceqG : decidable_eq G] +include ambientG deceqG finG + +theorem first_sylow_theorem {p : nat} (Pp : prime p) : + ∀ n, p^n ∣ card G → ∃ (H : finset G) (finsubgH : is_finsubg H), card H = p^n +| 0 := assume Pdvd, exists.intro ('{1}) + (exists.intro one_is_finsubg + (by rewrite [pow_zero])) +| (succ n) := assume Pdvd, + obtain H PfinsubgH PcardH, from first_sylow_theorem n (pow_dvd_of_pow_succ_dvd Pdvd), + have Ppsubg : psubg H p n, from and.intro Pp PcardH, + have Ppowsucc : p^(succ n) ∣ (card (lcoset_type univ H) * p^n), + by rewrite [-PcardH, -(lagrange_theorem' !subset_univ)]; exact Pdvd, + have Ppdvd : p ∣ card (lcoset_type (normalizer H) H), from + dvd_of_mod_eq_zero + (by rewrite [-(card_psubg_cosets_mod_eq Ppsubg), -dvd_iff_mod_eq_zero]; + exact dvd_of_pow_succ_dvd_mul_pow (pos_of_prime Pp) Ppowsucc), + obtain J PJ, from cauchy_theorem Pp Ppdvd, + exists.intro (fin_coset_Union (cyc J)) + (exists.intro _ + (by rewrite [pow_succ, -PcardH, -PJ]; apply card_Union_lcosets)) + +end sylow + +end group_theory diff --git a/old_library/theories/group_theory/subgroup.lean b/old_library/theories/group_theory/subgroup.lean new file mode 100644 index 0000000000..fc1916e10c --- /dev/null +++ b/old_library/theories/group_theory/subgroup.lean @@ -0,0 +1,380 @@ +/- +Copyright (c) 2015 Haitao Zhang. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author : Haitao Zhang +-/ +import data algebra.group data +open function eq.ops + +open set + +namespace coset +-- semigroup coset definition +section +variable {A : Type} +variable [s : semigroup A] +include s +definition lmul (a : A) := λ x, a * x +definition rmul (a : A) := λ x, x * a +definition l a (S : set A) := (lmul a) ' S +definition r a (S : set A) := (rmul a) ' S +lemma lmul_compose : ∀ (a b : A), (lmul a) ∘ (lmul b) = lmul (a*b) := + take a, take b, + funext (assume x, by + rewrite [↑function.comp, ↑lmul, mul.assoc]) +lemma rmul_compose : ∀ (a b : A), (rmul a) ∘ (rmul b) = rmul (b*a) := + take a, take b, + funext (assume x, by + rewrite [↑function.comp, ↑rmul, mul.assoc]) +lemma lcompose a b (S : set A) : l a (l b S) = l (a*b) S := + calc (lmul a) ' ((lmul b) ' S) = ((lmul a) ∘ (lmul b)) ' S : image_comp + ... = lmul (a*b) ' S : lmul_compose +lemma rcompose a b (S : set A) : r a (r b S) = r (b*a) S := + calc (rmul a) ' ((rmul b) ' S) = ((rmul a) ∘ (rmul b)) ' S : image_comp + ... = rmul (b*a) ' S : rmul_compose +lemma l_sub a (S H : set A) : S ⊆ H → (l a S) ⊆ (l a H) := image_subset (lmul a) +definition l_same S (a b : A) := l a S = l b S +definition r_same S (a b : A) := r a S = r b S +lemma l_same.refl S (a : A) : l_same S a a := rfl +lemma l_same.symm S (a b : A) : l_same S a b → l_same S b a := eq.symm +lemma l_same.trans S (a b c : A) : l_same S a b → l_same S b c → l_same S a c := eq.trans +example (S : set A) : equivalence (l_same S) := mk_equivalence (l_same S) (l_same.refl S) (l_same.symm S) (l_same.trans S) +end +end coset + +section +variable {A : Type} +variable [s : group A] +include s +definition lmul_by (a : A) := λ x, a * x +definition rmul_by (a : A) := λ x, x * a +definition glcoset a (H : set A) : set A := λ x, H (a⁻¹ * x) +definition grcoset H (a : A) : set A := λ x, H (x * a⁻¹) +end + +namespace group_theory + namespace ops + infixr `∘>`:55 := glcoset -- stronger than = (50), weaker than * (70) + infixl `<∘`:55 := grcoset + infixr `∘c`:55 := conj_by + end ops +end group_theory + +open group_theory.ops +section +variable {A : Type} +variable [s : group A] +include s + +lemma conj_inj (g : A) : injective (conj_by g) := +injective_of_has_left_inverse (exists.intro (conj_by g⁻¹) take a, !conj_inv_cancel) + +lemma lmul_inj (a : A) : injective (lmul_by a) := +take x₁ x₂ Peq, by esimp [lmul_by] at Peq; + rewrite [-(inv_mul_cancel_left a x₁), -(inv_mul_cancel_left a x₂), Peq] +lemma lmul_inv_on (a : A) (H : set A) : left_inv_on (lmul_by a⁻¹) (lmul_by a) H := + take x Px, show a⁻¹*(a*x) = x, by rewrite inv_mul_cancel_left +lemma lmul_inj_on (a : A) (H : set A) : inj_on (lmul_by a) H := + inj_on_of_left_inv_on (lmul_inv_on a H) + +lemma glcoset_eq_lcoset a (H : set A) : a ∘> H = coset.l a H := + ext + begin + intro x, + rewrite [↑glcoset, ↑coset.l, ↑image, ↑set_of, ↑mem, ↑coset.lmul], + apply iff.intro, + intro P1, + apply (exists.intro (a⁻¹ * x)), + apply and.intro, + exact P1, + exact (mul_inv_cancel_left a x), + show (∃ (x_1 : A), H x_1 ∧ a * x_1 = x) → H (a⁻¹ * x), from + assume P2, obtain x_1 P3, from P2, + have P4 : a * x_1 = x, from and.right P3, + have P5 : x_1 = a⁻¹ * x, from eq_inv_mul_of_mul_eq P4, + eq.subst P5 (and.left P3) + end +lemma grcoset_eq_rcoset a (H : set A) : H <∘ a = coset.r a H := + begin + rewrite [↑grcoset, ↑coset.r, ↑image, ↑coset.rmul, ↑set_of], + apply ext, rewrite ↑mem, + intro x, + apply iff.intro, + show H (x * a⁻¹) → (∃ (x_1 : A), H x_1 ∧ x_1 * a = x), from + assume PH, + exists.intro (x * a⁻¹) + (and.intro PH (inv_mul_cancel_right x a)), + show (∃ (x_1 : A), H x_1 ∧ x_1 * a = x) → H (x * a⁻¹), from + assume Pex, + obtain x_1 Pand, from Pex, + eq.subst (eq_mul_inv_of_mul_eq (and.right Pand)) (and.left Pand) + end +lemma glcoset_sub a (S H : set A) : S ⊆ H → (a ∘> S) ⊆ (a ∘> H) := + assume Psub, + have P : _, from coset.l_sub a S H Psub, + eq.symm (glcoset_eq_lcoset a S) ▸ eq.symm (glcoset_eq_lcoset a H) ▸ P +lemma glcoset_compose (a b : A) (H : set A) : a ∘> b ∘> H = a*b ∘> H := + begin + rewrite [*glcoset_eq_lcoset], exact (coset.lcompose a b H) + end +lemma grcoset_compose (a b : A) (H : set A) : H <∘ a <∘ b = H <∘ a*b := + begin + rewrite [*grcoset_eq_rcoset], exact (coset.rcompose b a H) + end +lemma glcoset_id (H : set A) : 1 ∘> H = H := + funext (assume x, + calc (1 ∘> H) x = H (1⁻¹*x) : rfl + ... = H (1*x) : {one_inv} + ... = H x : {one_mul x}) +lemma grcoset_id (H : set A) : H <∘ 1 = H := + funext (assume x, + calc H (x*1⁻¹) = H (x*1) : {one_inv} + ... = H x : {mul_one x}) +--lemma glcoset_inv a (H : set A) : a⁻¹ ∘> a ∘> H = H := +-- funext (assume x, +-- calc glcoset a⁻¹ (glcoset a H) x = H x : {mul_inv_cancel_left a⁻¹ x}) +lemma glcoset_inv a (H : set A) : a⁻¹ ∘> a ∘> H = H := + calc a⁻¹ ∘> a ∘> H = (a⁻¹*a) ∘> H : glcoset_compose + ... = 1 ∘> H : mul.left_inv + ... = H : glcoset_id +lemma grcoset_inv H (a : A) : (H <∘ a) <∘ a⁻¹ = H := + funext (assume x, + calc grcoset (grcoset H a) a⁻¹ x = H x : {inv_mul_cancel_right x a⁻¹}) +lemma glcoset_cancel a b (H : set A) : (b*a⁻¹) ∘> a ∘> H = b ∘> H := + calc (b*a⁻¹) ∘> a ∘> H = b*a⁻¹*a ∘> H : glcoset_compose + ... = b ∘> H : {inv_mul_cancel_right b a} +lemma grcoset_cancel a b (H : set A) : H <∘ a <∘ a⁻¹*b = H <∘ b := + calc H <∘ a <∘ a⁻¹*b = H <∘ a*(a⁻¹*b) : grcoset_compose + ... = H <∘ b : {mul_inv_cancel_left a b} +-- test how precedence breaks tie: infixr takes hold since its encountered first +example a b (H : set A) : a ∘> H <∘ b = a ∘> (H <∘ b) := rfl +-- should be true for semigroup as well but irrelevant +lemma lcoset_rcoset_assoc a b (H : set A) : a ∘> H <∘ b = (a ∘> H) <∘ b := + funext (assume x, begin + esimp [glcoset, grcoset], rewrite mul.assoc + end) +definition mul_closed_on H := ∀ (x y : A), x ∈ H → y ∈ H → x * y ∈ H +lemma closed_lcontract a (H : set A) : mul_closed_on H → a ∈ H → a ∘> H ⊆ H := + begin + rewrite [↑mul_closed_on, ↑glcoset, ↑subset, ↑mem], + intro Pclosed, intro PHa, intro x, intro PHainvx, + exact (eq.subst (mul_inv_cancel_left a x) + (Pclosed a (a⁻¹*x) PHa PHainvx)) + end +lemma closed_rcontract a (H : set A) : mul_closed_on H → a ∈ H → H <∘ a ⊆ H := + assume P1 : mul_closed_on H, + assume P2 : H a, + begin + rewrite ↑subset, + intro x, + rewrite [↑grcoset, ↑mem], + intro P3, + exact (eq.subst (inv_mul_cancel_right x a) (P1 (x * a⁻¹) a P3 P2)) + end +lemma closed_lcontract_set a (H G : set A) : mul_closed_on G → H ⊆ G → a∈G → a∘>H ⊆ G := + assume Pclosed, assume PHsubG, assume PainG, + have PaGsubG : a ∘> G ⊆ G, from closed_lcontract a G Pclosed PainG, + have PaHsubaG : a ∘> H ⊆ a ∘> G, from + eq.symm (glcoset_eq_lcoset a H) ▸ eq.symm (glcoset_eq_lcoset a G) ▸ (coset.l_sub a H G PHsubG), + subset.trans PaHsubaG PaGsubG +definition subgroup.has_inv H := ∀ (a : A), a ∈ H → a⁻¹ ∈ H +-- two ways to define the same equivalence relatiohship for subgroups +attribute [reducible] +definition in_lcoset H (a b : A) := a ∈ b ∘> H +attribute [reducible] +definition in_rcoset H (a b : A) := a ∈ H <∘ b +attribute [reducible] +definition same_lcoset H (a b : A) := a ∘> H = b ∘> H +attribute [reducible] +definition same_rcoset H (a b : A) := H <∘ a = H <∘ b +definition same_left_right_coset (N : set A) := ∀ x, x ∘> N = N <∘ x +structure is_subgroup [class] (H : set A) : Type := + (has_one : H 1) + (mul_closed : mul_closed_on H) + (has_inv : subgroup.has_inv H) +structure is_normal_subgroup [class] (N : set A) extends is_subgroup N := + (normal : same_left_right_coset N) +end + +section subgroup +variable {A : Type} +variable [s : group A] +include s +variable {H : set A} +variable [is_subg : is_subgroup H] +include is_subg +section set_reducible +local attribute set [reducible] +lemma subg_has_one : H (1 : A) := @is_subgroup.has_one A s H is_subg +lemma subg_mul_closed : mul_closed_on H := @is_subgroup.mul_closed A s H is_subg +lemma subg_has_inv : subgroup.has_inv H := @is_subgroup.has_inv A s H is_subg +lemma subgroup_coset_id : ∀ a, a ∈ H → (a ∘> H = H ∧ H <∘ a = H) := + take a, assume PHa : H a, + have Pl : a ∘> H ⊆ H, from closed_lcontract a H subg_mul_closed PHa, + have Pr : H <∘ a ⊆ H, from closed_rcontract a H subg_mul_closed PHa, + have PHainv : H a⁻¹, from subg_has_inv a PHa, + and.intro + (ext (assume x, + begin + esimp [glcoset, mem], + apply iff.intro, + apply Pl, + intro PHx, exact (subg_mul_closed a⁻¹ x PHainv PHx) + end)) + (ext (assume x, + begin + esimp [grcoset, mem], + apply iff.intro, + apply Pr, + intro PHx, exact (subg_mul_closed x a⁻¹ PHx PHainv) + end)) +lemma subgroup_lcoset_id : ∀ a, a ∈ H → a ∘> H = H := + take a, assume PHa : H a, + and.left (subgroup_coset_id a PHa) +lemma subgroup_rcoset_id : ∀ a, a ∈ H → H <∘ a = H := + take a, assume PHa : H a, + and.right (subgroup_coset_id a PHa) +lemma subg_in_coset_refl (a : A) : a ∈ a ∘> H ∧ a ∈ H <∘ a := + have PH1 : H 1, from subg_has_one, + have PHinvaa : H (a⁻¹*a), from (eq.symm (mul.left_inv a)) ▸ PH1, + have PHainva : H (a*a⁻¹), from (eq.symm (mul.right_inv a)) ▸ PH1, + and.intro PHinvaa PHainva +end set_reducible +lemma subg_in_lcoset_same_lcoset (a b : A) : in_lcoset H a b → same_lcoset H a b := + assume Pa_in_b : H (b⁻¹*a), + have Pbinva : b⁻¹*a ∘> H = H, from subgroup_lcoset_id (b⁻¹*a) Pa_in_b, + have Pb_binva : b ∘> b⁻¹*a ∘> H = b ∘> H, from Pbinva ▸ rfl, + have Pbbinva : b*(b⁻¹*a)∘>H = b∘>H, from glcoset_compose b (b⁻¹*a) H ▸ Pb_binva, + mul_inv_cancel_left b a ▸ Pbbinva +lemma subg_same_lcoset_in_lcoset (a b : A) : same_lcoset H a b → in_lcoset H a b := + assume Psame : a∘>H = b∘>H, + have Pa : a ∈ a∘>H, from and.left (subg_in_coset_refl a), + by exact (Psame ▸ Pa) +lemma subg_lcoset_same (a b : A) : in_lcoset H a b = (a∘>H = b∘>H) := + propext(iff.intro (subg_in_lcoset_same_lcoset a b) (subg_same_lcoset_in_lcoset a b)) +lemma subg_rcoset_same (a b : A) : in_rcoset H a b = (H<∘a = H<∘b) := + propext(iff.intro + (assume Pa_in_b : H (a*b⁻¹), + have Pabinv : H<∘a*b⁻¹ = H, from subgroup_rcoset_id (a*b⁻¹) Pa_in_b, + have Pabinv_b : H <∘ a*b⁻¹ <∘ b = H <∘ b, from Pabinv ▸ rfl, + have Pabinvb : H <∘ a*b⁻¹*b = H <∘ b, from grcoset_compose (a*b⁻¹) b H ▸ Pabinv_b, + inv_mul_cancel_right a b ▸ Pabinvb) + (assume Psame, + have Pa : a ∈ H<∘a, from and.right (subg_in_coset_refl a), + by exact (Psame ▸ Pa))) +lemma subg_same_lcoset.refl (a : A) : same_lcoset H a a := rfl +lemma subg_same_rcoset.refl (a : A) : same_rcoset H a a := rfl +lemma subg_same_lcoset.symm (a b : A) : same_lcoset H a b → same_lcoset H b a := eq.symm +lemma subg_same_rcoset.symm (a b : A) : same_rcoset H a b → same_rcoset H b a := eq.symm +lemma subg_same_lcoset.trans (a b c : A) : same_lcoset H a b → same_lcoset H b c → same_lcoset H a c := + eq.trans +lemma subg_same_rcoset.trans (a b c : A) : same_rcoset H a b → same_rcoset H b c → same_rcoset H a c := + eq.trans +variable {S : set A} +lemma subg_lcoset_subset_subg (Psub : S ⊆ H) (a : A) : a ∈ H → a ∘> S ⊆ H := + assume Pin, have P : a ∘> S ⊆ a ∘> H, from glcoset_sub a S H Psub, + subgroup_lcoset_id a Pin ▸ P + +end subgroup + +section normal_subg +open quot +variable {A : Type} +variable [s : group A] +include s +variable (N : set A) +variable [is_nsubg : is_normal_subgroup N] +include is_nsubg + +local notation a `~` b := same_lcoset N a b -- note : does not bind as strong as → + +lemma nsubg_normal : same_left_right_coset N := @is_normal_subgroup.normal A s N is_nsubg +lemma nsubg_same_lcoset_product : ∀ a1 a2 b1 b2, (a1 ~ b1) → (a2 ~ b2) → ((a1*a2) ~ (b1*b2)) := + take a1, take a2, take b1, take b2, + assume Psame1 : a1 ∘> N = b1 ∘> N, + assume Psame2 : a2 ∘> N = b2 ∘> N, + calc + a1*a2 ∘> N = a1 ∘> a2 ∘> N : glcoset_compose + ... = a1 ∘> b2 ∘> N : by rewrite Psame2 + ... = a1 ∘> (N <∘ b2) : by rewrite (nsubg_normal N) + ... = (a1 ∘> N) <∘ b2 : by rewrite lcoset_rcoset_assoc + ... = (b1 ∘> N) <∘ b2 : by rewrite Psame1 + ... = N <∘ b1 <∘ b2 : by rewrite (nsubg_normal N) + ... = N <∘ (b1*b2) : by rewrite grcoset_compose + ... = (b1*b2) ∘> N : by rewrite (nsubg_normal N) + +example (a b : A) : (a⁻¹ ~ b⁻¹) = (a⁻¹ ∘> N = b⁻¹ ∘> N) := rfl +lemma nsubg_same_lcoset_inv : ∀ a b, (a ~ b) → (a⁻¹ ~ b⁻¹) := + take a b, assume Psame : a ∘> N = b ∘> N, calc + a⁻¹ ∘> N = a⁻¹*b*b⁻¹ ∘> N : by rewrite mul_inv_cancel_right + ... = a⁻¹*b ∘> b⁻¹ ∘> N : by rewrite glcoset_compose + ... = a⁻¹*b ∘> (N <∘ b⁻¹) : by rewrite nsubg_normal + ... = (a⁻¹*b ∘> N) <∘ b⁻¹ : by rewrite lcoset_rcoset_assoc + ... = (a⁻¹ ∘> b ∘> N) <∘ b⁻¹ : by rewrite glcoset_compose + ... = (a⁻¹ ∘> a ∘> N) <∘ b⁻¹ : by rewrite Psame + ... = N <∘ b⁻¹ : by rewrite glcoset_inv + ... = b⁻¹ ∘> N : by rewrite nsubg_normal +attribute [instance] +definition nsubg_setoid : setoid A := + setoid.mk (same_lcoset N) + (mk_equivalence (same_lcoset N) (subg_same_lcoset.refl) (subg_same_lcoset.symm) (subg_same_lcoset.trans)) +definition coset_of : Type := quot (nsubg_setoid N) + +definition coset_inv_base (a : A) : coset_of N := ⟦a⁻¹⟧ +definition coset_product (a b : A) : coset_of N := ⟦a*b⟧ +lemma coset_product_well_defined : ∀ a1 a2 b1 b2, (a1 ~ b1) → (a2 ~ b2) → ⟦a1*a2⟧ = ⟦b1*b2⟧ := + take a1 a2 b1 b2, assume P1 P2, + quot.sound (nsubg_same_lcoset_product N a1 a2 b1 b2 P1 P2) +definition coset_mul (aN bN : coset_of N) : coset_of N := + quot.lift_on₂ aN bN (coset_product N) (coset_product_well_defined N) +lemma coset_inv_well_defined : ∀ a b, (a ~ b) → ⟦a⁻¹⟧ = ⟦b⁻¹⟧ := + take a b, assume P, quot.sound (nsubg_same_lcoset_inv N a b P) +definition coset_inv (aN : coset_of N) : coset_of N := + quot.lift_on aN (coset_inv_base N) (coset_inv_well_defined N) +definition coset_one : coset_of N := ⟦1⟧ + +local infixl `cx`:70 := coset_mul N +example (a b c : A) : ⟦a⟧ cx ⟦b*c⟧ = ⟦a*(b*c)⟧ := rfl + +lemma coset_product_assoc (a b c : A) : ⟦a⟧ cx ⟦b⟧ cx ⟦c⟧ = ⟦a⟧ cx (⟦b⟧ cx ⟦c⟧) := calc + ⟦a*b*c⟧ = ⟦a*(b*c)⟧ : {mul.assoc a b c} + ... = ⟦a⟧ cx ⟦b*c⟧ : rfl +lemma coset_product_left_id (a : A) : ⟦1⟧ cx ⟦a⟧ = ⟦a⟧ := calc + ⟦1*a⟧ = ⟦a⟧ : {one_mul a} +lemma coset_product_right_id (a : A) : ⟦a⟧ cx ⟦1⟧ = ⟦a⟧ := calc + ⟦a*1⟧ = ⟦a⟧ : {mul_one a} +lemma coset_product_left_inv (a : A) : ⟦a⁻¹⟧ cx ⟦a⟧ = ⟦1⟧ := calc + ⟦a⁻¹*a⟧ = ⟦1⟧ : {mul.left_inv a} +lemma coset_mul.assoc (aN bN cN : coset_of N) : aN cx bN cx cN = aN cx (bN cx cN) := + quot.ind (λ a, quot.ind (λ b, quot.ind (λ c, coset_product_assoc N a b c) cN) bN) aN +lemma coset_mul.one_mul (aN : coset_of N) : coset_one N cx aN = aN := + quot.ind (coset_product_left_id N) aN +lemma coset_mul.mul_one (aN : coset_of N) : aN cx (coset_one N) = aN := + quot.ind (coset_product_right_id N) aN +lemma coset_mul.left_inv (aN : coset_of N) : (coset_inv N aN) cx aN = (coset_one N) := + quot.ind (coset_product_left_inv N) aN +definition mk_quotient_group : group (coset_of N):= + group.mk (coset_mul N) (coset_mul.assoc N) (coset_one N) (coset_mul.one_mul N) (coset_mul.mul_one N) (coset_inv N) (coset_mul.left_inv N) + +end normal_subg + +namespace group_theory +namespace quotient +section +open quot +variable {A : Type} +variable [s : group A] +include s +variable {N : set A} +variable [is_nsubg : is_normal_subgroup N] +include is_nsubg +attribute [instance] +definition quotient_group : group (coset_of N) := mk_quotient_group N + +example (aN : coset_of N) : aN * aN⁻¹ = 1 := mul.right_inv aN +definition natural (a : A) : coset_of N := ⟦a⟧ + +end +end quotient +end group_theory diff --git a/old_library/theories/measure_theory/extended_real.lean b/old_library/theories/measure_theory/extended_real.lean new file mode 100644 index 0000000000..c2c6748668 --- /dev/null +++ b/old_library/theories/measure_theory/extended_real.lean @@ -0,0 +1,420 @@ +/- +Copyright (c) 2015 Jacob Gross. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jacob Gross, Jeremy Avigad + +Extended reals. +-/ +import data.real +open real eq.ops classical + +-- This is a hack, to get around the fact that the top level names are inaccessible when +-- defining these theorems in the ereal namespace. Is there a better way? +private definition zero_mul' := @zero_mul +private definition mul_zero' := @mul_zero +private definition neg_neg' := @neg_neg + +noncomputable theory + +inductive ereal : Type := +| of_real : ℝ → ereal +| infty : ereal +| neginfty : ereal + +-- attribute ereal.of_real [coercion] +notation `∞` := ereal.infty +notation `-∞` := ereal.neginfty + +namespace ereal + +protected definition prio := num.pred real.prio + +/- arithmetic operations on the ereals -/ + +attribute [instance, priority ereal.prio] +definition ereal_has_zero : has_zero ereal := +has_zero.mk (of_real 0) + +attribute [instance, priority ereal.prio] +definition ereal_has_one : has_one ereal := +has_one.mk (of_real 1) + +protected definition add : ereal → ereal → ereal +| (of_real x) (of_real y) := of_real (x + y) +| ∞ _ := ∞ +| _ ∞ := ∞ +| -∞ _ := -∞ +| _ -∞ := -∞ + +protected definition neg : ereal → ereal +| (of_real x) := of_real (-x) +| ∞ := -∞ +| -∞ := ∞ + +attribute [reducible] +private definition blow_up : ereal → ereal +| (of_real x) := if x = 0 then of_real 0 else if x > 0 then ∞ else -∞ +| ∞ := ∞ +| -∞ := -∞ + +protected definition mul : ereal → ereal → ereal +| (of_real x) (of_real y) := of_real (x * y) +| ∞ a := blow_up a +| a ∞ := blow_up a +| -∞ a := ereal.neg (blow_up a) +| a -∞ := ereal.neg (blow_up a) + +attribute [instance, priority ereal.prio] +definition ereal_has_add : has_add ereal := +has_add.mk ereal.add + +attribute [instance, priority ereal.prio] +definition ereal_has_neg : has_neg ereal := +has_neg.mk ereal.neg + +protected definition sub (u v : ereal) : ereal := u + -v + +attribute [instance, priority ereal.prio] +definition ereal_has_sub : has_sub ereal := +has_sub.mk ereal.sub + +attribute [instance, priority ereal.prio] +definition ereal_has_mul : has_mul ereal := +has_mul.mk ereal.mul + +protected theorem zero_def : (0 : ereal) = of_real 0 := rfl + +protected theorem one_def : (1 : ereal) = of_real 1 := rfl + +protected theorem add_def (x y : ereal) : x + y = ereal.add x y := rfl + +protected theorem neg_def (x : ereal) : -x = ereal.neg x := rfl + +protected theorem sub_eq_add_neg (u v : ereal) : u - v = u + -v := rfl + +protected theorem mul_def (x y : ereal) : x * y = ereal.mul x y := rfl + +theorem of_real.inj {x y : real} (H : of_real x = of_real y) : x = y := +ereal.no_confusion H (assume H1, H1) + +abbreviation eq_of_of_real_eq_of_real := @of_real.inj + +theorem of_real_add (x y : real) : of_real (x + y) = of_real x + of_real y := rfl + +theorem of_real_mul (x y : real) : of_real (x * y) = of_real x * of_real y := rfl + +theorem infty_ne_neg_infty : ∞ ≠ -∞ := ereal.no_confusion + +theorem infty_ne_of_real (x : real) : ∞ ≠ of_real x := ereal.no_confusion + +theorem neg_infty_ne_of_real (x : real) : -∞ ≠ of_real x := ereal.no_confusion + +/- properties of the arithmetic operations -/ + +protected theorem add_comm : ∀ u v : ereal, u + v = v + u +| (of_real x) (of_real y) := congr_arg of_real !add.comm +| ∞ v := by rewrite[*ereal.add_def, ↑ereal.add] +| u ∞ := by rewrite[*ereal.add_def, ↑ereal.add] +| -∞ v := by rewrite[*ereal.add_def, ↑ereal.add] +| u -∞ := by rewrite[*ereal.add_def, ↑ereal.add] + +theorem infty_add : ∀ u, ∞ + u = ∞ +| (of_real x) := rfl +| ∞ := rfl +| -∞ := rfl + +theorem add_infty : ∀ u, u + ∞ = ∞ +| (of_real x) := rfl +| ∞ := rfl +| -∞ := rfl + +protected theorem add_assoc : ∀ u v w : ereal, (u + v) + w = u + (v + w) +| (of_real x) (of_real y) (of_real z) := congr_arg of_real !add.assoc +| ∞ v w := by rewrite [*infty_add, *add_infty] +| u ∞ w := by rewrite [*infty_add, *add_infty, infty_add] +| u v ∞ := by rewrite [*infty_add, *add_infty] +| (of_real x) (of_real y) -∞ := by rewrite[*ereal.add_def, ↑ereal.add] +| (of_real x) -∞ (of_real z) := by rewrite[*ereal.add_def, ↑ereal.add] +| -∞ (of_real y) (of_real z) := by rewrite[*ereal.add_def, ↑ereal.add] +| (of_real x) -∞ -∞ := by rewrite[*ereal.add_def, ↑ereal.add] +| -∞ (of_real y) -∞ := rfl +| -∞ -∞ (of_real z) := by rewrite[*ereal.add_def, ↑ereal.add] +| -∞ -∞ -∞ := rfl + +protected theorem zero_add : ∀ u : ereal, 0 + u = u +| (of_real x) := congr_arg of_real !real.zero_add +| ∞ := rfl +| -∞ := rfl + +protected theorem add_zero : ∀ u : ereal, u + 0 = u := +by intro u; rewrite [ereal.add_comm, ereal.zero_add] + +protected theorem mul_comm : ∀ u v : ereal, u * v = v * u +| (of_real x) (of_real y) := congr_arg of_real !mul.comm +| ∞ a := by rewrite [*ereal.mul_def, ↑ereal.mul] +| a ∞ := by rewrite [*ereal.mul_def, ↑ereal.mul] +| -∞ a := by rewrite [*ereal.mul_def, ↑ereal.mul] +| a -∞ := by rewrite [*ereal.mul_def, ↑ereal.mul] + +protected theorem neg_neg : ∀ u : ereal, -(-u) = u +| ∞ := rfl +| (of_real x) := by rewrite [*ereal.neg_def, ↑ereal.neg, ▸*, + (neg_neg' x)] +| -∞ := rfl + +theorem neg_infty : -∞ = - ∞ := rfl + +protected theorem neg_zero : -(0 : ereal) = 0 := rfl + +theorem infty_mul_pos {x : real} (H : x > 0) : ∞ * x = ∞ := +have H1 : x ≠ 0, from ne_of_gt H, +by rewrite [*ereal.mul_def, ↑ereal.mul, if_neg H1, if_pos H] + +theorem pos_mul_infty {x : real} (H : x > 0) : x * ∞ = ∞ := +by rewrite [ereal.mul_comm, infty_mul_pos H] + +theorem infty_mul_neg {x : real} (H : x < 0) : ∞ * x = -∞ := +have H1 : x ≠ 0, from ne_of_lt H, +have H2 : ¬ x > 0, from not_lt_of_gt H, +by rewrite [*ereal.mul_def, ↑ereal.mul, if_neg H1, if_neg H2] + +theorem neg_mul_infty {x : real} (H : x < 0) : x * ∞ = -∞ := +by rewrite [ereal.mul_comm, infty_mul_neg H] + +private theorem infty_mul_zero : ∞ * 0 = 0 := +by rewrite [*ereal.mul_def, ↑ereal.mul, ereal.zero_def, ↑blow_up, if_pos rfl] + +private theorem zero_mul_infty : 0 * ∞ = 0 := +by rewrite [ereal.mul_comm, infty_mul_zero] + +theorem infty_mul_infty : ∞ * ∞ = ∞ := rfl + +protected theorem neg_of_real (x : real) : -(of_real x) = of_real (-x) := +rfl + +private theorem aux1 : ∀ v : ereal, -∞ * v = -(∞ * v) +| ∞ := rfl +| (of_real x) := rfl +| -∞ := rfl + +private theorem aux2 : ∀ u : ereal, -u * ∞ = -(u * ∞) +| ∞ := rfl +| (of_real x) := lt.by_cases + (assume H : x < 0, + by rewrite [ereal.neg_of_real, pos_mul_infty (neg_pos_of_neg H), + neg_mul_infty H]) + (assume H : x = 0, + by krewrite [H, ereal.neg_zero, *zero_mul_infty, ereal.neg_zero]) + (assume H : x > 0, + by rewrite [ereal.neg_of_real, neg_mul_infty (neg_neg_of_pos H), + pos_mul_infty H]) +| -∞ := rfl + +theorem ereal_neg_mul : ∀ u v : ereal, -u * v = -(u * v) +| ∞ v := aux1 v +| -∞ v := by rewrite [aux1, *ereal.neg_neg] +| u ∞ := by rewrite [-aux2] +| u -∞ := by rewrite [ereal.mul_comm, ereal.mul_comm u, + *aux1, ereal.mul_comm, aux2, *ereal.neg_neg] +| (of_real x) (of_real y) := congr_arg of_real (eq.symm (neg_mul_eq_neg_mul x y)) + +theorem ereal_mul_neg (u v : ereal) : u * -v = -(u * v) := +by rewrite [*ereal.mul_comm u, ereal_neg_mul] + +protected theorem mul_zero : ∀ u : ereal, u * 0 = 0 +| ∞ := infty_mul_zero +| -∞ := by rewrite [neg_infty, ereal_neg_mul, infty_mul_zero] +| (of_real x) := congr_arg of_real (mul_zero' x) + +protected theorem zero_mul (u : ereal) : 0 * u = 0 := +by rewrite [ereal.mul_comm, ereal.mul_zero] + +private theorem aux3 : ∀ u, ∞ * (∞ * u) = ∞ * u +| ∞ := rfl +| (of_real x) := if H : x = 0 then + by rewrite [*ereal.mul_def, ↑ereal.mul, ↑blow_up, *H, *if_pos rfl] + else if H1 : x > 0 then + by rewrite [*ereal.mul_def, ↑ereal.mul, ↑blow_up, if_neg H, if_pos H1] + else + by rewrite [*ereal.mul_def, ↑ereal.mul, ↑blow_up, if_neg H, if_neg H1] +| -∞ := rfl + +private theorem aux4 (x y : real) : ∞ * x * y = ∞ * (x * y) := +lt.by_cases + (assume H : x < 0, + lt.by_cases + (assume H1 : y < 0, by rewrite [infty_mul_neg H, neg_infty, ereal_neg_mul, -of_real_mul, + infty_mul_neg H1, infty_mul_pos (mul_pos_of_neg_of_neg H H1)]) + (assume H1 : y = 0, by krewrite [H1, *ereal.mul_zero]) + (assume H1 : y > 0, by rewrite [infty_mul_neg H, neg_infty, *ereal_neg_mul, -of_real_mul, + infty_mul_pos H1, infty_mul_neg (mul_neg_of_neg_of_pos H H1)])) + (assume H : x = 0, + by krewrite [H, ereal.mul_zero, *ereal.zero_mul, ereal.mul_zero]) + (assume H : x > 0, + lt.by_cases + (assume H1 : y < 0, by rewrite [infty_mul_pos H, infty_mul_neg H1, -of_real_mul, + infty_mul_neg (mul_neg_of_pos_of_neg H H1)]) + (assume H1 : y = 0, by krewrite [H1, *ereal.mul_zero]) + (assume H1 : y > 0, by rewrite [infty_mul_pos H, infty_mul_pos H1, -of_real_mul, + infty_mul_pos (mul_pos H H1)])) + +private theorem aux5 : ∀ u v, ∞ * u * v = ∞ * (u * v) +| ∞ v := by rewrite [infty_mul_infty, aux3] +| u ∞ := by rewrite [-*ereal.mul_comm ∞] +| -∞ v := by rewrite [neg_infty, *ereal_neg_mul, *ereal_mul_neg, ereal_neg_mul, infty_mul_infty, + aux3] +| u -∞ := by rewrite [neg_infty, *ereal_mul_neg] +| (of_real x) (of_real y) := aux4 x y + +protected theorem mul_assoc : ∀ u v w : ereal, u * v * w = u * (v * w) +| ∞ v w := !aux5 +| u ∞ w := by rewrite [-*ereal.mul_comm ∞, *ereal.mul_comm u, *aux5, *ereal.mul_comm u] +| u v ∞ := by rewrite [-*ereal.mul_comm ∞, *ereal.mul_comm u, aux5] +| -∞ v w := by rewrite [neg_infty, *ereal_neg_mul, aux5] +| u -∞ w := by rewrite [neg_infty, *ereal_mul_neg, *ereal_neg_mul, ereal_mul_neg, *ereal.mul_comm u, + *aux5, ereal.mul_comm u] +| u v -∞ := by rewrite [neg_infty, *ereal_mul_neg, *ereal.mul_comm u, -*ereal.mul_comm ∞, aux5] +| (of_real x) (of_real y) (of_real z) := congr_arg of_real (mul.assoc x y z) + +protected theorem one_mul : ∀ u : ereal, of_real 1 * u = u +| (of_real x) := !real.one_mul ▸ rfl +| ∞ := pos_mul_infty zero_lt_one +| -∞ := by rewrite [neg_infty, ereal_mul_neg, pos_mul_infty zero_lt_one] + +protected theorem mul_one (u : ereal) : u * 1 = u := +by krewrite [ereal.mul_comm, ereal.one_mul] + +/- instantiating arithmetic structures -/ + +-- Note that distributivity fails, e.g. ∞ ⬝ (-1 + 1) ≠ ∞ * -1 + ∞ * 1 + +attribute [trans_instance] +protected definition comm_monoid : comm_monoid ereal := +⦃comm_monoid, + mul := ereal.mul, + mul_assoc := ereal.mul_assoc, + one := 1, + one_mul := ereal.one_mul, + mul_one := ereal.mul_one, + mul_comm := ereal.mul_comm +⦄ + +attribute [trans_instance] +protected definition add_comm_monoid : add_comm_monoid ereal := +⦃add_comm_monoid, + add := ereal.add, + add_assoc := ereal.add_assoc, + zero := 0, + zero_add := ereal.zero_add, + add_zero := ereal.add_zero, + add_comm := ereal.add_comm +⦄ + +/- ordering on the ereals -/ + +protected definition le : ereal → ereal → Prop +| u ∞ := true +| -∞ v := true +| (of_real x) (of_real y) := x ≤ y +| (of_real x) -∞ := false +| ∞ (of_real y) := false +| ∞ -∞ := false + +attribute [instance, priority ereal.prio] +definition ereal_has_le : has_le ereal := +has_le.mk ereal.le + +theorem of_real_le_of_real (x y : real) : of_real x ≤ of_real y ↔ x ≤ y := +!iff.refl + +theorem le_infty : ∀ u, u ≤ ∞ +| ∞ := trivial +| (of_real x) := trivial +| -∞ := trivial + +theorem neg_infty_le : ∀ v, -∞ ≤ v +| ∞ := trivial +| (of_real x) := trivial +| -∞ := trivial + +protected theorem le_refl : ∀ u : ereal, u ≤ u +| ∞ := trivial +| -∞ := trivial +| (of_real x) := by rewrite [of_real_le_of_real] + +protected theorem le_trans : ∀ u v w : ereal, u ≤ v → v ≤ w → u ≤ w +| u v ∞ H1 H2 := !le_infty +| -∞ v w H1 H2 := !neg_infty_le +| u ∞ (of_real x) H1 H2 := false.elim H2 +| ∞ (of_real x) v H1 H2 := false.elim H1 +| ∞ -∞ v H1 H2 := false.elim H1 +| u (of_real x) -∞ H1 H2 := false.elim H2 +| u ∞ -∞ H1 H2 := false.elim H2 +| (of_real x) -∞ v H1 H2 := false.elim H1 +| (of_real x) (of_real y) (of_real z) H1 H2 := + iff.mpr !of_real_le_of_real + (le.trans (iff.mp !of_real_le_of_real H1) (iff.mp !of_real_le_of_real H2)) + +protected theorem le_antisymm : ∀ u v : ereal, u ≤ v → v ≤ u → u = v +| ∞ ∞ H1 H2 := rfl +| ∞ (of_real x) H1 H2 := false.elim H1 +| ∞ -∞ H1 H2 := false.elim H1 +| -∞ -∞ H1 H2 := rfl +| -∞ (of_real x) H1 H2 := false.elim H2 +| -∞ ∞ H1 H2 := false.elim H2 +| (of_real x) ∞ H1 H2 := false.elim H2 +| (of_real x) -∞ H1 H2 := false.elim H1 +| (of_real x) (of_real y) H1 H2 := + congr_arg of_real (le.antisymm (iff.mp !of_real_le_of_real H1) (iff.mp !of_real_le_of_real H2)) + +protected definition lt (x y : ereal) : Prop := x ≤ y ∧ x ≠ y + +attribute [instance, priority ereal.prio] +definition ereal_has_lt : + has_lt ereal := +has_lt.mk ereal.lt + +protected theorem le_iff_lt_or_eq (u v : ereal) : u ≤ v ↔ u < v ∨ u = v := +iff.intro + (assume H : u ≤ v, + by_cases + (assume H1 : u = v, or.inr H1) + (assume H1 : u ≠ v, or.inl (and.intro H H1))) + (assume H : u < v ∨ u = v, + or.elim H + (assume H1 : u < v, and.left H1) + (assume H1 : u = v, by rewrite H1; apply ereal.le_refl)) + +protected theorem le_total : ∀ u v : ereal, u ≤ v ∨ v ≤ u +| u ∞ := or.inl (le_infty u) +| u -∞ := or.inr (neg_infty_le u) +| ∞ v := or.inr (le_infty v) +| -∞ v := or.inl (neg_infty_le v) +| (of_real x) (of_real y) := + or.elim (le.total x y) + (assume H : x ≤[real] y, or.inl (iff.mpr !of_real_le_of_real H)) + (assume H : x ≥[real] y, or.inr (iff.mpr !of_real_le_of_real H)) + +theorem neg_infty_lt_infty : -∞ < ∞ := and.intro trivial (ne.symm infty_ne_neg_infty) + +theorem neg_infty_lt_of_real (x : real) : -∞ < of_real x := and.intro trivial !neg_infty_ne_of_real + +theorem of_real_lt_infty (x : real) : of_real x < ∞ := and.intro trivial (ne.symm !infty_ne_of_real) + +attribute [trans_instance] +protected definition decidable_linear_order : decidable_linear_order ereal := +⦃decidable_linear_order, + le := ereal.le, + le_refl := ereal.le_refl, + le_trans := ereal.le_trans, + le_antisymm := ereal.le_antisymm, + lt := ereal.lt, + le_iff_lt_or_eq := ereal.le_iff_lt_or_eq, + lt_irrefl := abstract λ u H, and.right H rfl end, + decidable_lt := abstract λ u v : ereal, prop_decidable (u < v) end, + le_total := ereal.le_total +⦄ + +-- TODO : we still need some properties relating the arithmetic operations and the order. + +end ereal diff --git a/old_library/theories/measure_theory/measure_theory.md b/old_library/theories/measure_theory/measure_theory.md new file mode 100644 index 0000000000..66b1420049 --- /dev/null +++ b/old_library/theories/measure_theory/measure_theory.md @@ -0,0 +1,5 @@ +measure_theory +============== + +* [extended_real](extended_real.lean) +* [sigma_algebra](sigma_algebra.lean) \ No newline at end of file diff --git a/old_library/theories/measure_theory/sigma_algebra.lean b/old_library/theories/measure_theory/sigma_algebra.lean new file mode 100644 index 0000000000..79b3e4f8d3 --- /dev/null +++ b/old_library/theories/measure_theory/sigma_algebra.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2016 Jacob Gross. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jacob Gross, Jeremy Avigad + +Sigma algebras. +-/ +import data.set data.nat theories.topology.basic +open eq.ops set nat + +structure sigma_algebra [class] (X : Type) := + (sets : set (set X)) + (univ_mem_sets : univ ∈ sets) + (comp_mem_sets : ∀ {s : set X}, s ∈ sets → (-s ∈ sets)) + (cUnion_mem_sets : ∀ {s : ℕ → set X}, (∀ i, s i ∈ sets) → (⋃ i, s i) ∈ sets) + +/- Closure properties -/ + +namespace measure_theory +open sigma_algebra + +variables {X : Type} [sigma_algebra X] + +definition measurable (t : set X) : Prop := t ∈ sets X + +theorem measurable_univ : measurable (@univ X) := +univ_mem_sets X + +theorem measurable_compl {s : set X} (H : measurable s) : measurable (-s) := +comp_mem_sets H + +theorem measurable_of_measurable_compl {s : set X} (H : measurable (-s)) : measurable s := +!compl_compl ▸ measurable_compl H + +theorem measurable_empty : measurable (∅ : set X) := +compl_univ ▸ measurable_compl measurable_univ + +theorem measurable_cUnion {s : ℕ → set X} (H : ∀ i, measurable (s i)) : + measurable (⋃ i, s i) := +cUnion_mem_sets H + +theorem measurable_cInter {s : ℕ → set X} (H : ∀ i, measurable (s i)) : + measurable (⋂ i, s i) := +have ∀ i, measurable (-(s i)), from take i, measurable_compl (H i), +have measurable (-(⋃ i, -(s i))), from measurable_compl (measurable_cUnion this), +show measurable (⋂ i, s i), by rewrite Inter_eq_comp_Union_comp; apply this + +theorem measurable_union {s t : set X} (Hs : measurable s) (Ht : measurable t) : + measurable (s ∪ t) := +have ∀ i, measurable (bin_ext s t i), by intro i; cases i; exact Hs; exact Ht, +show measurable (s ∪ t), by rewrite -Union_bin_ext; exact measurable_cUnion this + +theorem measurable_inter {s t : set X} (Hs : measurable s) (Ht : measurable t) : + measurable (s ∩ t) := +have ∀ i, measurable (bin_ext s t i), by intro i; cases i; exact Hs; exact Ht, +show measurable (s ∩ t), by rewrite -Inter_bin_ext; exact measurable_cInter this + +theorem measurable_diff {s t : set X} (Hs : measurable s) (Ht : measurable t) : + measurable (s \ t) := +measurable_inter Hs (measurable_compl Ht) + +theorem measurable_insert {x : X} {s : set X} (Hx : measurable '{x}) (Hs : measurable s) : + measurable (insert x s) := +!insert_eq⁻¹ ▸ measurable_union Hx Hs + +end measure_theory + +/- +-- Properties of sigma algebras +-/ + +namespace sigma_algebra +open measure_theory +variable {X : Type} + +protected theorem eq {M N : sigma_algebra X} (H : @sets X M = @sets X N) : + M = N := +by cases M; cases N; cases H; apply rfl + +/- sigma algebra generated by a set -/ + +inductive sets_generated_by (G : set (set X)) : set X → Prop := +| generators_mem : ∀ ⦃s : set X⦄, s ∈ G → sets_generated_by G s +| univ_mem : sets_generated_by G univ +| comp_mem : ∀ ⦃s : set X⦄, sets_generated_by G s → sets_generated_by G (-s) +| cUnion_mem : ∀ ⦃s : ℕ → set X⦄, (∀ i, sets_generated_by G (s i)) → + sets_generated_by G (⋃ i, s i) + +protected definition generated_by {X : Type} (G : set (set X)) : sigma_algebra X := +⦃sigma_algebra, + sets := sets_generated_by G, + univ_mem_sets := sets_generated_by.univ_mem G, + comp_mem_sets := sets_generated_by.comp_mem , + cUnion_mem_sets := sets_generated_by.cUnion_mem ⦄ + +theorem sets_generated_by_initial {G : set (set X)} {M : sigma_algebra X} (H : G ⊆ @sets _ M) : + sets_generated_by G ⊆ @sets _ M := +begin + intro s Hs, + induction Hs with s sG s Hs ssX s Hs sisX, + {exact H sG}, + {exact measurable_univ}, + {exact measurable_compl ssX}, + exact measurable_cUnion sisX +end + +theorem measurable_generated_by {G : set (set X)} : + ∀₀ s ∈ G, @measurable _ (sigma_algebra.generated_by G) s := +λ s H, sets_generated_by.generators_mem H + +/- The collection of sigma algebras forms a complete lattice. -/ + +protected definition le (M N : sigma_algebra X) : Prop := @sets _ M ⊆ @sets _ N + +attribute [instance] +definition sigma_algebra_has_le : + has_le (sigma_algebra X) := +has_le.mk sigma_algebra.le + +protected theorem le_refl (M : sigma_algebra X) : M ≤ M := subset.refl (@sets _ M) + +protected theorem le_trans (M N L : sigma_algebra X) : M ≤ N → N ≤ L → M ≤ L := +assume H1, assume H2, +subset.trans H1 H2 + +protected theorem le_antisymm (M N : sigma_algebra X) : M ≤ N → N ≤ M → M = N := +assume H1, assume H2, +sigma_algebra.eq (subset.antisymm H1 H2) + +protected theorem generated_by_initial {G : set (set X)} {M : sigma_algebra X} (H : G ⊆ @sets X M) : + sigma_algebra.generated_by G ≤ M := +sets_generated_by_initial H + +protected definition inf (M N : sigma_algebra X) : sigma_algebra X := +⦃sigma_algebra, + sets := @sets X M ∩ @sets X N, + univ_mem_sets := abstract and.intro (@measurable_univ X M) (@measurable_univ X N) end, + comp_mem_sets := abstract take s, assume Hs, and.intro + (@measurable_compl X M s (and.elim_left Hs)) + (@measurable_compl X N s (and.elim_right Hs)) end, + cUnion_mem_sets := abstract take s, assume Hs, and.intro + (@measurable_cUnion X M s (λ i, and.elim_left (Hs i))) + (@measurable_cUnion X N s (λ i, and.elim_right (Hs i))) end⦄ + +protected theorem inf_le_left (M N : sigma_algebra X) : sigma_algebra.inf M N ≤ M := +λ s, !inter_subset_left + +protected theorem inf_le_right (M N : sigma_algebra X) : sigma_algebra.inf M N ≤ N := +λ s, !inter_subset_right + +protected theorem le_inf (M N L : sigma_algebra X) (H1 : L ≤ M) (H2 : L ≤ N) : + L ≤ sigma_algebra.inf M N := +λ s H, and.intro (H1 s H) (H2 s H) + +protected definition Inf (MS : set (sigma_algebra X)) : sigma_algebra X := +⦃sigma_algebra, + sets := ⋂ M ∈ MS, @sets _ M, + univ_mem_sets := abstract take M, assume HM, @measurable_univ X M end, + comp_mem_sets := abstract take s, assume Hs, take M, assume HM, + measurable_compl (Hs M HM) end, + cUnion_mem_sets := abstract take s, assume Hs, take M, assume HM, + measurable_cUnion (λ i, Hs i M HM) end +⦄ + +protected theorem Inf_le {M : sigma_algebra X} {MS : set (sigma_algebra X)} (MMS : M ∈ MS) : + sigma_algebra.Inf MS ≤ M := +bInter_subset_of_mem MMS + +protected theorem le_Inf {M : sigma_algebra X} {MS : set (sigma_algebra X)} (H : ∀₀ N ∈ MS, M ≤ N) : + M ≤ sigma_algebra.Inf MS := +take s, assume Hs : s ∈ @sets _ M, +take N, assume NMS : N ∈ MS, +show s ∈ @sets _ N, from H NMS s Hs + +protected definition sup (M N : sigma_algebra X) : sigma_algebra X := +sigma_algebra.generated_by (@sets _ M ∪ @sets _ N) + +protected theorem le_sup_left (M N : sigma_algebra X) : M ≤ sigma_algebra.sup M N := +take s, assume Hs : s ∈ @sets _ M, +measurable_generated_by (or.inl Hs) + +protected theorem le_sup_right (M N : sigma_algebra X) : N ≤ sigma_algebra.sup M N := +take s, assume Hs : s ∈ @sets _ N, +measurable_generated_by (or.inr Hs) + +protected theorem sup_le {M N L : sigma_algebra X} (H1 : M ≤ L) (H2 : N ≤ L) : + sigma_algebra.sup M N ≤ L := +have @sets _ M ∪ @sets _ N ⊆ @sets _ L, from union_subset H1 H2, +sets_generated_by_initial this + +protected definition Sup (MS : set (sigma_algebra X)) : sigma_algebra X := +sigma_algebra.generated_by (⋃ M ∈ MS, @sets _ M) + +protected theorem le_Sup {M : sigma_algebra X} {MS : set (sigma_algebra X)} (MMS : M ∈ MS) : + M ≤ sigma_algebra.Sup MS := +take s, assume Hs : s ∈ @sets _ M, +measurable_generated_by (mem_bUnion MMS Hs) + +protected theorem Sup_le {N : sigma_algebra X} {MS : set (sigma_algebra X)} (H : ∀₀ M ∈ MS, M ≤ N) : + sigma_algebra.Sup MS ≤ N := +have (⋃ M ∈ MS, @sets _ M) ⊆ @sets _ N, from bUnion_subset H, +sets_generated_by_initial this + +attribute [trans_instance] +protected definition complete_lattice : + complete_lattice (sigma_algebra X) := +⦃complete_lattice, + le := sigma_algebra.le, + le_refl := sigma_algebra.le_refl, + le_trans := sigma_algebra.le_trans, + le_antisymm := sigma_algebra.le_antisymm, + inf := sigma_algebra.inf, + sup := sigma_algebra.sup, + inf_le_left := sigma_algebra.inf_le_left, + inf_le_right := sigma_algebra.inf_le_right, + le_inf := sigma_algebra.le_inf, + le_sup_left := sigma_algebra.le_sup_left, + le_sup_right := sigma_algebra.le_sup_right, + sup_le := @sigma_algebra.sup_le X, + Inf := sigma_algebra.Inf, + Sup := sigma_algebra.Sup, + Inf_le := @sigma_algebra.Inf_le X, + le_Inf := @sigma_algebra.le_Inf X, + le_Sup := @sigma_algebra.le_Sup X, + Sup_le := @sigma_algebra.Sup_le X⦄ +end sigma_algebra + +/- Borel sets -/ + +namespace measure_theory + +section + open topology + variables (X : Type) [topology X] + + definition borel_algebra : sigma_algebra X := + sigma_algebra.generated_by (opens X) + + variable {X} + definition borel (s : set X) : Prop := @measurable _ (borel_algebra X) s + + theorem borel_of_open {s : set X} (H : Open s) : borel s := + sigma_algebra.measurable_generated_by H + + theorem borel_of_closed {s : set X} (H : closed s) : borel s := + have borel (-s), from borel_of_open H, + @measurable_of_measurable_compl _ (borel_algebra X) _ this +end + +end measure_theory diff --git a/old_library/theories/number_theory/bezout.lean b/old_library/theories/number_theory/bezout.lean new file mode 100644 index 0000000000..a313696322 --- /dev/null +++ b/old_library/theories/number_theory/bezout.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2015 William Peterson. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: William Peterson, Jeremy Avigad + +Extended gcd, Bezout's theorem, chinese remainder theorem. +-/ +import data.nat.div data.int .primes + +/- Bezout's theorem -/ + +section Bezout + +open nat int +open eq.ops well_founded decidable prod + +private definition pair_nat.lt : ℕ × ℕ → ℕ × ℕ → Prop := measure pr₂ +private definition pair_nat.lt.wf : well_founded pair_nat.lt := intro_k (measure.wf pr₂) 20 +local attribute pair_nat.lt.wf [instance] +local infixl `≺`:50 := pair_nat.lt + +private definition gcd.lt.dec (x y₁ : ℕ) : (succ y₁, x % succ y₁) ≺ (x, succ y₁) := +!nat.mod_lt (succ_pos y₁) + +private definition egcd_rec_f (z : ℤ) : ℤ → ℤ → ℤ × ℤ := λ s t, (t, s - t * z) + +definition egcd.F : Π (p₁ : ℕ × ℕ), (Π p₂ : ℕ × ℕ, p₂ ≺ p₁ → ℤ × ℤ) → ℤ × ℤ +| (x, y) := nat.cases_on y + (λ f, (1, 0) ) + (λ y₁ (f : Π p₂, p₂ ≺ (x, succ y₁) → ℤ × ℤ), + let bz := f (succ y₁, x % succ y₁) !gcd.lt.dec in + prod.cases_on bz (egcd_rec_f (x / succ y₁))) + +definition egcd (x y : ℕ) := fix egcd.F (pair x y) + +theorem egcd_zero (x : ℕ) : egcd x 0 = (1, 0) := +well_founded.fix_eq egcd.F (x, 0) + +theorem egcd_succ (x y : ℕ) : + egcd x (succ y) = prod.cases_on (egcd (succ y) (x % succ y)) (egcd_rec_f (x / succ y)) := +well_founded.fix_eq egcd.F (x, succ y) + +theorem egcd_of_pos (x : ℕ) {y : ℕ} (ypos : y > 0) : + let erec := egcd y (x % y), u := pr₁ erec, v := pr₂ erec in + egcd x y = (v, u - v * (x / y)) := +obtain (y' : nat) (yeq : y = succ y'), from exists_eq_succ_of_pos ypos, +begin + rewrite [yeq, egcd_succ, -prod.eta (egcd _ _)], + esimp, unfold egcd_rec_f, + rewrite [of_nat_div] +end + +theorem egcd_prop (x y : ℕ) : (pr₁ (egcd x y)) * x + (pr₂ (egcd x y)) * y = gcd x y := +gcd.induction x y + (take m, by krewrite [egcd_zero, mul_zero, one_mul]) + (take m n, + assume npos : 0 < n, + assume IH, + begin + note H := egcd_of_pos m npos, esimp at H, + rewrite H, + esimp, + rewrite [gcd_rec, -IH], + rewrite [add.comm], + rewrite [-of_nat_mod], + rewrite [int.mod_def], + rewrite [+mul_sub_right_distrib], + rewrite [+mul_sub_left_distrib, *left_distrib], + rewrite [*sub_eq_add_neg, {pr₂ (egcd n (m % n)) * of_nat m + - _}add.comm], + rewrite [-add.assoc, mul.assoc] + end) + +theorem Bezout_aux (x y : ℕ) : ∃ a b : ℤ, a * x + b * y = gcd x y := +exists.intro _ (exists.intro _ (egcd_prop x y)) + +theorem Bezout (x y : ℤ) : ∃ a b : ℤ, a * x + b * y = gcd x y := +obtain a' b' (H : a' * nat_abs x + b' * nat_abs y = gcd x y), from !Bezout_aux, +begin + existsi (a' * sign x), + existsi (b' * sign y), + rewrite [*mul.assoc, -*abs_eq_sign_mul, -*of_nat_nat_abs], + apply H +end +end Bezout + +/- +A sample application of Bezout's theorem, namely, an alternative proof that irreducible +implies prime (dvd_or_dvd_of_prime_of_dvd_mul). +-/ + +namespace nat +open int + +example {p x y : ℕ} (pp : prime p) (H : p ∣ x * y) : p ∣ x ∨ p ∣ y := +decidable.by_cases + (suppose p ∣ x, or.inl this) + (suppose ¬ p ∣ x, + have cpx : coprime p x, from coprime_of_prime_of_not_dvd pp this, + obtain (a b : ℤ) (Hab : a * p + b * x = gcd p x), from Bezout_aux p x, + have a * p * y + b * x * y = y, + by krewrite [-right_distrib, Hab, ↑coprime at cpx, cpx, int.one_mul], + have p ∣ y, + begin + apply dvd_of_of_nat_dvd_of_nat, + rewrite [-this], + apply @dvd_add, + {apply dvd_mul_of_dvd_left, + apply dvd_mul_of_dvd_right, + apply dvd.refl}, + {rewrite mul.assoc, + apply dvd_mul_of_dvd_right, + apply of_nat_dvd_of_nat_of_dvd H} + end, + or.inr this) + +end nat diff --git a/old_library/theories/number_theory/irrational_roots.lean b/old_library/theories/number_theory/irrational_roots.lean new file mode 100644 index 0000000000..46ea68a95e --- /dev/null +++ b/old_library/theories/number_theory/irrational_roots.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Jeremy Avigad + +A proof that if n > 1 and a > 0, then the nth root of a is irrational, unless a is a perfect nth power. +-/ +import data.rat .prime_factorization +open eq.ops + +/- First, a textbook proof that sqrt 2 is irrational. -/ + +section + open nat + + theorem sqrt_two_irrational {a b : ℕ} (co : coprime a b) : a^2 ≠ 2 * b^2 := + assume H : a^2 = 2 * b^2, + have even (a^2), + from even_of_exists (exists.intro _ H), + have even a, + from even_of_even_pow this, + obtain (c : nat) (aeq : a = 2 * c), + from exists_of_even this, + have 2 * (2 * c^2) = 2 * b^2, + by rewrite [-H, aeq, *pow_two, mul.assoc, mul.left_comm c], + have 2 * c^2 = b^2, + from eq_of_mul_eq_mul_left dec_trivial this, + have even (b^2), + from even_of_exists (exists.intro _ (eq.symm this)), + have even b, + from even_of_even_pow this, + have 2 ∣ gcd a b, + from dvd_gcd (dvd_of_even `even a`) (dvd_of_even `even b`), + have (2:nat) ∣ 1, + begin rewrite [gcd_eq_one_of_coprime co at this], exact this end, + show false, from absurd `2 ∣ 1` dec_trivial +end + +/- + Replacing 2 by an arbitrary prime and the power 2 by any n ≥ 1 yields the stronger result + that the nth root of an integer is irrational, unless the integer is already a perfect nth + power. +-/ + +section + open nat decidable + + theorem root_irrational {a b c n : ℕ} (npos : n > 0) (apos : a > 0) (co : coprime a b) + (H : a^n = c * b^n) : b = 1 := + have bpos : b > 0, from pos_of_ne_zero + (suppose b = 0, + have a^n = 0, + by rewrite [H, this, zero_pow npos], + have a = 0, + from eq_zero_of_pow_eq_zero this, + show false, + from ne_of_lt `0 < a` this⁻¹), + have H₁ : ∀ p, prime p → ¬ p ∣ b, from + take p, + suppose prime p, + suppose p ∣ b, + have p ∣ b^n, + from dvd_pow_of_dvd_of_pos `p ∣ b` `n > 0`, + have p ∣ a^n, + by rewrite H; apply dvd_mul_of_dvd_right this, + have p ∣ a, + from dvd_of_prime_of_dvd_pow `prime p` this, + have ¬ coprime a b, + from not_coprime_of_dvd_of_dvd (gt_one_of_prime `prime p`) `p ∣ a` `p ∣ b`, + show false, + from this `coprime a b`, + have blt2 : b < 2, + from by_contradiction + (suppose ¬ b < 2, + have b ≥ 2, + from le_of_not_gt this, + obtain p [primep pdvdb], + from exists_prime_and_dvd this, + show false, + from H₁ p primep pdvdb), + show b = 1, + from (le.antisymm (le_of_lt_succ blt2) (succ_le_of_lt bpos)) +end + +/- + Here we state this in terms of the rationals, ℚ. The main difficulty is casting between ℕ, ℤ, + and ℚ. +-/ + +section + open rat int nat decidable + + theorem denom_eq_one_of_pow_eq {q : ℚ} {n : ℕ} {c : ℤ} (npos : n > 0) (H : q^n = c) : + denom q = 1 := + let a := num q, b := denom q in + have b ≠ 0, + from ne_of_gt (denom_pos q), + have bnz : b ≠ (0 : ℚ), + from assume H, `b ≠ 0` (of_int.inj H), + have bnnz : (b : rat)^n ≠ 0, + from assume bneqz, bnz (_root_.eq_zero_of_pow_eq_zero bneqz), + have a^n /[rat] (b:rat)^n = c, + begin rewrite [*of_int_pow, -div_pow, -eq_num_div_denom, -H] end, + have (a^n : rat) = c * (b:rat)^n, + from eq.symm (!mul_eq_of_eq_div bnnz (eq.symm this)), + have a^n = c * b^n, -- int version + by rewrite [-of_int_pow at this, -of_int_mul at this]; exact of_int.inj this, + have (abs a)^n = abs c * (abs b)^n, + by rewrite [-abs_pow, this, abs_mul, abs_pow], + have H₁ : (nat_abs a)^n = nat_abs c * (nat_abs b)^n, + begin apply int.of_nat.inj, rewrite [int.of_nat_mul, +int.of_nat_pow, +of_nat_nat_abs], + exact this end, + have H₂ : nat.coprime (nat_abs a) (nat_abs b), + from of_nat.inj !coprime_num_denom, + have nat_abs b = 1, from + by_cases + (suppose q = 0, + by rewrite this) + (suppose qne0 : q ≠ 0, + begin + have ane0 : a ≠ 0, from + suppose aeq0 : a = 0, + have qeq0 : q = 0, + by rewrite [eq_num_div_denom, aeq0, of_int_zero, zero_div], + show false, + from qne0 qeq0, + have nat_abs a ≠ 0, from + suppose nat_abs a = 0, + have aeq0 : a = 0, + from eq_zero_of_nat_abs_eq_zero this, + show false, from ane0 aeq0, + show nat_abs b = 1, from (root_irrational npos (pos_of_ne_zero this) H₂ H₁) + end), + show b = 1, + begin rewrite [-of_nat_nat_abs_of_nonneg (le_of_lt !denom_pos), this] end + + theorem eq_num_pow_of_pow_eq {q : ℚ} {n : ℕ} {c : ℤ} (npos : n > 0) (H : q^n = c) : + c = (num q)^n := + have denom q = 1, + from denom_eq_one_of_pow_eq npos H, + have of_int c = of_int ((num q)^n), + by rewrite [-H, eq_num_div_denom q at {1}, this, of_int_one, div_one, of_int_pow], + show c = (num q)^n , from of_int.inj this +end + +/- As a corollary, for n > 1, the nth root of a prime is irrational. -/ + +section + open nat + + theorem not_eq_pow_of_prime {p n : ℕ} (a : ℕ) (ngt1 : n > 1) (primep : prime p) : p ≠ a^n := + assume peq : p = a^n, + have npos : n > 0, + from lt.trans dec_trivial ngt1, + have pnez : p ≠ 0, from + (suppose p = 0, + show false, + by note H := (pos_of_prime primep); rewrite this at H; exfalso; exact !lt.irrefl H), + have agtz : a > 0, from pos_of_ne_zero + (suppose a = 0, + show false, by revert peq; rewrite [this, zero_pow npos]; exact pnez), + have n * mult p a = 1, from calc + n * mult p a = mult p (a^n) : begin rewrite [mult_pow n agtz primep] end + ... = mult p p : peq + ... = 1 : mult_self (gt_one_of_prime primep), + have n ∣ 1, + from dvd_of_mul_right_eq this, + have n = 1, + from eq_one_of_dvd_one this, + show false, + by rewrite this at ngt1; exact !lt.irrefl ngt1 + + open int rat + + theorem root_prime_irrational {p n : ℕ} {q : ℚ} (qnonneg : q ≥ 0) (ngt1 : n > 1) + (primep : prime p) : + q^n ≠ p := + have numq : num q ≥ 0, from num_nonneg_of_nonneg qnonneg, + have npos : n > 0, from lt.trans dec_trivial ngt1, + suppose q^n = p, + have p = (num q)^n, from eq_num_pow_of_pow_eq npos this, + have p = (nat_abs (num q))^n, + by apply of_nat.inj; rewrite [this, of_nat_pow, of_nat_nat_abs_of_nonneg numq], + show false, from not_eq_pow_of_prime _ ngt1 primep this +end + +/- + Thaetetus, who lives in the fourth century BC, is said to have proved the irrationality of square + roots up to seventeen. In Chapter 4 of /Why Prove it Again/, John Dawson notes that Thaetetus may + have used an approach similar to the one below. (See data/nat/gcd.lean for the key theorem, + "div_gcd_eq_div_gcd".) +-/ + +section + open int + + example {a b c : ℤ} (co : coprime a b) (apos : a > 0) (bpos : b > 0) + (H : a * a = c * (b * b)) : + b = 1 := + have H₁ : gcd (c * b) a = gcd c a, + from gcd_mul_right_cancel_of_coprime _ (coprime_swap co), + have a * a = c * b * b, + by rewrite -mul.assoc at H; apply H, + have a / (gcd a b) = c * b / gcd (c * b) a, + from div_gcd_eq_div_gcd this bpos apos, + have a = c * b / gcd c a, + by revert this; rewrite [↑coprime at co, co, int.div_one, H₁]; intros; assumption, + have a = b * (c / gcd c a), + by revert this; rewrite [mul.comm, !int.mul_div_assoc !gcd_dvd_left]; intros; assumption, + have b ∣ a, + from dvd_of_mul_right_eq this⁻¹, + have b ∣ gcd a b, + from dvd_gcd this !dvd.refl, + have b ∣ 1, + by rewrite [↑coprime at co, co at this]; apply this, + show b = 1, + from eq_one_of_dvd_one (le_of_lt bpos) this +end diff --git a/old_library/theories/number_theory/number_theory.md b/old_library/theories/number_theory/number_theory.md new file mode 100644 index 0000000000..072dd2d9bd --- /dev/null +++ b/old_library/theories/number_theory/number_theory.md @@ -0,0 +1,7 @@ +theories.number_theory +====================== + +* [primes](primes.lean) +* [bezout](bezout.lean) : Bezout's theorem +* [prime_factorization](prime_factorization.lean) : prime divisors and multiplicity +* [irrational_roots](irrational_roots.lean) : irrationality of nth roots \ No newline at end of file diff --git a/old_library/theories/number_theory/prime_factorization.lean b/old_library/theories/number_theory/prime_factorization.lean new file mode 100644 index 0000000000..87649d5925 --- /dev/null +++ b/old_library/theories/number_theory/prime_factorization.lean @@ -0,0 +1,311 @@ +/- +Copyright (c) 2015 Jeremy Avigad. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jeremy Avigad + +Multiplicity and prime factors. We have: + + mult p n := the greatest power of p dividing n if p > 1 and n > 0, and 0 otherwise. + prime_factors n := the finite set of prime factors of n, assuming n > 0 + +-/ +import data.nat data.finset .primes algebra.group_bigops +open eq.ops finset well_founded decidable + +namespace nat +-- TODO: this should be proved more generally in ring_bigops +theorem Prod_pos {A : Type} [deceqA : decidable_eq A] + {s : finset A} {f : A → ℕ} (fpos : ∀ n, n ∈ s → f n > 0) : + (∏ n ∈ s, f n) > 0 := +begin + induction s with a s anins ih, + {rewrite Prod_empty; exact zero_lt_one}, + rewrite [!Prod_insert_of_not_mem anins], + exact (mul_pos (fpos a (mem_insert a _)) (ih (forall_of_forall_insert fpos))) +end + +/- multiplicity -/ + +theorem mult_rec_decreasing {p n : ℕ} (Hp : p > 1) (Hn : n > 0) : n / p < n := +have H' : n < n * p, + by rewrite [-mul_one n at {1}]; apply mul_lt_mul_of_pos_left Hp Hn, +nat.div_lt_of_lt_mul H' + +private definition mult.F (p : ℕ) (n : ℕ) (f: Π {m : ℕ}, m < n → ℕ) : ℕ := +if H : (p > 1 ∧ n > 0) ∧ p ∣ n then + succ (f (mult_rec_decreasing (and.left (and.left H)) (and.right (and.left H)))) +else 0 + +definition mult (p n : ℕ) : ℕ := fix (mult.F p) n + +theorem mult_rec {p n : ℕ} (pgt1 : p > 1) (ngt0 : n > 0) (pdivn : p ∣ n) : + mult p n = succ (mult p (n / p)) := +have (p > 1 ∧ n > 0) ∧ p ∣ n, from and.intro (and.intro pgt1 ngt0) pdivn, +eq.trans (well_founded.fix_eq (mult.F p) n) (dif_pos this) + +private theorem mult_base {p n : ℕ} (H : ¬ ((p > 1 ∧ n > 0) ∧ p ∣ n)) : + mult p n = 0 := +eq.trans (well_founded.fix_eq (mult.F p) n) (dif_neg H) + +theorem mult_zero_right (p : ℕ) : mult p 0 = 0 := +mult_base (assume H, !lt.irrefl (and.right (and.left H))) + +theorem mult_eq_zero_of_not_dvd {p n : ℕ} (H : ¬ p ∣ n) : mult p n = 0 := +mult_base (assume H', H (and.right H')) + +theorem mult_eq_zero_of_le_one {p : ℕ} (n : ℕ) (H : p ≤ 1) : mult p n = 0 := +mult_base (assume H', not_lt_of_ge H (and.left (and.left H'))) + +theorem mult_zero_left (n : ℕ) : mult 0 n = 0 := +mult_eq_zero_of_le_one n !dec_trivial + +theorem mult_one_left (n : ℕ) : mult 1 n = 0 := +mult_eq_zero_of_le_one n !dec_trivial + +theorem mult_pos_of_dvd {p n : ℕ} (pgt1 : p > 1) (npos : n > 0) (pdvdn : p ∣ n) : mult p n > 0 := +by rewrite (mult_rec pgt1 npos pdvdn); apply succ_pos + +theorem not_dvd_of_mult_eq_zero {p n : ℕ} (pgt1 : p > 1) (npos : n > 0) (H : mult p n = 0) : + ¬ p ∣ n := +suppose p ∣ n, +ne_of_gt (mult_pos_of_dvd pgt1 npos this) H + +theorem dvd_of_mult_pos {p n : ℕ} (H : mult p n > 0) : p ∣ n := +by_contradiction (suppose ¬ p ∣ n, ne_of_gt H (mult_eq_zero_of_not_dvd this)) + +/- properties of mult -/ + +theorem mult_eq_zero_of_prime_of_ne {p q : ℕ} (primep : prime p) (primeq : prime q) + (pneq : p ≠ q) : + mult p q = 0 := +mult_eq_zero_of_not_dvd (not_dvd_of_prime_of_coprime primep (coprime_primes primep primeq pneq)) + +theorem pow_mult_dvd (p n : ℕ) : p^(mult p n) ∣ n := +begin + induction n using nat.strong_induction_on with [n, ih], + cases eq_zero_or_pos n with [nz, npos], + {rewrite nz, apply dvd_zero}, + cases le_or_gt p 1 with [ple1, pgt1], + {rewrite [!mult_eq_zero_of_le_one ple1, pow_zero], apply one_dvd}, + cases (or.swap (em (p ∣ n))) with [pndvdn, pdvdn], + {rewrite [mult_eq_zero_of_not_dvd pndvdn, pow_zero], apply one_dvd}, + show p ^ (mult p n) ∣ n, from dvd.elim pdvdn + (take n', + suppose n = p * n', + have p > 0, from lt.trans zero_lt_one pgt1, + have n / p = n', from !nat.div_eq_of_eq_mul_right this `n = p * n'`, + have n' < n, + by rewrite -this; apply mult_rec_decreasing pgt1 npos, + begin + rewrite [mult_rec pgt1 npos pdvdn, `n / p = n'`, pow_succ], subst n, + apply mul_dvd_mul !dvd.refl, + apply ih _ this + end) +end + +theorem mult_one_right (p : ℕ) : mult p 1 = 0:= +have H : p^(mult p 1) = 1, from eq_one_of_dvd_one !pow_mult_dvd, +or.elim (le_or_gt p 1) + (suppose p ≤ 1, by rewrite [!mult_eq_zero_of_le_one this]) + (suppose p > 1, + by_contradiction + (suppose mult p 1 ≠ 0, + have mult p 1 > 0, from pos_of_ne_zero this, + have p^(mult p 1) > 1, from pow_gt_one `p > 1` this, + show false, by rewrite H at this; apply !lt.irrefl this)) + +private theorem mult_pow_mul {p n : ℕ} (i : ℕ) (pgt1 : p > 1) (npos : n > 0) : + mult p (p^i * n) = i + mult p n := +begin + induction i with [i, ih], + {krewrite [pow_zero, one_mul, zero_add]}, + have p > 0, from lt.trans zero_lt_one pgt1, + have psin_pos : p^(succ i) * n > 0, from mul_pos (!pow_pos_of_pos this) npos, + have p ∣ p^(succ i) * n, by rewrite [pow_succ, mul.assoc]; apply dvd_mul_right, + rewrite [mult_rec pgt1 psin_pos this, pow_succ', mul.right_comm, !nat.mul_div_cancel `p > 0`, ih], + rewrite [add.comm i, add.comm (succ i)] +end + +theorem mult_pow_self {p : ℕ} (i : ℕ) (pgt1 : p > 1) : mult p (p^i) = i := +by rewrite [-(mul_one (p^i)), mult_pow_mul i pgt1 zero_lt_one, mult_one_right] + +theorem mult_self {p : ℕ} (pgt1 : p > 1) : mult p p = 1 := +by rewrite [-pow_one p at {2}]; apply mult_pow_self 1 pgt1 + +theorem le_mult {p i n : ℕ} (pgt1 : p > 1) (npos : n > 0) (pidvd : p^i ∣ n) : i ≤ mult p n := +dvd.elim pidvd + (take m, + suppose n = p^i * m, + have m > 0, from pos_of_mul_pos_left (this ▸ npos), + by subst n; rewrite [mult_pow_mul i pgt1 this]; apply le_add_right) + +theorem not_dvd_div_pow_mult {p n : ℕ} (pgt1 : p > 1) (npos : n > 0) : ¬ p ∣ n / p^(mult p n) := +assume pdvd : p ∣ n / p^(mult p n), +obtain m (H : n / p^(mult p n) = p * m), from exists_eq_mul_right_of_dvd pdvd, +have n = p^(succ (mult p n)) * m, from + calc + n = p^mult p n * (n / p^mult p n) : by rewrite (nat.mul_div_cancel' !pow_mult_dvd) + ... = p^(succ (mult p n)) * m : by rewrite [H, pow_succ', mul.assoc], +have p^(succ (mult p n)) ∣ n, by rewrite this at {2}; apply dvd_mul_right, +have succ (mult p n) ≤ mult p n, from le_mult pgt1 npos this, +show false, from !not_succ_le_self this + +theorem mult_mul {p m n : ℕ} (primep : prime p) (mpos : m > 0) (npos : n > 0) : + mult p (m * n) = mult p m + mult p n := +let m' := m / p^mult p m, n' := n / p^mult p n in +have p > 1, from gt_one_of_prime primep, +have meq : m = p^mult p m * m', by rewrite (nat.mul_div_cancel' !pow_mult_dvd), +have neq : n = p^mult p n * n', by rewrite (nat.mul_div_cancel' !pow_mult_dvd), +have m'pos : m' > 0, from pos_of_mul_pos_left (meq ▸ mpos), +have n'pos : n' > 0, from pos_of_mul_pos_left (neq ▸ npos), +have npdvdm' : ¬ p ∣ m', from !not_dvd_div_pow_mult `p > 1` mpos, +have npdvdn' : ¬ p ∣ n', from !not_dvd_div_pow_mult `p > 1` npos, +have npdvdm'n' : ¬ p ∣ m' * n', from not_dvd_mul_of_prime primep npdvdm' npdvdn', +have m'n'pos : m' * n' > 0, from mul_pos m'pos n'pos, +have multm'n' : mult p (m' * n') = 0, from mult_eq_zero_of_not_dvd npdvdm'n', +calc + mult p (m * n) = mult p (p^(mult p m + mult p n) * (m' * n')) : + by rewrite [pow_add, mul.right_comm, -mul.assoc, -meq, mul.assoc, + mul.comm (n / _), -neq] + ... = mult p m + mult p n : + by rewrite [!mult_pow_mul `p > 1` m'n'pos, multm'n'] + +theorem mult_pow {p m : ℕ} (n : ℕ) (mpos : m > 0) (primep : prime p) : + mult p (m^n) = n * mult p m := +begin + induction n with n ih, + krewrite [pow_zero, mult_one_right, zero_mul], + rewrite [pow_succ, mult_mul primep mpos (!pow_pos_of_pos mpos), ih, succ_mul, add.comm] +end + +theorem dvd_of_forall_prime_mult_le {m n : ℕ} (mpos : m > 0) + (H : ∀ {p}, prime p → mult p m ≤ mult p n) : + m ∣ n := +begin + revert H, revert n, + induction m using nat.strong_induction_on with [m, ih], + cases (decidable.em (m = 1)) with [meq, mneq], + {intros, rewrite meq, apply one_dvd}, + have mgt1 : m > 1, from lt_of_le_of_ne (succ_le_of_lt mpos) (ne.symm mneq), + have mge2 : m ≥ 2, from succ_le_of_lt mgt1, + have hpd : ∃ p, prime p ∧ p ∣ m, from exists_prime_and_dvd mge2, + cases hpd with [p, H1], + cases H1 with [primep, pdvdm], + intro n, + cases (eq_zero_or_pos n) with [nz, npos], + {intros; rewrite nz; apply dvd_zero}, + assume H : ∀ {p : ℕ}, prime p → mult p m ≤ mult p n, + obtain m' (meq : m = p * m'), from exists_eq_mul_right_of_dvd pdvdm, + have pgt1 : p > 1, from gt_one_of_prime primep, + have m'pos : m' > 0, from pos_of_ne_zero + (assume m'z, by revert mpos; rewrite [meq, m'z, mul_zero]; apply not_lt_zero), + have m'ltm : m' < m, + by rewrite [meq, -one_mul m' at {1}]; apply mul_lt_mul_of_lt_of_le m'pos pgt1 !le.refl, + have multpm : mult p m ≥ 1, from le_mult pgt1 mpos (by rewrite pow_one; apply pdvdm), + have multpn : mult p n ≥ 1, from le.trans multpm (H primep), + obtain n' (neq : n = p * n'), + from exists_eq_mul_right_of_dvd (dvd_of_mult_pos (lt_of_succ_le multpn)), + have n'pos : n' > 0, from pos_of_ne_zero + (assume n'z, by revert npos; rewrite [neq, n'z, mul_zero]; apply not_lt_zero), + have ∀q, prime q → mult q m' ≤ mult q n', from + (take q, + assume primeq : prime q, + have multqm : mult q m = mult q p + mult q m', + by rewrite [meq, mult_mul primeq (pos_of_prime primep) m'pos], + have multqn : mult q n = mult q p + mult q n', + by rewrite [neq, mult_mul primeq (pos_of_prime primep) n'pos], + show mult q m' ≤ mult q n', from le_of_add_le_add_left (multqm ▸ multqn ▸ H primeq)), + have m'dvdn' : m' ∣ n', from ih m' m'ltm m'pos n' this, + show m ∣ n, by rewrite [meq, neq]; apply mul_dvd_mul !dvd.refl m'dvdn' +end + +theorem eq_of_forall_prime_mult_eq {m n : ℕ} (mpos : m > 0) (npos : n > 0) + (H : ∀ p, prime p → mult p m = mult p n) : m = n := +dvd.antisymm + (dvd_of_forall_prime_mult_le mpos (take p, assume primep, H _ primep ▸ !le.refl)) + (dvd_of_forall_prime_mult_le npos (take p, assume primep, H _ primep ▸ !le.refl)) + +/- prime factors -/ + +definition prime_factors (n : ℕ) : finset ℕ := { p ∈ upto (succ n) | prime p ∧ p ∣ n } + +theorem prime_of_mem_prime_factors {p n : ℕ} (H : p ∈ prime_factors n) : prime p := +and.left (of_mem_sep H) + +theorem dvd_of_mem_prime_factors {p n : ℕ} (H : p ∈ prime_factors n) : p ∣ n := +and.right (of_mem_sep H) + +theorem mem_prime_factors {p n : ℕ} (npos : n > 0) (primep : prime p) (pdvdn : p ∣ n) : + p ∈ prime_factors n := +have plen : p ≤ n, from le_of_dvd npos pdvdn, +mem_sep_of_mem (mem_upto_of_lt (lt_succ_of_le plen)) (and.intro primep pdvdn) + +/- prime factorization -/ + +theorem mult_pow_eq_zero_of_prime_of_ne {p q : ℕ} (primep : prime p) (primeq : prime q) + (pneq : p ≠ q) (i : ℕ) : mult p (q^i) = 0 := +begin + induction i with i ih, + {krewrite [pow_zero, mult_one_right]}, + have qpos : q > 0, from pos_of_prime primeq, + have qipos : q^i > 0, from !pow_pos_of_pos qpos, + rewrite [pow_succ', mult_mul primep qipos qpos, ih, mult_eq_zero_of_prime_of_ne primep + primeq pneq] +end + +theorem mult_prod_pow_of_not_mem {p : ℕ} (primep : prime p) {s : finset ℕ} + (sprimes : ∀ p, p ∈ s → prime p) (f : ℕ → ℕ) (pns : p ∉ s) : + mult p (∏ q ∈ s, q^(f q)) = 0 := +begin + induction s with a s anins ih, + {rewrite [Prod_empty, mult_one_right]}, + have pnea : p ≠ a, from assume peqa, by rewrite peqa at pns; exact pns !mem_insert, + have primea : prime a, from sprimes a !mem_insert, + have afapos : a ^ f a > 0, from !pow_pos_of_pos (pos_of_prime primea), + have prodpos : (∏ q ∈ s, q ^ f q) > 0, + from Prod_pos (take q, assume qs, + !pow_pos_of_pos (pos_of_prime (forall_of_forall_insert sprimes q qs))), + rewrite [!Prod_insert_of_not_mem anins, mult_mul primep afapos prodpos], + rewrite (mult_pow_eq_zero_of_prime_of_ne primep primea pnea), + rewrite (ih (forall_of_forall_insert sprimes) (λ H, pns (!mem_insert_of_mem H))) +end + +theorem mult_prod_pow_of_mem {p : ℕ} (primep : prime p) {s : finset ℕ} + (sprimes : ∀ p, p ∈ s → prime p) (f : ℕ → ℕ) (ps : p ∈ s) : + mult p (∏ q ∈ s, q^(f q)) = f p := +begin + induction s with a s anins ih, + {exact absurd ps !not_mem_empty}, + have primea : prime a, from sprimes a !mem_insert, + have afapos : a ^ f a > 0, from !pow_pos_of_pos (pos_of_prime primea), + have prodpos : (∏ q ∈ s, q ^ f q) > 0, + from Prod_pos (take q, assume qs, + !pow_pos_of_pos (pos_of_prime (forall_of_forall_insert sprimes q qs))), + rewrite [!Prod_insert_of_not_mem anins, mult_mul primep afapos prodpos], + cases eq_or_mem_of_mem_insert ps with peqa pins, + {rewrite [peqa, !mult_pow_self (gt_one_of_prime primea)], + rewrite [mult_prod_pow_of_not_mem primea (forall_of_forall_insert sprimes) _ anins]}, + have pnea : p ≠ a, from by intro peqa; rewrite peqa at pins; exact anins pins, + rewrite [mult_pow_eq_zero_of_prime_of_ne primep primea pnea, zero_add], + exact (ih (forall_of_forall_insert sprimes) pins) +end + +theorem eq_prime_factorization {n : ℕ} (npos : n > 0) : + n = (∏ p ∈ prime_factors n, p^(mult p n)) := +let nprod := ∏ p ∈ prime_factors n, p^(mult p n) in +have primefactors : ∀ p, p ∈ prime_factors n → prime p, + from take p, @prime_of_mem_prime_factors p n, +have prodpos : (∏ q ∈ prime_factors n, q^(mult q n)) > 0, + from Prod_pos (take q, assume qpf, + !pow_pos_of_pos (pos_of_prime (prime_of_mem_prime_factors qpf))), +eq_of_forall_prime_mult_eq npos prodpos + (take p, + assume primep, + decidable.by_cases + (assume pprimefactors : p ∈ prime_factors n, + eq.symm (mult_prod_pow_of_mem primep primefactors (λ p, mult p n) pprimefactors)) + (assume pnprimefactors : p ∉ prime_factors n, + have ¬ p ∣ n, from assume H, pnprimefactors (mem_prime_factors npos primep H), + have mult p n = 0, from mult_eq_zero_of_not_dvd this, + by rewrite [this, mult_prod_pow_of_not_mem primep primefactors _ pnprimefactors])) +end nat diff --git a/old_library/theories/number_theory/primes.lean b/old_library/theories/number_theory/primes.lean new file mode 100644 index 0000000000..e0008571dd --- /dev/null +++ b/old_library/theories/number_theory/primes.lean @@ -0,0 +1,237 @@ +/- +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Leonardo de Moura, Jeremy Avigad + +Prime numbers. +-/ +import data.nat logic.identities +open bool subtype + +namespace nat +open decidable + +attribute [reducible] +definition prime (p : nat) := p ≥ 2 ∧ ∀ m, m ∣ p → m = 1 ∨ m = p + +definition prime_ext (p : nat) := p ≥ 2 ∧ ∀ m, m ≤ p → m ∣ p → m = 1 ∨ m = p +local attribute prime_ext [reducible] + +lemma prime_ext_iff_prime (p : nat) : prime_ext p ↔ prime p := +iff.intro + begin + intro h, cases h with h₁ h₂, constructor, assumption, + intro m d, exact h₂ m (le_of_dvd (lt_of_succ_le (le_of_succ_le h₁)) d) d + end + begin + intro h, cases h with h₁ h₂, constructor, assumption, + intro m l d, exact h₂ m d + end + +attribute [instance] +definition decidable_prime (p : nat) : decidable (prime p) := +decidable_of_decidable_of_iff _ (prime_ext_iff_prime p) + +lemma ge_two_of_prime {p : nat} : prime p → p ≥ 2 := +suppose prime p, obtain h₁ h₂, from this, +h₁ + +theorem gt_one_of_prime {p : ℕ} (primep : prime p) : p > 1 := +lt_of_succ_le (ge_two_of_prime primep) + +theorem pos_of_prime {p : ℕ} (primep : prime p) : p > 0 := +lt.trans zero_lt_one (gt_one_of_prime primep) + +lemma not_prime_zero : ¬ prime 0 := +λ h, absurd (ge_two_of_prime h) dec_trivial + +lemma not_prime_one : ¬ prime 1 := +λ h, absurd (ge_two_of_prime h) dec_trivial + +lemma prime_two : prime 2 := +dec_trivial + +lemma prime_three : prime 3 := +dec_trivial + +lemma pred_prime_pos {p : nat} : prime p → pred p > 0 := +suppose prime p, +have p ≥ 2, from ge_two_of_prime this, +show pred p > 0, from lt_of_succ_le (pred_le_pred this) + +lemma succ_pred_prime {p : nat} : prime p → succ (pred p) = p := +assume h, succ_pred_of_pos (pos_of_prime h) + +lemma eq_one_or_eq_self_of_prime_of_dvd {p m : nat} : prime p → m ∣ p → m = 1 ∨ m = p := +assume h d, obtain h₁ h₂, from h, h₂ m d + +lemma gt_one_of_pos_of_prime_dvd {i p : nat} : prime p → 0 < i → i % p = 0 → 1 < i := +assume ipp pos h, +have p ≥ 2, from ge_two_of_prime ipp, +have p ∣ i, from dvd_of_mod_eq_zero h, +have p ≤ i, from le_of_dvd pos this, +lt_of_succ_le (le.trans `2 ≤ p` this) + +definition sub_dvd_of_not_prime {n : nat} : n ≥ 2 → ¬ prime n → {m | m ∣ n ∧ m ≠ 1 ∧ m ≠ n} := +assume h₁ h₂, +have ¬ prime_ext n, from iff.mpr (not_iff_not_of_iff !prime_ext_iff_prime) h₂, +have ¬ n ≥ 2 ∨ ¬ (∀ m, m ≤ n → m ∣ n → m = 1 ∨ m = n), from iff.mp !not_and_iff_not_or_not this, +have ¬ (∀ m, m ≤ n → m ∣ n → m = 1 ∨ m = n), from or_resolve_right this (not_not_intro h₁), +have ¬ (∀ m, m < succ n → m ∣ n → m = 1 ∨ m = n), from + assume h, absurd (λ m hl hd, h m (lt_succ_of_le hl) hd) this, +have {m | m < succ n ∧ ¬(m ∣ n → m = 1 ∨ m = n)}, from bsub_not_of_not_ball this, +obtain m hlt (h₃ : ¬(m ∣ n → m = 1 ∨ m = n)), from this, +obtain `m ∣ n` (h₅ : ¬ (m = 1 ∨ m = n)), from iff.mp !not_implies_iff_and_not h₃, +have ¬ m = 1 ∧ ¬ m = n, from iff.mp !not_or_iff_not_and_not h₅, +subtype.tag m (and.intro `m ∣ n` this) + +theorem exists_dvd_of_not_prime {n : nat} : n ≥ 2 → ¬ prime n → ∃ m, m ∣ n ∧ m ≠ 1 ∧ m ≠ n := +assume h₁ h₂, exists_of_subtype (sub_dvd_of_not_prime h₁ h₂) + +definition sub_dvd_of_not_prime2 {n : nat} : n ≥ 2 → ¬ prime n → {m | m ∣ n ∧ m ≥ 2 ∧ m < n} := +assume h₁ h₂, +have n ≠ 0, from assume h, begin subst n, exact absurd h₁ dec_trivial end, +obtain m m_dvd_n m_ne_1 m_ne_n, from sub_dvd_of_not_prime h₁ h₂, +have m_ne_0 : m ≠ 0, from assume h, begin subst m, exact absurd (eq_zero_of_zero_dvd m_dvd_n) `n ≠ 0` end, +begin + existsi m, split, assumption, + split, + {cases m with m, exact absurd rfl m_ne_0, + cases m with m, exact absurd rfl m_ne_1, exact succ_le_succ (succ_le_succ (zero_le _))}, + {have m_le_n : m ≤ n, from le_of_dvd (pos_of_ne_zero `n ≠ 0`) m_dvd_n, + exact lt_of_le_of_ne m_le_n m_ne_n} +end + +theorem exists_dvd_of_not_prime2 {n : nat} : n ≥ 2 → ¬ prime n → ∃ m, m ∣ n ∧ m ≥ 2 ∧ m < n := +assume h₁ h₂, exists_of_subtype (sub_dvd_of_not_prime2 h₁ h₂) + +definition sub_prime_and_dvd {n : nat} : n ≥ 2 → {p | prime p ∧ p ∣ n} := +nat.strong_rec_on n + (take n, + assume ih : ∀ m, m < n → m ≥ 2 → {p | prime p ∧ p ∣ m}, + suppose n ≥ 2, + by_cases + (suppose prime n, subtype.tag n (and.intro this (dvd.refl n))) + (suppose ¬ prime n, + obtain m m_dvd_n m_ge_2 m_lt_n, from sub_dvd_of_not_prime2 `n ≥ 2` this, + obtain p (hp : prime p) (p_dvd_m : p ∣ m), from ih m m_lt_n m_ge_2, + have p ∣ n, from dvd.trans p_dvd_m m_dvd_n, + subtype.tag p (and.intro hp this))) + +lemma exists_prime_and_dvd {n : nat} : n ≥ 2 → ∃ p, prime p ∧ p ∣ n := +assume h, exists_of_subtype (sub_prime_and_dvd h) + +open eq.ops + +definition infinite_primes (n : nat) : {p | p ≥ n ∧ prime p} := +let m := fact (n + 1) in +have m ≥ 1, from le_of_lt_succ (succ_lt_succ (fact_pos _)), +have m + 1 ≥ 2, from succ_le_succ this, +obtain p `prime p` `p ∣ m + 1`, from sub_prime_and_dvd this, +have p ≥ 2, from ge_two_of_prime `prime p`, +have p > 0, from lt_of_succ_lt (lt_of_succ_le `p ≥ 2`), +have p ≥ n, from by_contradiction + (suppose ¬ p ≥ n, + have p < n, from lt_of_not_ge this, + have p ≤ n + 1, from le_of_lt (lt.step this), + have p ∣ m, from dvd_fact `p > 0` this, + have p ∣ 1, from dvd_of_dvd_add_right (!add.comm ▸ `p ∣ m + 1`) this, + have p ≤ 1, from le_of_dvd zero_lt_one this, + show false, from absurd (le.trans `2 ≤ p` `p ≤ 1`) dec_trivial), +subtype.tag p (and.intro this `prime p`) + +lemma exists_infinite_primes (n : nat) : ∃ p, p ≥ n ∧ prime p := +exists_of_subtype (infinite_primes n) + +lemma odd_of_prime {p : nat} : prime p → p > 2 → odd p := +λ pp p_gt_2, by_contradiction (λ hn, + have even p, from even_of_not_odd hn, + obtain k `p = 2*k`, from exists_of_even this, + have 2 ∣ p, by rewrite [`p = 2*k`]; apply dvd_mul_right, + or.elim (eq_one_or_eq_self_of_prime_of_dvd pp this) + (suppose 2 = 1, absurd this dec_trivial) + (suppose 2 = p, by subst this; exact absurd p_gt_2 !lt.irrefl)) + +theorem dvd_of_prime_of_not_coprime {p n : ℕ} (primep : prime p) (nc : ¬ coprime p n) : p ∣ n := +have H : gcd p n = 1 ∨ gcd p n = p, from eq_one_or_eq_self_of_prime_of_dvd primep !gcd_dvd_left, +or_resolve_right H nc ▸ !gcd_dvd_right + +theorem coprime_of_prime_of_not_dvd {p n : ℕ} (primep : prime p) (npdvdn : ¬ p ∣ n) : + coprime p n := +by_contradiction (suppose ¬ coprime p n, npdvdn (dvd_of_prime_of_not_coprime primep this)) + +theorem not_dvd_of_prime_of_coprime {p n : ℕ} (primep : prime p) (cop : coprime p n) : ¬ p ∣ n := +suppose p ∣ n, +have p ∣ gcd p n, from dvd_gcd !dvd.refl this, +have p ≤ gcd p n, from le_of_dvd (!gcd_pos_of_pos_left (pos_of_prime primep)) this, +have 2 ≤ 1, from le.trans (ge_two_of_prime primep) (cop ▸ this), +show false, from !not_succ_le_self this + +theorem not_coprime_of_prime_dvd {p n : ℕ} (primep : prime p) (pdvdn : p ∣ n) : ¬ coprime p n := +assume cop, not_dvd_of_prime_of_coprime primep cop pdvdn + +theorem dvd_of_prime_of_dvd_mul_left {p m n : ℕ} (primep : prime p) + (Hmn : p ∣ m * n) (Hm : ¬ p ∣ m) : + p ∣ n := +have coprime p m, from coprime_of_prime_of_not_dvd primep Hm, +show p ∣ n, from dvd_of_coprime_of_dvd_mul_left this Hmn + +theorem dvd_of_prime_of_dvd_mul_right {p m n : ℕ} (primep : prime p) + (Hmn : p ∣ m * n) (Hn : ¬ p ∣ n) : + p ∣ m := +dvd_of_prime_of_dvd_mul_left primep (!mul.comm ▸ Hmn) Hn + +theorem not_dvd_mul_of_prime {p m n : ℕ} (primep : prime p) (Hm : ¬ p ∣ m) (Hn : ¬ p ∣ n) : + ¬ p ∣ m * n := +assume Hmn, Hm (dvd_of_prime_of_dvd_mul_right primep Hmn Hn) + +lemma dvd_or_dvd_of_prime_of_dvd_mul {p m n : nat} : prime p → p ∣ m * n → p ∣ m ∨ p ∣ n := +λ h₁ h₂, by_cases + (suppose p ∣ m, or.inl this) + (suppose ¬ p ∣ m, or.inr (dvd_of_prime_of_dvd_mul_left h₁ h₂ this)) + +lemma dvd_of_prime_of_dvd_pow {p m : nat} : ∀ {n}, prime p → p ∣ m^n → p ∣ m +| 0 hp hd := + have p = 1, from eq_one_of_dvd_one hd, + have (1:nat) ≥ 2, begin rewrite -this at {1}, apply ge_two_of_prime hp end, + absurd this dec_trivial +| (succ n) hp hd := + have p ∣ (m^n)*m, by rewrite [pow_succ' at hd]; exact hd, + or.elim (dvd_or_dvd_of_prime_of_dvd_mul hp this) + (suppose p ∣ m^n, dvd_of_prime_of_dvd_pow hp this) + (suppose p ∣ m, this) + +lemma coprime_pow_of_prime_of_not_dvd {p m a : nat} : prime p → ¬ p ∣ a → coprime a (p^m) := +λ h₁ h₂, coprime_pow_right m (coprime_swap (coprime_of_prime_of_not_dvd h₁ h₂)) + +lemma coprime_primes {p q : nat} : prime p → prime q → p ≠ q → coprime p q := +λ hp hq hn, + have gcd p q ∣ p, from !gcd_dvd_left, + or.elim (eq_one_or_eq_self_of_prime_of_dvd hp this) + (suppose gcd p q = 1, this) + (assume h : gcd p q = p, + have gcd p q ∣ q, from !gcd_dvd_right, + have p ∣ q, by rewrite -h; exact this, + or.elim (eq_one_or_eq_self_of_prime_of_dvd hq this) + (suppose p = 1, by subst p; exact absurd hp not_prime_one) + (suppose p = q, by contradiction)) + +lemma coprime_pow_primes {p q : nat} (n m : nat) : prime p → prime q → p ≠ q → coprime (p^n) (q^m) := +λ hp hq hn, coprime_pow_right m (coprime_pow_left n (coprime_primes hp hq hn)) + +lemma coprime_or_dvd_of_prime {p} (Pp : prime p) (i : nat) : coprime p i ∨ p ∣ i := +by_cases + (suppose p ∣ i, or.inr this) + (suppose ¬ p ∣ i, or.inl (coprime_of_prime_of_not_dvd Pp this)) + +lemma eq_one_or_dvd_of_dvd_prime_pow {p : nat} : ∀ {m i : nat}, prime p → i ∣ (p^m) → i = 1 ∨ p ∣ i +| 0 := take i, assume Pp, begin rewrite [pow_zero], intro Pdvd, apply or.inl (eq_one_of_dvd_one Pdvd) end +| (succ m) := take i, assume Pp, or.elim (coprime_or_dvd_of_prime Pp i) + (λ Pcp, begin + rewrite [pow_succ'], intro Pdvd, + apply eq_one_or_dvd_of_dvd_prime_pow Pp, + apply dvd_of_coprime_of_dvd_mul_right, + apply coprime_swap Pcp, exact Pdvd + end) + (λ Pdvd, assume P, or.inr Pdvd) +end nat diff --git a/old_library/theories/theories.md b/old_library/theories/theories.md new file mode 100644 index 0000000000..7e03be8024 --- /dev/null +++ b/old_library/theories/theories.md @@ -0,0 +1,9 @@ +theories +======== + +* [number_theory](number_theory/number_theory.md) +* [combinatorics](combinatorics/combinatorics.md) +* [group_theory](group_theory/group_theory.md) +* [topology](topology/topology.md) +* [analysis](analysis/analysis.md) +* [measure_theory](measure_theory/measure_theory.md) \ No newline at end of file diff --git a/old_library/theories/topology/basic.lean b/old_library/theories/topology/basic.lean new file mode 100644 index 0000000000..39bbe89d8c --- /dev/null +++ b/old_library/theories/topology/basic.lean @@ -0,0 +1,315 @@ +/- +Copyright (c) 2015 Jacob Gross. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jacob Gross, Jeremy Avigad + +Open and closed sets, seperation axioms and generated topologies. +-/ +import data.set data.nat +open algebra eq.ops set nat + +structure topology [class] (X : Type) := + (opens : set (set X)) + (univ_mem_opens : univ ∈ opens) + (sUnion_mem_opens : ∀ {S : set (set X)}, S ⊆ opens → ⋃₀ S ∈ opens) + (inter_mem_opens : ∀₀ s ∈ opens, ∀₀ t ∈ opens, s ∩ t ∈ opens) + +namespace topology + +variables {X : Type} [topology X] + +/- open sets -/ + +definition Open (s : set X) : Prop := s ∈ opens X + +theorem Open_empty : Open (∅ : set X) := +have ∅ ⊆ opens X, from empty_subset _, +have ⋃₀ ∅ ∈ opens X, from sUnion_mem_opens this, +show ∅ ∈ opens X, by rewrite -sUnion_empty; apply this + +theorem Open_univ : Open (univ : set X) := +univ_mem_opens X + +theorem Open_sUnion {S : set (set X)} (H : ∀₀ t ∈ S, Open t) : Open (⋃₀ S) := +sUnion_mem_opens H + +theorem Open_Union {I : Type} {s : I → set X} (H : ∀ i, Open (s i)) : Open (⋃ i, s i) := +have ∀₀ t ∈ s ' univ, Open t, + from take t, suppose t ∈ s ' univ, + obtain i [univi (Hi : s i = t)], from this, + show Open t, by rewrite -Hi; exact H i, +using this, by rewrite Union_eq_sUnion_image; apply Open_sUnion this + +theorem Open_union {s t : set X} (Hs : Open s) (Ht : Open t) : Open (s ∪ t) := +have ∀ i, Open (bin_ext s t i), by intro i; cases i; exact Hs; exact Ht, +show Open (s ∪ t), by rewrite -Union_bin_ext; exact Open_Union this + +theorem Open_inter {s t : set X} (Hs : Open s) (Ht : Open t) : Open (s ∩ t) := +inter_mem_opens X Hs Ht + +theorem Open_sInter_of_finite {s : set (set X)} [fins : finite s] (H : ∀₀ t ∈ s, Open t) : + Open (⋂₀ s) := +begin + induction fins with a s fins anins ih, + {rewrite sInter_empty, exact Open_univ}, + rewrite sInter_insert, + apply Open_inter, + show Open a, from H (mem_insert a s), + apply ih, intros t ts, + show Open t, from H (mem_insert_of_mem a ts) +end + +/- closed sets -/ + +attribute [reducible] +definition closed (s : set X) : Prop := Open (-s) + +theorem closed_iff_Open_compl (s : set X) : closed s ↔ Open (-s) := !iff.refl + +theorem Open_iff_closed_compl (s : set X) : Open s ↔ closed (-s) := +by rewrite [closed_iff_Open_compl, compl_compl] + +theorem closed_compl {s : set X} (H : Open s) : closed (-s) := +by rewrite [-Open_iff_closed_compl]; apply H + +theorem closed_empty : closed (∅ : set X) := +by rewrite [↑closed, compl_empty]; exact Open_univ + +theorem closed_univ : closed (univ : set X) := +by rewrite [↑closed, compl_univ]; exact Open_empty + +theorem closed_sInter {S : set (set X)} (H : ∀₀ t ∈ S, closed t) : closed (⋂₀ S) := +begin + rewrite [↑closed, compl_sInter], + apply Open_sUnion, + intro t, + rewrite [mem_image_compl, Open_iff_closed_compl], + apply H +end + +theorem closed_Inter {I : Type} {s : I → set X} (H : ∀ i, closed (s i : set X)) : + closed (⋂ i, s i) := +by rewrite [↑closed, compl_Inter]; apply Open_Union; apply H + +theorem closed_inter {s t : set X} (Hs : closed s) (Ht : closed t) : closed (s ∩ t) := +by rewrite [↑closed, compl_inter]; apply Open_union; apply Hs; apply Ht + +theorem closed_union {s t : set X} (Hs : closed s) (Ht : closed t) : closed (s ∪ t) := +by rewrite [↑closed, compl_union]; apply Open_inter; apply Hs; apply Ht + +theorem closed_sUnion_of_finite {s : set (set X)} [fins : finite s] (H : ∀₀ t ∈ s, closed t) : + closed (⋂₀ s) := +begin + rewrite [↑closed, compl_sInter], + apply Open_sUnion, + intro t, + rewrite [mem_image_compl, Open_iff_closed_compl], + apply H +end + +theorem open_diff {s t : set X} (Hs : Open s) (Ht : closed t) : Open (s \ t) := +Open_inter Hs Ht + +theorem closed_diff {s t : set X} (Hs : closed s) (Ht : Open t) : closed (s \ t) := +closed_inter Hs (closed_compl Ht) + +section +local attribute classical.prop_decidable [instance] + +theorem Open_of_forall_exists_Open_nbhd {s : set X} (H : ∀₀ x ∈ s, ∃ tx : set X, Open tx ∧ x ∈ tx ∧ tx ⊆ s) : + Open s := + let Hset : X → set X := λ x, if Hxs : x ∈ s then some (H Hxs) else univ in + let sFam := image (λ x, Hset x) s in + have H_union_open : Open (⋃₀ sFam), from Open_sUnion + (take t : set X, suppose t ∈ sFam, + have H_preim : ∃ t', t' ∈ s ∧ Hset t' = t, from this, + obtain t' (Ht' : t' ∈ s) (Ht't : Hset t' = t), from H_preim, + have HHsett : t = some (H Ht'), from Ht't ▸ dif_pos Ht', + show Open t, from and.left (HHsett⁻¹ ▸ some_spec (H Ht'))), + have H_subset_union : s ⊆ ⋃₀ sFam, from + (take x : X, suppose x ∈ s, + have HxHset : x ∈ Hset x, from (dif_pos this)⁻¹ ▸ (and.left (and.right (some_spec (H this)))), + show x ∈ ⋃₀ sFam, from mem_sUnion HxHset (mem_image this rfl)), + have H_union_subset : ⋃₀ sFam ⊆ s, from + (take x : X, suppose x ∈ ⋃₀ sFam, + obtain (t : set X) (Ht : t ∈ sFam) (Hxt : x ∈ t), from this, + have H_preim : ∃ t', t' ∈ s ∧ Hset t' = t, from Ht, + obtain t' (Ht' : t' ∈ s) (Ht't : Hset t' = t), from H_preim, + have HHsett : t = some (H Ht'), from Ht't ▸ dif_pos Ht', + have t ⊆ s, from and.right (and.right (HHsett⁻¹ ▸ some_spec (H Ht'))), + show x ∈ s, from this Hxt), + have H_union_eq : ⋃₀ sFam = s, from eq_of_subset_of_subset H_union_subset H_subset_union, + show Open s, from H_union_eq ▸ H_union_open + +end + +end topology + +/- separation -/ + +structure T0_space [class] (X : Type) extends topology X := + (T0 : ∀ {x y}, x ≠ y → ∃ U, U ∈ opens ∧ ¬(x ∈ U ↔ y ∈ U)) + +namespace topology + variables {X : Type} [T0_space X] + + theorem separation_T0 {x y : X} : x ≠ y ↔ ∃ U, Open U ∧ ¬(x ∈ U ↔ y ∈ U) := + iff.intro + (T0_space.T0) + (assume H, obtain U [OpU xyU], from H, + suppose x = y, + have x ∈ U ↔ y ∈ U, from iff.intro + (assume xU, this ▸ xU) + (assume yU, this⁻¹ ▸ yU), + absurd this xyU) +end topology + +structure T1_space [class] (X : Type) extends topology X := + (T1 : ∀ {x y}, x ≠ y → ∃ U, U ∈ opens ∧ x ∈ U ∧ y ∉ U) + +attribute [trans_instance] +protected definition T0_space.of_T1 {X : Type} [T : T1_space X] : + T0_space X := +⦃T0_space, T, + T0 := abstract + take x y, assume H, + obtain U [Uopens [xU ynU]], from T1_space.T1 H, + exists.intro U (and.intro Uopens + (show ¬ (x ∈ U ↔ y ∈ U), from assume H, ynU (iff.mp H xU))) + end ⦄ + +namespace topology + variables {X : Type} [T1_space X] + + theorem separation_T1 {x y : X} : x ≠ y ↔ (∃ U, Open U ∧ x ∈ U ∧ y ∉ U) := + iff.intro + (T1_space.T1) + (suppose ∃ U, Open U ∧ x ∈ U ∧ y ∉ U, + obtain U [OpU xU nyU], from this, + suppose x = y, + absurd xU (this⁻¹ ▸ nyU)) + + theorem closed_singleton {a : X} : closed '{a} := + let T := ⋃₀ {S| Open S ∧ a ∉ S} in + have Open T, from Open_sUnion (λS HS, and.elim_left HS), + have T = -'{a}, from ext(take x, iff.intro + (assume xT, assume xa, + obtain S [[OpS aS] xS], from xT, + have ∃ U, Open U ∧ x ∈ U ∧ a ∉ U, from + exists.intro S (and.intro OpS (and.intro xS aS)), + have x ≠ a, from (iff.elim_right separation_T1) this, + absurd ((iff.elim_left !mem_singleton_iff) xa) this) + (assume xa, + have x ≠ a, from not.intro( + assume H, absurd ((iff.elim_right !mem_singleton_iff) H) xa), + obtain U [OpU xU aU], from (iff.elim_left separation_T1) this, + show _, from exists.intro U (and.intro (and.intro OpU aU) xU))), + show _, from this ▸ `Open T` +end topology + +structure T2_space [class] (X : Type) extends topology X := + (T2 : ∀ {x y}, x ≠ y → ∃ U V, U ∈ opens ∧ V ∈ opens ∧ x ∈ U ∧ y ∈ V ∧ U ∩ V = ∅) + +attribute [trans_instance] +protected definition T1_space.of_T2 {X : Type} [T : T2_space X] : + T1_space X := +⦃T1_space, T, + T1 := abstract + take x y, assume H, + obtain U [V [Uopens [Vopens [xU [yV UVempty]]]]], from T2_space.T2 H, + exists.intro U (and.intro Uopens (and.intro xU + (show y ∉ U, from assume yU, + have y ∈ U ∩ V, from and.intro yU yV, + show y ∈ ∅, from UVempty ▸ this))) + end ⦄ + +namespace topology + variables {X : Type} [T2_space X] + + theorem seperation_T2 {x y : X} : x ≠ y ↔ ∃ U V, Open U ∧ Open V ∧ x ∈ U ∧ y ∈ V ∧ U ∩ V = ∅ := + iff.intro + (T2_space.T2) + (assume H, obtain U V [OpU OpV xU yV UV], from H, + suppose x = y, + have ¬(x ∈ U ∩ V), from not.intro( + assume xUV, absurd (UV ▸ xUV) !not_mem_empty), + absurd (and.intro xU (`x = y`⁻¹ ▸ yV)) this) +end topology + +structure perfect_space [class] (X : Type) extends topology X := + (perfect : ∀ x, '{x} ∉ opens) + +/- topology generated by a set -/ + +namespace topology + +inductive opens_generated_by {X : Type} (B : set (set X)) : set X → Prop := +| generators_mem : ∀ ⦃s : set X⦄, s ∈ B → opens_generated_by B s +| univ_mem : opens_generated_by B univ +| inter_mem : ∀ ⦃s t⦄, opens_generated_by B s → opens_generated_by B t → + opens_generated_by B (s ∩ t) +| sUnion_mem : ∀ ⦃S : set (set X)⦄, S ⊆ opens_generated_by B → opens_generated_by B (⋃₀ S) + +attribute [instance] +protected definition generated_by {X : Type} (B : set (set X)) : topology X := +⦃topology, + opens := opens_generated_by B, + univ_mem_opens := opens_generated_by.univ_mem B, + inter_mem_opens := λ s Hs t Ht, opens_generated_by.inter_mem Hs Ht, + sUnion_mem_opens := opens_generated_by.sUnion_mem +⦄ + +theorem generators_mem_topology_generated_by {X : Type} (B : set (set X)) : + let T := topology.generated_by B in + ∀₀ s ∈ B, @Open _ T s := +λ s H, opens_generated_by.generators_mem H + +theorem opens_generated_by_initial {X : Type} {B : set (set X)} {T : topology X} (H : B ⊆ @opens _ T) : + opens_generated_by B ⊆ @opens _ T := +begin + intro s Hs, + induction Hs with s sB s t os ot soX toX S SB SOX, + {exact H sB}, + {exact univ_mem_opens X}, + {exact inter_mem_opens X soX toX}, + exact sUnion_mem_opens SOX +end + +theorem topology_generated_by_initial {X : Type} {B : set (set X)} {T : topology X} + (H : ∀₀ s ∈ B, @Open _ T s) {s : set X} (H1 : @Open _ (topology.generated_by B) s) : + @Open _ T s := +opens_generated_by_initial H H1 + +section continuity + +/- continuous mappings -/ +/- continuity at a point -/ + +variables {M N : Type} [Tm : topology M] [Tn : topology N] +include Tm Tn + +definition continuous_at (f : M → N) (x : M) := + ∀ U : set N, f x ∈ U → Open U → ∃ V : set M, x ∈ V ∧ Open V ∧ f 'V ⊆ U + +definition continuous (f : M → N) := + ∀ x : M, continuous_at f x + +end continuity + +section boundary +variables {X : Type} [TX : topology X] +include TX + +definition on_boundary (x : X) (u : set X) := ∀ v : set X, Open v → x ∈ v → u ∩ v ≠ ∅ ∧ ¬ v ⊆ u + +theorem not_open_of_on_boundary {x : X} {u : set X} (Hxu : x ∈ u) (Hob : on_boundary x u) : ¬ Open u := + begin + intro Hop, + note Hbxu := Hob _ Hop Hxu, + apply and.right Hbxu, + apply subset.refl + end + +end boundary + +end topology diff --git a/old_library/theories/topology/order_topology.lean b/old_library/theories/topology/order_topology.lean new file mode 100644 index 0000000000..308835100c --- /dev/null +++ b/old_library/theories/topology/order_topology.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2016 Jacob Gross. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Jacob Gross + +The order topology. +-/ +import data.set theories.topology.basic algebra.interval +open algebra eq.ops set interval topology + +namespace order_topology + +variables {X : Type} [linear_strong_order_pair X] + +definition linorder_generators : set (set X) := {y | ∃ a, y = '(a, ∞) } ∪ {y | ∃ a, y = '(-∞, a)} + +attribute [instance] +definition linorder_topology : topology X := + topology.generated_by linorder_generators + +theorem Open_Ioi {a : X} : Open '(a, ∞) := +(generators_mem_topology_generated_by linorder_generators) (!mem_unionl (exists.intro a rfl)) + +theorem Open_Iio {a : X} : Open '(-∞, a) := +(generators_mem_topology_generated_by linorder_generators) (!mem_unionr (exists.intro a rfl)) + +theorem closed_Ici (a : X) : closed '[a,∞) := +!compl_Ici⁻¹ ▸ Open_Iio + +theorem closed_Iic (a : X) : closed '(-∞,a] := +have '(a, ∞) = -'(-∞,a], from ext(take x, iff.intro + (assume H, not_le_of_gt H) + (assume H, lt_of_not_ge H)), +this ▸ Open_Ioi + +theorem Open_Ioo (a b : X) : Open '(a, b) := +Open_inter !Open_Ioi !Open_Iio + +theorem closed_Icc (a b : X) : closed '[a, b] := +closed_inter !closed_Ici !closed_Iic + +section + local attribute classical.prop_decidable [instance] + + theorem linorder_separation {x y : X} : + x < y → ∃ a b, (x < a ∧ b < y) ∧ '(-∞, a) ∩ '(b, ∞) = ∅ := + suppose x < y, + if H1 : ∃ z, x < z ∧ z < y then + obtain z (Hz : x < z ∧ z < y), from H1, + have '(-∞, z) ∩ '(z, ∞) = ∅, from ext (take r, iff.intro + (assume H, absurd (!lt.trans (and.elim_left H) (and.elim_right H)) !lt.irrefl) + (assume H, !not.elim !not_mem_empty H)), + exists.intro z (exists.intro z (and.intro Hz this)) + else + have '(-∞, y) ∩ '(x, ∞) = ∅, from ext(take r, iff.intro + (assume H, absurd (exists.intro r (iff.elim_left and.comm H)) H1) + (assume H, !not.elim !not_mem_empty H)), + exists.intro y (exists.intro x (and.intro (and.intro `x < y` `x < y`) this)) +end + +attribute [trans_instance] +protected definition T2_space.of_linorder_topology : + T2_space X := +⦃ T2_space, linorder_topology, + T2 := abstract + take x y, assume H, + or.elim (lt_or_gt_of_ne H) + (assume H, + obtain a [b Hab], from linorder_separation H, + show _, from exists.intro '(-∞, a) (exists.intro '(b, ∞) + (and.intro Open_Iio (and.intro Open_Ioi (iff.elim_left and.assoc Hab))))) + (assume H, + obtain a [b Hab], from linorder_separation H, + have Hx : x ∈ '(b, ∞), from and.elim_right (and.elim_left Hab), + have Hy : y ∈ '(-∞, a), from and.elim_left (and.elim_left Hab), + have Hi : '(b, ∞) ∩ '(-∞, a) = ∅, from !inter_comm ▸ (and.elim_right Hab), + have (Open '(b,∞)) ∧ (Open '(-∞, a)) ∧ x ∈ '(b, ∞) ∧ y ∈ '(-∞, a) ∧ + '(b, ∞) ∩ '(-∞, a) = ∅, from + and.intro Open_Ioi (and.intro Open_Iio (and.intro Hx (and.intro Hy Hi))), + show _, from exists.intro '(b,∞) (exists.intro '(-∞, a) this)) + end ⦄ + +end order_topology diff --git a/old_library/theories/topology/topology.md b/old_library/theories/topology/topology.md new file mode 100644 index 0000000000..33f5f2ebf7 --- /dev/null +++ b/old_library/theories/topology/topology.md @@ -0,0 +1,5 @@ +theories.topology +================= + +* [basic](basic.lean) : open and closed sets, separation axioms, and generated topologies +* [order_topology](order_topology.lean) \ No newline at end of file diff --git a/old_library/tools/tools.md b/old_library/tools/tools.md new file mode 100644 index 0000000000..bc88f47d1a --- /dev/null +++ b/old_library/tools/tools.md @@ -0,0 +1,6 @@ +tools +===== + +Various additional tools. + +* [helper_tactics](helper_tactics.lean) : useful tactics \ No newline at end of file