/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author:  Aaron Anderson.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.complete_boolean_algebra
import Mathlib.order.modular_lattice
import Mathlib.data.fintype.basic
import Mathlib.PostPort

universes u_1 l u_2

namespace Mathlib

/-!
# Atoms, Coatoms, and Simple Lattices

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_lattice` indicates that a bounded lattice has only two elements, `⊥` and `⊤`.
  * `is_simple_lattice.bounded_distrib_lattice`
  * Given an instance of `is_simple_lattice`, we provide the following definitions. These are not
    made global instances as they contain data :
    * `is_simple_lattice.boolean_algebra`
    * `is_simple_lattice.complete_lattice`
    * `is_simple_lattice.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_lattice_iff_is_atom_top` and `is_simple_lattice_iff_is_coatom_bot` express the
  connection between atoms, coatoms, and simple lattices

-/

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

theorem eq_bot_or_eq_of_le_atom {α : Type u_1} [order_bot α] {a : α} {b : α} (ha : is_atom a) (hab : b ≤ a) : b = ⊥ ∨ b = a :=
  or.imp_left (and.right ha b) (has_le.le.lt_or_eq hab)

theorem is_atom.Iic {α : Type u_1} [order_bot α] {x : α} {a : α} (ha : is_atom a) (hax : a ≤ x) : is_atom { val := a, property := hax } := sorry

theorem is_atom.of_is_atom_coe_Iic {α : Type u_1} [order_bot α] {x : α} {a : ↥(set.Iic x)} (ha : is_atom a) : is_atom ↑a := sorry

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

theorem eq_top_or_eq_of_coatom_le {α : Type u_1} [order_top α] {a : α} {b : α} (ha : is_coatom a) (hab : a ≤ b) : b = ⊤ ∨ b = a :=
  or.imp (and.right ha b) (iff.mpr eq_comm) (has_le.le.lt_or_eq hab)

theorem is_coatom.Ici {α : Type u_1} [order_top α] {x : α} {a : α} (ha : is_coatom a) (hax : x ≤ a) : is_coatom { val := a, property := hax } := sorry

theorem is_coatom.of_is_coatom_coe_Ici {α : Type u_1} [order_top α] {x : α} {a : ↥(set.Ici x)} (ha : is_coatom a) : is_coatom ↑a := sorry

theorem is_atom.inf_eq_bot_of_ne {α : Type u_1} [semilattice_inf_bot α] {a : α} {b : α} (ha : is_atom a) (hb : is_atom b) (hab : a ≠ b) : a ⊓ b = ⊥ := sorry

theorem is_atom.disjoint_of_ne {α : Type u_1} [semilattice_inf_bot α] {a : α} {b : α} (ha : is_atom a) (hb : is_atom b) (hab : a ≠ b) : disjoint a b :=
  iff.mpr disjoint_iff (is_atom.inf_eq_bot_of_ne ha hb hab)

theorem is_coatom.sup_eq_top_of_ne {α : Type u_1} [semilattice_sup_top α] {a : α} {b : α} (ha : is_coatom a) (hb : is_coatom b) (hab : a ≠ b) : a ⊔ b = ⊤ := sorry

@[simp] theorem is_coatom_dual_iff_is_atom {α : Type u_1} [bounded_lattice α] {a : α} : is_coatom (coe_fn order_dual.to_dual a) ↔ is_atom a :=
  iff.refl (is_coatom (coe_fn order_dual.to_dual a))

@[simp] theorem is_atom_dual_iff_is_coatom {α : Type u_1} [bounded_lattice α] {a : α} : is_atom (coe_fn order_dual.to_dual a) ↔ is_coatom a :=
  iff.refl (is_atom (coe_fn order_dual.to_dual a))

/-- A lattice is atomic iff every element other than `⊥` has an atom below it. -/
class is_atomic (α : Type u_1) [bounded_lattice α]
where
  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. -/
class is_coatomic (α : Type u_1) [bounded_lattice α]
where
  eq_top_or_exists_le_coatom : ∀ (b : α), b = ⊤ ∨ ∃ (a : α), is_coatom a ∧ b ≤ a

@[simp] theorem is_coatomic_dual_iff_is_atomic {α : Type u_1} [bounded_lattice α] : is_coatomic (order_dual α) ↔ is_atomic α :=
  { mp := fun (h : is_coatomic (order_dual α)) => is_atomic.mk fun (b : α) => eq_top_or_exists_le_coatom b,
    mpr := fun (h : is_atomic α) => is_coatomic.mk fun (b : order_dual α) => eq_bot_or_exists_atom_le b }

@[simp] theorem is_atomic_dual_iff_is_coatomic {α : Type u_1} [bounded_lattice α] : is_atomic (order_dual α) ↔ is_coatomic α :=
  { mp := fun (h : is_atomic (order_dual α)) => is_coatomic.mk fun (b : α) => eq_bot_or_exists_atom_le b,
    mpr := fun (h : is_coatomic α) => is_atomic.mk fun (b : order_dual α) => eq_top_or_exists_le_coatom b }

namespace is_atomic

protected instance is_coatomic_dual {α : Type u_1} [bounded_lattice α] [h : is_atomic α] : is_coatomic (order_dual α) :=
  iff.mpr is_coatomic_dual_iff_is_atomic h

protected instance set.Iic.is_atomic {α : Type u_1} [bounded_lattice α] [is_atomic α] {x : α} : is_atomic ↥(set.Iic x) :=
  mk fun (_x : ↥(set.Iic x)) => sorry

end is_atomic

namespace is_coatomic

protected instance is_coatomic {α : Type u_1} [bounded_lattice α] [h : is_coatomic α] : is_atomic (order_dual α) :=
  iff.mpr is_atomic_dual_iff_is_coatomic h

protected instance set.Ici.is_coatomic {α : Type u_1} [bounded_lattice α] [is_coatomic α] {x : α} : is_coatomic ↥(set.Ici x) :=
  mk fun (_x : ↥(set.Ici x)) => sorry

end is_coatomic

theorem is_atomic_iff_forall_is_atomic_Iic {α : Type u_1} [bounded_lattice α] : is_atomic α ↔ ∀ (x : α), is_atomic ↥(set.Iic x) := sorry

theorem is_coatomic_iff_forall_is_coatomic_Ici {α : Type u_1} [bounded_lattice α] : is_coatomic α ↔ ∀ (x : α), is_coatomic ↥(set.Ici x) :=
  iff.trans (iff.symm is_atomic_dual_iff_is_coatomic)
    (iff.trans is_atomic_iff_forall_is_atomic_Iic
      (forall_congr fun (x : order_dual α) => iff.trans (iff.symm is_coatomic_dual_iff_is_atomic) iff.rfl))

/-- A lattice is atomistic iff every element is a `Sup` of a set of atoms. -/
class is_atomistic (α : Type u_1) [complete_lattice α]
where
  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 (α : Type u_1) [complete_lattice α]
where
  eq_Inf_coatoms : ∀ (b : α), ∃ (s : set α), b = Inf s ∧ ∀ (a : α), a ∈ s → is_coatom a

@[simp] theorem is_coatomistic_dual_iff_is_atomistic {α : Type u_1} [complete_lattice α] : is_coatomistic (order_dual α) ↔ is_atomistic α :=
  { mp := fun (h : is_coatomistic (order_dual α)) => is_atomistic.mk fun (b : α) => eq_Inf_coatoms b,
    mpr := fun (h : is_atomistic α) => is_coatomistic.mk fun (b : order_dual α) => eq_Sup_atoms b }

@[simp] theorem is_atomistic_dual_iff_is_coatomistic {α : Type u_1} [complete_lattice α] : is_atomistic (order_dual α) ↔ is_coatomistic α :=
  { mp := fun (h : is_atomistic (order_dual α)) => is_coatomistic.mk fun (b : α) => eq_Sup_atoms b,
    mpr := fun (h : is_coatomistic α) => is_atomistic.mk fun (b : order_dual α) => eq_Inf_coatoms b }

namespace is_atomistic

protected instance is_coatomistic_dual {α : Type u_1} [complete_lattice α] [h : is_atomistic α] : is_coatomistic (order_dual α) :=
  iff.mpr is_coatomistic_dual_iff_is_atomistic h

protected instance is_atomic {α : Type u_1} [complete_lattice α] [is_atomistic α] : is_atomic α := sorry

end is_atomistic

namespace is_coatomistic

protected instance is_atomistic_dual {α : Type u_1} [complete_lattice α] [h : is_coatomistic α] : is_atomistic (order_dual α) :=
  iff.mpr is_atomistic_dual_iff_is_coatomistic h

protected instance is_coatomic {α : Type u_1} [complete_lattice α] [is_coatomistic α] : is_coatomic α := sorry

end is_coatomistic

/-- A lattice is simple iff it has only two elements, `⊥` and `⊤`. -/
class is_simple_lattice (α : Type u_2) [bounded_lattice α]
extends nontrivial α
where
  eq_bot_or_eq_top : ∀ (a : α), a = ⊥ ∨ a = ⊤

theorem is_simple_lattice_iff_is_simple_lattice_order_dual {α : Type u_1} [bounded_lattice α] : is_simple_lattice α ↔ is_simple_lattice (order_dual α) := sorry

protected instance order_dual.is_simple_lattice {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] : is_simple_lattice (order_dual α) :=
  iff.mp is_simple_lattice_iff_is_simple_lattice_order_dual _inst_2

@[simp] theorem is_atom_top {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] : is_atom ⊤ :=
  { left := top_ne_bot, right := fun (a : α) (ha : a < ⊤) => or.resolve_right (eq_bot_or_eq_top a) (ne_of_lt ha) }

@[simp] theorem is_coatom_bot {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] : is_coatom ⊥ :=
  iff.mp is_atom_dual_iff_is_coatom is_atom_top

namespace is_simple_lattice

/-- A simple `bounded_lattice` is also distributive. -/
protected instance bounded_distrib_lattice {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] : bounded_distrib_lattice α :=
  bounded_distrib_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry sorry sorry sorry
    bounded_lattice.inf sorry sorry sorry sorry bounded_lattice.top sorry bounded_lattice.bot sorry

protected instance is_atomic {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] : is_atomic α :=
  is_atomic.mk
    fun (b : α) =>
      or.imp_right (fun (h : b = ⊤) => Exists.intro ⊤ { left := is_atom_top, right := ge_of_eq h }) (eq_bot_or_eq_top b)

protected instance is_coatomic {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] : is_coatomic α :=
  iff.mp is_atomic_dual_iff_is_coatomic is_simple_lattice.is_atomic

/-- Every simple lattice is order-isomorphic to `bool`. -/
def order_iso_bool {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] [DecidableEq α] : α ≃o Bool :=
  rel_iso.mk (equiv.mk (fun (x : α) => to_bool (x = ⊤)) (fun (x : Bool) => cond x ⊤ ⊥) sorry sorry) sorry

protected instance fintype {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] [DecidableEq α] : fintype α :=
  fintype.of_equiv Bool (equiv.symm (rel_iso.to_equiv order_iso_bool))

/-- A simple `bounded_lattice` is also a `boolean_algebra`. -/
protected def boolean_algebra {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] [DecidableEq α] : boolean_algebra α :=
  boolean_algebra.mk bounded_distrib_lattice.sup bounded_distrib_lattice.le bounded_distrib_lattice.lt sorry sorry sorry
    sorry sorry sorry bounded_distrib_lattice.inf sorry sorry sorry sorry bounded_distrib_lattice.top sorry
    bounded_distrib_lattice.bot sorry (fun (x : α) => ite (x = ⊥) ⊤ ⊥) (fun (x y : α) => ite (x = ⊤ ∧ y = ⊥) ⊤ ⊥) sorry
    sorry sorry

/-- A simple `bounded_lattice` is also complete. -/
protected def complete_lattice {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] : complete_lattice α :=
  complete_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry sorry sorry sorry
    bounded_lattice.inf sorry sorry sorry bounded_lattice.top sorry bounded_lattice.bot sorry
    (fun (s : set α) => ite (⊤ ∈ s) ⊤ ⊥) (fun (s : set α) => ite (⊥ ∈ s) ⊥ ⊤) sorry sorry sorry sorry

/-- A simple `bounded_lattice` is also a `complete_boolean_algebra`. -/
protected def complete_boolean_algebra {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] : complete_boolean_algebra α :=
  complete_boolean_algebra.mk complete_lattice.sup complete_lattice.le complete_lattice.lt sorry sorry sorry sorry sorry
    sorry complete_lattice.inf sorry sorry sorry sorry complete_lattice.top sorry complete_lattice.bot sorry
    boolean_algebra.compl boolean_algebra.sdiff sorry sorry sorry complete_lattice.Sup complete_lattice.Inf sorry sorry
    sorry sorry sorry sorry

end is_simple_lattice

namespace is_simple_lattice

protected instance is_atomistic {α : Type u_1} [complete_lattice α] [is_simple_lattice α] : is_atomistic α :=
  is_atomistic.mk
    fun (b : α) =>
      or.elim (eq_bot_or_eq_top b)
        (fun (h : b = ⊥) =>
          Exists.intro ∅
            { left := Eq.trans h (Eq.symm Sup_empty),
              right := fun (a : α) (ha : a ∈ ∅) => false.elim (set.not_mem_empty a ha) })
        fun (h : b = ⊤) =>
          Exists.intro (singleton ⊤)
            { left := Eq.trans h (Eq.symm Sup_singleton),
              right := fun (a : α) (ha : a ∈ singleton ⊤) => Eq.symm (iff.mp set.mem_singleton_iff ha) ▸ is_atom_top }

protected instance is_coatomistic {α : Type u_1} [complete_lattice α] [is_simple_lattice α] : is_coatomistic α :=
  iff.mp is_atomistic_dual_iff_is_coatomistic is_simple_lattice.is_atomistic

end is_simple_lattice

namespace fintype

namespace is_simple_lattice

theorem univ {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] [DecidableEq α] : finset.univ = insert ⊤ (singleton ⊥) := sorry

theorem card {α : Type u_1} [bounded_lattice α] [is_simple_lattice α] [DecidableEq α] : card α = bit0 1 :=
  Eq.trans (of_equiv_card (equiv.symm (rel_iso.to_equiv is_simple_lattice.order_iso_bool))) card_bool

end is_simple_lattice

end fintype

namespace bool

protected instance is_simple_lattice : is_simple_lattice Bool :=
  is_simple_lattice.mk
    fun (a : Bool) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (a = ⊥ ∨ a = ⊤)) (Eq.symm (propext finset.mem_singleton))))
        (eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ singleton ⊥ ∨ a = ⊤)) (propext or.comm)))
          (eq.mpr (id (Eq._oldrec (Eq.refl (a = ⊤ ∨ a ∈ singleton ⊥)) (Eq.symm (propext finset.mem_insert))))
            (eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ insert ⊤ (singleton ⊥))) top_eq_tt))
              (eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ insert tt (singleton ⊥))) bot_eq_ff))
                (eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ insert tt (singleton false))) (Eq.symm fintype.univ_bool)))
                  (finset.mem_univ a))))))

end bool

theorem is_simple_lattice_iff_is_atom_top {α : Type u_1} [bounded_lattice α] : is_simple_lattice α ↔ is_atom ⊤ := sorry

theorem is_simple_lattice_iff_is_coatom_bot {α : Type u_1} [bounded_lattice α] : is_simple_lattice α ↔ is_coatom ⊥ :=
  iff.trans is_simple_lattice_iff_is_simple_lattice_order_dual is_simple_lattice_iff_is_atom_top

namespace set

theorem is_simple_lattice_Iic_iff_is_atom {α : Type u_1} [bounded_lattice α] {a : α} : is_simple_lattice ↥(Iic a) ↔ is_atom a := sorry

theorem is_simple_lattice_Ici_iff_is_coatom {α : Type u_1} [bounded_lattice α] {a : α} : is_simple_lattice ↥(Ici a) ↔ is_coatom a := sorry

end set

namespace order_iso

@[simp] theorem is_atom_iff {α : Type u_1} [bounded_lattice α] {β : Type u_2} [bounded_lattice β] (f : α ≃o β) (a : α) : is_atom (coe_fn f a) ↔ is_atom a := sorry

@[simp] theorem is_coatom_iff {α : Type u_1} [bounded_lattice α] {β : Type u_2} [bounded_lattice β] (f : α ≃o β) (a : α) : is_coatom (coe_fn f a) ↔ is_coatom a :=
  is_atom_iff (order_iso.dual f) a

theorem is_simple_lattice_iff {α : Type u_1} [bounded_lattice α] {β : Type u_2} [bounded_lattice β] (f : α ≃o β) : is_simple_lattice α ↔ is_simple_lattice β := sorry

theorem is_simple_lattice {α : Type u_1} [bounded_lattice α] {β : Type u_2} [bounded_lattice β] [h : is_simple_lattice β] (f : α ≃o β) : is_simple_lattice α :=
  iff.mpr (is_simple_lattice_iff f) h

end order_iso

namespace is_compl

theorem is_atom_iff_is_coatom {α : Type u_1} [bounded_lattice α] [is_modular_lattice α] {a : α} {b : α} (hc : is_compl a b) : is_atom a ↔ is_coatom b :=
  iff.trans (iff.symm set.is_simple_lattice_Iic_iff_is_atom)
    (iff.trans (order_iso.is_simple_lattice_iff (Iic_order_iso_Ici hc)) set.is_simple_lattice_Ici_iff_is_coatom)

theorem is_coatom_iff_is_atom {α : Type u_1} [bounded_lattice α] [is_modular_lattice α] {a : α} {b : α} (hc : is_compl a b) : is_coatom a ↔ is_atom b :=
  iff.symm (is_atom_iff_is_coatom (is_compl.symm hc))


/-
Copyright (c) 2021 Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa
-/
import data.zmod.basic
import ring_theory.subsemiring.basic
import algebra.order.monoid
/-!

A `canonically_ordered_comm_semiring` with two different elements `a` and `b` such that
`a ≠ b` and `2 * a = 2 * b`.  Thus, multiplication by a fixed non-zero element of a canonically
ordered semiring need not be injective.  In particular, multiplying by a strictly positive element
need not be strictly monotone.

Recall that a `canonically_ordered_comm_semiring` is a commutative semiring with a partial ordering
that is "canonical" in the sense that the inequality `a ≤ b` holds if and only if there is a `c`
such that `a + c = b`.  There are several compatibility conditions among addition/multiplication
and the order relation.  The point of the counterexample is to show that monotonicity of
multiplication cannot be strengthened to **strict** monotonicity.

Reference:
https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/canonically_ordered.20pathology
-/

namespace from_Bhavik

/--  Bhavik Mehta's example.  There are only the initial definitions, but no proofs.  The Type
`K` is a canonically ordered commutative semiring with the property that `2 * (1/2) ≤ 2 * 1`, even
though it is not true that `1/2 ≤ 1`, since `1/2` and `1` are not comparable. -/
@[derive [comm_semiring]]
def K : Type := subsemiring.closure ({1.5} : set ℚ)

instance : has_coe K ℚ := ⟨λ x, x.1⟩

instance inhabited_K : inhabited K := ⟨0⟩

instance : preorder K :=
{ le := λ x y, x = y ∨ (x : ℚ) + 1 ≤ (y : ℚ),
  le_refl := λ x, or.inl rfl,
  le_trans := λ x y z xy yz,
  begin
    rcases xy with (rfl | _), { apply yz },
    rcases yz with (rfl | _), { right, apply xy },
    right,
    exact xy.trans (le_trans ((le_add_iff_nonneg_right _).mpr zero_le_one) yz)
  end }

end from_Bhavik

lemma mem_zmod_2 (a : zmod 2) : a = 0 ∨ a = 1 :=
begin
  rcases a with ⟨_ | _ | _ | _ | a_val, _ | ⟨_, _ | ⟨_, ⟨⟩⟩⟩⟩,
  { exact or.inl rfl },
  { exact or.inr rfl },
end

lemma add_self_zmod_2 (a : zmod 2) : a + a = 0 :=
begin
  rcases mem_zmod_2 a with rfl | rfl;
  refl,
end

namespace Nxzmod_2

variables {a b : ℕ × zmod 2}

/-- The preorder relation on `ℕ × ℤ/2ℤ` where we only compare the first coordinate,
except that we leave incomparable each pair of elements with the same first component.
For instance, `∀ α, β ∈ ℤ/2ℤ`, the inequality `(1,α) ≤ (2,β)` holds,
whereas, `∀ n ∈ ℤ`, the elements `(n,0)` and `(n,1)` are incomparable. -/
instance preN2 : partial_order (ℕ × zmod 2) :=
{ le := λ x y, x = y ∨ x.1 < y.1,
  le_refl := λ a, or.inl rfl,
  le_trans := λ x y z xy yz,
  begin
    rcases xy with (rfl | _),
    { exact yz },
    { rcases yz with (rfl | _),
      { exact or.inr xy},
      { exact or.inr (xy.trans yz) } }
  end,
  le_antisymm := begin
    intros a b ab ba,
    cases ab with ab ab,
    { exact ab },
    { cases ba with ba ba,
      { exact ba.symm },
      { exact (nat.lt_asymm ab ba).elim } }
  end }

instance csrN2 : comm_semiring (ℕ × zmod 2) := by apply_instance

instance csrN2_1 : add_cancel_comm_monoid (ℕ × zmod 2) :=
{ add_left_cancel := λ a b c h, (add_right_inj a).mp h,
  ..Nxzmod_2.csrN2 }

/-- A strict inequality forces the first components to be different. -/
@[simp] lemma lt_def : a < b ↔ a.1 < b.1 :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { rcases h with ⟨(rfl | a1), h1⟩,
    { exact ((not_or_distrib.mp h1).1).elim rfl },
    { exact a1 } },
  refine ⟨or.inr h, not_or_distrib.mpr ⟨λ k, _, not_lt.mpr h.le⟩⟩,
  rw k at h,
  exact nat.lt_asymm h h
end

lemma add_left_cancel : ∀ (a b c : ℕ × zmod 2), a + b = a + c → b = c :=
λ a b c h, (add_right_inj a).mp h

lemma add_le_add_left : ∀ (a b : ℕ × zmod 2), a ≤ b → ∀ (c : ℕ × zmod 2), c + a ≤ c + b :=
begin
  rintros a b (rfl | ab) c,
  { refl },
  { exact or.inr (by simpa) }
end

lemma le_of_add_le_add_left : ∀ (a b c : ℕ × zmod 2), a + b ≤ a + c → b ≤ c :=
begin
  rintros a b c (bc | bc),
  { exact le_of_eq ((add_right_inj a).mp bc) },
  { exact or.inr (by simpa using bc) }
end

lemma zero_le_one : (0 : ℕ × zmod 2) ≤ 1 := dec_trivial

lemma mul_lt_mul_of_pos_left : ∀ (a b c : ℕ × zmod 2), a < b → 0 < c → c * a < c * b :=
λ a b c ab c0, lt_def.mpr ((mul_lt_mul_left (lt_def.mp c0)).mpr (lt_def.mp ab))

lemma mul_lt_mul_of_pos_right : ∀ (a b c : ℕ × zmod 2), a < b → 0 < c → a * c < b * c :=
λ a b c ab c0, lt_def.mpr ((mul_lt_mul_right (lt_def.mp c0)).mpr (lt_def.mp ab))

instance ocsN2 : ordered_comm_semiring (ℕ × zmod 2) :=
{ add_le_add_left := add_le_add_left,
  le_of_add_le_add_left := le_of_add_le_add_left,
  zero_le_one := zero_le_one,
  mul_lt_mul_of_pos_left := mul_lt_mul_of_pos_left,
  mul_lt_mul_of_pos_right := mul_lt_mul_of_pos_right,
  ..Nxzmod_2.csrN2_1,
  ..(infer_instance : partial_order (ℕ × zmod 2)),
  ..(infer_instance : comm_semiring (ℕ × zmod 2)) }

end Nxzmod_2

namespace ex_L

open Nxzmod_2 subtype

/-- Initially, `L` was defined as the subsemiring closure of `(1,0)`. -/
def L : Type := { l : (ℕ × zmod 2) // l ≠ (0, 1) }

instance zero : has_zero L := ⟨⟨(0, 0), dec_trivial⟩⟩

instance one : has_one L := ⟨⟨(1, 1), dec_trivial⟩⟩

instance inhabited : inhabited L := ⟨1⟩

lemma add_L {a b : ℕ × zmod 2} (ha : a ≠ (0, 1)) (hb : b ≠ (0, 1)) :
  a + b ≠ (0, 1) :=
begin
  rcases a with ⟨a, a2⟩,
  rcases b with ⟨b, b2⟩,
  cases b,
  { rcases mem_zmod_2 b2 with rfl | rfl,
    { simp [ha] },
    { simpa only } },
  { simp [(a + b).succ_ne_zero] }
end

lemma mul_L {a b : ℕ × zmod 2} (ha : a ≠ (0, 1)) (hb : b ≠ (0, 1)) :
  a * b ≠ (0, 1) :=
begin
  rcases a with ⟨a, a2⟩,
  rcases b with ⟨b, b2⟩,
  cases b,
  { rcases mem_zmod_2 b2 with rfl | rfl;
    rcases mem_zmod_2 a2 with rfl | rfl;
    -- while this looks like a non-terminal `simp`, it (almost) isn't: there is only one goal where
    -- it does not finish the proof and on that goal it asks to prove `false`
    simp,
    exact hb rfl },
  cases a,
  { rcases mem_zmod_2 b2 with rfl | rfl;
    rcases mem_zmod_2 a2 with rfl | rfl;
    -- while this looks like a non-terminal `simp`, it (almost) isn't: there is only one goal where
    -- it does not finish the proof and on that goal it asks to prove `false`
    simp,
    exact ha rfl },
  { simp [mul_ne_zero _ _, nat.succ_ne_zero _] }
end

instance has_add_L : has_add L :=
{ add := λ ⟨a, ha⟩ ⟨b, hb⟩, ⟨a + b, add_L ha hb⟩ }

instance : has_mul L :=
{ mul := λ ⟨a, ha⟩ ⟨b, hb⟩, ⟨a * b, mul_L ha hb⟩ }

instance : ordered_comm_semiring L :=
begin
  refine function.injective.ordered_comm_semiring _ subtype.coe_injective rfl rfl _ _;
  { refine λ x y, _,
    cases x,
    cases y,
    refl }
end

lemma bot_le : ∀ (a : L), 0 ≤ a :=
begin
  rintros ⟨⟨an, a2⟩, ha⟩,
  cases an,
  { rcases mem_zmod_2 a2 with (rfl | rfl),
    { refl, },
    { exact (ha rfl).elim } },
  { refine or.inr _,
    exact nat.succ_pos _ }
end

instance order_bot : order_bot L :=
{ bot := 0,
  bot_le := bot_le,
  ..(infer_instance : partial_order L) }

lemma le_iff_exists_add : ∀ (a b : L), a ≤ b ↔ ∃ (c : L), b = a + c :=
begin
  rintros ⟨⟨an, a2⟩, ha⟩ ⟨⟨bn, b2⟩, hb⟩,
  rw subtype.mk_le_mk,
  refine ⟨λ h, _, λ h, _⟩,
  { rcases h with ⟨rfl, rfl⟩ | h,
    { exact ⟨(0 : L), (add_zero _).symm⟩ },
    { refine ⟨⟨⟨bn - an, b2 + a2⟩, _⟩, _⟩,
      { rw [ne.def, prod.mk.inj_iff, not_and_distrib],
        exact or.inl (ne_of_gt (tsub_pos_of_lt h)) },
      { congr,
        { exact (add_tsub_cancel_of_le h.le).symm },
        { change b2 = a2 + (b2 + a2),
          rw [add_comm b2, ← add_assoc, add_self_zmod_2, zero_add] } } } },
  { rcases h with ⟨⟨⟨c, c2⟩, hc⟩, abc⟩,
    injection abc with abc,
    rw [prod.mk_add_mk, prod.mk.inj_iff] at abc,
    rcases abc with ⟨rfl, rfl⟩,
    cases c,
    { refine or.inl _,
      rw [ne.def, prod.mk.inj_iff, eq_self_iff_true, true_and] at hc,
      rcases mem_zmod_2 c2 with rfl | rfl,
      { rw [add_zero, add_zero] },
      { exact (hc rfl).elim } },
    { refine or.inr _,
      exact (lt_add_iff_pos_right _).mpr c.succ_pos } }
end

lemma eq_zero_or_eq_zero_of_mul_eq_zero : ∀ (a b : L), a * b = 0 → a = 0 ∨ b = 0 :=
begin
  rintros ⟨⟨a, a2⟩, ha⟩ ⟨⟨b, b2⟩, hb⟩ ab1,
  injection ab1 with ab,
  injection ab with abn ab2,
  rw mul_eq_zero at abn,
  rcases abn with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩,
  { refine or.inl _,
    rcases mem_zmod_2 a2 with rfl | rfl,
    { refl },
    { exact (ha rfl).elim } },
  { refine or.inr _,
    rcases mem_zmod_2 b2 with rfl | rfl,
    { refl },
    { exact (hb rfl).elim } }
end

instance can : canonically_ordered_comm_semiring L :=
{ le_iff_exists_add := le_iff_exists_add,
  eq_zero_or_eq_zero_of_mul_eq_zero := eq_zero_or_eq_zero_of_mul_eq_zero,
  ..(infer_instance : order_bot L),
  ..(infer_instance : ordered_comm_semiring L) }

/--
The elements `(1,0)` and `(1,1)` of `L` are different, but their doubles coincide.
-/
example : ∃ a b : L, a ≠ b ∧ 2 * a = 2 * b :=
begin
  refine ⟨⟨(1,0), by simp⟩, 1, λ (h : (⟨(1, 0), _⟩ : L) = ⟨⟨1, 1⟩, _⟩), _, rfl⟩,
  obtain (F : (0 : zmod 2) = 1) := congr_arg (λ j : L, j.1.2) h,
  cases F,
end

end ex_L


import algebra.ring data.rat data.real.basic data.complex.basic
import data.nat.prime ring_theory.subring.basic number_theory.zsqrtd.gaussian_int data.zmod.basic
import topology.constructions topology.continuous_function.algebra topology.instances.real
import data.mv_polynomial
import tactic.ring

import commutative_algebra.local_integers
import commutative_algebra.galois_field_4
import commutative_algebra.ring_of_subsets

namespace sec_rings

variable (n : ℕ+)

/- -------------------------------------------------------- -/
/- defn-ring -/
#print comm_ring

/- eg-numbers -/
#check (by apply_instance : comm_ring ℤ)
#check (by apply_instance : comm_ring ℚ)
#check (by apply_instance : comm_ring ℝ)
#check (by apply_instance : comm_ring ℂ)

#check (by apply_instance : comm_semiring ℕ)
-- #check (by apply_instance : comm_ring ℕ) -- fails

/- -------------------------------------------------------- -/
/- eg-tw-local -/
#check (by apply_instance : comm_ring (local_integers 2))
#check (by apply_instance : comm_ring gaussian_int)

/- -------------------------------------------------------- -/
/- defn-subring -/
#print subring

/- -------------------------------------------------------- -/
/- eg-subrings -/
-- TO DO

/- -------------------------------------------------------- -/
/- eg-modular -/
#check (by apply_instance : comm_ring (zmod n))

/- -------------------------------------------------------- -/
/- eg-trivial-ring -/
def unit_comm_ring : comm_ring unit := by { apply_instance }

/- -------------------------------------------------------- -/
/- eg-square-matrices -/
-- TO DO

/- -------------------------------------------------------- -/
/- eg-F-four -/
#check F4
#check (by apply_instance : field F4) -- from galois_field_4.lean

/- -------------------------------------------------------- -/
/- eg-boolean -/
namespace eg_boolean
universes uS
variables (S : Type uS)
#check (by apply_instance : comm_ring (ring_of_subsets S))
end eg_boolean

/- -------------------------------------------------------- -/
/- defn-binary-product -/

namespace defn_binary_product

universes uA uB
variables (A : Type uA) (B : Type uB) [comm_ring A] [comm_ring B]

#check (by apply_instance : comm_ring (A × B))
example (a a' : A) (b b' : B) :
 (prod.mk a b) * (prod.mk a' b') = prod.mk (a * a') (b * b')  := rfl

end defn_binary_product

/- -------------------------------------------------------- -/
/- rem axis-not_subring -/

namespace axis_not_subring

lemma axis_not_subring (A B : Type*) [comm_ring A] [comm_ring B]
 (hB : (1 : B) ≠ 0) {S : subring (A × B)}
 (hS : S.carrier = (λ ab : (A × B), ab.snd = 0)) : false :=
begin
 let h := S.one_mem,
 rw[← subring.mem_carrier, hS] at h,
 exact hB h,
end

end axis_not_subring

/- -------------------------------------------------------- -/
/- rem-infinite-product -/
-- TO DO

/- -------------------------------------------------------- -/
/- defn-map-ring -/

namespace defn_map_ring

universes uA uS
variables (A : Type uA) [comm_ring A] (S : Type uS)

#check (by apply_instance : comm_ring (S → A))

end defn_map_ring

/- -------------------------------------------------------- -/
/- rem-function-rings -/
namespace rem_function_rings
universe uX
variables (X : Type uX) [topological_space X]

noncomputable def R : (comm_ring (continuous_map X ℝ)) :=
 continuous_map.comm_ring

end rem_function_rings

/- -------------------------------------------------------- -/
/- eg-sunset -/
namespace eg_sunset

def X := { xy : ℝ × ℝ // (xy.1 ^ 2 + xy.2 ^ 2 - 1) * xy.2 = 0 }

noncomputable instance :
 topological_space X := by { unfold X, apply_instance }

@[reducible ]
def CX := continuous_map X ℝ

noncomputable instance CX_comm_ring : comm_ring CX :=
 by { unfold CX, exact continuous_map.comm_ring }

def CX.x : CX := ⟨prod.fst ∘ subtype.val,
 continuous.comp continuous_fst continuous_subtype_val⟩

def CX.y : CX := ⟨prod.snd ∘ subtype.val,
 continuous.comp continuous_snd continuous_subtype_val⟩

lemma CX.x_def (xy : X) : CX.x xy = xy.val.1 := rfl
lemma CX.y_def (xy : X) : CX.y xy = xy.val.2 := rfl

lemma CX.rel : (CX.x ^ 2 + CX.y ^2 - 1) * CX.y = 0 :=
begin
 ext ab, rcases ab with ⟨⟨a,b⟩,e⟩, exact e
end

@[derive decidable_eq]
inductive A_gens
| x : A_gens
| y : A_gens

def PX := mv_polynomial A_gens ℝ
noncomputable instance PX_comm_ring :
 comm_ring PX := by {unfold PX, apply_instance}

noncomputable def PX.x : PX := @mv_polynomial.X ℝ A_gens _ A_gens.x
noncomputable def PX.y : PX := @mv_polynomial.X ℝ A_gens _ A_gens.y

noncomputable def PX.relator : PX := (PX.x ^ 2 + PX.y ^ 2 - 1) * PX.y

def φ₀ : ℝ →+* CX := {
 to_fun := λ c, ⟨(λ u, c),continuous_const⟩,
 map_zero' := by { ext, refl },
 map_add' := λ c d, by { ext, refl },
 map_one' := by { ext, refl },
 map_mul' := λ c d, by { ext, refl }
}

def φ₁ : A_gens → CX
| A_gens.x := CX.x
| A_gens.y := CX.y

noncomputable def φ : PX →+* CX :=
 mv_polynomial.eval₂_hom φ₀ φ₁

end eg_sunset

/- -------------------------------------------------------- -/
/- defn-general-product -/

-- TO DO

/- -------------------------------------------------------- -/
/- rem-product-subring -/

-- TO DO

/- -------------------------------------------------------- -/
/- eg-padic -/

namespace eg_padic

variables (p : ℕ) [fact (p > 0)]

lemma p_pow_pos (k : ℕ) : fact (p ^ k > 0) := fact.mk begin
 have h : p > 0 := fact.elim (by apply_instance),
 exact pow_pos h k
end

local attribute [instance] p_pow_pos

def P := ∀ (k : ℕ), (zmod (p ^ k))
instance P_ring : comm_ring (P p) := by { unfold P, apply_instance }

def π (k : ℕ) : zmod (p ^ (k + 1)) →+* zmod (p ^ k) :=
 zmod.cast_hom (pow_dvd_pow p (le_of_lt (nat.lt_succ_self k))) (zmod (p ^ k))

def is_coherent (a : P p) := ∀ (k : ℕ), π p k (a (k + 1)) = (a k)

def p_adic_integers : subring (P p) := {
 carrier := is_coherent p,
 zero_mem' := by { intro k, change π p k 0 = 0,
                   exact ring_hom.map_zero _ },
 add_mem'  := by { intros a b ha hb k,
                   change π p k ((a (k + 1)) + (b (k + 1))) = (a k) + (b k),
                   rw[ring_hom.map_add, ha k, hb k],
                 },
 neg_mem'  := by { intros a ha k,
                  change π p k (- (a (k + 1))) = - (a k),
                  rw[ring_hom.map_neg,ha k],
                 },
 one_mem'  := by { intro k, change π p k 1 = 1,
                  exact ring_hom.map_one _ },
 mul_mem'  := by { intros a b ha hb k,
                  change π p k ((a (k + 1)) * (b (k + 1))) = (a k) * (b k),
                  rw[ring_hom.map_mul, ha k, hb k],
                }
}

variables (q : ℕ) [fact q.prime]

lemma q_pos : fact (q > 0) :=
 ⟨nat.prime.pos (fact.elim (by { apply_instance }))⟩

lemma q_pred (k : ℕ) : (q.pred : (zmod (q ^ k))) = (q : (zmod (q ^ k))) - 1 :=
begin
 have h : q.pred + 1 = q :=
  nat.succ_pred_eq_of_pos (fact.elim (by {apply_instance})),
 symmetry, rw[sub_eq_iff_eq_add, ← nat.cast_one, ← nat.cast_add, h]
end

local attribute [instance] q_pos

def a₀ : ℕ → ℕ
| 0 := 0
| (k + 1) := (a₀ k) + q ^ k

lemma a₀_step (k : ℕ) : a₀ q (k + 1) = 1 + q * (a₀ q k) :=
begin
 induction k with k ih,
 { dsimp[a₀], rw[pow_zero, mul_zero, zero_add] },
 { have h₀ : 1 + q * (a₀ q (k + 1)) = 1 + q * (a₀ q k) + q ^ (k + 1) :=
    by { rw[a₀, mul_add, add_assoc, pow_succ] },
   have h₁ : a₀ q (k + 2) = a₀ q (k + 1) + q ^ (k + 1) := rfl,
   rw[h₀, h₁, ih]
 }
end

def a : p_adic_integers q := ⟨
 λ k, (a₀ q k),
begin
 intro k,
 change π q k (a₀ q (k + 1)) = a₀ q k,
 rw[map_nat_cast,a₀],
 rw[nat.cast_add,zmod.nat_cast_self,add_zero]
end
⟩

def b : p_adic_integers q := ⟨λ k, (q : zmod (q ^ k)) - 1,
begin
 intro k,
 change π q k (q - 1) = (q - 1),
 rw[← q_pred, ← q_pred, map_nat_cast],
end
⟩

lemma ab : (a q) * (b q) = - 1 :=
begin
 rw[mul_comm],
 ext k,
 change ((q : zmod (q ^ k)) - 1) * (a₀ q k) = - (1 : (zmod (q ^ k))),
 rw[sub_mul, one_mul, sub_eq_iff_eq_add', ← sub_eq_add_neg],
 symmetry,
 rw[sub_eq_iff_eq_add', ← nat.cast_one, ← nat.cast_mul, ← nat.cast_add],
 rw[← a₀_step, a₀, nat.cast_add, zmod.nat_cast_self, add_zero]
end

end eg_padic

end sec_rings


import integral_limits

open measure_theory set filter interval_integral
open_locale topological_space

lemma real.integral_exp_Iic (x : ℝ) : ∫ t in Iic x, t.exp = x.exp :=
begin
  have key : tendsto (λ (n : ℕ), ∫ (t : ℝ) in -n..x, t.exp) at_top (𝓝 x.exp),
  { have : ∀ (n:ℕ), x.exp - real.exp (-n) = ∫ t:ℝ in -n..x, t.exp,
    { intro n,
      rw integral_eq_sub_of_has_deriv_at
        (λ t ht, real.has_deriv_at_exp t)
        real.continuous_exp.continuous_on },
    refine tendsto.congr this _,
    convert tendsto_const_nhds.sub
      (real.tendsto_exp_neg_at_top_nhds_0.comp tendsto_coe_nat_at_top_at_top),
    rw sub_zero _ },
  have antimono_neg_coe : ∀ i j : ℕ, i ≤ j → (-j : ℝ) ≤ -i := λ i j hij, by simpa,
  have tendsto_neg_coe : tendsto (λ n : ℕ, -(n : ℝ)) at_top at_bot :=
    tendsto_neg_at_top_at_bot.comp tendsto_coe_nat_at_top_at_top,
  have hfi : integrable_on real.exp (Iic x) :=
    integrable_on_Iic_of_tendsto_interval_integral_norm antimono_neg_coe real.measurable_exp
      _ _ (λ n, (real.continuous_exp.interval_integrable _ _).1) tendsto_neg_coe
      (key.congr $ λ n, integral_congr (λ t _, (real.norm_of_nonneg t.exp_pos.le).symm)),
  exact integral_Iic_eq_of_tendsto_interval_integral antimono_neg_coe
    real.measurable_exp _ _ hfi tendsto_neg_coe key,
end

example : ∫ (t : ℝ) in Iic 0, t.exp = 1 := real.exp_zero ▸ real.integral_exp_Iic 0


/-
Copyright (c) 2018 Rohan Mitta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rohan Mitta
-/
import analysis.topology.topological_space
import analysis.topology.continuity
import analysis.metric_space
import analysis.topology.uniform_space
import order.filter
import analysis.limits

import Topology.Material.topological_sequences

--import data.complex.exponential
--Move this to algebra.big_operators

--Start of Chris's Stuff
import data.complex.basic algebra.archimedean data.nat.binomial algebra.field_power tactic.linarith

section
open real is_absolute_value finset

local attribute [instance, priority 0] classical.prop_decidable

lemma geo_sum_eq {α : Type*} [field α] {x : α} : ∀ (n : ℕ) (hx1 : x ≠ 1),
  (range n).sum (λ m, x ^ m) = (1 - x ^ n) / (1 - x)
| 0     hx1 := by simp
| (n+1) hx1 := have 1 - x ≠ 0 := mt sub_eq_zero_iff_eq.1 hx1.symm,
by rw [sum_range_succ, ← mul_div_cancel (x ^ n) this, geo_sum_eq n hx1, ← add_div, _root_.pow_succ];
    simp [mul_add, add_mul, mul_comm]
end
--End of Chris's stuff

--Kevin's Lemma
open filter
lemma tendsto_succ (X : Type*) (f : ℕ → X) (F : filter X) (H : tendsto f at_top F) :
tendsto (λ n, f (n + 1)) at_top F :=
tendsto.comp (tendsto_def.2 $ λ U HU,
  let ⟨a,Ha⟩ := mem_at_top_sets.1 HU in
  mem_at_top_sets.2 ⟨a,λ x Hx,Ha _ $ le_trans Hx $ by simp⟩) H

local attribute [instance, priority 0] classical.prop_decidable
noncomputable theory

open function

--The following material comes from "Metric Spaces and Topology" by Sutherland

--Half of Proposition 17.4
theorem complete_of_complete_of_uniform_cts_bij {α : Type*} [metric_space α] {β : Type*} [metric_space β] (f : α → β)
    (g : β → α) (Hf : uniform_continuous f) (Hg : uniform_continuous g) (left_inv : function.left_inverse g f)
    (right_inv : function.right_inverse g f) : complete_space α → complete_space β :=
begin
  rintro ⟨H1⟩,
  split,
  intros filt Hfilt,
  cases H1 (cauchy_map Hg Hfilt) with x H_converges_to_x,
  existsi f x,
  rw [map_le_iff_le_comap,
      ←filter.map_eq_comap_of_inverse (id_of_right_inverse right_inv) (id_of_left_inverse left_inv)] at H_converges_to_x,
  exact le_trans H_converges_to_x (continuous.tendsto Hf.continuous x)
end

--Proposition 17.4
theorem complete_iff_of_uniform_cts_bij {α : Type*} [metric_space α] {β : Type*} [metric_space β] (f : α → β)
    (g : β → α) (Hf : uniform_continuous f) (Hg : uniform_continuous g) (left_inv : function.left_inverse g f)
    (right_inv : function.right_inverse g f) : complete_space α ↔ complete_space β :=
        ⟨complete_of_complete_of_uniform_cts_bij f g Hf Hg left_inv right_inv,
        complete_of_complete_of_uniform_cts_bij g f Hg Hf right_inv left_inv⟩

open nat
def iteration_map {α : Type*} (f : α → α) (start : α) : ℕ → α
| zero := start
| (succ x) := f (iteration_map x)

--Definition 17.24
def is_contraction {α : Type*} [metric_space α] (f : α → α) :=
∃ (k : ℝ) (H1 : k < 1) (H2 : 0 < k), ∀ (x y : α), dist (f x) (f y) ≤ k* (dist x y)

--Lemma 17.25
lemma uniform_continuous_of_contraction {α : Type*} [metric_space α] (f : α → α)
(H : is_contraction f) : uniform_continuous f := uniform_continuous_of_metric.2
    (λ ε Hε, ⟨ε,Hε,(λ a b Hab, let ⟨K, H1, H2, H3⟩ := H in lt_of_le_of_lt (le_trans (H3 a b)
      (by convert mul_le_mul_of_nonneg_right (le_of_lt H1) dist_nonneg; rw one_mul)) Hab)⟩)

--Banach's Fixed Point Theorem (Exists Statement)
theorem Banach_fixed_point_exists {α : Type*} [metric_space α] [complete_space α] (H1 : nonempty α) {f : α → α} (H : is_contraction f)
: ∃ (p : α), f p = p :=
begin
  cases classical.exists_true_of_nonempty H1 with start trivial,
  let seq := iteration_map f start,
  let H' := H,
  rcases H with ⟨K, HK1, HK2, Hf⟩,
  have consecutive_distance : ∀ n, dist (seq (n+1)) (seq (n)) ≤ K^n * dist (seq 1) (seq 0),
  { intro n, induction n with N HN,
    show dist (seq 1) (seq 0) ≤ 1 * dist (seq 1) (seq 0),
    rw one_mul,
    have K_times_HN := (mul_le_mul_left HK2).2 HN,
    rw ← mul_assoc at K_times_HN,
    exact le_trans (Hf (seq (N+1)) (seq (N+0))) K_times_HN },

  --Now repeatedly use the triangle inequality
  let sum_consecutives := λ m n, finset.sum (finset.range (m)) (λ x, dist (seq (n+x+1)) (seq (n+x))),
  have le_sum_consecutives : ∀ m n, dist (seq (n+m)) (seq n) ≤ sum_consecutives m n,
  { intros m n,
    induction m with M HM,
    { rw add_zero, rw dist_self,
      apply finset.zero_le_sum,
      intros n Hn, exact dist_nonneg },
    have sum_cons_insert : sum_consecutives (succ M) n =
        finset.sum (insert (M) (finset.range (M))) (λ (x : ℕ), dist (seq (n + x + 1)) (seq (n + x))),
    { have : (finset.range (succ M)) = insert M (finset.range M),
      { rw finset.range_succ },
      dsimp [sum_consecutives],
      rw this },
    have dist_triangleone : dist (seq (n + succ M)) (seq n) ≤
        dist (seq (n + succ M)) (seq (n+M)) + dist (seq (n + M)) (seq n) := dist_triangle _ _ _,
    refine le_trans dist_triangleone _,
    rw sum_cons_insert,
    rw finset.sum_insert (by rw finset.mem_range; exact lt_irrefl M),
    apply add_le_add_left, exact HM },

  let sum_consecutives_K := λ m n, finset.sum (finset.range (m)) (λ x,(K^(n+x))*dist (seq 1) (seq 0)),

  have sum_le : ∀ m n, sum_consecutives m n ≤ sum_consecutives_K m n,
  { intros m n, apply finset.sum_le_sum,
    intros x Hx, exact consecutive_distance (n+x) },

  have take_out_dist : ∀ m n, sum_consecutives_K m n =
      (finset.sum (finset.range m) (λ (x : ℕ), K ^ (x)))* (K^n)*dist (seq 1) (seq 0),
  { intros m n, rw [finset.sum_mul, finset.sum_mul],
    simp only [(_root_.pow_add _ _ _).symm, add_comm] },

  replace take_out_dist : ∀ (m n : ℕ), sum_consecutives_K m n = (1 - K ^ m) / (1 - K) * K ^ n * dist (seq 1) (seq 0),
  { intros m n, rw [← geo_sum_eq _ (ne_of_lt HK1), take_out_dist m n] },

  have : ∀ (m : ℕ), (1 - K ^ m) ≤ 1,
  { intros m, refine sub_le_self 1 ((pow_nonneg (le_of_lt HK2)) m) },

  have this2 : ∀ (n : ℕ), 0 ≤ (1 - K)⁻¹ * (K ^ n * dist (seq 1) (seq 0)),
  { intro n, rw ← mul_assoc,
    refine mul_nonneg (mul_nonneg (le_of_lt (inv_pos'.2 (by linarith))) (le_of_lt ((pow_pos HK2) n))) dist_nonneg },

  have k_sum_le_k_sum : ∀ (m n : ℕ), (1 - K ^ m) / (1 - K) * K ^ n * dist (seq 1) (seq 0)
      ≤ 1 / (1 - K) *(K ^ n)* dist (seq 1) (seq 0),
  { intros m n, rw [mul_assoc, mul_assoc, div_eq_mul_inv, mul_assoc, div_eq_mul_inv, mul_assoc],
    refine mul_le_mul_of_nonneg_right (this m) (this2 n) },

  have k_to_n_converges := tendsto_pow_at_top_nhds_0_of_lt_1 (le_of_lt HK2) HK1,
  have const_converges : filter.tendsto (λ (n : ℕ), 1 / (1 - K) * dist (seq 1) (seq 0))
      filter.at_top (nhds (1 / (1 - K) * dist (seq 1) (seq 0))) := tendsto_const_nhds,

  have k_sum_converges := tendsto_mul k_to_n_converges const_converges,
  dsimp at k_sum_converges, rw [zero_mul, seq_tendsto_iff] at k_sum_converges,

  have equal : ∀ (n : ℕ), K ^ n * (1 / (1 + -K) * dist (seq 1) (seq 0)) =  1 / (1 - K) * K ^ n * dist (seq 1) (seq 0),
  { intro n, conv in (_ * K ^ n) begin rw mul_comm, end, rw mul_assoc, refl },

  have cauchy_seq : ∀ ε > 0, ∃ (N : ℕ), ∀ {n m}, n ≥ N → m ≥ N → dist (seq n) (seq m) < ε,
  { intros ε Hε,
    cases k_sum_converges ε Hε with N HN,
    existsi N,
    intros r s Hr Hs,
    wlog h : s ≤ r,
    { have := HN Hs,
      rw real.dist_eq at this, rw sub_zero at this,
      replace := (abs_lt.1 this).2, rw equal at this,
      have this2 := λ m, lt_of_le_of_lt (k_sum_le_k_sum m s) this,
      have this3 : ∀ (m : ℕ), sum_consecutives_K m s < ε,
      { intro m, rw take_out_dist, exact this2 m },
      have this4 := λ m, lt_of_le_of_lt (sum_le m s) (this3 m),
      have this5 := λ m, lt_of_le_of_lt (le_sum_consecutives m s) (this4 m),
      cases le_iff_exists_add.1 h with c Hc, rw Hc,
      exact this5 c },
    rw dist_comm, exact this_1 Hs Hr },

  rw ← metric_space.seq_cauchy_of_mathematician at cauchy_seq,
  cases @complete_space.complete _ _ _inst_2 _ cauchy_seq with p Hseq_tendsto_p,
  existsi p,

  have f_cont : continuous f := uniform_continuous.continuous (uniform_continuous_of_contraction f H'),
  let next_seq := f ∘ seq,
  have Hnext_seq_tendsto_fp : filter.tendsto next_seq filter.at_top (nhds (f p))
      := filter.tendsto.comp Hseq_tendsto_p (continuous.tendsto f_cont p),

  have Hnext_seq_eq_seqsucc : next_seq = (λ n, seq (n + 1)),
  { apply funext, intro x, refl },

  have Hnext_seq_tendsto_p : filter.tendsto next_seq filter.at_top (nhds p),
  { rw Hnext_seq_eq_seqsucc,
    exact tendsto_succ _ _ _ Hseq_tendsto_p },

  exact metric_space.unique_limit_seq next_seq (f p) p
      ((seq_tendsto_iff next_seq (f p)).1 Hnext_seq_tendsto_fp)
      ((seq_tendsto_iff next_seq p).1 Hnext_seq_tendsto_p),

end

def Banach's_fixed_point {α : Type*} [metric_space α] [complete_space α] (H1 : nonempty α) {f : α → α} (H : is_contraction f)
: α := classical.some (Banach_fixed_point_exists H1 H)

theorem Banach's_fixed_point_is_fixed_point {α : Type*} [metric_space α] [complete_space α] (H1 : nonempty α) {f : α → α} (H : is_contraction f)
: f (Banach's_fixed_point H1 H) = Banach's_fixed_point H1 H := classical.some_spec (Banach_fixed_point_exists H1 H)

theorem Banach's_fixed_point_is_unique {α : Type*} [metric_space α] [complete_space α] (H1 : nonempty α) {f : α → α} (H : is_contraction f)
: ∀ (p : α), f p = p → p = Banach's_fixed_point H1 H :=
begin
  intros y Hy,
  by_contra Hnot,
  let p := Banach's_fixed_point H1 H,
  have H4 := @dist_nonneg _ _ p y,
  have H3 : 0 < dist p y, exact or.elim H4 (λ x, x) (λ m, by_contradiction
    (λ o, Hnot (eq_of_dist_eq_zero (eq.symm (eq.trans m (dist_comm p y)))))),
  let H' := H,
  rcases H with ⟨K,HK1,_,Hf⟩,
  have := Hf p y, rw [Hy, (Banach's_fixed_point_is_fixed_point H1 H')] at this,
  have this1_5 : K * dist p y < 1 * dist p y,
  { apply lt_of_sub_pos, rw ← mul_sub_right_distrib, refine mul_pos (sub_pos_of_lt HK1) H3 },

  have this2 : dist p y < 1 * dist p y,
  { refine lt_of_le_of_lt this this1_5 },
  rw one_mul at this2, exact lt_irrefl (dist p y) this2,
end


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/

/-
Linear natural number arithmetic terms in pre-normalized form.
-/

import tactic.omega.term

open tactic

namespace omega
namespace nat

/-- The shadow syntax for arithmetic terms. All constants are reified to `cst`
(e.g., `5` is reified to `cst 5`) and all other atomic terms are reified to
`exp` (e.g., `5 * (list.length l)` is reified to `exp 5 \`(list.length l)`).
`exp` accepts a coefficient of type `nat` as its first argument because
multiplication by constant is allowed by the omega test. -/
meta inductive exprterm : Type
| cst : nat → exprterm
| exp : nat → expr → exprterm
| add : exprterm → exprterm → exprterm
| sub : exprterm → exprterm → exprterm

