/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module category_theory.preadditive.hom_orthogonal
! leanprover-community/mathlib commit 829895f162a1f29d0133f4b3538f4cd1fb5bffd3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Linear.Basic
import Mathbin.CategoryTheory.Preadditive.Biproducts
import Mathbin.LinearAlgebra.Matrix.InvariantBasisNumber

/-!
# Hom orthogonal families.

A family of objects in a category with zero morphisms is "hom orthogonal" if the only
morphism between distinct objects is the zero morphism.

We show that in any category with zero morphisms and finite biproducts,
a morphism between biproducts drawn from a hom orthogonal family `s : ι → C`
can be decomposed into a block diagonal matrix with entries in the endomorphism rings of the `s i`.

When the category is preadditive, this decomposition is an additive equivalence,
and intertwines composition and matrix multiplication.
When the category is `R`-linear, the decomposition is an `R`-linear equivalence.

If every object in the hom orthogonal family has an endomorphism ring with invariant basis number
(e.g. if each object in the family is simple, so its endomorphism ring is a division ring,
or otherwise if each endomorphism ring is commutative),
then decompositions of an object as a biproduct of the family have uniquely defined multiplicities.
We state this as:
```
lemma hom_orthogonal.equiv_of_iso (o : hom_orthogonal s) {f : α → ι} {g : β → ι}
  (i : ⨁ (λ a, s (f a)) ≅ ⨁ (λ b, s (g b))) : ∃ e : α ≃ β, ∀ a, g (e a) = f a
```

This is preliminary to defining semisimple categories.
-/

open Classical Matrix

open CategoryTheory.Limits

universe v u

namespace CategoryTheory

variable {C : Type u} [Category.{v} C]

/-- A family of objects is "hom orthogonal" if
there is at most one morphism between distinct objects.

(In a category with zero morphisms, that must be the zero morphism.) -/
def HomOrthogonal {ι : Type _} (s : ι → C) : Prop :=
  ∀ i j, i ≠ j → Subsingleton (s i ⟶ s j)
#align category_theory.hom_orthogonal CategoryTheory.HomOrthogonal

namespace HomOrthogonal

variable {ι : Type _} {s : ι → C}

theorem eq_zero [HasZeroMorphisms C] (o : HomOrthogonal s) {i j : ι} (w : i ≠ j) (f : s i ⟶ s j) :
    f = 0 := by
  haveI := o i j w
  apply Subsingleton.elim
#align category_theory.hom_orthogonal.eq_zero CategoryTheory.HomOrthogonal.eq_zero

section

variable [HasZeroMorphisms C] [HasFiniteBiproducts C]

/-- Morphisms between two direct sums over a hom orthogonal family `s : ι → C`
are equivalent to block diagonal matrices,
with blocks indexed by `ι`,
and matrix entries in `i`-th block living in the endomorphisms of `s i`. -/
@[simps]
noncomputable def matrixDecomposition (o : HomOrthogonal s) {α β : Type} [Fintype α] [Fintype β]
    {f : α → ι} {g : β → ι} :
    ((⨁ fun a => s (f a)) ⟶ ⨁ fun b => s (g b)) ≃
      ∀ i : ι, Matrix (g ⁻¹' {i}) (f ⁻¹' {i}) (End (s i))
    where
  toFun z i j k :=
    eqToHom
        (by
          rcases k with ⟨k, ⟨⟩⟩
          simp) ≫
      biproduct.components z k j ≫
        eqToHom
          (by
            rcases j with ⟨j, ⟨⟩⟩
            simp)
  invFun z :=
    biproduct.matrix fun j k =>
      if h : f j = g k then z (f j) ⟨k, by simp [h]⟩ ⟨j, by simp⟩ ≫ eqToHom (by simp [h]) else 0
  left_inv z := by
    ext (j k)
    simp only [category.assoc, biproduct.lift_π, biproduct.ι_matrix]
    split_ifs
    · simp
      rfl
    · symm
      apply o.eq_zero h
  right_inv z := by
    ext (i⟨j, w⟩⟨k, ⟨⟩⟩)
    simp only [Set.mem_preimage, Set.mem_singleton_iff]
    simp [w.symm]; rfl
#align category_theory.hom_orthogonal.matrix_decomposition CategoryTheory.HomOrthogonal.matrixDecomposition

end

section

variable [Preadditive C] [HasFiniteBiproducts C]

/-- `hom_orthogonal.matrix_decomposition` as an additive equivalence. -/
@[simps]
noncomputable def matrixDecompositionAddEquiv (o : HomOrthogonal s) {α β : Type} [Fintype α]
    [Fintype β] {f : α → ι} {g : β → ι} :
    ((⨁ fun a => s (f a)) ⟶ ⨁ fun b => s (g b)) ≃+
      ∀ i : ι, Matrix (g ⁻¹' {i}) (f ⁻¹' {i}) (End (s i)) :=
  { o.matrixDecomposition with
    map_add' := fun w z => by
      ext
      dsimp [biproduct.components]
      simp }
#align category_theory.hom_orthogonal.matrix_decomposition_add_equiv CategoryTheory.HomOrthogonal.matrixDecompositionAddEquiv

@[simp]
theorem matrixDecomposition_id (o : HomOrthogonal s) {α : Type} [Fintype α] {f : α → ι} (i : ι) :
    o.matrixDecomposition (𝟙 (⨁ fun a => s (f a))) i = 1 :=
  by
  ext (⟨b, ⟨⟩⟩⟨a⟩)
  simp only [Set.mem_preimage, Set.mem_singleton_iff] at j_property
  simp only [category.comp_id, category.id_comp, category.assoc, End.one_def, eq_to_hom_refl,
    Matrix.one_apply, hom_orthogonal.matrix_decomposition_apply, biproduct.components]
  split_ifs with h
  · cases h
    simp
  · convert comp_zero
    simpa using biproduct.ι_π_ne _ (Ne.symm h)
#align category_theory.hom_orthogonal.matrix_decomposition_id CategoryTheory.HomOrthogonal.matrixDecomposition_id

theorem matrixDecomposition_comp (o : HomOrthogonal s) {α β γ : Type} [Fintype α] [Fintype β]
    [Fintype γ] {f : α → ι} {g : β → ι} {h : γ → ι} (z : (⨁ fun a => s (f a)) ⟶ ⨁ fun b => s (g b))
    (w : (⨁ fun b => s (g b)) ⟶ ⨁ fun c => s (h c)) (i : ι) :
    o.matrixDecomposition (z ≫ w) i = o.matrixDecomposition w i ⬝ o.matrixDecomposition z i :=
  by
  ext (⟨c, ⟨⟩⟩⟨a⟩)
  simp only [Set.mem_preimage, Set.mem_singleton_iff] at j_property
  simp only [Matrix.mul_apply, limits.biproduct.components,
    hom_orthogonal.matrix_decomposition_apply, category.comp_id, category.id_comp, category.assoc,
    End.mul_def, eq_to_hom_refl, eq_to_hom_trans_assoc, Finset.sum_congr]
  conv_lhs => rw [← category.id_comp w, ← biproduct.total]
  simp only [preadditive.sum_comp, preadditive.comp_sum]
  apply Finset.sum_congr_set
  · intros
    simp
    rfl
  · intro b nm
    simp only [Set.mem_preimage, Set.mem_singleton_iff] at nm
    simp only [category.assoc]
    convert comp_zero
    convert comp_zero
    convert comp_zero
    convert comp_zero
    apply o.eq_zero nm
#align category_theory.hom_orthogonal.matrix_decomposition_comp CategoryTheory.HomOrthogonal.matrixDecomposition_comp

section

variable {R : Type _} [Semiring R] [Linear R C]

/-- `hom_orthogonal.matrix_decomposition` as an `R`-linear equivalence. -/
@[simps]
noncomputable def matrixDecompositionLinearEquiv (o : HomOrthogonal s) {α β : Type} [Fintype α]
    [Fintype β] {f : α → ι} {g : β → ι} :
    ((⨁ fun a => s (f a)) ⟶ ⨁ fun b => s (g b)) ≃ₗ[R]
      ∀ i : ι, Matrix (g ⁻¹' {i}) (f ⁻¹' {i}) (End (s i)) :=
  { o.matrixDecompositionAddEquiv with
    map_smul' := fun w z => by
      ext
      dsimp [biproduct.components]
      simp }
#align category_theory.hom_orthogonal.matrix_decomposition_linear_equiv CategoryTheory.HomOrthogonal.matrixDecompositionLinearEquiv

end

/-!
The hypothesis that `End (s i)` has invariant basis number is automatically satisfied
if `s i` is simple (as then `End (s i)` is a division ring).
-/

variable [∀ i, InvariantBasisNumber (End (s i))]

/-- Given a hom orthogonal family `s : ι → C`
for which each `End (s i)` is a ring with invariant basis number (e.g. if each `s i` is simple),
if two direct sums over `s` are isomorphic, then they have the same multiplicities.
-/
theorem equiv_of_iso (o : HomOrthogonal s) {α β : Type} [Fintype α] [Fintype β] {f : α → ι}
    {g : β → ι} (i : (⨁ fun a => s (f a)) ≅ ⨁ fun b => s (g b)) : ∃ e : α ≃ β, ∀ a, g (e a) = f a :=
  by
  refine' ⟨Equiv.ofPreimageEquiv _, fun a => Equiv.ofPreimageEquiv_map _ _⟩
  intro c
  apply Nonempty.some
  apply Cardinal.eq.1
  simp only [Cardinal.mk_fintype, Nat.cast_inj]
  exact
    Matrix.square_of_invertible (o.matrix_decomposition i.inv c) (o.matrix_decomposition i.hom c)
      (by
        rw [← o.matrix_decomposition_comp]
        simp)
      (by
        rw [← o.matrix_decomposition_comp]
        simp)
#align category_theory.hom_orthogonal.equiv_of_iso CategoryTheory.HomOrthogonal.equiv_of_iso

end

end HomOrthogonal

end CategoryTheory


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import order.modular_lattice
import order.well_founded

/-!
# Atoms, Coatoms, and Simple Lattices

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This module defines atoms, which are minimal non-`⊥` elements in bounded lattices, simple lattices,
which are lattices with only two elements, and related ideas.

## Main definitions

### Atoms and Coatoms
  * `is_atom a` indicates that the only element below `a` is `⊥`.
  * `is_coatom a` indicates that the only element above `a` is `⊤`.

### Atomic and Atomistic Lattices
  * `is_atomic` indicates that every element other than `⊥` is above an atom.
  * `is_coatomic` indicates that every element other than `⊤` is below a coatom.
  * `is_atomistic` indicates that every element is the `Sup` of a set of atoms.
  * `is_coatomistic` indicates that every element is the `Inf` of a set of coatoms.

### Simple Lattices
  * `is_simple_order` indicates that an order has only two unique elements, `⊥` and `⊤`.
  * `is_simple_order.bounded_order`
  * `is_simple_order.distrib_lattice`
  * Given an instance of `is_simple_order`, we provide the following definitions. These are not
    made global instances as they contain data :
    * `is_simple_order.boolean_algebra`
    * `is_simple_order.complete_lattice`
    * `is_simple_order.complete_boolean_algebra`

## Main results
  * `is_atom_dual_iff_is_coatom` and `is_coatom_dual_iff_is_atom` express the (definitional) duality
   of `is_atom` and `is_coatom`.
  * `is_simple_order_iff_is_atom_top` and `is_simple_order_iff_is_coatom_bot` express the
  connection between atoms, coatoms, and simple lattices
  * `is_compl.is_atom_iff_is_coatom` and `is_compl.is_coatom_if_is_atom`: In a modular
  bounded lattice, a complement of an atom is a coatom and vice versa.
  * `is_atomic_iff_is_coatomic`: A modular complemented lattice is atomic iff it is coatomic.

-/

variables {α β : Type*}

section atoms

section is_atom

section preorder

variables [preorder α] [order_bot α] {a b x : α}

/-- An atom of an `order_bot` is an element with no other element between it and `⊥`,
  which is not `⊥`. -/
def is_atom (a : α) : Prop := a ≠ ⊥ ∧ (∀ b, b < a → b = ⊥)

lemma is_atom.Iic (ha : is_atom a) (hax : a ≤ x) : is_atom (⟨a, hax⟩ : set.Iic x) :=
⟨λ con, ha.1 (subtype.mk_eq_mk.1 con), λ ⟨b, hb⟩ hba, subtype.mk_eq_mk.2 (ha.2 b hba)⟩

lemma is_atom.of_is_atom_coe_Iic {a : set.Iic x} (ha : is_atom a) : is_atom (a : α) :=
⟨λ con, ha.1 (subtype.ext con), λ b hba, subtype.mk_eq_mk.1 (ha.2 ⟨b, hba.le.trans a.prop⟩ hba)⟩

lemma is_atom_iff {a : α} : is_atom a ↔ a ≠ ⊥ ∧ ∀ b ≠ ⊥, b ≤ a → a ≤ b :=
and_congr iff.rfl $ forall_congr $
  λ b, by simp only [ne.def, @not_imp_comm (b = ⊥), not_imp, lt_iff_le_not_le]

end preorder

variables [partial_order α] [order_bot α] {a b x : α}

lemma is_atom.lt_iff (h : is_atom a) : x < a ↔ x = ⊥ := ⟨h.2 x, λ hx, hx.symm ▸ h.1.bot_lt⟩

lemma is_atom.le_iff (h : is_atom a) : x ≤ a ↔ x = ⊥ ∨ x = a :=
by rw [le_iff_lt_or_eq, h.lt_iff]

lemma is_atom.Iic_eq (h : is_atom a) : set.Iic a = {⊥, a} := set.ext $ λ x, h.le_iff

@[simp] lemma bot_covby_iff : ⊥ ⋖ a ↔ is_atom a :=
by simp only [covby, bot_lt_iff_ne_bot, is_atom, not_imp_not]

alias bot_covby_iff ↔ covby.is_atom is_atom.bot_covby

end is_atom

section is_coatom

section preorder

variables [preorder α]

/-- A coatom of an `order_top` is an element with no other element between it and `⊤`,
  which is not `⊤`. -/
def is_coatom [order_top α] (a : α) : Prop := a ≠ ⊤ ∧ (∀ b, a < b → b = ⊤)

@[simp] lemma is_coatom_dual_iff_is_atom [order_bot α] {a : α}:
  is_coatom (order_dual.to_dual a) ↔ is_atom a :=
iff.rfl

@[simp] lemma is_atom_dual_iff_is_coatom [order_top α] {a : α} :
  is_atom (order_dual.to_dual a) ↔ is_coatom a :=
iff.rfl

alias is_coatom_dual_iff_is_atom ↔ _ is_atom.dual
alias is_atom_dual_iff_is_coatom ↔ _ is_coatom.dual

variables [order_top α] {a x : α}

lemma is_coatom.Ici (ha : is_coatom a) (hax : x ≤ a) : is_coatom (⟨a, hax⟩ : set.Ici x) :=
ha.dual.Iic hax

lemma is_coatom.of_is_coatom_coe_Ici {a : set.Ici x} (ha : is_coatom a) :
  is_coatom (a : α) :=
@is_atom.of_is_atom_coe_Iic αᵒᵈ _ _ x a ha

lemma is_coatom_iff {a : α} : is_coatom a ↔ a ≠ ⊤ ∧ ∀ b ≠ ⊤, a ≤ b → b ≤ a := @is_atom_iff αᵒᵈ _ _ _

end preorder

variables [partial_order α] [order_top α] {a b x : α}

lemma is_coatom.lt_iff (h : is_coatom a) : a < x ↔ x = ⊤ := h.dual.lt_iff
lemma is_coatom.le_iff (h : is_coatom a) : a ≤ x ↔ x = ⊤ ∨ x = a := h.dual.le_iff
lemma is_coatom.Ici_eq (h : is_coatom a) : set.Ici a = {⊤, a} := h.dual.Iic_eq

@[simp] lemma covby_top_iff : a ⋖ ⊤ ↔ is_coatom a :=
to_dual_covby_to_dual_iff.symm.trans bot_covby_iff

alias covby_top_iff ↔ covby.is_coatom is_coatom.covby_top

end is_coatom

section partial_order
variables [partial_order α] {a b : α}

@[simp] lemma set.Ici.is_atom_iff {b : set.Ici a} : is_atom b ↔ a ⋖ b :=
begin
  rw ←bot_covby_iff,
  refine (set.ord_connected.apply_covby_apply_iff (order_embedding.subtype $ λ c, a ≤ c) _).symm,
  simpa only [order_embedding.subtype_apply, subtype.range_coe_subtype] using set.ord_connected_Ici,
end

@[simp] lemma set.Iic.is_coatom_iff {a : set.Iic b} : is_coatom a ↔ ↑a ⋖ b :=
begin
  rw ←covby_top_iff,
  refine (set.ord_connected.apply_covby_apply_iff (order_embedding.subtype $ λ c, c ≤ b) _).symm,
  simpa only [order_embedding.subtype_apply, subtype.range_coe_subtype] using set.ord_connected_Iic,
end

lemma covby_iff_atom_Ici (h : a ≤ b) : a ⋖ b ↔ is_atom (⟨b, h⟩ : set.Ici a) := by simp
lemma covby_iff_coatom_Iic (h : a ≤ b) : a ⋖ b ↔ is_coatom (⟨a, h⟩ : set.Iic b) := by simp

end partial_order

section pairwise

lemma is_atom.inf_eq_bot_of_ne [semilattice_inf α] [order_bot α] {a b : α}
  (ha : is_atom a) (hb : is_atom b) (hab : a ≠ b) : a ⊓ b = ⊥ :=
hab.not_le_or_not_le.elim (ha.lt_iff.1 ∘ inf_lt_left.2) (hb.lt_iff.1 ∘ inf_lt_right.2)

lemma is_atom.disjoint_of_ne [semilattice_inf α] [order_bot α] {a b : α}
  (ha : is_atom a) (hb : is_atom b) (hab : a ≠ b) : disjoint a b :=
disjoint_iff.mpr (is_atom.inf_eq_bot_of_ne ha hb hab)

lemma is_coatom.sup_eq_top_of_ne [semilattice_sup α] [order_top α] {a b : α}
  (ha : is_coatom a) (hb : is_coatom b) (hab : a ≠ b) : a ⊔ b = ⊤ :=
ha.dual.inf_eq_bot_of_ne hb.dual hab

end pairwise

end atoms

section atomic

variables [partial_order α] (α)

/-- A lattice is atomic iff every element other than `⊥` has an atom below it. -/
@[mk_iff] class is_atomic [order_bot α] : Prop :=
(eq_bot_or_exists_atom_le : ∀ (b : α), b = ⊥ ∨ ∃ (a : α), is_atom a ∧ a ≤ b)

/-- A lattice is coatomic iff every element other than `⊤` has a coatom above it. -/
@[mk_iff] class is_coatomic [order_top α] : Prop :=
(eq_top_or_exists_le_coatom : ∀ (b : α), b = ⊤ ∨ ∃ (a : α), is_coatom a ∧ b ≤ a)

export is_atomic (eq_bot_or_exists_atom_le) is_coatomic (eq_top_or_exists_le_coatom)

variable {α}

@[simp] lemma is_coatomic_dual_iff_is_atomic [order_bot α] : is_coatomic αᵒᵈ ↔ is_atomic α :=
⟨λ h, ⟨λ b, by apply h.eq_top_or_exists_le_coatom⟩, λ h, ⟨λ b, by apply h.eq_bot_or_exists_atom_le⟩⟩

@[simp] lemma is_atomic_dual_iff_is_coatomic [order_top α] : is_atomic αᵒᵈ ↔ is_coatomic α :=
⟨λ h, ⟨λ b, by apply h.eq_bot_or_exists_atom_le⟩, λ h, ⟨λ b, by apply h.eq_top_or_exists_le_coatom⟩⟩

namespace is_atomic

variables [order_bot α] [is_atomic α]

instance is_coatomic_dual : is_coatomic αᵒᵈ := is_coatomic_dual_iff_is_atomic.2 ‹is_atomic α›

instance {x : α} : is_atomic (set.Iic x) :=
⟨λ ⟨y, hy⟩, (eq_bot_or_exists_atom_le y).imp subtype.mk_eq_mk.2
  (λ ⟨a, ha, hay⟩, ⟨⟨a, hay.trans hy⟩, ha.Iic (hay.trans hy), hay⟩)⟩

end is_atomic

namespace is_coatomic

variables [order_top α] [is_coatomic α]

instance is_coatomic : is_atomic αᵒᵈ := is_atomic_dual_iff_is_coatomic.2 ‹is_coatomic α›

instance {x : α} : is_coatomic (set.Ici x) :=
⟨λ ⟨y, hy⟩, (eq_top_or_exists_le_coatom y).imp subtype.mk_eq_mk.2
  (λ ⟨a, ha, hay⟩, ⟨⟨a, le_trans hy hay⟩, ha.Ici (le_trans hy hay), hay⟩)⟩

end is_coatomic

theorem is_atomic_iff_forall_is_atomic_Iic [order_bot α] :
  is_atomic α ↔ ∀ (x : α), is_atomic (set.Iic x) :=
⟨@is_atomic.set.Iic.is_atomic _ _ _, λ h, ⟨λ x, ((@eq_bot_or_exists_atom_le _ _ _ (h x))
  (⊤ : set.Iic x)).imp subtype.mk_eq_mk.1 (exists_imp_exists' coe
  (λ ⟨a, ha⟩, and.imp_left (is_atom.of_is_atom_coe_Iic)))⟩⟩

theorem is_coatomic_iff_forall_is_coatomic_Ici [order_top α] :
  is_coatomic α ↔ ∀ (x : α), is_coatomic (set.Ici x) :=
is_atomic_dual_iff_is_coatomic.symm.trans $ is_atomic_iff_forall_is_atomic_Iic.trans $ forall_congr
  (λ x, is_coatomic_dual_iff_is_atomic.symm.trans iff.rfl)

section well_founded

lemma is_atomic_of_order_bot_well_founded_lt [order_bot α]
  (h : well_founded ((<) : α → α → Prop)) : is_atomic α :=
⟨λ a, or_iff_not_imp_left.2 $
  λ ha, let ⟨b, hb, hm⟩ := h.has_min { b | b ≠ ⊥ ∧ b ≤ a } ⟨a, ha, le_rfl⟩ in
  ⟨b, ⟨hb.1, λ c, not_imp_not.1 $ λ hc hl, hm c ⟨hc, hl.le.trans hb.2⟩ hl⟩, hb.2⟩⟩

lemma is_coatomic_of_order_top_gt_well_founded [order_top α]
  (h : well_founded ((>) : α → α → Prop)) : is_coatomic α :=
is_atomic_dual_iff_is_coatomic.1 (@is_atomic_of_order_bot_well_founded_lt αᵒᵈ _ _ h)

end well_founded

end atomic

section atomistic

variables (α) [complete_lattice α]

/-- A lattice is atomistic iff every element is a `Sup` of a set of atoms. -/
class is_atomistic : Prop :=
(eq_Sup_atoms : ∀ (b : α), ∃ (s : set α), b = Sup s ∧ ∀ a, a ∈ s → is_atom a)

/-- A lattice is coatomistic iff every element is an `Inf` of a set of coatoms. -/
class is_coatomistic : Prop :=
(eq_Inf_coatoms : ∀ (b : α), ∃ (s : set α), b = Inf s ∧ ∀ a, a ∈ s → is_coatom a)

export is_atomistic (eq_Sup_atoms) is_coatomistic (eq_Inf_coatoms)

variable {α}

@[simp]
theorem is_coatomistic_dual_iff_is_atomistic : is_coatomistic αᵒᵈ ↔ is_atomistic α :=
⟨λ h, ⟨λ b, by apply h.eq_Inf_coatoms⟩, λ h, ⟨λ b, by apply h.eq_Sup_atoms⟩⟩

@[simp]
theorem is_atomistic_dual_iff_is_coatomistic : is_atomistic αᵒᵈ ↔ is_coatomistic α :=
⟨λ h, ⟨λ b, by apply h.eq_Sup_atoms⟩, λ h, ⟨λ b, by apply h.eq_Inf_coatoms⟩⟩

namespace is_atomistic

instance is_coatomistic_dual [h : is_atomistic α] : is_coatomistic αᵒᵈ :=
is_coatomistic_dual_iff_is_atomistic.2 h

variable [is_atomistic α]

@[priority 100]
instance : is_atomic α :=
⟨λ b, by { rcases eq_Sup_atoms b with ⟨s, rfl, hs⟩,
  cases s.eq_empty_or_nonempty with h h,
  { simp [h] },
  { exact or.intro_right _ ⟨h.some, hs _ h.some_spec, le_Sup h.some_spec⟩ } } ⟩

end is_atomistic

section is_atomistic
variables [is_atomistic α]

@[simp]
theorem Sup_atoms_le_eq (b : α) : Sup {a : α | is_atom a ∧ a ≤ b} = b :=
begin
  rcases eq_Sup_atoms b with ⟨s, rfl, hs⟩,
  exact le_antisymm (Sup_le (λ _, and.right)) (Sup_le_Sup (λ a ha, ⟨hs a ha, le_Sup ha⟩)),
end

@[simp]
theorem Sup_atoms_eq_top : Sup {a : α | is_atom a} = ⊤ :=
begin
  refine eq.trans (congr rfl (set.ext (λ x, _))) (Sup_atoms_le_eq ⊤),
  exact (and_iff_left le_top).symm,
end

theorem le_iff_atom_le_imp {a b : α} :
  a ≤ b ↔ ∀ c : α, is_atom c → c ≤ a → c ≤ b :=
⟨λ ab c hc ca, le_trans ca ab, λ h, begin
  rw [← Sup_atoms_le_eq a, ← Sup_atoms_le_eq b],
  exact Sup_le_Sup (λ c hc, ⟨hc.1, h c hc.1 hc.2⟩),
end⟩

end is_atomistic

namespace is_coatomistic

instance is_atomistic_dual [h : is_coatomistic α] : is_atomistic αᵒᵈ :=
is_atomistic_dual_iff_is_coatomistic.2 h

variable [is_coatomistic α]

@[priority 100]
instance : is_coatomic α :=
⟨λ b, by { rcases eq_Inf_coatoms b with ⟨s, rfl, hs⟩,
  cases s.eq_empty_or_nonempty with h h,
  { simp [h] },
  { exact or.intro_right _ ⟨h.some, hs _ h.some_spec, Inf_le h.some_spec⟩ } } ⟩

end is_coatomistic
end atomistic

/-- An order is simple iff it has exactly two elements, `⊥` and `⊤`. -/
class is_simple_order (α : Type*) [has_le α] [bounded_order α] extends nontrivial α : Prop :=
(eq_bot_or_eq_top : ∀ (a : α), a = ⊥ ∨ a = ⊤)

export is_simple_order (eq_bot_or_eq_top)

theorem is_simple_order_iff_is_simple_order_order_dual [has_le α] [bounded_order α] :
  is_simple_order α ↔ is_simple_order αᵒᵈ :=
begin
  split; intro i; haveI := i,
  { exact { exists_pair_ne := @exists_pair_ne α _,
      eq_bot_or_eq_top := λ a, or.symm (eq_bot_or_eq_top ((order_dual.of_dual a)) : _ ∨ _) } },
  { exact { exists_pair_ne := @exists_pair_ne αᵒᵈ _,
      eq_bot_or_eq_top := λ a, or.symm (eq_bot_or_eq_top (order_dual.to_dual a)) } }
end

lemma is_simple_order.bot_ne_top [has_le α] [bounded_order α] [is_simple_order α] :
  (⊥ : α) ≠ (⊤ : α) :=
begin
  obtain ⟨a, b, h⟩ := exists_pair_ne α,
  rcases eq_bot_or_eq_top a with rfl|rfl;
  rcases eq_bot_or_eq_top b with rfl|rfl;
  simpa <|> simpa using h.symm
end

section is_simple_order

variables [partial_order α] [bounded_order α] [is_simple_order α]

instance {α} [has_le α] [bounded_order α] [is_simple_order α] : is_simple_order αᵒᵈ :=
is_simple_order_iff_is_simple_order_order_dual.1 (by apply_instance)

/-- A simple `bounded_order` induces a preorder. This is not an instance to prevent loops. -/
protected def is_simple_order.preorder {α} [has_le α] [bounded_order α] [is_simple_order α] :
  preorder α :=
{ le := (≤),
  le_refl := λ a, by rcases eq_bot_or_eq_top a with rfl|rfl; simp,
  le_trans := λ a b c, begin
    rcases eq_bot_or_eq_top a with rfl|rfl,
    { simp },
    { rcases eq_bot_or_eq_top b with rfl|rfl,
      { rcases eq_bot_or_eq_top c with rfl|rfl; simp },
      { simp } }
  end }

/-- A simple partial ordered `bounded_order` induces a linear order.
This is not an instance to prevent loops. -/
protected def is_simple_order.linear_order [decidable_eq α] : linear_order α :=
{ le_total := λ a b, by rcases eq_bot_or_eq_top a with rfl|rfl; simp,
  decidable_le := λ a b, if ha : a = ⊥ then is_true (ha.le.trans bot_le) else
    if hb : b = ⊤ then is_true (le_top.trans hb.ge) else
      is_false (λ H, hb (top_unique
        (le_trans (top_le_iff.mpr (or.resolve_left (eq_bot_or_eq_top a) ha)) H))),
  decidable_eq := by assumption,
  ..(infer_instance : partial_order α) }

@[simp] lemma is_atom_top : is_atom (⊤ : α) :=
⟨top_ne_bot, λ a ha, or.resolve_right (eq_bot_or_eq_top a) (ne_of_lt ha)⟩

@[simp] lemma is_coatom_bot : is_coatom (⊥ : α) := is_atom_dual_iff_is_coatom.1 is_atom_top

lemma bot_covby_top : (⊥ : α) ⋖ ⊤ := is_atom_top.bot_covby

end is_simple_order

namespace is_simple_order
section preorder
variables [preorder α] [bounded_order α] [is_simple_order α] {a b : α} (h : a < b)

lemma eq_bot_of_lt : a = ⊥ := (is_simple_order.eq_bot_or_eq_top _).resolve_right h.ne_top
lemma eq_top_of_lt : b = ⊤ := (is_simple_order.eq_bot_or_eq_top _).resolve_left h.ne_bot

alias eq_bot_of_lt ← has_lt.lt.eq_bot
alias eq_top_of_lt ← has_lt.lt.eq_top

end preorder

section bounded_order

variables [lattice α] [bounded_order α] [is_simple_order α]

/-- A simple partial ordered `bounded_order` induces a lattice.
This is not an instance to prevent loops -/
protected def lattice {α} [decidable_eq α] [partial_order α] [bounded_order α]
  [is_simple_order α] : lattice α :=
@linear_order.to_lattice α (is_simple_order.linear_order)

/-- A lattice that is a `bounded_order` is a distributive lattice.
This is not an instance to prevent loops -/
protected def distrib_lattice : distrib_lattice α :=
{ le_sup_inf := λ x y z, by { rcases eq_bot_or_eq_top x with rfl | rfl; simp },
  .. (infer_instance : lattice α) }

@[priority 100] -- see Note [lower instance priority]
instance : is_atomic α :=
⟨λ b, (eq_bot_or_eq_top b).imp_right (λ h, ⟨⊤, ⟨is_atom_top, ge_of_eq h⟩⟩)⟩

@[priority 100] -- see Note [lower instance priority]
instance : is_coatomic α := is_atomic_dual_iff_is_coatomic.1 is_simple_order.is_atomic

end bounded_order

/- It is important that in this section `is_simple_order` is the last type-class argument. -/
section decidable_eq