/-- Similar to `exprterm`, except that all exprs are now replaced with
de Brujin indices of type `nat`. This is akin to generalizing over
the terms represented by the said exprs. -/
@[derive has_reflect, derive decidable_eq, derive inhabited]
inductive preterm : Type
| cst : nat → preterm
| var : nat → nat → preterm
| add : preterm → preterm → preterm
| sub : preterm → preterm → preterm

localized "notation `&` k := omega.nat.preterm.cst k" in omega.nat
localized "infix ` ** ` : 300 := omega.nat.preterm.var" in omega.nat
localized "notation t ` +* ` s := omega.nat.preterm.add t s" in omega.nat
localized "notation t ` -* ` s := omega.nat.preterm.sub t s" in omega.nat

namespace preterm

/-- Helper tactic for proof by induction over preterms -/
meta def induce (tac : tactic unit := tactic.skip) : tactic unit :=
`[ intro t, induction t with m m n t s iht ihs t s iht ihs; tac]

/-- Preterm evaluation -/
def val (v : nat → nat) : preterm → nat
| (& i) := i
| (i ** n) :=
  if i = 1
  then v n
  else (v n) * i
| (t1 +* t2) := t1.val + t2.val
| (t1 -* t2) := t1.val - t2.val

@[simp] lemma val_const {v : nat → nat} {m : nat} :
  (& m).val v = m := rfl

@[simp] lemma val_var {v : nat → nat} {m n : nat} :
  (m ** n).val v = m * (v n) :=
begin
  simp only [val], by_cases h1 : m = 1,
  rw [if_pos h1, h1, one_mul],
  rw [if_neg h1, mul_comm],
end

@[simp] lemma val_add {v : nat → nat} {t s : preterm} :
  (t +* s).val v = t.val v + s.val v := rfl

@[simp] lemma val_sub {v : nat → nat} {t s : preterm} :
  (t -* s).val v = t.val v - s.val v := rfl

/-- Fresh de Brujin index not used by any variable in argument -/
def fresh_index : preterm → nat
| (& _)      := 0
| (i ** n)   := n + 1
| (t1 +* t2) := max t1.fresh_index t2.fresh_index
| (t1 -* t2) := max t1.fresh_index t2.fresh_index

/-- If variable assignments `v` and `w` agree on all variables that occur
in term `t`, the value of `t` under `v` and `w` are identical. -/
lemma val_constant (v w : nat → nat) :
  ∀ t : preterm, (∀ x < t.fresh_index, v x = w x) →
  t.val v = t.val w
| (& n)      h1 := rfl
| (m ** n)   h1 :=
  begin
    simp only [val_var],
    apply congr_arg (λ y, m * y),
    apply h1 _ (lt_add_one _)
  end
| (t +* s) h1 :=
  begin
    simp only [val_add],
    have ht := val_constant t
      (λ x hx, h1 _ (lt_of_lt_of_le hx (le_max_left _ _))),
    have hs := val_constant s
      (λ x hx, h1 _ (lt_of_lt_of_le hx (le_max_right _ _))),
    rw [ht, hs]
  end
| (t -* s) h1 :=
  begin
    simp only [val_sub],
    have ht := val_constant t
      (λ x hx, h1 _ (lt_of_lt_of_le hx (le_max_left _ _))),
    have hs := val_constant s
      (λ x hx, h1 _ (lt_of_lt_of_le hx (le_max_right _ _))),
    rw [ht, hs]
  end

def repr : preterm → string
| (& i)      := i.repr
| (i ** n)   := i.repr ++ "*x" ++ n.repr
| (t1 +* t2) := "(" ++ t1.repr ++ " + " ++ t2.repr ++ ")"
| (t1 -* t2) := "(" ++ t1.repr ++ " - " ++ t2.repr ++ ")"

@[simp] def add_one (t : preterm) : preterm := t +* (&1)

/-- Preterm is free of subtractions -/
def sub_free : preterm → Prop
| (& m)    := true
| (m ** n) := true
| (t +* s) := t.sub_free ∧ s.sub_free
| (_ -* _) := false

end preterm

open_locale list.func -- get notation for list.func.set

/-- Return a term (which is in canonical form by definition)
    that is equivalent to the input preterm -/
@[simp] def canonize : preterm → term
| (& m)    := ⟨↑m, []⟩
| (m ** n) := ⟨0, [] {n ↦ ↑m}⟩
| (t +* s) := term.add (canonize t) (canonize s)
| (_ -* _) := ⟨0, []⟩

@[simp] lemma val_canonize {v : nat → nat} :
  ∀ {t : preterm}, t.sub_free →
  (canonize t).val (λ x, ↑(v x)) = t.val v
| (& i) h1 :=
  by simp only [canonize, preterm.val_const,
     term.val, coeffs.val_nil, add_zero]
| (i ** n) h1 :=
  by simp only [preterm.val_var, coeffs.val_set,
      term.val, zero_add, int.coe_nat_mul, canonize]
| (t +* s) h1 :=
  by simp only [val_canonize h1.left,
     val_canonize h1.right, int.coe_nat_add,
     canonize, term.val_add, preterm.val_add]

end nat

end omega


/-

Some toy examples of working with heterogeneous equality,
in particular for dependent functions and structures.

-/

import tactic.ext

#check @eq_rec_heq
/-
eq_rec_heq :
∀ {α : Sort u_1}
  {φ : α → Sort u_2}
  {a a' : α}
  (h : a = a')
  (p : φ a),
h.rec_on p == p

This seems to be the fundamental idea of heq:
Casting a term to another type (using eq.rec or similar)
necessarily gives something which can't be eq, but it can be heq.

The following lemma, if true, would give a partial converse:
-/
lemma converse (P Q : Sort*) (p : P) (q : Q) (h : P = Q) :
  (p == q) → (h.rec_on p = q) := sorry

/-
The following lemma gives an actual eq for type casting using eq.rec,
by casting both the argument type and the function input type
in a function application.

The key is on the line marked (*), which works because of two facts:
1. The proof (_ : A₁ = A₁) is automatically equal to (eq.refl A₁)
2. When eq.rec is applied to a proof of the form (eq.refl x), the
   term can be evaluated, getting rid of eq.rec
-/
lemma cast_func_apply_eq
  (A₁ A₂ B : Type)
  (h₁₂ : A₁ = A₂)
  (f : A₁ → B)
  (a : A₁)
:
  (@eq.rec Type A₁ (fun A, A → B) f A₂ h₁₂)
  (@eq.rec Type A₁ (fun A, A)     a A₂ h₁₂) =
  (f a)
:=
  @eq.rec Type A₁
  (fun A₃, forall (h₁₃ : A₁ = A₃),
    (@eq.rec Type A₁ (fun A, A → B) f A₃ h₁₃)
    (@eq.rec Type A₁ (fun A, A)     a A₃ h₁₃) =
    (f a))
  (fun (_ : A₁ = A₁), eq.refl (f a)) -- (*)
  A₂ h₁₂ h₁₂

/-
The following lemma can be used to prove that two functions with
different domains are heq (even when they can't be eq).

It concerns two partial functions from A to B,
f₁ : {a : A // P₁ a} → B
f₂ : {a : A // P₂ a} → B
where the two propositions are equivalent (∀ a : A, (P₁ a) ↔ (P₂ a)),
so that the domains are mathematically equal,
but not syntactically equal.

The main complication is that funext can only be applied to
functions whose domains are syntactically equal, so it's necessary
to cast back and forth between the two domains using eq.rec.
-/
lemma subtype_func_ext
  (A B : Type)
  (P₁ P₂ : A → Prop)
  (f₁ : subtype P₁ → B)
  (f₂ : subtype P₂ → B)
  (hP : P₁ = P₂)
  (hf : forall (a : A) (h₁ : P₁ a) (h₂ : P₂ a),
    (f₁ ⟨a, h₁⟩) = (f₂ ⟨a, h₂⟩))
:
  (f₁ == f₂)
:=
  let f (P : A → Prop) : (P₁ = P) → subtype P → B :=
    (@eq.rec (A → Prop) P₁ (fun P, subtype P → B) f₁ P)
  in @eq.rec (subtype P₂ → B) (f P₂ hP) (fun f, f₁ == f)
  -- rewrite (heq.refl : f₁ == f₁) into (_ : f₁ == hP.rec_on f₁)
  (@eq.rec (A → Prop) P₁ (fun P, forall h : P₁ = P, f₁ == f P h) (fun _, heq.refl f₁) P₂ hP hP)
  -- then prove that (hP.rec_on f₁ = f₂) using funext
  f₂
  (funext (@subtype.rec A P₂ (fun x, f P₂ hP x = f₂ x) (fun a h₂,
  let h₁ : P₁ a := (eq.rec h₂ hP.symm) in calc
  (f P₂ hP ⟨a, h₂⟩) = (f₁ ⟨a, h₁⟩) : (@eq.rec (A → Prop) P₁
                                       (fun P, forall h : P₁ = P, f P h ⟨a, eq.rec h₁ h⟩ = f₁ ⟨a, h₁⟩)
                                       (fun _, eq.refl (f₁ ⟨a, h₁⟩)) P₂ hP hP)
  ...               = (f₂ ⟨a, h₂⟩) : (hf a h₁ h₂))))

/-
The lemma subtype_func_ext might be used to show equality between
two structures which have function fields, as below.
-/
@[ext] structure bla :=
  (A : Type)
  (f : A → nat)

inductive AB | A | B
lemma distinct : AB.A ≠ AB.B := @AB.no_confusion _ _ _

def Aeq : Type := {x : AB // x = AB.A}
def Ane : Type := {x : AB // x ≠ AB.B}
lemma same : Aeq = Ane :=
  congr_arg (@subtype AB) (funext (@AB.rec (fun x, (x = AB.A) = (x ≠ AB.B))
  (propext (iff.intro (fun _, distinct) (fun _, eq.refl AB.A)))
  (propext (iff.intro (fun h _, distinct h.symm) (fun h, false.elim (h (eq.refl AB.B)))))))

def bla_eq : bla := {A := Aeq, f := (fun _, 0)}
def bla_ne : bla := {A := Ane, f := (fun _, 0)}

example : bla_eq = bla_ne := begin
  ext,
  exact same,
  exact same,
  intros aeq ane h, -- h : aeq == ane
  -- TODO: what now?
  sorry
end

------------------------------------------------

inductive binary_string : Type
| empty : binary_string
| append_zero : binary_string → binary_string
| append_one : binary_string → binary_string

inductive my_nat : Type
| zero : my_nat
| succ : my_nat → my_nat

example : my_nat := my_nat.succ (my_nat.succ my_nat.zero)

#print prefix my_nat

/-
my_nat.rec :
Π {C : my_nat → Sort l},
  (C my_nat.zero) →
  (Π (a : my_nat), (C a) → (C a.succ)) →
Π (n : my_nat), (C n)
-/

def f : my_nat → bool
| (my_nat.zero) := tt
| (my_nat.succ n) := ff

def g : my_nat → bool :=
  @my_nat.rec
    (fun n, bool)
    tt
    (fun (n : my_nat) (recur : bool), ff)

def my_factorial : nat → nat :=
  @nat.rec
    (fun n, nat)
    1
    (fun n recur, (n+1) * recur)

def foo (a b : nat) : Prop := (a = b)
--set_option pp.all true
#print foo

#print eq
#print eq.rec

inductive optionat : Type
| none : optionat
| some : nat → optionat

example : optionat := optionat.none
example : optionat := optionat.some 5
example : optionat := optionat.some 3

inductive my_bool_list : Type
| nil : my_bool_list
| cons : bool → my_bool_list → my_bool_list
open my_bool_list

example : my_bool_list :=
  (cons ff (cons tt nil))

/-
eq.rec :
Π {α : Sort u}       nat
  {a : α}            a : nat
  {C : α → Sort l},
  (C a) →
Π {b : α},           b : nat
  (a = b) →          h : a = b
(C b)
-/

example (a b : nat) : (a = b) = (@eq nat a b) := rfl

example (a b : nat) (f : nat → bool) :
  (a = b) → (f a = f b) :=
    λ (h : a = b),
    @eq.rec
      nat
      a
      (fun rhs, (f a = f rhs))
      (eq.refl (f a) : (f a = f a))
      b
      h

example (a b : nat) :
  (a = b) → (b = a) :=
    λ (h : a = b), @eq.rec
    nat
    a
    (fun rhs, (rhs = a))
    (eq.refl a : (a = a))
    b
    h

example (a b c : nat) :
  (a = b) → (b = c) → (a = c) :=
    λ (hab : a = b) (hbc : b = c), @eq.rec
    nat
    b
    (fun rhs, (a = rhs))
    (hab : a = b)
    c
    hbc

#print eq
/-
inductive eq : Π {α : Sort u}, α → α → Prop
constructors:
eq.refl : ∀ {α : Sort u} (a : α), a = a  -- (@eq α a a)
-/

example (a b : nat) : Prop := @eq nat a b

#print eq.rec
/-
eq.rec :
Π {α : Sort u}       nat
  {a : α}            a : nat
  {C : α → Sort l},
  (C a) →
Π {b : α},           b : nat
  (a = b) →          h : a = b
(C b)
-/

#print heq
/-
inductive heq : Π {α : Sort u}, α → Π {β : Sort u}, β → Prop
constructors:
heq.refl : ∀ {α : Sort u} (a : α), a == a  -- (@heq α a α a)
-/

example (a b : nat) : Prop := @heq nat a nat b

#print heq.rec
/-
heq.rec :
Π {α : Sort u}
  {a : α}
  {C : Π {β : Sort u} (b : β), Sort l},
  (@C α a) →
Π {β : Sort u}
  {b : β},
  (a == b) →
(@C β b)
-/

-- heq on the level of values imples eq in the level of types
#check @type_eq_of_heq
example (α β : Sort*) (a : α) (b : β) :
  (a == b) → (α = β)
:=
  @heq.rec
  α a
  (fun γ c, α = γ)
  (eq.refl α)
  β b

-- heq of values can be upgraded to eq of values with a type-cast
lemma cast_eq_of_heq (α β : Sort*) (a : α) (b : β) :
  forall (h : a == b),
  let cast : α → β := fun x, (@eq.rec _ α id x β (type_eq_of_heq h)) in
  (cast a) = b
:=
  fun h, @heq.rec
  α a
  (fun γ c, forall (hγ : α = γ), (@eq.rec _ α id a γ hγ) = c)
  (fun _, eq.refl a)
  β b
  h (type_eq_of_heq h)

-- the type-cast isn't needed when the types are defeq
#check @eq_of_heq
example (α : Sort*) (a b : α) :
  (a == b) → (a = b)
:=
  fun h, @heq.rec
  α a
  (fun γ c, forall (hγ : α = γ), (@eq.rec _ α id a γ hγ) = c)
  (fun _, eq.refl a)
  α b
  h (eq.refl α)

#check @congr
/-
congr :
∀ {α β : Sort*}
  {f₁ f₂ : α → β}
  {a₁ a₂ : α},
  (f₁ = f₂) →
  (a₁ = a₂) →
(f₁ a₁ = f₂ a₂)
-/

#check @congr_arg_heq
/-
congr_arg_heq :
∀ {α : Sort*}
  {β : α → Sort*}
  (f : Π (a : α), β a)
  {a₁ a₂ : α},
  (a₁ = a₂) →
(f a₁ == f a₂)
-/

def ccast {α : Sort*} {lhs rhs : α} (h : lhs = rhs) (C : α → Sort*) :
  (C lhs) → (C rhs) :=
    fun val, @eq.rec α lhs C val rhs h

lemma ccast_heq {α : Sort*} {lhs rhs : α} (h : lhs = rhs) (C : α → Sort*) (val : C lhs) :
  (ccast h C val) == val :=
    @eq.rec α lhs
    (fun a, forall (ha : lhs = a), (ccast ha C val) == val)
    (fun _, heq.refl val)
    rhs h h

lemma ccast_apply {α : Sort*} {lhs rhs : α} (h : lhs = rhs)
  (C : α → Sort*) (val : C lhs)
  {β : Sort*} (f : (C lhs) → β) :
  f val = (ccast h (fun a, (C a) → β) f) (ccast h C val) :=
    @eq.rec α lhs
    (fun a', forall (ha' : lhs = a'), f val = (ccast ha' (fun a, (C a) → β) f) (ccast ha' C val))
    (fun _, eq.refl (f val))
    rhs h h

lemma congr_heq
  (α₁ α₂ β : Sort*)
  (f₁ : α₁ → β)
  (f₂ : α₂ → β)
  (a₁ : α₁) (a₂ : α₂)
:
  (f₁ == f₂) →
  (a₁ == a₂) →
(f₁ a₁ = f₂ a₂)
:=
  fun hf ha, let
    hα : α₁ = α₂ := type_eq_of_heq ha,
    hf' : (ccast hα (fun α, α → β) f₁) = f₂ :=
      eq_of_heq (
      calc (ccast hα (fun α, α → β) f₁) == f₁ : ccast_heq _ _ _
      ...                               == f₂ : hf),
    ha' : (ccast hα (fun α, α) a₁) = a₂ :=
      eq_of_heq (
      calc (ccast hα (fun α, α) a₁) == a₁ : ccast_heq _ _ _
      ...                           == a₂ : ha)
  in
  calc f₁ a₁ = (ccast hα (fun α, α → β) f₁) (ccast hα (fun α, α) a₁) : ccast_apply hα _ _ _
  ...        = f₂ a₂                                                 : congr hf' ha'


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import ring_theory.ideal.operations

/-!
# Ideals in product rings

For commutative rings `R` and `S` and ideals `I ≤ R`, `J ≤ S`, we define `ideal.prod I J` as the
product `I × J`, viewed as an ideal of `R × S`. In `ideal_prod_eq` we show that every ideal of
`R × S` is of this form.  Furthermore, we show that every prime ideal of `R × S` is of the form
`p × S` or `R × p`, where `p` is a prime ideal.
-/

universes u v
variables {R : Type u} {S : Type v} [ring R] [ring S] (I I' : ideal R) (J J' : ideal S)

namespace ideal

/-- `I × J` as an ideal of `R × S`. -/
def prod : ideal (R × S) :=
{ carrier := { x | x.fst ∈ I ∧ x.snd ∈ J },
  zero_mem' := by simp,
  add_mem' :=
  begin
    rintros ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ⟨ha₁, ha₂⟩ ⟨hb₁, hb₂⟩,
    exact ⟨I.add_mem ha₁ hb₁, J.add_mem ha₂ hb₂⟩
  end,
  smul_mem' :=
  begin
    rintros ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ⟨hb₁, hb₂⟩,
    exact ⟨I.mul_mem_left _ hb₁, J.mul_mem_left _ hb₂⟩,
  end }

@[simp] lemma mem_prod {r : R} {s : S} : (⟨r, s⟩ : R × S) ∈ prod I J ↔ r ∈ I ∧ s ∈ J := iff.rfl
@[simp] lemma prod_top_top : prod (⊤ : ideal R) (⊤ : ideal S) = ⊤ := ideal.ext $ by simp

/-- Every ideal of the product ring is of the form `I × J`, where `I` and `J` can be explicitly
    given as the image under the projection maps. -/
theorem ideal_prod_eq (I : ideal (R × S)) :
  I = ideal.prod (map (ring_hom.fst R S) I) (map (ring_hom.snd R S) I) :=
begin
  apply ideal.ext,
  rintro ⟨r, s⟩,
  rw [mem_prod, mem_map_iff_of_surjective (ring_hom.fst R S) prod.fst_surjective,
    mem_map_iff_of_surjective (ring_hom.snd R S) prod.snd_surjective],
  refine ⟨λ h, ⟨⟨_, ⟨h, rfl⟩⟩, ⟨_, ⟨h, rfl⟩⟩⟩, _⟩,
  rintro ⟨⟨⟨r, s'⟩, ⟨h₁, rfl⟩⟩, ⟨⟨r', s⟩, ⟨h₂, rfl⟩⟩⟩,
  simpa using I.add_mem (I.mul_mem_left (1, 0) h₁) (I.mul_mem_left (0, 1) h₂),
end

@[simp] lemma map_fst_prod (I : ideal R) (J : ideal S) : map (ring_hom.fst R S) (prod I J) = I :=
begin
  ext,
  rw mem_map_iff_of_surjective (ring_hom.fst R S) prod.fst_surjective,
  exact ⟨by { rintro ⟨x, ⟨h, rfl⟩⟩, exact h.1 }, λ h, ⟨⟨x, 0⟩, ⟨⟨h, ideal.zero_mem _⟩, rfl⟩⟩⟩
end

@[simp] lemma map_snd_prod (I : ideal R) (J : ideal S) : map (ring_hom.snd R S) (prod I J) = J :=
begin
  ext,
  rw mem_map_iff_of_surjective (ring_hom.snd R S) prod.snd_surjective,
  exact ⟨by { rintro ⟨x, ⟨h, rfl⟩⟩, exact h.2 }, λ h, ⟨⟨0, x⟩, ⟨⟨ideal.zero_mem _, h⟩, rfl⟩⟩⟩
end

@[simp] lemma map_prod_comm_prod :
  map ↑(ring_equiv.prod_comm : R × S ≃+* S × R) (prod I J) = prod J I :=
begin
  refine trans (ideal_prod_eq _) _,
  simp [map_map],
end

/-- Ideals of `R × S` are in one-to-one correspondence with pairs of ideals of `R` and ideals of
    `S`. -/
def ideal_prod_equiv : ideal (R × S) ≃ ideal R × ideal S :=
{ to_fun := λ I, ⟨map (ring_hom.fst R S) I, map (ring_hom.snd R S) I⟩,
  inv_fun := λ I, prod I.1 I.2,
  left_inv := λ I, (ideal_prod_eq I).symm,
  right_inv := λ ⟨I, J⟩, by simp }

@[simp] lemma ideal_prod_equiv_symm_apply (I : ideal R) (J : ideal S) :
  ideal_prod_equiv.symm ⟨I, J⟩ = prod I J := rfl

lemma prod.ext_iff {I I' : ideal R} {J J' : ideal S} : prod I J = prod I' J' ↔ I = I' ∧ J = J' :=
by simp only [←ideal_prod_equiv_symm_apply, ideal_prod_equiv.symm.injective.eq_iff, prod.mk.inj_iff]

lemma is_prime_of_is_prime_prod_top {I : ideal R} (h : (ideal.prod I (⊤ : ideal S)).is_prime) :
  I.is_prime :=
begin
  split,
  { unfreezingI { contrapose! h },
    simp [is_prime_iff, h] },
  { intros x y hxy,
    have : (⟨x, 1⟩ : R × S) * ⟨y, 1⟩ ∈ prod I ⊤,
    { rw [prod.mk_mul_mk, mul_one, mem_prod],
      exact ⟨hxy, trivial⟩ },
    simpa using h.mem_or_mem this }
end

lemma is_prime_of_is_prime_prod_top' {I : ideal S} (h : (ideal.prod (⊤ : ideal R) I).is_prime) :
  I.is_prime :=
begin
  apply @is_prime_of_is_prime_prod_top _ R,
  rw ←map_prod_comm_prod,
  exact map_is_prime_of_equiv _
end

lemma is_prime_ideal_prod_top' {I : ideal S} [h : I.is_prime] : (prod (⊤ : ideal R) I).is_prime :=
begin
  rw ←map_prod_comm_prod,
  apply map_is_prime_of_equiv _,
  exact is_prime_ideal_prod_top,
end

lemma ideal_prod_prime_aux {I : ideal R} {J : ideal S} : (ideal.prod I J).is_prime →
  I = ⊤ ∨ J = ⊤ :=
begin
  contrapose!,
  simp only [ne_top_iff_one, is_prime_iff, not_and, not_forall, not_or_distrib],
  exact λ ⟨hI, hJ⟩ hIJ, ⟨⟨0, 1⟩, ⟨1, 0⟩, by simp, by simp [hJ], by simp [hI]⟩
end

/-- Classification of prime ideals in product rings: the prime ideals of `R × S` are precisely the
    ideals of the form `p × S` or `R × p`, where `p` is a prime ideal of `R` or `S`. -/
theorem ideal_prod_prime (I : ideal (R × S)) : I.is_prime ↔
  ((∃ p : ideal R, p.is_prime ∧ I = ideal.prod p ⊤) ∨
   (∃ p : ideal S, p.is_prime ∧ I = ideal.prod ⊤ p)) :=
begin
  split,
  { rw ideal_prod_eq I,
    introsI hI,
    rcases ideal_prod_prime_aux hI with (h|h),
    { right,
      rw h at hI ⊢,
      exact ⟨_, ⟨is_prime_of_is_prime_prod_top' hI, rfl⟩⟩ },
    { left,
      rw h at hI ⊢,
      exact ⟨_, ⟨is_prime_of_is_prime_prod_top hI, rfl⟩⟩ } },
  { rintro (⟨p, ⟨h, rfl⟩⟩|⟨p, ⟨h, rfl⟩⟩),
    { exactI is_prime_ideal_prod_top },
    { exactI is_prime_ideal_prod_top' } }
end

@[simp] private def prime_ideals_equiv_impl :
  { I : ideal R // I.is_prime } ⊕ { J : ideal S // J.is_prime } →
    { K : ideal (R × S) // K.is_prime }
| (sum.inl ⟨I, hI⟩) := ⟨ideal.prod I ⊤, by exactI is_prime_ideal_prod_top⟩
| (sum.inr ⟨J, hJ⟩) := ⟨ideal.prod ⊤ J, by exactI is_prime_ideal_prod_top'⟩

section
variables (R S)

/-- The prime ideals of `R × S` are in bijection with the disjoint union of the prime ideals
    of `R` and the prime ideals of `S`. -/
noncomputable def prime_ideals_equiv : { K : ideal (R × S) // K.is_prime } ≃
  { I : ideal R // I.is_prime } ⊕ { J : ideal S // J.is_prime } :=
equiv.symm $ equiv.of_bijective prime_ideals_equiv_impl
begin
  split,
  { rintros (⟨I, hI⟩|⟨J, hJ⟩) (⟨I',  hI'⟩|⟨J', hJ'⟩) h;
    simp [prod.ext_iff] at h,
    { simp [h] },
    { exact false.elim (hI.ne_top h.1) },
    { exact false.elim (hJ.ne_top h.2) },
    { simp [h] } },
  { rintro ⟨I, hI⟩,
    rcases (ideal_prod_prime I).1 hI with (⟨p, ⟨hp, rfl⟩⟩|⟨p, ⟨hp, rfl⟩⟩),
    { exact ⟨sum.inl ⟨p, hp⟩, rfl⟩ },
    { exact ⟨sum.inr ⟨p, hp⟩, rfl⟩ } }
end

end

@[simp] lemma prime_ideals_equiv_symm_inl (h : I.is_prime) :
  (prime_ideals_equiv R S).symm (sum.inl ⟨I, h⟩) = ⟨prod I ⊤, by exactI is_prime_ideal_prod_top⟩ :=
rfl
@[simp] lemma prime_ideals_equiv_symm_inr (h : J.is_prime) :
  (prime_ideals_equiv R S).symm (sum.inr ⟨J, h⟩) = ⟨prod ⊤ J, by exactI is_prime_ideal_prod_top'⟩ :=
rfl

end ideal


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/

/-
Negation elimination.
-/

import tactic.omega.nat.form

namespace omega
namespace nat

open_locale omega.nat

/-- push_neg p returns the result of normalizing ¬ p by
    pushing the outermost negation all the way down,
    until it reaches either a negation or an atom -/
@[simp] def push_neg : preform → preform
| (p ∨* q) := (push_neg p) ∧* (push_neg q)
| (p ∧* q) := (push_neg p) ∨* (push_neg q)
| (¬*p)    := p
| p        := ¬* p

lemma push_neg_equiv :
  ∀ {p : preform}, preform.equiv (push_neg p) (¬* p) :=
begin
  preform.induce `[intros v; try {refl}],
  { simp only [not_not, preform.holds, push_neg] },
  { simp only [preform.holds, push_neg, not_or_distrib, ihp v, ihq v] },
  { simp only [preform.holds, push_neg, not_and_distrib, ihp v, ihq v] }
end

/-- NNF transformation -/
def nnf : preform → preform
| (¬* p)   := push_neg (nnf p)
| (p ∨* q) := (nnf p) ∨* (nnf q)
| (p ∧* q) := (nnf p) ∧* (nnf q)
| a        := a

/-- Asserts that the given preform is in NNF -/
def is_nnf : preform → Prop
| (t =* s) := true
| (t ≤* s) := true
| ¬*(t =* s) := true
| ¬*(t ≤* s) := true
| (p ∨* q) := is_nnf p ∧ is_nnf q
| (p ∧* q) := is_nnf p ∧ is_nnf q
| _ := false

lemma is_nnf_push_neg : ∀ p : preform, is_nnf p → is_nnf (push_neg p) :=
begin
  preform.induce `[intro h1; try {trivial}],
  { cases p; try {cases h1}; trivial },
  { cases h1, constructor; [{apply ihp}, {apply ihq}]; assumption },
  { cases h1, constructor; [{apply ihp}, {apply ihq}]; assumption }
end

lemma is_nnf_nnf : ∀ p : preform, is_nnf (nnf p) :=
begin
  preform.induce `[try {trivial}],
  { apply is_nnf_push_neg _ ih },
  { constructor; assumption },
  { constructor; assumption }
end

lemma nnf_equiv : ∀ {p : preform}, preform.equiv (nnf p) p :=
begin
  preform.induce `[intros v; try {refl}; simp only [nnf]],
  { rw push_neg_equiv,
    apply not_iff_not_of_iff, apply ih },
  { apply pred_mono_2' (ihp v) (ihq v) },
  { apply pred_mono_2' (ihp v) (ihq v) }
end

@[simp] def neg_elim_core : preform → preform
| (¬* (t =* s)) := (t.add_one ≤* s) ∨* (s.add_one ≤* t)
| (¬* (t ≤* s)) := s.add_one ≤* t
| (p ∨* q) := (neg_elim_core p) ∨* (neg_elim_core q)
| (p ∧* q) := (neg_elim_core p) ∧* (neg_elim_core q)
| p        := p

lemma neg_free_neg_elim_core : ∀ p, is_nnf p → (neg_elim_core p).neg_free :=
begin
  preform.induce `[intro h1, try {simp only [neg_free, neg_elim_core]}, try {trivial}],
  { cases p; try {cases h1}; try {trivial},
    constructor; trivial },
  { cases h1, constructor; [{apply ihp}, {apply ihq}]; assumption },
  { cases h1, constructor; [{apply ihp}, {apply ihq}]; assumption }