variables [decidable_eq α] [partial_order α] [bounded_order α] [is_simple_order α]

/-- Every simple lattice is isomorphic to `bool`, regardless of order. -/
@[simps] def equiv_bool {α} [decidable_eq α] [has_le α] [bounded_order α] [is_simple_order α] :
  α ≃ bool :=
{ to_fun := λ x, x = ⊤,
  inv_fun := λ x, cond x ⊤ ⊥,
  left_inv := λ x, by { rcases (eq_bot_or_eq_top x) with rfl | rfl; simp [bot_ne_top] },
  right_inv := λ x, by { cases x; simp [bot_ne_top] } }

/-- Every simple lattice over a partial order is order-isomorphic to `bool`. -/
def order_iso_bool : α ≃o bool :=
{ map_rel_iff' := λ a b, begin
    rcases (eq_bot_or_eq_top a) with rfl | rfl,
    { simp [bot_ne_top] },
    { rcases (eq_bot_or_eq_top b) with rfl | rfl,
      { simp [bot_ne_top.symm, bot_ne_top, bool.ff_lt_tt] },
      { simp [bot_ne_top] } }
  end,
  ..equiv_bool }

/-- A simple `bounded_order` is also a `boolean_algebra`. -/
protected def boolean_algebra {α} [decidable_eq α] [lattice α] [bounded_order α]
  [is_simple_order α] : boolean_algebra α :=
{ compl := λ x, if x = ⊥ then ⊤ else ⊥,
  sdiff := λ x y, if x = ⊤ ∧ y = ⊥ then ⊤ else ⊥,
  sdiff_eq := λ x y, by rcases eq_bot_or_eq_top x with rfl | rfl;
      simp [bot_ne_top, has_sdiff.sdiff, compl],
  inf_compl_le_bot := λ x, begin
      rcases eq_bot_or_eq_top x with rfl | rfl,
      { simp },
      { simp only [top_inf_eq],
        split_ifs with h h;
        simp [h] }
    end,
  top_le_sup_compl := λ x, by rcases eq_bot_or_eq_top x with rfl | rfl; simp,
  .. (show bounded_order α, by apply_instance),
  .. is_simple_order.distrib_lattice }

end decidable_eq

variables [lattice α] [bounded_order α] [is_simple_order α]
open_locale classical

/-- A simple `bounded_order` is also complete. -/
protected noncomputable def complete_lattice : complete_lattice α :=
{ Sup := λ s, if ⊤ ∈ s then ⊤ else ⊥,
  Inf := λ s, if ⊥ ∈ s then ⊥ else ⊤,
  le_Sup := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { exact bot_le },
    { rw if_pos h } },
  Sup_le := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { rw if_neg,
      intro con,
      exact bot_ne_top (eq_top_iff.2 (h ⊤ con)) },
    { exact le_top } },
  Inf_le := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { rw if_pos h },
    { exact le_top } },
  le_Inf := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { exact bot_le },
    { rw if_neg,
      intro con,
      exact top_ne_bot (eq_bot_iff.2 (h ⊥ con)) } },
  .. (infer_instance : lattice α),
  .. (infer_instance : bounded_order α) }

/-- A simple `bounded_order` is also a `complete_boolean_algebra`. -/
protected noncomputable def complete_boolean_algebra : complete_boolean_algebra α :=
{ infi_sup_le_sup_Inf := λ x s, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { simp only [bot_sup_eq, ← Inf_eq_infi], exact le_rfl },
    { simp only [top_sup_eq, le_top] }, },
  inf_Sup_le_supr_inf := λ x s, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { simp only [bot_inf_eq, bot_le] },
    { simp only [top_inf_eq, ← Sup_eq_supr], exact le_rfl } },
  .. is_simple_order.complete_lattice,
  .. is_simple_order.boolean_algebra }

end is_simple_order

namespace is_simple_order
variables [complete_lattice α] [is_simple_order α]
set_option default_priority 100

instance : is_atomistic α :=
⟨λ b, (eq_bot_or_eq_top b).elim
  (λ h, ⟨∅, ⟨h.trans Sup_empty.symm, λ a ha, false.elim (set.not_mem_empty _ ha)⟩⟩)
  (λ h, ⟨{⊤}, h.trans Sup_singleton.symm, λ a ha, (set.mem_singleton_iff.1 ha).symm ▸ is_atom_top⟩)⟩

instance : is_coatomistic α := is_atomistic_dual_iff_is_coatomistic.1 is_simple_order.is_atomistic

end is_simple_order

theorem is_simple_order_iff_is_atom_top [partial_order α] [bounded_order α] :
  is_simple_order α ↔ is_atom (⊤ : α) :=
⟨λ h, @is_atom_top _ _ _ h, λ h,
  { exists_pair_ne := ⟨⊤, ⊥, h.1⟩,
    eq_bot_or_eq_top := λ a, ((eq_or_lt_of_le le_top).imp_right (h.2 a)).symm }⟩

theorem is_simple_order_iff_is_coatom_bot [partial_order α] [bounded_order α] :
  is_simple_order α ↔ is_coatom (⊥ : α) :=
is_simple_order_iff_is_simple_order_order_dual.trans is_simple_order_iff_is_atom_top

namespace set

theorem is_simple_order_Iic_iff_is_atom [partial_order α] [order_bot α] {a : α} :
  is_simple_order (Iic a) ↔ is_atom a :=
is_simple_order_iff_is_atom_top.trans $ and_congr (not_congr subtype.mk_eq_mk)
  ⟨λ h b ab, subtype.mk_eq_mk.1 (h ⟨b, le_of_lt ab⟩ ab),
    λ h ⟨b, hab⟩ hbotb, subtype.mk_eq_mk.2 (h b (subtype.mk_lt_mk.1 hbotb))⟩

theorem is_simple_order_Ici_iff_is_coatom [partial_order α] [order_top α] {a : α} :
  is_simple_order (Ici a) ↔ is_coatom a :=
is_simple_order_iff_is_coatom_bot.trans $ and_congr (not_congr subtype.mk_eq_mk)
  ⟨λ h b ab, subtype.mk_eq_mk.1 (h ⟨b, le_of_lt ab⟩ ab),
    λ h ⟨b, hab⟩ hbotb, subtype.mk_eq_mk.2 (h b (subtype.mk_lt_mk.1 hbotb))⟩

end set

namespace order_embedding

variables [partial_order α] [partial_order β]

lemma is_atom_of_map_bot_of_image [order_bot α] [order_bot β] (f : β ↪o α) (hbot : f ⊥ = ⊥) {b : β}
  (hb : is_atom (f b)) : is_atom b :=
by { simp only [←bot_covby_iff] at hb ⊢, exact covby.of_image f (hbot.symm ▸ hb) }

lemma is_coatom_of_map_top_of_image [order_top α] [order_top β] (f : β ↪o α) (htop : f ⊤ = ⊤)
  {b : β} (hb : is_coatom (f b)) : is_coatom b :=
f.dual.is_atom_of_map_bot_of_image htop hb

end order_embedding

namespace galois_insertion

variables [partial_order α] [partial_order β]

lemma is_atom_of_u_bot [order_bot α] [order_bot β] {l : α → β} {u : β → α}
  (gi : galois_insertion l u) (hbot : u ⊥ = ⊥) {b : β} (hb : is_atom (u b)) : is_atom b :=
order_embedding.is_atom_of_map_bot_of_image
  ⟨⟨u, gi.u_injective⟩, @galois_insertion.u_le_u_iff _ _ _ _ _ _ gi⟩ hbot hb

lemma is_atom_iff [order_bot α] [is_atomic α] [order_bot β] {l : α → β} {u : β → α}
  (gi : galois_insertion l u) (hbot : u ⊥ = ⊥) (h_atom : ∀ a, is_atom a → u (l a) = a) (a : α) :
  is_atom (l a) ↔ is_atom a :=