end

lemma le_and_le_iff_eq {α : Type} [partial_order α] {a b : α} :
  (a ≤ b ∧ b ≤ a) ↔ a = b :=
begin
  constructor; intro h1,
  { cases h1, apply le_antisymm; assumption },
  { constructor; apply le_of_eq; rw h1 }
end

lemma implies_neg_elim_core : ∀ {p : preform},
  preform.implies p (neg_elim_core p) :=
begin
  preform.induce `[intros v h, try {apply h}],
  { cases p with t s t s; try {apply h},
    { apply or.symm,
      simpa only [preform.holds, le_and_le_iff_eq.symm,
        not_and_distrib, not_le] using h },
    simpa only [preform.holds, not_le, int.add_one_le_iff] using h },
  { simp only [neg_elim_core], cases h;
    [{left, apply ihp}, {right, apply ihq}];
    assumption },
  apply and.imp (ihp _) (ihq _) h
end

/-- Eliminate all negations in a preform -/
def neg_elim : preform → preform := neg_elim_core ∘ nnf

lemma neg_free_neg_elim {p : preform} : (neg_elim p).neg_free :=
neg_free_neg_elim_core _ (is_nnf_nnf _)

lemma implies_neg_elim {p : preform} : preform.implies p (neg_elim p) :=
begin
  intros v h1, apply implies_neg_elim_core,
  apply (nnf_equiv v).elim_right h1
end

end nat

end omega


/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.real.ennreal
import Mathlib.PostPort

universes l

namespace Mathlib

/-!
# Real conjugate exponents

`p.is_conjugate_exponent q` registers the fact that the real numbers `p` and `q` are `> 1` and
satisfy `1/p + 1/q = 1`. This property shows up often in analysis, especially when dealing with
`L^p` spaces.

We make several basic facts available through dot notation in this situation.

We also introduce `p.conjugate_exponent` for `p / (p-1)`. When `p > 1`, it is conjugate to `p`.
-/

namespace real

/-- Two real exponents `p, q` are conjugate if they are `> 1` and satisfy the equality
`1/p + 1/q = 1`. This condition shows up in many theorems in analysis, notably related to `L^p`
norms. -/
structure is_conjugate_exponent (p : ℝ) (q : ℝ)
where
  one_lt : 1 < p
  inv_add_inv_conj : 1 / p + 1 / q = 1

/-- The conjugate exponent of `p` is `q = p/(p-1)`, so that `1/p + 1/q = 1`. -/
def conjugate_exponent (p : ℝ) : ℝ :=
  p / (p - 1)

namespace is_conjugate_exponent

/- Register several non-vanishing results following from the fact that `p` has a conjugate exponent
`q`: many computations using these exponents require clearing out denominators, which can be done
with `field_simp` given a proof that these denominators are non-zero, so we record the most usual
ones. -/

theorem pos {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : 0 < p :=
  lt_trans zero_lt_one (one_lt h)

theorem nonneg {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : 0 ≤ p :=
  le_of_lt (pos h)

theorem ne_zero {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : p ≠ 0 :=
  ne_of_gt (pos h)

theorem sub_one_pos {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : 0 < p - 1 :=
  iff.mpr sub_pos (one_lt h)

theorem sub_one_ne_zero {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : p - 1 ≠ 0 :=
  ne_of_gt (sub_one_pos h)

theorem one_div_pos {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : 0 < 1 / p :=
  iff.mpr one_div_pos (pos h)

theorem one_div_nonneg {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : 0 ≤ 1 / p :=
  le_of_lt (one_div_pos h)

theorem one_div_ne_zero {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : 1 / p ≠ 0 :=
  ne_of_gt (one_div_pos h)

theorem conj_eq {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : q = p / (p - 1) := sorry

theorem conjugate_eq {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : conjugate_exponent p = q :=
  Eq.symm (conj_eq h)

theorem sub_one_mul_conj {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : (p - 1) * q = p :=
  mul_comm q (p - 1) ▸ iff.mp (eq_div_iff (sub_one_ne_zero h)) (conj_eq h)

theorem mul_eq_add {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : p * q = p + q := sorry

protected theorem symm {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : is_conjugate_exponent q p := sorry

theorem one_lt_nnreal {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : 1 < nnreal.of_real p := sorry

theorem inv_add_inv_conj_nnreal {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : 1 / nnreal.of_real p + 1 / nnreal.of_real q = 1 := sorry

theorem inv_add_inv_conj_ennreal {p : ℝ} {q : ℝ} (h : is_conjugate_exponent p q) : 1 / ennreal.of_real p + 1 / ennreal.of_real q = 1 := sorry

end is_conjugate_exponent

theorem is_conjugate_exponent_iff {p : ℝ} {q : ℝ} (h : 1 < p) : is_conjugate_exponent p q ↔ q = p / (p - 1) := sorry

theorem is_conjugate_exponent_conjugate_exponent {p : ℝ} (h : 1 < p) : is_conjugate_exponent p (conjugate_exponent p) :=
  iff.mpr (is_conjugate_exponent_iff h) rfl