begin
  refine ⟨λ hla, _, λ ha, gi.is_atom_of_u_bot hbot ((h_atom a ha).symm ▸ ha)⟩,
  obtain ⟨a', ha', hab'⟩ := (eq_bot_or_exists_atom_le (u (l a))).resolve_left
    (hbot ▸ λ h, hla.1 (gi.u_injective h)),
  have := (hla.le_iff.mp $ (gi.l_u_eq (l a) ▸ gi.gc.monotone_l hab' : l a' ≤ l a)).resolve_left
    (λ h, ha'.1 (hbot ▸ (h_atom a' ha') ▸ congr_arg u h)),
  have haa' : a = a' := (ha'.le_iff.mp $
    (gi.gc.le_u_l a).trans_eq (h_atom a' ha' ▸ congr_arg u this.symm)).resolve_left
    (mt (congr_arg l) (gi.gc.l_bot.symm ▸ hla.1)),
  exact haa'.symm ▸ ha'
end

lemma is_atom_iff' [order_bot α] [is_atomic α] [order_bot β] {l : α → β} {u : β → α}
  (gi : galois_insertion l u) (hbot : u ⊥ = ⊥) (h_atom : ∀ a, is_atom a → u (l a) = a) (b : β) :
  is_atom (u b) ↔ is_atom b :=
by rw [←gi.is_atom_iff hbot h_atom, gi.l_u_eq]

lemma is_coatom_iff [order_top α] [is_coatomic α] [order_top β] {l : α → β} {u : β → α}
  (gi : galois_insertion l u) (h_coatom : ∀ a : α, is_coatom a → u (l a) = a) (b : β) :
  is_coatom (u b) ↔ is_coatom b :=
begin
  refine ⟨λ hb, gi.is_coatom_of_image hb, λ hb, _⟩,
  obtain ⟨a, ha, hab⟩ := (eq_top_or_exists_le_coatom (u b)).resolve_left
    (λ h, hb.1 $ (gi.gc.u_top ▸ gi.l_u_eq ⊤ : l ⊤ = ⊤) ▸ gi.l_u_eq b ▸ congr_arg l h),
  have : l a = b := (hb.le_iff.mp ((gi.l_u_eq b ▸ gi.gc.monotone_l hab) : b ≤ l a)).resolve_left
    (λ hla, ha.1 (gi.gc.u_top ▸ h_coatom a ha ▸ congr_arg u hla)),
  exact this ▸ (h_coatom a ha).symm ▸ ha,
end

end galois_insertion

namespace galois_coinsertion

variables [partial_order α] [partial_order β]

lemma is_coatom_of_l_top [order_top α] [order_top β] {l : α → β} {u : β → α}
  (gi : galois_coinsertion l u) (hbot : l ⊤ = ⊤) {a : α} (hb : is_coatom (l a)) : is_coatom a :=
gi.dual.is_atom_of_u_bot hbot hb.dual

lemma is_coatom_iff [order_top α] [order_top β] [is_coatomic β] {l : α → β} {u : β → α}
  (gi : galois_coinsertion l u) (htop : l ⊤ = ⊤) (h_coatom : ∀ b, is_coatom b → l (u b) = b)
  (b : β) : is_coatom (u b) ↔ is_coatom b :=
gi.dual.is_atom_iff htop h_coatom b

lemma is_coatom_iff' [order_top α] [order_top β] [is_coatomic β] {l : α → β} {u : β → α}
  (gi : galois_coinsertion l u) (htop : l ⊤ = ⊤) (h_coatom : ∀ b, is_coatom b → l (u b) = b)
  (a : α) : is_coatom (l a) ↔ is_coatom a :=
gi.dual.is_atom_iff' htop h_coatom a

lemma is_atom_of_image [order_bot α] [order_bot β] {l : α → β} {u : β → α}
  (gi : galois_coinsertion l u) {a : α} (hb : is_atom (l a)) : is_atom a :=
gi.dual.is_coatom_of_image hb.dual

lemma is_atom_iff [order_bot α] [order_bot β] [is_atomic β] {l : α → β} {u : β → α}
  (gi : galois_coinsertion l u) (h_atom : ∀ b, is_atom b → l (u b) = b) (a : α) :
  is_atom (l a) ↔ is_atom a :=
gi.dual.is_coatom_iff h_atom a

end galois_coinsertion

namespace order_iso

variables [partial_order α] [partial_order β]

@[simp] lemma is_atom_iff [order_bot α] [order_bot β] (f : α ≃o β) (a : α) :
  is_atom (f a) ↔ is_atom a :=
⟨f.to_galois_coinsertion.is_atom_of_image,
 λ ha, f.to_galois_insertion.is_atom_of_u_bot (map_bot f.symm) $ (f.symm_apply_apply a).symm ▸ ha⟩

@[simp] lemma is_coatom_iff [order_top α] [order_top β] (f : α ≃o β) (a : α) :
  is_coatom (f a) ↔ is_coatom a :=
f.dual.is_atom_iff a

lemma is_simple_order_iff [bounded_order α] [bounded_order β] (f : α ≃o β) :
  is_simple_order α ↔ is_simple_order β :=
by rw [is_simple_order_iff_is_atom_top, is_simple_order_iff_is_atom_top,
  ← f.is_atom_iff ⊤, f.map_top]

lemma is_simple_order [bounded_order α] [bounded_order β] [h : is_simple_order β] (f : α ≃o β) :
  is_simple_order α :=
f.is_simple_order_iff.mpr h

protected lemma is_atomic_iff [order_bot α] [order_bot β] (f : α ≃o β) :
  is_atomic α ↔ is_atomic β :=
by simp only [is_atomic_iff, f.surjective.forall, f.surjective.exists, ← map_bot f, f.eq_iff_eq,
  f.le_iff_le, f.is_atom_iff]

protected lemma is_coatomic_iff [order_top α] [order_top β] (f : α ≃o β) :
  is_coatomic α ↔ is_coatomic β :=
by simp only [← is_atomic_dual_iff_is_coatomic, f.dual.is_atomic_iff]

end order_iso

section is_modular_lattice
variables [lattice α] [bounded_order α] [is_modular_lattice α]

namespace is_compl
variables {a b : α} (hc : is_compl a b)
include hc

lemma is_atom_iff_is_coatom : is_atom a ↔ is_coatom b :=
set.is_simple_order_Iic_iff_is_atom.symm.trans $ hc.Iic_order_iso_Ici.is_simple_order_iff.trans
  set.is_simple_order_Ici_iff_is_coatom

lemma is_coatom_iff_is_atom : is_coatom a ↔ is_atom b := hc.symm.is_atom_iff_is_coatom.symm

end is_compl

variables [complemented_lattice α]

lemma is_coatomic_of_is_atomic_of_complemented_lattice_of_is_modular [is_atomic α] :
  is_coatomic α :=
⟨λ x, begin
  rcases exists_is_compl x with ⟨y, xy⟩,
  apply (eq_bot_or_exists_atom_le y).imp _ _,
  { rintro rfl,
    exact eq_top_of_is_compl_bot xy },
  { rintro ⟨a, ha, ay⟩,
    rcases exists_is_compl (xy.symm.Iic_order_iso_Ici ⟨a, ay⟩) with ⟨⟨b, xb⟩, hb⟩,
    refine ⟨↑(⟨b, xb⟩ : set.Ici x), is_coatom.of_is_coatom_coe_Ici _, xb⟩,
    rw [← hb.is_atom_iff_is_coatom, order_iso.is_atom_iff],
    apply ha.Iic }
end⟩

lemma is_atomic_of_is_coatomic_of_complemented_lattice_of_is_modular [is_coatomic α] :
  is_atomic α :=
is_coatomic_dual_iff_is_atomic.1 is_coatomic_of_is_atomic_of_complemented_lattice_of_is_modular

theorem is_atomic_iff_is_coatomic : is_atomic α ↔ is_coatomic α :=
⟨λ h, @is_coatomic_of_is_atomic_of_complemented_lattice_of_is_modular _ _ _ _ _ h,
  λ h, @is_atomic_of_is_coatomic_of_complemented_lattice_of_is_modular _ _ _ _ _ h⟩

end is_modular_lattice

namespace set

lemma is_atom_singleton (x : α) : is_atom ({x} : set α) :=
⟨singleton_ne_empty _, λ s hs, ssubset_singleton_iff.mp hs⟩

lemma is_atom_iff (s : set α) : is_atom s ↔ ∃ x, s = {x} :=
begin
  refine ⟨_, by { rintro ⟨x, rfl⟩, exact is_atom_singleton x }⟩,
  rw [is_atom_iff, bot_eq_empty, ←nonempty_iff_ne_empty],
  rintro ⟨⟨x, hx⟩, hs⟩,
  exact ⟨x, eq_singleton_iff_unique_mem.2 ⟨hx, λ y hy,
    (hs {y} (singleton_ne_empty _) (singleton_subset_iff.2 hy) hx).symm⟩⟩,
end

lemma is_coatom_iff (s : set α) : is_coatom s ↔ ∃ x, s = {x}ᶜ :=
by simp_rw [is_compl_compl.is_coatom_iff_is_atom, is_atom_iff, @eq_comm _ s, compl_eq_comm]

lemma is_coatom_singleton_compl (x : α) : is_coatom ({x}ᶜ : set α) :=
(is_coatom_iff {x}ᶜ).mpr ⟨x, rfl⟩

instance : is_atomistic (set α) :=
{ eq_Sup_atoms := λ s, ⟨(λ x, {x}) '' s,
    by rw [Sup_eq_sUnion, sUnion_image, bUnion_of_singleton],
    by { rintro - ⟨x, hx, rfl⟩, exact is_atom_singleton x }⟩ }

instance : is_coatomistic (set α) :=
{ eq_Inf_coatoms := λ s, ⟨(λ x, {x}ᶜ) '' sᶜ,
    by rw [Inf_eq_sInter, sInter_image, ←compl_Union₂, bUnion_of_singleton, compl_compl],
    by { rintro - ⟨x, hx, rfl⟩, exact is_coatom_singleton_compl x }⟩ }

end set


/- Spatial Reasoning Problem 01 -/
/- It can be found at: SpatialQs.txt -/

/- (1) A is on the right of B. C is on the left of B. Hence, A is on the right of C -/

constant U : Type

constants A B C : U
constants Left Right : U
constant orientation : U → U → U → Prop

axiom a1 : orientation A B Right
axiom a2 : orientation C B Left

/- axioms to be added to SUMO -/
axiom a3 : ∀ X Y Z R, (orientation X Y R) ∧ (orientation Y Z R) → (orientation X Z R)
axiom a4 : ∀ OBJ1 OBJ2, (orientation OBJ1 OBJ2 Right) ↔ (orientation OBJ2 OBJ1 Left)

/- Demonstration Start -/
theorem A_is_on_the_right_of_C : orientation A C Right :=
begin
    have h, from (a4 _ _).elim_right a2,
    apply a3 _ _ _ _,
    apply and.intro a1 h
end


/-
Copyright (c) 2021 Thomas Browning. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning
-/

import group_theory.quotient_group
import set_theory.cardinal.finite

/-!
# Index of a Subgroup

In this file we define the index of a subgroup, and prove several divisibility properties.
Several theorems proved in this file are known as Lagrange's theorem.

## Main definitions

- `H.index` : the index of `H : subgroup G` as a natural number,
  and returns 0 if the index is infinite.
- `H.relindex K` : the relative index of `H : subgroup G` in `K : subgroup G` as a natural number,
  and returns 0 if the relative index is infinite.

# Main results

- `card_mul_index` : `nat.card H * H.index = nat.card G`
- `index_mul_card` : `H.index * fintype.card H = fintype.card G`
- `index_dvd_card` : `H.index ∣ fintype.card G`
- `index_eq_mul_of_le` : If `H ≤ K`, then `H.index = K.index * (H.subgroup_of K).index`
- `index_dvd_of_le` : If `H ≤ K`, then `K.index ∣ H.index`
- `relindex_mul_relindex` : `relindex` is multiplicative in towers

-/

namespace subgroup

open_locale cardinal

variables {G : Type*} [group G] (H K L : subgroup G)

/-- The index of a subgroup as a natural number, and returns 0 if the index is infinite. -/
@[to_additive "The index of a subgroup as a natural number,
and returns 0 if the index is infinite."]
noncomputable def index : ℕ :=
nat.card (G ⧸ H)

/-- The relative index of a subgroup as a natural number,
  and returns 0 if the relative index is infinite. -/
@[to_additive "The relative index of a subgroup as a natural number,
  and returns 0 if the relative index is infinite."]
noncomputable def relindex : ℕ :=
(H.subgroup_of K).index

@[to_additive] lemma index_comap_of_surjective {G' : Type*} [group G'] {f : G' →* G}
  (hf : function.surjective f) : (H.comap f).index = H.index :=
begin
  letI := quotient_group.left_rel H,
  letI := quotient_group.left_rel (H.comap f),
  have key : ∀ x y : G', setoid.r x y ↔ setoid.r (f x) (f y),
  { simp only [quotient_group.left_rel_apply],
    exact λ x y, iff_of_eq (congr_arg (∈ H) (by rw [f.map_mul, f.map_inv])) },
  refine cardinal.to_nat_congr (equiv.of_bijective (quotient.map' f (λ x y, (key x y).mp)) ⟨_, _⟩),
  { simp_rw [←quotient.eq'] at key,
    refine quotient.ind' (λ x, _),
    refine quotient.ind' (λ y, _),
    exact (key x y).mpr },
  { refine quotient.ind' (λ x, _),
    obtain ⟨y, hy⟩ := hf x,
    exact ⟨y, (quotient.map'_mk' f _ y).trans (congr_arg quotient.mk' hy)⟩ },
end

@[to_additive] lemma index_comap {G' : Type*} [group G'] (f : G' →* G) :
  (H.comap f).index = H.relindex f.range :=
eq.trans (congr_arg index (by refl))
  ((H.subgroup_of f.range).index_comap_of_surjective f.range_restrict_surjective)

variables {H K L}

@[to_additive relindex_mul_index] lemma relindex_mul_index (h : H ≤ K) :
  H.relindex K * K.index = H.index :=
((mul_comm _ _).trans (cardinal.to_nat_mul _ _).symm).trans
  (congr_arg cardinal.to_nat (equiv.cardinal_eq (quotient_equiv_prod_of_le h))).symm

@[to_additive] lemma index_dvd_of_le (h : H ≤ K) : K.index ∣ H.index :=
dvd_of_mul_left_eq (H.relindex K) (relindex_mul_index h)

@[to_additive] lemma relindex_dvd_index_of_le (h : H ≤ K) : H.relindex K ∣ H.index :=
dvd_of_mul_right_eq K.index (relindex_mul_index h)

@[to_additive] lemma relindex_subgroup_of (hKL : K ≤ L) :
  (H.subgroup_of L).relindex (K.subgroup_of L) = H.relindex K :=
((index_comap (H.subgroup_of L) (inclusion hKL)).trans (congr_arg _ (inclusion_range hKL))).symm

variables (H K L)

@[to_additive relindex_mul_relindex] lemma relindex_mul_relindex (hHK : H ≤ K) (hKL : K ≤ L) :
  H.relindex K * K.relindex L = H.relindex L :=
begin
  rw [←relindex_subgroup_of hKL],
  exact relindex_mul_index (λ x hx, hHK hx),
end

@[to_additive] lemma inf_relindex_right : (H ⊓ K).relindex K = H.relindex K :=
begin
  rw [←subgroup_of_map_subtype, relindex, relindex, subgroup_of, comap_map_eq_self_of_injective],
  exact subtype.coe_injective,
end

@[to_additive] lemma inf_relindex_left : (H ⊓ K).relindex H = K.relindex H :=
by rw [inf_comm, inf_relindex_right]

@[to_additive relindex_inf_mul_relindex]
lemma relindex_inf_mul_relindex : H.relindex (K ⊓ L) * K.relindex L = (H ⊓ K).relindex L :=
by rw [←inf_relindex_right H (K ⊓ L), ←inf_relindex_right K L, ←inf_relindex_right (H ⊓ K) L,
  inf_assoc, relindex_mul_relindex (H ⊓ (K ⊓ L)) (K ⊓ L) L inf_le_right inf_le_right]

@[to_additive]
lemma inf_relindex_eq_relindex_sup [K.normal] : (H ⊓ K).relindex H = K.relindex (H ⊔ K) :=
cardinal.to_nat_congr (quotient_group.quotient_inf_equiv_prod_normal_quotient H K).to_equiv

@[to_additive] lemma relindex_eq_relindex_sup [K.normal] : K.relindex H = K.relindex (H ⊔ K) :=
by rw [←inf_relindex_left, inf_relindex_eq_relindex_sup]

@[to_additive] lemma relindex_dvd_index_of_normal [H.normal] : H.relindex K ∣ H.index :=
(relindex_eq_relindex_sup K H).symm ▸ relindex_dvd_index_of_le le_sup_right

variables {H K}

@[to_additive] lemma relindex_dvd_of_le_left (hHK : H ≤ K) : K.relindex L ∣ H.relindex L :=
begin
  apply dvd_of_mul_left_eq ((H ⊓ L).relindex (K ⊓ L)),
  rw [←inf_relindex_right H L, ←inf_relindex_right K L],
  exact relindex_mul_relindex (H ⊓ L) (K ⊓ L) L (inf_le_inf_right L hHK) inf_le_right,
end

variables (H K)

@[simp, to_additive] lemma index_top : (⊤ : subgroup G).index = 1 :=
cardinal.to_nat_eq_one_iff_unique.mpr ⟨quotient_group.subsingleton_quotient_top, ⟨1⟩⟩

@[simp, to_additive] lemma index_bot : (⊥ : subgroup G).index = nat.card G :=
cardinal.to_nat_congr (quotient_group.quotient_bot.to_equiv)

@[to_additive] lemma index_bot_eq_card [fintype G] : (⊥ : subgroup G).index = fintype.card G :=
index_bot.trans nat.card_eq_fintype_card

@[simp, to_additive] lemma relindex_top_left : (⊤ : subgroup G).relindex H = 1 :=
index_top

@[simp, to_additive] lemma relindex_top_right : H.relindex ⊤ = H.index :=
by rw [←relindex_mul_index (show H ≤ ⊤, from le_top), index_top, mul_one]

@[simp, to_additive] lemma relindex_bot_left : (⊥ : subgroup G).relindex H = nat.card H :=
by rw [relindex, bot_subgroup_of, index_bot]

@[to_additive] lemma relindex_bot_left_eq_card [fintype H] :
  (⊥ : subgroup G).relindex H = fintype.card H :=
H.relindex_bot_left.trans nat.card_eq_fintype_card

@[simp, to_additive] lemma relindex_bot_right : H.relindex ⊥ = 1 :=
by rw [relindex, subgroup_of_bot_eq_top, index_top]

@[simp, to_additive] lemma relindex_self : H.relindex H = 1 :=
by rw [relindex, subgroup_of_self, index_top]

@[simp, to_additive card_mul_index]
lemma card_mul_index : nat.card H * H.index = nat.card G :=
by { rw [←relindex_bot_left, ←index_bot], exact relindex_mul_index bot_le }

@[to_additive] lemma index_map {G' : Type*} [group G'] (f : G →* G') :
  (H.map f).index = (H ⊔ f.ker).index * f.range.index :=
by rw [←comap_map_eq, index_comap, relindex_mul_index (H.map_le_range f)]

@[to_additive] lemma index_map_dvd {G' : Type*} [group G'] {f : G →* G'}
  (hf : function.surjective f) : (H.map f).index ∣ H.index :=
begin
  rw [index_map, f.range_top_of_surjective hf, index_top, mul_one],
  exact index_dvd_of_le le_sup_left,
end

@[to_additive] lemma dvd_index_map {G' : Type*} [group G'] {f : G →* G'}
  (hf : f.ker ≤ H) : H.index ∣ (H.map f).index :=
begin
  rw [index_map, sup_of_le_left hf],
  apply dvd_mul_right,
end

@[to_additive] lemma index_map_eq {G' : Type*} [group G'] {f : G →* G'}
  (hf1 : function.surjective f) (hf2 : f.ker ≤ H) : (H.map f).index = H.index :=
nat.dvd_antisymm (H.index_map_dvd hf1) (H.dvd_index_map hf2)

@[to_additive] lemma index_eq_card [fintype (G ⧸ H)] :
  H.index = fintype.card (G ⧸ H) :=
nat.card_eq_fintype_card

@[to_additive index_mul_card] lemma index_mul_card [fintype G] [hH : fintype H] :
  H.index * fintype.card H = fintype.card G :=
by rw [←relindex_bot_left_eq_card, ←index_bot_eq_card, mul_comm]; exact relindex_mul_index bot_le

@[to_additive] lemma index_dvd_card [fintype G] : H.index ∣ fintype.card G :=
begin
  classical,
  exact ⟨fintype.card H, H.index_mul_card.symm⟩,
end

variables {H K L}

@[to_additive]
lemma relindex_eq_zero_of_le_left (hHK : H ≤ K) (hKL : K.relindex L = 0) : H.relindex L = 0 :=
eq_zero_of_zero_dvd (hKL ▸ (relindex_dvd_of_le_left L hHK))

@[to_additive]
lemma relindex_eq_zero_of_le_right (hKL : K ≤ L) (hHK : H.relindex K = 0) : H.relindex L = 0 :=
cardinal.to_nat_apply_of_aleph_0_le (le_trans (le_of_not_lt (λ h, cardinal.mk_ne_zero _
  ((cardinal.cast_to_nat_of_lt_aleph_0 h).symm.trans (cardinal.nat_cast_inj.mpr hHK))))
    (quotient_subgroup_of_embedding_of_le H hKL).cardinal_le)

@[to_additive] lemma relindex_le_of_le_left (hHK : H ≤ K) (hHL : H.relindex L ≠ 0) :
  K.relindex L ≤ H.relindex L :=
nat.le_of_dvd (nat.pos_of_ne_zero hHL) (relindex_dvd_of_le_left L hHK)

@[to_additive] lemma relindex_le_of_le_right (hKL : K ≤ L) (hHL : H.relindex L ≠ 0) :
  H.relindex K ≤ H.relindex L :=
cardinal.to_nat_le_of_le_of_lt_aleph_0 (lt_of_not_ge (mt cardinal.to_nat_apply_of_aleph_0_le hHL))
  (cardinal.mk_le_of_injective (quotient_subgroup_of_embedding_of_le H hKL).2)

@[to_additive] lemma relindex_ne_zero_trans (hHK : H.relindex K ≠ 0) (hKL : K.relindex L ≠ 0) :
  H.relindex L ≠ 0 :=
λ h, mul_ne_zero (mt (relindex_eq_zero_of_le_right (show K ⊓ L ≤ K, from inf_le_left)) hHK) hKL
  ((relindex_inf_mul_relindex H K L).trans (relindex_eq_zero_of_le_left inf_le_left h))

@[to_additive] lemma relindex_inf_ne_zero (hH : H.relindex L ≠ 0) (hK : K.relindex L ≠ 0) :
  (H ⊓ K).relindex L ≠ 0 :=
begin
  replace hH : H.relindex (K ⊓ L) ≠ 0 := mt (relindex_eq_zero_of_le_right inf_le_right) hH,
  rw ← inf_relindex_right at hH hK ⊢,
  rw inf_assoc,
  exact relindex_ne_zero_trans hH hK,
end

@[to_additive] lemma index_inf_ne_zero (hH : H.index ≠ 0) (hK : K.index ≠ 0) : (H ⊓ K).index ≠ 0 :=
begin
  rw ← relindex_top_right at hH hK ⊢,
  exact relindex_inf_ne_zero hH hK,
end

@[to_additive] lemma relindex_inf_le : (H ⊓ K).relindex L ≤ H.relindex L * K.relindex L :=
begin
  by_cases h : H.relindex L = 0,
  { exact (le_of_eq (relindex_eq_zero_of_le_left (by exact inf_le_left) h)).trans (zero_le _) },
  rw [←inf_relindex_right, inf_assoc, ←relindex_mul_relindex _ _ L inf_le_right inf_le_right,
      inf_relindex_right, inf_relindex_right],
  exact mul_le_mul_right' (relindex_le_of_le_right inf_le_right h) (K.relindex L),
end

@[to_additive] lemma index_inf_le : (H ⊓ K).index ≤ H.index * K.index :=
by simp_rw [←relindex_top_right, relindex_inf_le]

@[simp, to_additive index_eq_one] lemma index_eq_one : H.index = 1 ↔ H = ⊤ :=
⟨λ h, quotient_group.subgroup_eq_top_of_subsingleton H (cardinal.to_nat_eq_one_iff_unique.mp h).1,
  λ h, (congr_arg index h).trans index_top⟩

@[to_additive] lemma index_ne_zero_of_fintype [hH : fintype (G ⧸ H)] : H.index ≠ 0 :=
by { rw index_eq_card, exact fintype.card_ne_zero }

/-- Finite index implies finite quotient. -/
@[to_additive "Finite index implies finite quotient."]
noncomputable def fintype_of_index_ne_zero (hH : H.index ≠ 0) : fintype (G ⧸ H) :=
(cardinal.lt_aleph_0_iff_fintype.mp (lt_of_not_ge (mt cardinal.to_nat_apply_of_aleph_0_le hH))).some

@[to_additive one_lt_index_of_ne_top]
lemma one_lt_index_of_ne_top [fintype (G ⧸ H)] (hH : H ≠ ⊤) : 1 < H.index :=
nat.one_lt_iff_ne_zero_and_ne_one.mpr ⟨index_ne_zero_of_fintype, mt index_eq_one.mp hH⟩

end subgroup


universe u

namespace one
  /-
  As an exercise, we encourage you to use do_twice and double to
  define functions that quadruple their input,
  and multiply the input by 8.
  As a further exercise, we encourage you to try defining a
  function Do_Twice : ((ℕ → ℕ) → (ℕ → ℕ)) → (ℕ → ℕ) → (ℕ → ℕ)
  which applies its argument twice, so that Do_Twice do_twice
  is a function that applies its input four times.
  Then evaluate Do_Twice do_twice double 2.
  -/

  -- reference code from section 2.4
  def double : ℕ → ℕ := λ x, x + x
  def square : ℕ → ℕ := λ x, x * x
  def do_twice : (ℕ → ℕ) → ℕ → ℕ := λ f x, f (f x)
  def compose (α β γ : Type) (g : β → γ) (f : α → β) (x : α) : γ := g (f x)

  -- solution
  def Do_Twice {α :Type} (f: (α → α) → (α → α)) (g: α → α) (x: α) := f g x
  #reduce @Do_Twice ℕ do_twice double 2
  #reduce Do_Twice do_twice double 2
end one

namespace two
  /-
  Above, we discussed the process of “currying” a function,
  that is, taking a function f (a, b) that takes an ordered
  pair as an argument, and recasting it as a function f' a b
  that takes two arguments successively.
  As another exercise, we encourage you to complete the
  following definitions, which “curry” and “uncurry” a function.
  -/
  def curry (α β γ : Type) (f : α × β → γ) : α → β → γ
  := λ (a: α), (λ (b: β), f (a, b) )
  def uncurry (α β γ : Type) (f : α → β → γ) : α × β → γ
  := λ (x : α × β), f x.1 x.2
end two

namespace three
  /-
  Above, we used the example vec α n for vectors of elements of
  type α of length n.
  Declare a constant vec_add that could represent a
  function that adds two vectors of natural numbers of
  the same length, and a constant vec_reverse that can
  represent a function that reverses its argument.
  Use implicit arguments for parameters that can be inferred.
  Declare some variables and check some expressions
  involving the constants that you have declared.
  -/

  -- dependant types reference code from section 2.9

  constant cons   : Π {α : Type u}, α → list α → list α
  constant nil    : Π {α : Type u}, list α
  constant append : Π {α : Type u}, list α → list α → list α

  variable  α : Type
  variable  a : α
  variables l1 l2 : list α

  #check cons a nil
  #check append (cons a nil) l1
  #check append (append (cons a nil) l1) l2

  -- vector reference code from section 2.8

  constant vec : Type u → ℕ → Type u

  constant vec_empty : Π α : Type u, vec α 0
  constant vec_cons : Π (α : Type u) (n : ℕ), α → vec α n → vec α (n + 1)
  constant vec_append : Π (α : Type u) (n m : ℕ),  vec α m → vec α n → vec α (n + m)

  #check vec_empty ℕ
  #check (vec_cons ℕ 0) 9 (vec_empty ℕ) -- vec of len 1
  #check (vec_cons ℕ 1) 9 ((vec_cons ℕ 0) 9 (vec_empty ℕ)) -- vec of len 2
  #check vec_append ℕ 2 2 ((vec_cons ℕ 1) 9 ((vec_cons ℕ 0) 9 (vec_empty ℕ))) ((vec_cons ℕ 1) 9 ((vec_cons ℕ 0) 9 (vec_empty ℕ))) -- vec of len 4

  -- solution

  constant Vec_empty : Π {α : Type u}, vec α 0
  constant Vec_cons : Π {α : Type u} {n: ℕ}, α → vec α n → vec α (n + 1)
  constant Vec_append : Π {α : Type u} {n m: ℕ},  vec α m → vec α n → vec α (n + m)

  constant Vec_add : Π {α : Type u} {n m: ℕ}, vec α n → vec α m → vec α (n + m)
  constant Vec_reverses : Π {α : Type u} {n: ℕ}, vec α n → vec α n

  #check @Vec_empty
  #check Vec_cons 9 Vec_empty -- vec of len 1
  #check Vec_cons 9 (Vec_cons 9 Vec_empty) -- vec of len 2
  #check Vec_append (Vec_cons 9 (Vec_cons 9 Vec_empty)) (Vec_cons 9 (Vec_cons 9 Vec_empty)) -- vec of len 4

  #check Vec_add (Vec_append (Vec_cons 9 (Vec_cons 9 Vec_empty)) (Vec_cons 9 (Vec_cons 9 Vec_empty))) (Vec_cons 9 (Vec_cons 9 Vec_empty))  -- vec of len 6
  #check Vec_reverses (Vec_cons 9 (Vec_cons 9 Vec_empty))
end three

namespace four
  /-
  Similarly, declare a constant matrix so that matrix α m n could represent the
  type of m by n matrices.
  Declare some constants to represent functions on this type,
  such as matrix addition and multiplication, and (using vec)
  multiplication of a matrix by a vector.
  Once again, declare some variables and check some expressions
  involving the constants that you have declared.
  -/

  -- solution
  open three

  constant mat : Type u → ℕ → ℕ → Type u

  constant mat_empty : Π {α : Type u}, mat α 0 0
  constant mat_concat_vecs_as_rows : Π {α : Type u} {n: ℕ}, vec α n → vec α n → mat α 2 n
  constant mat_concat_vecs_as_cols : Π {α : Type u} {n: ℕ}, vec α n → vec α n → mat α n 2

  #check mat_concat_vecs_as_rows Vec_empty Vec_empty  -- 2x0 matrix
  #check mat_concat_vecs_as_rows (Vec_cons 9 (Vec_cons 9 Vec_empty)) (Vec_cons 9 (Vec_cons 9 Vec_empty))  -- 2x2 matrix

  constant mat_add : Π {α : Type u} {n m: ℕ},  mat α n m → mat α n m → mat α n m
  constant mat_mul : Π {α : Type u} {n m t: ℕ},  mat α n m → mat α m t → mat α n t
  constant mat_mul_by_vec : Π {α : Type u} {n m: ℕ},  mat α n m → vec α m → vec α n
end four


/-
Here is the practice exam. It provides you
with a set of problems illustrative of the
material to be tested. This is a homework
assignment due this coming Thursday. We will
review the questions in class.

Copy this file your "work" directory. Work
on it there. Upload to Collab when done.

Note: An incorrect answer above or below
a correct answer can cause Lean to be unable
to process the correct answer. If you are not
able to complete a problem successfully please
comment out your incomplete answer so that we
can see your work but so that your incomplete
work does not cause problems for surrounding
problems and answers.
-/

/-
PART I: Functions. Functions are an essential
element of the language of predicate logic. In
this section, you show that you understand how
to define, use, and reason about functions in
Lean.
-/

/- 1.
Study each of the following definitions,
then answer the associated question about
the types involved in these definitions.
-/

-- Consider this function
def f (n : ℕ) (s : string) := s

/-
a. What is it's return type? Answer:
-/

/-
b. What is the type of (f 5)? Answer:
-/

/-
c. What is the value of (f 0 "yay")
-/

/-
d. What is the type of this function?
-/

/- 2.
Define three functions called square,
square', and square'', each of type
ℕ → ℕ. Each function must return the
square of the value to which it is
applied. Write the first function in
"C" style, the second using a tactic
script, and the third using a lambda
abstraction. Declare all argument and
return types explicitly. Answer below.
-/

def square (n : ℕ) : ℕ := n^2

def square' (n : ℕ) : ℕ :=
begin
exact n^2
end

def square'' : ℕ → ℕ :=
λ n, n^2

/- 3.
Construct three proofs to test your
function definitions. The first must
use "lemma" to define a proof, called
square_3_9, of the proposition that
(square 3) equals 9. The second must
use "theorem" to define a proof, called
square'_4_16, of the proposition that
square' applied to 4 reduces to 16. The
third must prove that square'' 5 is
equal to 25. This third proof must not
use the equals sign, =, but must use
"eq" instead to state the proposition
to be proved. Hint on #3, sometimes
you need to use parentheses to express
how you want terms to be grouped. Answer
below.
-/

lemma square_3_9 : eq (square 3) 9 := rfl

/- 4.
Define a function called last_first.
It must take two string values, called
"first" and "last" (without quotes),
and return a string consisting of "last"
followed by a comma and a space followed
by "first".

For example (last_first "Orson" "Welles")
must return the string, "Welles, Orson".
Write a test case for your function to
prove that (last_first "Orson" "Welles")
is "Welles, Orson". Use "example", to
check the proof. Hint: The ++ operator
implements the string append function.
Answer below.
-/

def lastFirst (s1 s2 : string) : string :=
    s2 ++ ", " ++ s1

example :
    lastFirst "Orson" "Welles" = "Welles, Orson" := rfl

/- 5.

Complete the following definition of a
function, called apply3. It takes, as an
argument, a function, you might call it f,
of type ℕ → ℕ. It must return a function,
also of type ℕ to ℕ, that, when applied
to a value, n, returns the result of
applying the given function, f, to the
given value, n, three times. The function
returned must compute f(f(f(n))) when it
is applied to an argument, n.
-/

def apply3 : (ℕ → ℕ) → (ℕ → ℕ) :=
    λ f : ℕ → ℕ,
        λ n, f(f(f(n)))

#reduce apply3 (λ n : ℕ, n^2) 2
/- 6.

The Lean libraries define a function,
string.length, that takes a string and
returns its length as a natural number.
Define a function, len2, that takes two
strings and returns the sum of their
lengths. You may use the ++ operator
but not the + operator in your answer.
Follow your function definition with a
test case in the form of a proof using
"example" showing that len2 applied to
"Orson" and "Welles" is 11. Remember:
you might need parenthesis in some
cases to group terms correctly into
larger terms.
-/

def len2 (s1 s2 : string) : ℕ :=
    string.length (s1 ++ s2)

/- 7.
Use "example" to prove that there is a
function of the following type:

((ℕ → ℕ) → (ℕ → ℕ)) →
    ((ℕ → ℕ) → ℕ) →
        ((ℕ → ℕ) → ℕ)
-/

example : ((ℕ → ℕ) → (ℕ → ℕ)) →
          ((ℕ → ℕ) → ℕ) →
          ((ℕ → ℕ) → ℕ) :=
λ f,
    λ g,
        g

/-
PART II: Functions, revisited. In
mathematics,  functions play a central
role. A function, f, in the mathematical
sense is a triple, f = { D, P, C }, where
D, a set, is the domain of definition of
f, C is the co-domain of f, and P is a
set of ordered pairs, each with a first
element from D and a second element from
C,. In addition, P has one additional
essential  property, the subject of one
of the following questions.
-/

/- 8.

What one additional property is essential to
the definition of what it means for a triple,
{ D, P, C } to be a function?

Name the property. Answer:

Now explain precisely what it means:  "That there
are no two pairs, (x, y) and (x', y') such that..."

Fill in the blank, and use a logical ∧ in answering.
You might also want to use = or ≠.

Answer:
-/

/- 9.

Give names to the following concepts:

The set of all values appearing as the first
element of any pair in P.

Answer:

The set of all values appearing as the second
element of any pair in P.

Answer:

The property that the set of all values
appearing as the first element of P is the
same as the entire set, D.

Answer:

The property that the set of all
values appearing as the second element of
P is the same as the entire set, C.

Answer:

The property of being one-to-one and onto.

Answer:

-/

/- 10.

What does it mean for a function, f, to be
injective? Give you answer by completing the
following sentences with logical expressions.

"A function, f, is said to be injective if
it has no two pairs, (x, y) and (x', y'),
such that ..."

Answer:

In other words, "If (x, y) and (x', y') are
related by f and x ≠ x' then ..."

Answer:
-/

/- 11.

Suppose that S and T are types and that f
is defined to be a function, *in Lean*, of
type S → T. Which of the following properties,
if any, does f necessarily have?

- injective
- surjective
- bijective
- one-to-many
- one-to-one
- onto
- single-valued
- partial
- total

Answer:

-/

/-
PART III: Logic and Proof.
-/

/- 12a.

Use axiom and/or axioms in Lean to express,
in formal logic, the following assumptions:

- T is a type
- t1 and t2 are values of type T
- t1 = t2

Answer immediately after this comment block.
If you need to introduce a name, use eqt1t2.
-/

axiom T : Type
axioms t1 t2 : T
axiom t1eqt2 :t1 = t2

/- 12b.

Use axiom or axioms to represent the
additional assumptions that

- P is a predicate expressing a property of objects of type T
- t1 has property P

If you need to use a name, use Pt1
-/

axiom P : T → Prop
axiom pf : P t1

example : P t2 := eq.subst t1eqt2 pf

/- 12 c.

Now use "example" to assert, and then
prove, that t2 also has property P.
-/

/- 13 a.
Define eq_1_0 to be the proposition, 1 = 0.
-/

/- 13 b.
Define pf_eq_0_0 to be a proof of the
proposition that 0 = 0. Use the lemma
keyword.
-/

/- 13 c.
Write a function, w, that takes three
values, a, b, and c of type ℕ, and that
also takes proofs, cb : c = b, and
ba : b = a, and that returns a proof
that a = c.
-/

/- 13d.

What is the type of this function?

Answer:

What is the form of this proposition?

Answer:

What's the form the proposition after the
comma?

Answer:

What is the premise of the proposition after
the comma?

Answer:

-/

/- 14.
Complete the following proofs. Give each one
in the form indicated by a comment preceding
the statement of the conjecture to be proved.
When using tactic scripts, remember to write
begin/end pairs right away, so Lean knowns
you want to use a tactic script.
-/

-- lambda expression
example : ∀ (s : string), s = s :=
_

-- lambda expresion
example : ∀ (n : ℕ), ∀ (m : ℕ), true :=
_

-- tactic script
example : ∀ (T : Type), ∀ (t : T), eq t t :=
_

-- tactic script
example :
    ∀ (T : Type),
    ∀ (P : T → Prop),
    ∀ t1 t2 : T,
    ∀ Pt1 : P t1,
    ∀ t2t1 : t2 = t1,
    P t2 :=
_

/-
The following problems involve implications.
For example, false → P in an implication. To
prove an implication, just show that there is
(give) a function of the specified type.
-/

-- lambda expression
example : ∀ (P : Prop), false → P :=
_

-- tactic script
example : ∀ (P : Prop), false → P :=
_

-- lambda expression
example : ∀ (P Q : Prop), P ∧ Q → Q ∧ P :=
_

-- tactic script
example : ∀ (P Q : Prop), P ∧ Q → Q ∧ P :=
_

-- tactic script
example :
    ∀ T : Type,
    ∀ (t1 t2 t3 : T),
    t1 = t2 ∧ t2 = t3 → t1 = t3 :=
_

/- 15.

Use Lean to model a world in which there
are Dogs, all Dogs are friendly, and Fido
is a Dog, with a proof that in this world,
Fido must be friendly, too.
-/

/-
Another

Prove:  ∀(A B C: Prop), A ∧ (B ∧ C) →  (A ∧ B) ∧ C
-/


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.order.field.basic
import analysis.specific_limits.basic
import ring_theory.polynomial.bernstein
import topology.continuous_function.polynomial
import topology.continuous_function.compact

/-!
# Bernstein approximations and Weierstrass' theorem

We prove that the Bernstein approximations
```
∑ k : fin (n+1), f (k/n : ℝ) * n.choose k * x^k * (1-x)^(n-k)
```
for a continuous function `f : C([0,1], ℝ)` converge uniformly to `f` as `n` tends to infinity.

Our proof follows [Richard Beals' *Analysis, an introduction*][beals-analysis], §7D.
The original proof, due to [Bernstein](bernstein1912) in 1912, is probabilistic,
and relies on Bernoulli's theorem,
which gives bounds for how quickly the observed frequencies in a
Bernoulli trial approach the underlying probability.

The proof here does not directly rely on Bernoulli's theorem,
but can also be given a probabilistic account.
* Consider a weighted coin which with probability `x` produces heads,
  and with probability `1-x` produces tails.
* The value of `bernstein n k x` is the probability that
  such a coin gives exactly `k` heads in a sequence of `n` tosses.
* If such an appearance of `k` heads results in a payoff of `f(k / n)`,
  the `n`-th Bernstein approximation for `f` evaluated at `x` is the expected payoff.
* The main estimate in the proof bounds the probability that
  the observed frequency of heads differs from `x` by more than some `δ`,
  obtaining a bound of `(4 * n * δ^2)⁻¹`, irrespective of `x`.
* This ensures that for `n` large, the Bernstein approximation is (uniformly) close to the
  payoff function `f`.

(You don't need to think in these terms to follow the proof below: it's a giant `calc` block!)

This result proves Weierstrass' theorem that polynomials are dense in `C([0,1], ℝ)`,
although we defer an abstract statement of this until later.
-/

noncomputable theory

open_locale classical
open_locale big_operators
open_locale bounded_continuous_function
open_locale unit_interval

/--
The Bernstein polynomials, as continuous functions on `[0,1]`.
-/
def bernstein (n ν : ℕ) : C(I, ℝ) :=
(bernstein_polynomial ℝ n ν).to_continuous_map_on I

@[simp] lemma bernstein_apply (n ν : ℕ) (x : I) :
  bernstein n ν x = n.choose ν * x^ν * (1-x)^(n-ν) :=
begin
  dsimp [bernstein, polynomial.to_continuous_map_on, polynomial.to_continuous_map,
    bernstein_polynomial],
  simp,
end

lemma bernstein_nonneg {n ν : ℕ} {x : I} :
  0 ≤ bernstein n ν x :=
begin
  simp only [bernstein_apply],
  exact mul_nonneg
    (mul_nonneg (nat.cast_nonneg _) (pow_nonneg (by unit_interval) _))
    (pow_nonneg (by unit_interval) _),
end

/-!
We now give a slight reformulation of `bernstein_polynomial.variance`.
-/

namespace bernstein

/--
Send `k : fin (n+1)` to the equally spaced points `k/n` in the unit interval.
-/
def z {n : ℕ} (k : fin (n+1)) : I :=
⟨(k : ℝ) / n,
  begin
    cases n,
    { norm_num },
    { have h₁ : 0 < (n.succ : ℝ) := by exact_mod_cast (nat.succ_pos _),
      have h₂ : ↑k ≤ n.succ := by exact_mod_cast (fin.le_last k),
      rw [set.mem_Icc, le_div_iff h₁, div_le_iff h₁],
      norm_cast,
      simp [h₂], },
  end⟩

local postfix `/ₙ`:90 := z

lemma probability (n : ℕ) (x : I) :
  ∑ k : fin (n+1), bernstein n k x = 1 :=
begin
  have := bernstein_polynomial.sum ℝ n,
  apply_fun (λ p, polynomial.aeval (x : ℝ) p) at this,
  simp [alg_hom.map_sum, finset.sum_range] at this,
  exact this,
end

lemma variance {n : ℕ} (h : 0 < (n : ℝ)) (x : I) :
  ∑ k : fin (n+1), (x - k/ₙ : ℝ)^2 * bernstein n k x = x * (1-x) / n :=
begin
  have h' : (n : ℝ) ≠ 0 := ne_of_gt h,
  apply_fun (λ x : ℝ, x * n) using group_with_zero.mul_right_injective h',
  apply_fun (λ x : ℝ, x * n) using group_with_zero.mul_right_injective h',
  dsimp,
  conv_lhs { simp only [finset.sum_mul, z], },
  conv_rhs { rw div_mul_cancel _ h', },
  have := bernstein_polynomial.variance ℝ n,
  apply_fun (λ p, polynomial.aeval (x : ℝ) p) at this,
  simp [alg_hom.map_sum, finset.sum_range, ←polynomial.nat_cast_mul] at this,
  convert this using 1,
  { congr' 1, funext k,
    rw [mul_comm _ (n : ℝ), mul_comm _ (n : ℝ), ←mul_assoc, ←mul_assoc],
    congr' 1,
    field_simp [h],
    ring, },
  { ring, },
end

end bernstein

open bernstein

local postfix `/ₙ`:2000 := z

/--
The `n`-th approximation of a continuous function on `[0,1]` by Bernstein polynomials,
given by `∑ k, f (k/n) * bernstein n k x`.
-/
def bernstein_approximation (n : ℕ) (f : C(I, ℝ)) : C(I, ℝ) :=
∑ k : fin (n+1), f k/ₙ • bernstein n k

/-!
We now set up some of the basic machinery of the proof that the Bernstein approximations
converge uniformly.

A key player is the set `S f ε h n x`,
for some function `f : C(I, ℝ)`, `h : 0 < ε`, `n : ℕ` and `x : I`.

This is the set of points `k` in `fin (n+1)` such that
`k/n` is within `δ` of `x`, where `δ` is the modulus of uniform continuity for `f`,
chosen so `|f x - f y| < ε/2` when `|x - y| < δ`.

We show that if `k ∉ S`, then `1 ≤ δ^-2 * (x - k/n)^2`.
-/

namespace bernstein_approximation

@[simp] lemma apply (n : ℕ) (f : C(I, ℝ)) (x : I) :
  bernstein_approximation n f x = ∑ k : fin (n+1), f k/ₙ * bernstein n k x :=
by simp [bernstein_approximation]

/--
The modulus of (uniform) continuity for `f`, chosen so `|f x - f y| < ε/2` when `|x - y| < δ`.
-/
def δ (f : C(I, ℝ)) (ε : ℝ) (h : 0 < ε) : ℝ := f.modulus (ε/2) (half_pos h)

lemma δ_pos {f : C(I, ℝ)} {ε : ℝ} {h : 0 < ε} : 0 < δ f ε h := f.modulus_pos

/--
The set of points `k` so `k/n` is within `δ` of `x`.
-/
def S (f : C(I, ℝ)) (ε : ℝ) (h : 0 < ε) (n : ℕ) (x : I) : finset (fin (n+1)) :=
{ k : fin (n+1) | dist k/ₙ x < δ f ε h }.to_finset

/--
If `k ∈ S`, then `f(k/n)` is close to `f x`.
-/
lemma lt_of_mem_S
  {f : C(I, ℝ)} {ε : ℝ} {h : 0 < ε} {n : ℕ} {x : I} {k : fin (n+1)} (m : k ∈ S f ε h n x) :
  |f k/ₙ - f x| < ε/2 :=
begin
  apply f.dist_lt_of_dist_lt_modulus (ε/2) (half_pos h),
  simpa [S] using m,
end

/--
If `k ∉ S`, then as `δ ≤ |x - k/n|`, we have the inequality `1 ≤ δ^-2 * (x - k/n)^2`.
This particular formulation will be helpful later.
-/
lemma le_of_mem_S_compl
  {f : C(I, ℝ)} {ε : ℝ} {h : 0 < ε} {n : ℕ} {x : I} {k : fin (n+1)} (m : k ∈ (S f ε h n x)ᶜ) :
  (1 : ℝ) ≤ (δ f ε h)^(-2 : ℤ) * (x - k/ₙ) ^ 2 :=
begin
  simp only [finset.mem_compl, not_lt, set.mem_to_finset, set.mem_set_of_eq, S] at m,
  rw [zpow_neg, ← div_eq_inv_mul, zpow_two, ←pow_two, one_le_div (pow_pos δ_pos 2), sq_le_sq,
    abs_of_pos δ_pos],
  rwa [dist_comm] at m
end

end bernstein_approximation

open bernstein_approximation
open bounded_continuous_function
open filter

open_locale topology

/--
The Bernstein approximations
```
∑ k : fin (n+1), f (k/n : ℝ) * n.choose k * x^k * (1-x)^(n-k)
```
for a continuous function `f : C([0,1], ℝ)` converge uniformly to `f` as `n` tends to infinity.

This is the proof given in [Richard Beals' *Analysis, an introduction*][beals-analysis], §7D,
and reproduced on wikipedia.
-/
theorem bernstein_approximation_uniform (f : C(I, ℝ)) :
  tendsto (λ n : ℕ, bernstein_approximation n f) at_top (𝓝 f) :=
begin
  simp only [metric.nhds_basis_ball.tendsto_right_iff, metric.mem_ball, dist_eq_norm],
  intros ε h,
  let δ := δ f ε h,
  have nhds_zero := tendsto_const_div_at_top_nhds_0_nat (2 * ‖f‖ * δ ^ (-2 : ℤ)),
  filter_upwards [nhds_zero.eventually (gt_mem_nhds (half_pos h)), eventually_gt_at_top 0]
    with n nh npos',
  have npos : 0 < (n:ℝ) := by exact_mod_cast npos',
  -- Two easy inequalities we'll need later:
  have w₁ : 0 ≤ 2 * ‖f‖ := mul_nonneg (by norm_num) (norm_nonneg f),
  have w₂ : 0 ≤ 2 * ‖f‖ * δ^(-2 : ℤ) := mul_nonneg w₁ (zpow_neg_two_nonneg _),
  -- As `[0,1]` is compact, it suffices to check the inequality pointwise.
  rw (continuous_map.norm_lt_iff _ h),
  intro x,
  -- The idea is to split up the sum over `k` into two sets,
  -- `S`, where `x - k/n < δ`, and its complement.
  let S := S f ε h n x,
  calc
    |(bernstein_approximation n f - f) x|
        = |bernstein_approximation n f x - f x|
                              : rfl
    ... = |bernstein_approximation n f x - f x * 1|
                              : by rw mul_one
    ... = |bernstein_approximation n f x - f x * (∑ k : fin (n+1), bernstein n k x)|
                              : by rw bernstein.probability
    ... = |∑ k : fin (n+1), (f k/ₙ - f x) * bernstein n k x|
                              : by simp [bernstein_approximation, finset.mul_sum, sub_mul]
    ... ≤ ∑ k : fin (n+1), |(f k/ₙ - f x) * bernstein n k x|
                              : finset.abs_sum_le_sum_abs _ _
    ... = ∑ k : fin (n+1), |f k/ₙ - f x| * bernstein n k x
                              : by simp_rw [abs_mul, abs_eq_self.mpr bernstein_nonneg]
    ... = ∑ k in S, |f k/ₙ - f x| * bernstein n k x +
          ∑ k in Sᶜ, |f k/ₙ - f x| * bernstein n k x
                              : (S.sum_add_sum_compl _).symm
    -- We'll now deal with the terms in `S` and the terms in `Sᶜ` in separate calc blocks.
    ... < ε/2 + ε/2 : add_lt_add_of_le_of_lt _ _
    ... = ε : add_halves ε,
    { -- We now work on the terms in `S`: uniform continuity and `bernstein.probability`
      -- quickly give us a bound.
      calc ∑ k in S, |f k/ₙ - f x| * bernstein n k x
          ≤ ∑ k in S, ε/2 * bernstein n k x
                                :  finset.sum_le_sum
                                    (λ k m, (mul_le_mul_of_nonneg_right (le_of_lt (lt_of_mem_S m))
                                      bernstein_nonneg))
      ... = ε/2 * ∑ k in S, bernstein n k x
                                : by rw finset.mul_sum
      -- In this step we increase the sum over `S` back to a sum over all of `fin (n+1)`,
      -- so that we can use `bernstein.probability`.
      ... ≤ ε/2 * ∑ k : fin (n+1), bernstein n k x
                                : mul_le_mul_of_nonneg_left
                                    (finset.sum_le_univ_sum_of_nonneg (λ k, bernstein_nonneg))
                                    (le_of_lt (half_pos h))
      ... = ε/2 : by rw [bernstein.probability, mul_one] },
      { -- We now turn to working on `Sᶜ`: we control the difference term just using `‖f‖`,
        -- and then insert a `δ^(-2) * (x - k/n)^2` factor
        -- (which is at least one because we are not in `S`).
        calc ∑ k in Sᶜ, |f k/ₙ - f x| * bernstein n k x
            ≤ ∑ k in Sᶜ, (2 * ‖f‖) * bernstein n k x
                                  : finset.sum_le_sum
                                      (λ k m, mul_le_mul_of_nonneg_right (f.dist_le_two_norm _ _)
                                        bernstein_nonneg)
        ... = (2 * ‖f‖) * ∑ k in Sᶜ, bernstein n k x
                                  : by rw finset.mul_sum
        ... ≤ (2 * ‖f‖) * ∑ k in Sᶜ, δ^(-2 : ℤ) * (x - k/ₙ)^2 * bernstein n k x
                                  : mul_le_mul_of_nonneg_left
                                      (finset.sum_le_sum (λ k m, begin
                                        conv_lhs { rw ←one_mul (bernstein _ _ _), },
                                        exact mul_le_mul_of_nonneg_right
                                          (le_of_mem_S_compl m) bernstein_nonneg,
                                      end)) w₁
        -- Again enlarging the sum from `Sᶜ` to all of `fin (n+1)`
        ... ≤ (2 * ‖f‖) * ∑ k : fin (n+1), δ^(-2 : ℤ) * (x - k/ₙ)^2 * bernstein n k x
                                  : mul_le_mul_of_nonneg_left
                                      (finset.sum_le_univ_sum_of_nonneg
                                        (λ k, mul_nonneg
                                          (mul_nonneg (zpow_neg_two_nonneg _) (sq_nonneg _))
                                          bernstein_nonneg)) w₁
        ... = (2 * ‖f‖) * δ^(-2 : ℤ) * ∑ k : fin (n+1), (x - k/ₙ)^2 * bernstein n k x
                                  : by conv_rhs
                                    { rw [mul_assoc, finset.mul_sum], simp only [←mul_assoc], }
        -- `bernstein.variance` and `x ∈ [0,1]` gives the uniform bound
        ... = (2 * ‖f‖) * δ^(-2 : ℤ) * x * (1-x) / n
                                  : by { rw variance npos, ring, }
        ... ≤ (2 * ‖f‖) * δ^(-2 : ℤ) / n
                                  : (div_le_div_right npos).mpr $
              by refine mul_le_of_le_of_le_one' (mul_le_of_le_one_right w₂ _) _ _ w₂; unit_interval
        ... < ε/2 : nh, }
end


import data.rat.basic

import summation

open summation

/-The limit as `f` goes to ±∞ is 0 -/
def vanishes (f : ℤ → ℚ) := ∀ (ε : ℚ), ε > (0 : ℚ) → ∃ (K : ℕ), ∀ (k : ℤ), (k > K ∨ k < -K) → (f k > - ε ∧ f k < ε)

/-
The functions `F` and `G` form a WZ pair

That is, Δₙ F = Δₖ G
-/
def WZ_pair (F : ℤ → ℤ → ℚ) (G : ℤ → ℤ → ℚ) := (∀ (n k : ℤ), F (n+1) k - F n k = G n (k+1) - G n k)

/-
This lemma demonstrates that if functions `F` and `G` form a WZ pair, then a finite summation of `F` with the variable `k` can be converted to a telescoping sum of the funtion `G`.
-/
lemma creative_telescoping {F G : ℤ → ℤ → ℚ} (wz : WZ_pair F G) (n : ℤ) : ∀ (m : ℕ), summation (λ (k : ℤ), F (n+1) k - F n k) m = G n (m+1) - G n (-m) :=
begin
  intro m,
  induction m with d hd,
  {
    rw [summation, wz n 0],
    refl,
  },
  {
    rw [summation, hd, wz, wz],
    simp,
  }
end

/-This is the main WZ theorem.

Sketch of the proof:

Any identity of the form ∑ₖ f n k = S n can be rewritten as
∑ₖ F n k = c, where
`c` is a constant and
F n k = (f n k) / (S n)

To show that ∑ₖ F n k = c, it suffices to show that (∑ₖ F (n+1) k) - (∑ₖ F n k) = ∑ₖ (F (n+1) k - F n k) = 0.

Using the WZ mate of `F`, namely `G`, this summation can be converted into a telescoping sum which is easily evaluated:

∑ₖ G n (k+1) - G n k = lim_{m → ∞} G n (m+1) - G n (-m)

Since the function G n is assumed to vanish at infinity, the above sum is just zero.

This shows that ∑ₖ F n k is a constant function of `n`, and therefore the identity must hold.

-/
theorem WZ
  (F G : ℤ → ℤ → ℚ)
  (wz : WZ_pair F G)
  (Gvanishes : ∀ (n : ℤ), vanishes (G n))
  (c : ℚ)
  (base_case : equals_indefinite_sum (F 0) c)

  : ∀ (n : ℤ), equals_indefinite_sum (F n) c :=
begin

  -- this is the crux of the theorem - the fact that ∑ₖ (F (n+1) k - F n k) = 0
  have consecutive_difference_vanishes : ∀ (n : ℤ), equals_indefinite_sum (λ (k : ℤ), F (n+1) k - F n k) 0 :=
  begin
    intro n,
    rw equals_indefinite_sum,
    intros ε hε_pos,
    have hεby2_pos : ε/2 > 0 := half_pos hε_pos,
    cases (Gvanishes n (ε/2) hεby2_pos) with K hK,
    use K,
    intro m,
    intro hmgtK,
    rw creative_telescoping wz n,

    cases hK (-m) _ with Gnm_neg Gnm_pos,
    cases hK (m+1) (or.inl (int.coe_nat_lt.mpr (nat.lt.step hmgtK))) with Gnms_neg Gnms_pos,

    split,
    {
      linarith,
    },
    {
      linarith,
    },
    right,
    linarith,
  end,

  have inductive_case : _ := zero_diff_iff_equal F consecutive_difference_vanishes c,

  intro n,
  cases n,
  {
    induction n with d hd,
    exact base_case,
    exact (inductive_case d).1 hd,
  },
  {
    induction n with d hd,
    {
      exact (inductive_case (-1)).2 base_case,
    },
    {
      exact (inductive_case (-(d+2))).2 hd,
    }
  }
end


-- ----------------------------------------------------
-- Ejercicio . Demostrar
--    ¬¬p ⊢ p
-- ----------------------------------------------------

import tactic
variable (p : Prop)

open_locale classical

-- 1ª demostración
example
  (h1 : ¬¬p)
  : p :=
by_contra
  ( assume h2 : ¬p,
    show false,
      from h1 h2 )

-- 2ª demostración
example
  (h1 : ¬¬p)
  : p :=
by_contra
  ( assume h2 : ¬p,
    h1 h2 )

-- 3ª demostración
example
  (h1 : ¬¬p)
  : p :=
by_contra (λ h2, h1 h2)

-- 4ª demostración
example
  (h1 : ¬¬p)
  : p :=
-- by library_search
not_not.mp h1

-- 5ª demostración
example
  (h1 : ¬¬p)
  : p :=
begin
  by_contradiction h2,
  exact h1 h2,
end

-- 6ª demostración
example
  (h1 : ¬¬p)
  : p :=
-- by hint
by tauto

-- 7ª demostración
lemma aux
  (h1 : ¬¬p)
  : p :=
by finish


/-
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, Floris van Doorn, Amelia Livingston, Yury Kudryashov,
Neil Strickland, Aaron Anderson

! This file was ported from Lean 3 source module algebra.group_with_zero.divisibility
! leanprover-community/mathlib commit f1a2caaf51ef593799107fe9a8d5e411599f3996
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.GroupWithZero.Basic
import Mathlib.Algebra.Divisibility.Units

/-!
# Divisibility in groups with zero.

Lemmas about divisibility in groups and monoids with zero.

-/

variable {α : Type _}

section SemigroupWithZero

variable [SemigroupWithZero α] {a : α}

theorem eq_zero_of_zero_dvd (h : 0 ∣ a) : a = 0 :=
  Dvd.elim h fun c H' => H'.trans (zero_mul c)
#align eq_zero_of_zero_dvd eq_zero_of_zero_dvd

/-- Given an element `a` of a commutative semigroup with zero, there exists another element whose
    product with zero equals `a` iff `a` equals zero. -/
@[simp]
theorem zero_dvd_iff : 0 ∣ a ↔ a = 0 :=
  ⟨eq_zero_of_zero_dvd, fun h => by
    rw [h]
    exact ⟨0, by simp⟩⟩
#align zero_dvd_iff zero_dvd_iff

@[simp]
theorem dvd_zero (a : α) : a ∣ 0 :=
  Dvd.intro 0 (by simp)
#align dvd_zero dvd_zero

end SemigroupWithZero

/-- Given two elements `b`, `c` of a `CancelMonoidWithZero` and a nonzero element `a`,
 `a*b` divides `a*c` iff `b` divides `c`. -/
theorem mul_dvd_mul_iff_left [CancelMonoidWithZero α] {a b c : α} (ha : a ≠ 0) :
    a * b ∣ a * c ↔ b ∣ c :=
  exists_congr fun d => by rw [mul_assoc, mul_right_inj' ha]
#align mul_dvd_mul_iff_left mul_dvd_mul_iff_left

/-- Given two elements `a`, `b` of a commutative `CancelMonoidWithZero` and a nonzero
  element `c`, `a*c` divides `b*c` iff `a` divides `b`. -/
theorem mul_dvd_mul_iff_right [CancelCommMonoidWithZero α] {a b c : α} (hc : c ≠ 0) :
    a * c ∣ b * c ↔ a ∣ b :=
  exists_congr fun d => by rw [mul_right_comm, mul_left_inj' hc]
#align mul_dvd_mul_iff_right mul_dvd_mul_iff_right

section CommMonoidWithZero

variable [CommMonoidWithZero α]

/-- `DvdNotUnit a b` expresses that `a` divides `b` "strictly", i.e. that `b` divided by `a`
is not a unit. -/
def DvdNotUnit (a b : α) : Prop :=
  a ≠ 0 ∧ ∃ x, ¬IsUnit x ∧ b = a * x
#align dvd_not_unit DvdNotUnit

theorem dvdNotUnit_of_dvd_of_not_dvd {a b : α} (hd : a ∣ b) (hnd : ¬b ∣ a) : DvdNotUnit a b := by
  constructor
  · rintro rfl
    exact hnd (dvd_zero _)
  · rcases hd with ⟨c, rfl⟩
    refine' ⟨c, _, rfl⟩
    rintro ⟨u, rfl⟩
    simp at hnd
#align dvd_not_unit_of_dvd_of_not_dvd dvdNotUnit_of_dvd_of_not_dvd

end CommMonoidWithZero

theorem dvd_and_not_dvd_iff [CancelCommMonoidWithZero α] {x y : α} :
    x ∣ y ∧ ¬y ∣ x ↔ DvdNotUnit x y :=
  ⟨fun ⟨⟨d, hd⟩, hyx⟩ =>
    ⟨fun hx0 => by simp [hx0] at hyx,
      ⟨d, mt isUnit_iff_dvd_one.1 fun ⟨e, he⟩ => hyx ⟨e, by rw [hd, mul_assoc, ← he, mul_one]⟩,
        hd⟩⟩,
    fun ⟨hx0, d, hdu, hdx⟩ =>
    ⟨⟨d, hdx⟩, fun ⟨e, he⟩ =>
      hdu
        (isUnit_of_dvd_one
          ⟨e, mul_left_cancel₀ hx0 <| by conv =>
            lhs
            rw [he, hdx]
            simp [mul_assoc]⟩)⟩⟩
#align dvd_and_not_dvd_iff dvd_and_not_dvd_iff

section MonoidWithZero

variable [MonoidWithZero α]

theorem ne_zero_of_dvd_ne_zero {p q : α} (h₁ : q ≠ 0) (h₂ : p ∣ q) : p ≠ 0 := by
  rcases h₂ with ⟨u, rfl⟩
  exact left_ne_zero_of_mul h₁
#align ne_zero_of_dvd_ne_zero ne_zero_of_dvd_ne_zero

end MonoidWithZero


/-
Copyright (c) 2020 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anatole Dedecker, Devon Tuma
-/
import analysis.asymptotics.asymptotic_equivalent
import analysis.asymptotics.specific_asymptotics
import data.polynomial.ring_division

/-!
# Limits related to polynomial and rational functions

This file proves basic facts about limits of polynomial and rationals functions.
The main result is `eval_is_equivalent_at_top_eval_lead`, which states that for
any polynomial `P` of degree `n` with leading coefficient `a`, the corresponding
polynomial function is equivalent to `a * x^n` as `x` goes to +∞.

We can then use this result to prove various limits for polynomial and rational
functions, depending on the degrees and leading coefficients of the considered
polynomials.
-/

open filter finset asymptotics
open_locale asymptotics polynomial topology

namespace polynomial

variables {𝕜 : Type*} [normed_linear_ordered_field 𝕜] (P Q : 𝕜[X])

lemma eventually_no_roots (hP : P ≠ 0) : ∀ᶠ x in at_top, ¬ P.is_root x :=
at_top_le_cofinite $ (finite_set_of_is_root hP).compl_mem_cofinite

variables [order_topology 𝕜]

section polynomial_at_top

lemma is_equivalent_at_top_lead :
  (λ x, eval x P) ~[at_top] (λ x, P.leading_coeff * x ^ P.nat_degree) :=
begin
  by_cases h : P = 0,
  { simp [h] },
  { simp only [polynomial.eval_eq_sum_range, sum_range_succ],
    exact is_o.add_is_equivalent (is_o.sum $ λ i hi, is_o.const_mul_left
      (is_o.const_mul_right (λ hz, h $ leading_coeff_eq_zero.mp hz) $
        is_o_pow_pow_at_top_of_lt (mem_range.mp hi)) _) is_equivalent.refl }
end

lemma tendsto_at_top_of_leading_coeff_nonneg (hdeg : 0 < P.degree) (hnng : 0 ≤ P.leading_coeff) :
  tendsto (λ x, eval x P) at_top at_top :=
P.is_equivalent_at_top_lead.symm.tendsto_at_top $
  tendsto_const_mul_pow_at_top (nat_degree_pos_iff_degree_pos.2 hdeg).ne' $
    hnng.lt_of_ne' $ leading_coeff_ne_zero.mpr $ ne_zero_of_degree_gt hdeg

lemma tendsto_at_top_iff_leading_coeff_nonneg :
  tendsto (λ x, eval x P) at_top at_top ↔ 0 < P.degree ∧ 0 ≤ P.leading_coeff :=
begin
  refine ⟨λ h, _, λ h, tendsto_at_top_of_leading_coeff_nonneg P h.1 h.2⟩,
  have : tendsto (λ x, P.leading_coeff * x ^ P.nat_degree) at_top at_top :=
    (is_equivalent_at_top_lead P).tendsto_at_top h,
  rw [tendsto_const_mul_pow_at_top_iff, ← pos_iff_ne_zero, nat_degree_pos_iff_degree_pos] at this,
  exact ⟨this.1, this.2.le⟩
end

lemma tendsto_at_bot_iff_leading_coeff_nonpos :
  tendsto (λ x, eval x P) at_top at_bot ↔ 0 < P.degree ∧ P.leading_coeff ≤ 0 :=
by simp only [← tendsto_neg_at_top_iff, ← eval_neg, tendsto_at_top_iff_leading_coeff_nonneg,
  degree_neg, leading_coeff_neg, neg_nonneg]

lemma tendsto_at_bot_of_leading_coeff_nonpos (hdeg : 0 < P.degree) (hnps : P.leading_coeff ≤ 0) :
  tendsto (λ x, eval x P) at_top at_bot :=
P.tendsto_at_bot_iff_leading_coeff_nonpos.2 ⟨hdeg, hnps⟩

lemma abs_tendsto_at_top (hdeg : 0 < P.degree) :
  tendsto (λ x, abs $ eval x P) at_top at_top :=
begin
  cases le_total 0 P.leading_coeff with hP hP,
  { exact tendsto_abs_at_top_at_top.comp (P.tendsto_at_top_of_leading_coeff_nonneg hdeg hP) },
  { exact tendsto_abs_at_bot_at_top.comp (P.tendsto_at_bot_of_leading_coeff_nonpos hdeg hP) }
end

lemma abs_is_bounded_under_iff :
  is_bounded_under (≤) at_top (λ x, |eval x P|) ↔ P.degree ≤ 0 :=
begin
  refine ⟨λ h, _, λ h, ⟨|P.coeff 0|, eventually_map.mpr (eventually_of_forall
    (forall_imp (λ _, le_of_eq) (λ x, congr_arg abs $ trans (congr_arg (eval x)
    (eq_C_of_degree_le_zero h)) (eval_C))))⟩⟩,
  contrapose! h,
  exact not_is_bounded_under_of_tendsto_at_top (abs_tendsto_at_top P h)
end

lemma abs_tendsto_at_top_iff :
  tendsto (λ x, abs $ eval x P) at_top at_top ↔ 0 < P.degree :=
⟨λ h, not_le.mp (mt (abs_is_bounded_under_iff P).mpr (not_is_bounded_under_of_tendsto_at_top h)),
  abs_tendsto_at_top P⟩

lemma tendsto_nhds_iff {c : 𝕜} :
  tendsto (λ x, eval x P) at_top (𝓝 c) ↔ P.leading_coeff = c ∧ P.degree ≤ 0 :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { have := P.is_equivalent_at_top_lead.tendsto_nhds h,
    by_cases hP : P.leading_coeff = 0,
    { simp only [hP, zero_mul, tendsto_const_nhds_iff] at this,
      refine ⟨trans hP this, by simp [leading_coeff_eq_zero.1 hP]⟩ },
    { rw [tendsto_const_mul_pow_nhds_iff hP, nat_degree_eq_zero_iff_degree_le_zero] at this,
      exact this.symm } },
  { refine P.is_equivalent_at_top_lead.symm.tendsto_nhds _,
    have : P.nat_degree = 0 := nat_degree_eq_zero_iff_degree_le_zero.2 h.2,
    simp only [h.1, this, pow_zero, mul_one],
    exact tendsto_const_nhds }
end

end polynomial_at_top

section polynomial_div_at_top

lemma is_equivalent_at_top_div :
  (λ x, (eval x P)/(eval x Q)) ~[at_top]
    λ x, P.leading_coeff/Q.leading_coeff * x^(P.nat_degree - Q.nat_degree : ℤ) :=
begin
  by_cases hP : P = 0,
  { simp [hP] },
  by_cases hQ : Q = 0,
  { simp [hQ] },
  refine (P.is_equivalent_at_top_lead.symm.div
          Q.is_equivalent_at_top_lead.symm).symm.trans
         (eventually_eq.is_equivalent ((eventually_gt_at_top 0).mono $ λ x hx, _)),
  simp [← div_mul_div_comm, hP, hQ, zpow_sub₀ hx.ne.symm]
end

lemma div_tendsto_zero_of_degree_lt (hdeg : P.degree < Q.degree) :
  tendsto (λ x, (eval x P)/(eval x Q)) at_top (𝓝 0) :=
begin
  by_cases hP : P = 0,
  { simp [hP, tendsto_const_nhds] },
  rw ←  nat_degree_lt_nat_degree_iff hP at hdeg,
  refine (is_equivalent_at_top_div P Q).symm.tendsto_nhds _,
  rw ← mul_zero,
  refine (tendsto_zpow_at_top_zero _).const_mul _,
  linarith
end

lemma div_tendsto_zero_iff_degree_lt (hQ : Q ≠ 0) :
  tendsto (λ x, (eval x P)/(eval x Q)) at_top (𝓝 0) ↔ P.degree < Q.degree :=
begin
  refine ⟨λ h, _, div_tendsto_zero_of_degree_lt P Q⟩,
  by_cases hPQ : P.leading_coeff / Q.leading_coeff = 0,
  { simp only [div_eq_mul_inv, inv_eq_zero, mul_eq_zero] at hPQ,
    cases hPQ with hP0 hQ0,
    { rw [leading_coeff_eq_zero.1 hP0, degree_zero],
      exact bot_lt_iff_ne_bot.2 (λ hQ', hQ (degree_eq_bot.1 hQ')) },
    { exact absurd (leading_coeff_eq_zero.1 hQ0) hQ } },
  { have := (is_equivalent_at_top_div P Q).tendsto_nhds h,
    rw tendsto_const_mul_zpow_at_top_nhds_iff hPQ at this,
    cases this with h h,
    { exact absurd h.2 hPQ },
    { rw [sub_lt_iff_lt_add, zero_add, int.coe_nat_lt] at h,
      exact degree_lt_degree h.1 } }
end

lemma div_tendsto_leading_coeff_div_of_degree_eq (hdeg : P.degree = Q.degree) :
  tendsto (λ x, (eval x P)/(eval x Q)) at_top (𝓝 $ P.leading_coeff / Q.leading_coeff) :=
begin
  refine (is_equivalent_at_top_div P Q).symm.tendsto_nhds _,
  rw show (P.nat_degree : ℤ) = Q.nat_degree, by simp [hdeg, nat_degree],
  simp [tendsto_const_nhds]
end

lemma div_tendsto_at_top_of_degree_gt' (hdeg : Q.degree < P.degree)
  (hpos : 0 < P.leading_coeff/Q.leading_coeff) :
  tendsto (λ x, (eval x P)/(eval x Q)) at_top at_top :=
begin
  have hQ : Q ≠ 0 := λ h, by {simp only [h, div_zero, leading_coeff_zero] at hpos, linarith},
  rw ← nat_degree_lt_nat_degree_iff hQ at hdeg,
  refine (is_equivalent_at_top_div P Q).symm.tendsto_at_top _,
  apply tendsto.const_mul_at_top hpos,
  apply tendsto_zpow_at_top_at_top,
  linarith
end

lemma div_tendsto_at_top_of_degree_gt (hdeg : Q.degree < P.degree)
  (hQ : Q ≠ 0) (hnng : 0 ≤ P.leading_coeff/Q.leading_coeff) :
  tendsto (λ x, (eval x P)/(eval x Q)) at_top at_top :=
have ratio_pos : 0 < P.leading_coeff/Q.leading_coeff,
  from lt_of_le_of_ne hnng
    (div_ne_zero (λ h, ne_zero_of_degree_gt hdeg $ leading_coeff_eq_zero.mp h)
      (λ h, hQ $ leading_coeff_eq_zero.mp h)).symm,
div_tendsto_at_top_of_degree_gt' P Q hdeg ratio_pos

lemma div_tendsto_at_bot_of_degree_gt' (hdeg : Q.degree < P.degree)
  (hneg : P.leading_coeff/Q.leading_coeff < 0) :
  tendsto (λ x, (eval x P)/(eval x Q)) at_top at_bot :=
begin
  have hQ : Q ≠ 0 := λ h, by {simp only [h, div_zero, leading_coeff_zero] at hneg, linarith},
  rw ← nat_degree_lt_nat_degree_iff hQ at hdeg,
  refine (is_equivalent_at_top_div P Q).symm.tendsto_at_bot _,
  apply tendsto.neg_const_mul_at_top hneg,
  apply tendsto_zpow_at_top_at_top,
  linarith
end

lemma div_tendsto_at_bot_of_degree_gt (hdeg : Q.degree < P.degree)
  (hQ : Q ≠ 0) (hnps : P.leading_coeff/Q.leading_coeff ≤ 0) :
  tendsto (λ x, (eval x P)/(eval x Q)) at_top at_bot :=
have ratio_neg : P.leading_coeff/Q.leading_coeff < 0,
  from lt_of_le_of_ne hnps
    (div_ne_zero (λ h, ne_zero_of_degree_gt hdeg $ leading_coeff_eq_zero.mp h)
      (λ h, hQ $ leading_coeff_eq_zero.mp h)),
div_tendsto_at_bot_of_degree_gt' P Q hdeg ratio_neg

lemma abs_div_tendsto_at_top_of_degree_gt (hdeg : Q.degree < P.degree)
  (hQ : Q ≠ 0) :
  tendsto (λ x, |(eval x P)/(eval x Q)|) at_top at_top :=
begin
  by_cases h : 0 ≤ P.leading_coeff/Q.leading_coeff,
  { exact tendsto_abs_at_top_at_top.comp (P.div_tendsto_at_top_of_degree_gt Q hdeg hQ h) },
  { push_neg at h,
    exact tendsto_abs_at_bot_at_top.comp (P.div_tendsto_at_bot_of_degree_gt Q hdeg hQ h.le) }
end

end polynomial_div_at_top

theorem is_O_of_degree_le (h : P.degree ≤ Q.degree) :
  (λ x, eval x P) =O[at_top] (λ x, eval x Q) :=
begin
  by_cases hp : P = 0,
  { simpa [hp] using is_O_zero (λ x, eval x Q) at_top },
  { have hq : Q ≠ 0 := ne_zero_of_degree_ge_degree h hp,
    have hPQ : ∀ᶠ (x : 𝕜) in at_top, eval x Q = 0 → eval x P = 0 :=
      filter.mem_of_superset (polynomial.eventually_no_roots Q hq) (λ x h h', absurd h' h),
    cases le_iff_lt_or_eq.mp h with h h,
    { exact is_O_of_div_tendsto_nhds hPQ 0 (div_tendsto_zero_of_degree_lt P Q h) },
    { exact is_O_of_div_tendsto_nhds hPQ _ (div_tendsto_leading_coeff_div_of_degree_eq P Q h) } }
end

end polynomial


import ..lectures.love12_basic_mathematical_structures_demo
import data.int.gcd

/-! # LoVe Homework 7: Basic Mathematical Structures

This homework covers Ch 12 of the HHG.

-/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1: Numbers and embeddings (5 points)

We start with some questions to get you used to the "numeral tactics".

Remember that:
* `norm_num` will simplify numeral expressions without variables.
* `norm_cast` will simplify expressions with coercions.
* If you have an assumption `hx`, you can also `norm_cast at hx`.
* `exact_mod_cast h` is like `exact h`, except it will call `norm_cast` on `h` and the goal.

1.1 (1 point).
Use these tactics to solve the following problems.
-/

lemma num1 : 12345 < 67890 :=
sorry

lemma num2 {α : Type} [linear_ordered_field α] : 123 + 45 < 67890/3 :=
sorry

lemma num3 (x : ℤ) (hx : (x : ℝ) < 25*100) : x < 25*100 :=
sorry

/-!
1.2 (1 point). For each of these statements, either prove it, or prove its negation.
Think about why the statement (or its negation) is true!
-/

lemma num4 : 7/3 > 2 :=
sorry

lemma num5 : 40 - (2*30) + 20 = 0 :=
sorry

lemma num6 : 5 / (2 - 1 - 1) + 8 = 2 * 4 :=
sorry

/-!
1.3 (3 points).

This seems like a very natural way to write the theorem
"If `a` and `b` are coprime, then there are coefficients `u` and `v` such that `u*a + v*b = 1`."
But I've made a mistake! What did I do wrong? Correct the statement of the theorem and prove it.

You'll probably find the lemmas `nat.gcd_eq_gcd_ab` and `nat.coprime.gcd_eq_one` helpful.
-/
#check nat.gcd_eq_gcd_ab
#check nat.coprime.gcd_eq_one

lemma sum_eq_one_of_coprime (a b : ℕ) (h : nat.coprime a b) : ∃ u v, u*a+v*b = 1 :=
sorry

/-! ## Question 2: algebraic lemmas and classes (7 points)

2.1. (2 points) State and prove a lemma that says:
for any element `x` of an additive monoid, if `x` has a left inverse `y`
and a right inverse `z`, then `y = z`.
-/

-- your answer here

/-!
2.2 (2 points). A `rng` (not a random number generator)
is an algebraic structure like a ring, but that does not require
a multiplicative identity element.
<https://en.wikipedia.org/wiki/Rng_(algebra)>

Define a type class `rng` that represents the structure, in the style of
the "monolithic group" from the Ch 12 demo.
That is, your structure should not extend existing structures:
bundle all of the necessary axioms into your definition.
-/

#check monolithic_group.group

@[class] structure rng (α : Type) : Type :=
sorry

/-! 2.3 (2 points). Define an instance that shows that any `rng` is an `add_monoid`. -/

instance {α : Type} [rng α] : add_monoid α :=
sorry

/-! 2.4 (1 point). Show that for any `α : Type`, the type of functions `α → α` is
a monoid under the composition operator: `f * g = λ x, f (g x))`
-/

instance (α : Type) : monoid (α → α) :=
sorry

end LoVe


import data.real.basic
import tactic
-- import C_Limits.fae_solutions.Course
-- open vilnius

namespace vilnius

--local notation `|` x `|` := abs x

-- Recall the
definition is_limit (a : ℕ → ℝ) (l : ℝ) : Prop :=
∀ ε > 0, ∃ N, ∀ n ≥ N, | a n - l | < ε

example {a : ℕ → ℝ} {l : ℝ} (c : ℝ) (ha : is_limit a l) :
  is_limit (λ i, a i + c) (l + c) :=
begin
  intros e se,
  specialize ha e se,
  cases ha with N ha,
  use N,
  intros n sn,
  simp,
  specialize ha n sn,
  exact ha,
end

example (a : ℕ → ℝ) (l : ℝ) :
  is_limit a l ↔ is_limit (λ i, a i - l) 0 :=
begin
  split,
  intros ha e se,
  specialize ha e se,
  cases ha with N ha,
  use N,
  intros n sn,
  simp,
  specialize ha n sn,
  exact ha,

  intros ha e se,
  specialize ha e se,
  cases ha with N ha,
  use N,
  intros n sn,
  specialize ha n sn,
  simp only [tsub_zero] at ha,
  exact ha,
end

/- Helpful things:
'squeeze_simp' décrit ce que simp fait
`abs_pos : 0 < |a| ↔ a ≠ 0`
`div_pos : 0 < a → 0 < b → 0 < a / b`
`abs_mul x y : |x * y| = |x| * |y|`
`lt_div_iff' : 0 < c → (a < b / c ↔ c * a < b)`
I typically find these things myself with a combination of
the "guess the name of the lemma" game (and ctrl-space).

Recall also that we have proved the-/
theorem is_limit_add {a b : ℕ → ℝ} {l m : ℝ}
  (h1 : is_limit a l) (h2 : is_limit b m) :
  is_limit (a + b) (l + m) :=
  begin
    intros e se,
    specialize h1 (e/2),
    specialize h2 (e/2),
    have h: e/2 > 0,
    apply div_pos,
    exact se,
    exact two_pos,
    specialize h1 h,
    specialize h2 h,

    cases h1 with N1 h1,
    cases h2 with N2 h2,
    use max N1 N2,
    intros n sn,
    simp,
    rewrite <- sub_sub,
    rw ← add_sub,
    rw sub_eq_add_neg _ l,
    rw add_comm _ (-l),
    rw ← add_assoc,
    rw ← sub_eq_add_neg,
    rw sub_eq_add_neg _ m,
    rw add_assoc (a n - l) (b n) (- m),
    rw ← sub_eq_add_neg _ m,
    apply lt_of_le_of_lt,
    apply abs_add (a n -l) (b n -m) ,
    rw ← add_halves e,
    apply add_lt_add (h1 n _) (h2 n _),
    apply le_of_max_le_left,
    exact sn,
    apply le_of_max_le_left,
    rw max_comm,
    exact sn,
  end

-- And now, over to you!

-- A hint for starting:
-- It might be worth dealing with `c = 0` as a special case. You
-- can start with
-- `by_cases hc : c = 0`

theorem is_limit_mul_const_left {a : ℕ → ℝ} {l c : ℝ} (h : is_limit a l) :
  is_limit (λ n, c * (a n)) (c * l) :=
begin
  by_cases hc : c=0,
  intros e se,
  rewrite hc,
  simp only [ge_iff_le, zero_mul, tsub_zero, abs_zero],
  use 0,
  intros n sn,
  exact se,

  intros e se,
  specialize h (e/|c|),
  have hec : e/|c| > 0,
    apply div_pos,
    exact se,
    rw abs_pos,
    exact hc,
  specialize h hec,
  cases h with N h,
  use N,
  intros n sn,
  simp only,
  rewrite <- mul_sub,
  rewrite abs_mul,
  have hc' : 0 < |c|,
    rewrite abs_pos,
    exact hc,
  rewrite mul_comm,
  rewrite ← lt_div_iff hc',
  exact h n sn,
end

theorem sandwich (a b c : ℕ → ℝ)
  (l : ℝ) (ha : is_limit a l) (hc : is_limit c l)
  (hab : ∀ n, a n ≤ b n) (hbc : ∀ n, b n ≤ c n) : is_limit b l :=
begin
  intros e se,
  specialize ha e se,
  specialize hc e se,
  cases ha with na ha,
  cases hc with nc hc,
  use max na nc,
  intros n sn,
  specialize hab n,
  specialize hbc n,
  specialize ha n,
  specialize hc n,
  specialize ha (le_of_max_le_left sn),
  specialize hc (le_of_max_le_right sn),
  rewrite abs_sub_lt_iff,
  split,

  rewrite sub_lt_iff_lt_add,
  apply lt_of_lt_of_le',
  rewrite ← sub_lt_iff_lt_add,
  apply lt_of_abs_lt,
  use hc,
  exact hbc,

  rewrite sub_lt,
  apply lt_of_lt_of_le,
  swap,
  use hab,
  rewrite ← sub_lt,
  apply lt_of_abs_lt,
  rewrite abs_sub_comm,
  exact ha,
end

example (a : ℕ → ℝ) (b : ℕ → ℝ) (α β c d : ℝ)
    (ha : is_limit a α) (hb : is_limit b β) :
    is_limit ( λ n, c * (a n) + d * (b n) ) (c * α + d * β) :=
begin
  -- intros ε hε,**BAD IDEA**, you can do this much faster using the above theorems!
  apply is_limit_add,
  apply is_limit_mul_const_left,
  exact ha,

  apply is_limit_mul_const_left,
  exact hb,
end

example (a : ℕ → ℝ) (b : ℕ → ℝ)
  (l : ℝ) (m : ℝ) (hl : is_limit a l) (hm : is_limit b m)
  (hle : ∀ n, a n ≤ b n) : l ≤ m :=
begin
  sorry,
end

end vilnius