/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import order.rel_classes

/-!
# (Semi-)lattices

Semilattices are partially ordered sets with join (greatest lower bound, or `sup`) or
meet (least upper bound, or `inf`) operations. Lattices are posets that are both
join-semilattices and meet-semilattices.

Distributive lattices are lattices which satisfy any of four equivalent distributivity properties,
of `sup` over `inf`, on the left or on the right.

## Main declarations

* `has_sup`: type class for the `⊔` notation
* `has_inf`: type class for the `⊓` notation

* `semilattice_sup`: a type class for join semilattices
* `semilattice_sup.mk'`: an alternative constructor for `semilattice_sup` via proofs that `⊔` is
  commutative, associative and idempotent.
* `semilattice_inf`: a type class for meet semilattices
* `semilattice_sup.mk'`: an alternative constructor for `semilattice_inf` via proofs that `⊓` is
  commutative, associative and idempotent.

* `lattice`: a type class for lattices
* `lattice.mk'`: an alternative constructor for `lattice` via profs that `⊔` and `⊓` are
  commutative, associative and satisfy a pair of "absorption laws".

* `distrib_lattice`: a type class for distributive lattices.

## Notations

* `a ⊔ b`: the supremum or join of `a` and `b`
* `a ⊓ b`: the infimum or meet of `a` and `b`

## TODO

* (Semi-)lattice homomorphisms
* Alternative constructors for distributive lattices from the other distributive properties

## Tags

semilattice, lattice

-/
set_option old_structure_cmd true

universes u v w

variables {α : Type u} {β : Type v}

-- TODO: move this eventually, if we decide to use them
attribute [ematch] le_trans lt_of_le_of_lt lt_of_lt_of_le lt_trans

section
-- TODO: this seems crazy, but it also seems to work reasonably well
@[ematch] theorem le_antisymm' [partial_order α] : ∀ {a b : α}, (: a ≤ b :) → b ≤ a → a = b :=
@le_antisymm _ _
end

/- TODO: automatic construction of dual definitions / theorems -/

/-- Typeclass for the `⊔` (`\lub`) notation -/
class has_sup (α : Type u) := (sup : α → α → α)
/-- Typeclass for the `⊓` (`\glb`) notation -/
class has_inf (α : Type u) := (inf : α → α → α)

infix ⊔ := has_sup.sup
infix ⊓ := has_inf.inf

/-!
### Join-semilattices
-/

/-- A `semilattice_sup` is a join-semilattice, that is, a partial order
  with a join (a.k.a. lub / least upper bound, sup / supremum) operation
  `⊔` which is the least element larger than both factors. -/
class semilattice_sup (α : Type u) extends has_sup α, partial_order α :=
(le_sup_left : ∀ a b : α, a ≤ a ⊔ b)
(le_sup_right : ∀ a b : α, b ≤ a ⊔ b)
(sup_le : ∀ a b c : α, a ≤ c → b ≤ c → a ⊔ b ≤ c)

/--
A type with a commutative, associative and idempotent binary `sup` operation has the structure of a
join-semilattice.

The partial order is defined so that `a ≤ b` unfolds to `a ⊔ b = b`; cf. `sup_eq_right`.
-/
def semilattice_sup.mk' {α : Type*} [has_sup α]
  (sup_comm : ∀ (a b : α), a ⊔ b = b ⊔ a)
  (sup_assoc : ∀ (a b c : α), a ⊔ b ⊔ c = a ⊔ (b ⊔ c))
  (sup_idem : ∀ (a : α), a ⊔ a = a) : semilattice_sup α :=
{ sup := (⊔),
  le := λ a b, a ⊔ b = b,
  le_refl := sup_idem,
  le_trans := λ a b c hab hbc,
    begin
      dsimp only [(≤)] at *,
      rwa [←hbc, ←sup_assoc, hab],
    end,
  le_antisymm := λ a b hab hba,
    begin
      dsimp only [(≤)] at *,
      rwa [←hba, sup_comm],
    end,
  le_sup_left  := λ a b, show a ⊔ (a ⊔ b) = (a ⊔ b), by rw [←sup_assoc, sup_idem],
  le_sup_right := λ a b, show b ⊔ (a ⊔ b) = (a ⊔ b), by rw [sup_comm, sup_assoc, sup_idem],
  sup_le := λ a b c hac hbc,
    begin
      dsimp only [(≤), preorder.le] at *,
      rwa [sup_assoc, hbc],
    end }

instance (α : Type*) [has_inf α] : has_sup (order_dual α) := ⟨((⊓) : α → α → α)⟩
instance (α : Type*) [has_sup α] : has_inf (order_dual α) := ⟨((⊔) : α → α → α)⟩

section semilattice_sup
variables [semilattice_sup α] {a b c d : α}

@[simp] theorem le_sup_left : a ≤ a ⊔ b :=
semilattice_sup.le_sup_left a b

@[ematch] theorem le_sup_left' : a ≤ (: a ⊔ b :) :=
le_sup_left

@[simp] theorem le_sup_right : b ≤ a ⊔ b :=
semilattice_sup.le_sup_right a b

@[ematch] theorem le_sup_right' : b ≤ (: a ⊔ b :) :=
le_sup_right

theorem le_sup_left_of_le (h : c ≤ a) : c ≤ a ⊔ b :=
le_trans h le_sup_left

theorem le_sup_right_of_le (h : c ≤ b) : c ≤ a ⊔ b :=
le_trans h le_sup_right

theorem sup_le : a ≤ c → b ≤ c → a ⊔ b ≤ c :=
semilattice_sup.sup_le a b c

@[simp] theorem sup_le_iff : a ⊔ b ≤ c ↔ a ≤ c ∧ b ≤ c :=
⟨assume h : a ⊔ b ≤ c, ⟨le_trans le_sup_left h, le_trans le_sup_right h⟩,
  assume ⟨h₁, h₂⟩, sup_le h₁ h₂⟩

@[simp] theorem sup_eq_left : a ⊔ b = a ↔ b ≤ a :=
le_antisymm_iff.trans $ by simp [le_refl]

theorem sup_of_le_left (h : b ≤ a) : a ⊔ b = a :=
sup_eq_left.2 h

@[simp] theorem left_eq_sup : a = a ⊔ b ↔ b ≤ a :=
eq_comm.trans sup_eq_left

@[simp] theorem sup_eq_right : a ⊔ b = b ↔ a ≤ b :=
le_antisymm_iff.trans $ by simp [le_refl]

theorem sup_of_le_right (h : a ≤ b) : a ⊔ b = b :=
sup_eq_right.2 h

@[simp] theorem right_eq_sup : b = a ⊔ b ↔ a ≤ b :=
eq_comm.trans sup_eq_right

theorem sup_le_sup (h₁ : a ≤ b) (h₂ : c ≤ d) : a ⊔ c ≤ b ⊔ d :=
sup_le (le_sup_left_of_le h₁) (le_sup_right_of_le h₂)

theorem sup_le_sup_left (h₁ : a ≤ b) (c) : c ⊔ a ≤ c ⊔ b :=
sup_le_sup (le_refl _) h₁

theorem sup_le_sup_right (h₁ : a ≤ b) (c) : a ⊔ c ≤ b ⊔ c :=
sup_le_sup h₁ (le_refl _)

theorem le_of_sup_eq (h : a ⊔ b = b) : a ≤ b :=
by { rw ← h, simp }

lemma sup_ind [is_total α (≤)] (a b : α) {p : α → Prop} (ha : p a) (hb : p b) : p (a ⊔ b) :=
(is_total.total a b).elim (λ h : a ≤ b, by rwa sup_eq_right.2 h) (λ h, by rwa sup_eq_left.2 h)

@[simp] lemma sup_lt_iff [is_total α (≤)] {a b c : α} : b ⊔ c < a ↔ b < a ∧ c < a :=
⟨λ h, ⟨le_sup_left.trans_lt h, le_sup_right.trans_lt h⟩, λ h, sup_ind b c h.1 h.2⟩

@[simp] lemma le_sup_iff [is_total α (≤)] {a b c : α} : a ≤ b ⊔ c ↔ a ≤ b ∨ a ≤ c :=
by rw [← not_iff_not]; simp only [not_or_distrib, @sup_lt_iff α, @not_le (as_linear_order α)]

@[simp] lemma lt_sup_iff [is_total α (≤)] {a b c : α} : a < b ⊔ c ↔ a < b ∨ a < c :=
by { rw ← not_iff_not, simp only [not_or_distrib, @not_lt (as_linear_order α), sup_le_iff] }

@[simp] theorem sup_idem : a ⊔ a = a :=
by apply le_antisymm; simp

instance sup_is_idempotent : is_idempotent α (⊔) := ⟨@sup_idem _ _⟩

theorem sup_comm : a ⊔ b = b ⊔ a :=
by apply le_antisymm; simp

instance sup_is_commutative : is_commutative α (⊔) := ⟨@sup_comm _ _⟩

theorem sup_assoc : a ⊔ b ⊔ c = a ⊔ (b ⊔ c) :=
le_antisymm
  (sup_le
    (sup_le le_sup_left (le_sup_right_of_le le_sup_left))
    (le_sup_right_of_le le_sup_right))
  (sup_le
    (le_sup_left_of_le le_sup_left)
    (sup_le (le_sup_left_of_le le_sup_right) le_sup_right))

instance sup_is_associative : is_associative α (⊔) := ⟨@sup_assoc _ _⟩

lemma sup_left_right_swap (a b c : α) : a ⊔ b ⊔ c = c ⊔ b ⊔ a :=
by rw [sup_comm, @sup_comm _ _ a, sup_assoc]

@[simp] lemma sup_left_idem : a ⊔ (a ⊔ b) = a ⊔ b :=
by rw [← sup_assoc, sup_idem]

@[simp] lemma sup_right_idem : (a ⊔ b) ⊔ b = a ⊔ b :=
by rw [sup_assoc, sup_idem]

lemma sup_left_comm (a b c : α) : a ⊔ (b ⊔ c) = b ⊔ (a ⊔ c) :=
by rw [← sup_assoc, ← sup_assoc, @sup_comm α _ a]

lemma sup_right_comm (a b c : α) : a ⊔ b ⊔ c = a ⊔ c ⊔ b :=
by rw [sup_assoc, sup_assoc, @sup_comm _ _ b]

lemma forall_le_or_exists_lt_sup (a : α) : (∀b, b ≤ a) ∨ (∃b, a < b) :=
suffices (∃b, ¬b ≤ a) → (∃b, a < b),
  by rwa [or_iff_not_imp_left, not_forall],
assume ⟨b, hb⟩,
⟨a ⊔ b, lt_of_le_of_ne le_sup_left $ mt left_eq_sup.1 hb⟩

/-- If `f` is a monotonically increasing sequence, `g` is a monotonically decreasing
sequence, and `f n ≤ g n` for all `n`, then for all `m`, `n` we have `f m ≤ g n`. -/
theorem forall_le_of_monotone_of_mono_decr {β : Type*} [preorder β]
  {f g : α → β} (hf : monotone f) (hg : ∀ ⦃m n⦄, m ≤ n → g n ≤ g m)
  (h : ∀ n, f n ≤ g n) (m n : α) : f m ≤ g n :=
calc f m ≤ f (m ⊔ n) : hf le_sup_left
     ... ≤ g (m ⊔ n) : h _
     ... ≤ g n       : hg le_sup_right

theorem semilattice_sup.ext_sup {α} {A B : semilattice_sup α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y)
  (x y : α) : (by haveI := A; exact (x ⊔ y)) = x ⊔ y :=
eq_of_forall_ge_iff $ λ c,
by simp only [sup_le_iff]; rw [← H, @sup_le_iff α A, H, H]

theorem semilattice_sup.ext {α} {A B : semilattice_sup α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
begin
  have := partial_order.ext H,
  have ss := funext (λ x, funext $ semilattice_sup.ext_sup H x),
  casesI A, casesI B,
  injection this; congr'
end

end semilattice_sup

/-!
### Meet-semilattices
-/

/-- A `semilattice_inf` is a meet-semilattice, that is, a partial order
  with a meet (a.k.a. glb / greatest lower bound, inf / infimum) operation
  `⊓` which is the greatest element smaller than both factors. -/
class semilattice_inf (α : Type u) extends has_inf α, partial_order α :=
(inf_le_left : ∀ a b : α, a ⊓ b ≤ a)
(inf_le_right : ∀ a b : α, a ⊓ b ≤ b)
(le_inf : ∀ a b c : α, a ≤ b → a ≤ c → a ≤ b ⊓ c)

instance (α) [semilattice_inf α] : semilattice_sup (order_dual α) :=
{ le_sup_left  := semilattice_inf.inf_le_left,
  le_sup_right := semilattice_inf.inf_le_right,
  sup_le := assume a b c hca hcb, @semilattice_inf.le_inf α _ _ _ _ hca hcb,
  .. order_dual.partial_order α, .. order_dual.has_sup α }

instance (α) [semilattice_sup α] : semilattice_inf (order_dual α) :=
{ inf_le_left  := @le_sup_left α _,
  inf_le_right := @le_sup_right α _,
  le_inf := assume a b c hca hcb, @sup_le α _ _ _ _ hca hcb,
  .. order_dual.partial_order α, .. order_dual.has_inf α }

theorem semilattice_sup.dual_dual (α : Type*) [H : semilattice_sup α] :
  order_dual.semilattice_sup (order_dual α) = H :=
semilattice_sup.ext $ λ _ _, iff.rfl

section semilattice_inf
variables [semilattice_inf α] {a b c d : α}

@[simp] theorem inf_le_left : a ⊓ b ≤ a :=
semilattice_inf.inf_le_left a b

@[ematch] theorem inf_le_left' : (: a ⊓ b :) ≤ a :=
semilattice_inf.inf_le_left a b

@[simp] theorem inf_le_right : a ⊓ b ≤ b :=
semilattice_inf.inf_le_right a b

@[ematch] theorem inf_le_right' : (: a ⊓ b :) ≤ b :=
semilattice_inf.inf_le_right a b

theorem le_inf : a ≤ b → a ≤ c → a ≤ b ⊓ c :=
semilattice_inf.le_inf a b c

theorem inf_le_left_of_le (h : a ≤ c) : a ⊓ b ≤ c :=
le_trans inf_le_left h

theorem inf_le_right_of_le (h : b ≤ c) : a ⊓ b ≤ c :=
le_trans inf_le_right h

@[simp] theorem le_inf_iff : a ≤ b ⊓ c ↔ a ≤ b ∧ a ≤ c :=
@sup_le_iff (order_dual α) _ _ _ _

@[simp] theorem inf_eq_left : a ⊓ b = a ↔ a ≤ b :=
le_antisymm_iff.trans $ by simp [le_refl]

theorem inf_of_le_left (h : a ≤ b) : a ⊓ b = a :=
inf_eq_left.2 h

@[simp] theorem left_eq_inf : a = a ⊓ b ↔ a ≤ b :=
eq_comm.trans inf_eq_left

@[simp] theorem inf_eq_right : a ⊓ b = b ↔ b ≤ a :=
le_antisymm_iff.trans $ by simp [le_refl]

theorem inf_of_le_right (h : b ≤ a) : a ⊓ b = b :=
inf_eq_right.2 h

@[simp] theorem right_eq_inf : b = a ⊓ b ↔ b ≤ a :=
eq_comm.trans inf_eq_right

theorem inf_le_inf (h₁ : a ≤ b) (h₂ : c ≤ d) : a ⊓ c ≤ b ⊓ d :=
le_inf (inf_le_left_of_le h₁) (inf_le_right_of_le h₂)

lemma inf_le_inf_right (a : α) {b c : α} (h : b ≤ c) : b ⊓ a ≤ c ⊓ a :=
inf_le_inf h (le_refl _)

lemma inf_le_inf_left (a : α) {b c : α} (h : b ≤ c) : a ⊓ b ≤ a ⊓ c :=
inf_le_inf (le_refl _) h

theorem le_of_inf_eq (h : a ⊓ b = a) : a ≤ b :=
by { rw ← h, simp }

lemma inf_ind [is_total α (≤)] (a b : α) {p : α → Prop} (ha : p a) (hb : p b) : p (a ⊓ b) :=
@sup_ind (order_dual α) _ _ _ _ _ ha hb

@[simp] lemma lt_inf_iff [is_total α (≤)] {a b c : α} : a < b ⊓ c ↔ a < b ∧ a < c :=
@sup_lt_iff (order_dual α) _ _ _ _ _

@[simp] lemma inf_le_iff [is_total α (≤)] {a b c : α} : b ⊓ c ≤ a ↔ b ≤ a ∨ c ≤ a :=
@le_sup_iff (order_dual α) _ _ _ _ _

@[simp] theorem inf_idem : a ⊓ a = a :=
@sup_idem (order_dual α) _ _

instance inf_is_idempotent : is_idempotent α (⊓) := ⟨@inf_idem _ _⟩

theorem inf_comm : a ⊓ b = b ⊓ a :=
@sup_comm (order_dual α) _ _ _

instance inf_is_commutative : is_commutative α (⊓) := ⟨@inf_comm _ _⟩

theorem inf_assoc : a ⊓ b ⊓ c = a ⊓ (b ⊓ c) :=
@sup_assoc (order_dual α) _ a b c

instance inf_is_associative : is_associative α (⊓) := ⟨@inf_assoc _ _⟩

lemma inf_left_right_swap (a b c : α) : a ⊓ b ⊓ c = c ⊓ b ⊓ a :=
by rw [inf_comm, @inf_comm _ _ a, inf_assoc]

@[simp] lemma inf_left_idem : a ⊓ (a ⊓ b) = a ⊓ b :=
@sup_left_idem (order_dual α) _ a b

@[simp] lemma inf_right_idem : (a ⊓ b) ⊓ b = a ⊓ b :=
@sup_right_idem (order_dual α) _ a b

lemma inf_left_comm (a b c : α) : a ⊓ (b ⊓ c) = b ⊓ (a ⊓ c) :=
@sup_left_comm (order_dual α) _ a b c

lemma inf_right_comm (a b c : α) : a ⊓ b ⊓ c = a ⊓ c ⊓ b :=
@sup_right_comm (order_dual α) _ a b c

lemma forall_le_or_exists_lt_inf (a : α) : (∀b, a ≤ b) ∨ (∃b, b < a) :=
@forall_le_or_exists_lt_sup (order_dual α) _ a

theorem semilattice_inf.ext_inf {α} {A B : semilattice_inf α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y)
  (x y : α) : (by haveI := A; exact (x ⊓ y)) = x ⊓ y :=
eq_of_forall_le_iff $ λ c,
by simp only [le_inf_iff]; rw [← H, @le_inf_iff α A, H, H]

theorem semilattice_inf.ext {α} {A B : semilattice_inf α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
begin
  have := partial_order.ext H,
  have ss := funext (λ x, funext $ semilattice_inf.ext_inf H x),
  casesI A, casesI B,
  injection this; congr'
end

theorem semilattice_inf.dual_dual (α : Type*) [H : semilattice_inf α] :
  order_dual.semilattice_inf (order_dual α) = H :=
semilattice_inf.ext $ λ _ _, iff.rfl

end semilattice_inf

/--
A type with a commutative, associative and idempotent binary `inf` operation has the structure of a
meet-semilattice.

The partial order is defined so that `a ≤ b` unfolds to `b ⊓ a = a`; cf. `inf_eq_right`.
-/
def semilattice_inf.mk' {α : Type*} [has_inf α]
  (inf_comm : ∀ (a b : α), a ⊓ b = b ⊓ a)
  (inf_assoc : ∀ (a b c : α), a ⊓ b ⊓ c = a ⊓ (b ⊓ c))
  (inf_idem : ∀ (a : α), a ⊓ a = a) : semilattice_inf α :=
begin
  haveI : semilattice_sup (order_dual α) := semilattice_sup.mk' inf_comm inf_assoc inf_idem,
  haveI i := order_dual.semilattice_inf (order_dual α),
  exact i,
end

/-!
### Lattices
-/

/-- A lattice is a join-semilattice which is also a meet-semilattice. -/
class lattice (α : Type u) extends semilattice_sup α, semilattice_inf α

instance (α) [lattice α] : lattice (order_dual α) :=
{ .. order_dual.semilattice_sup α, .. order_dual.semilattice_inf α }

/-- The partial orders from `semilattice_sup_mk'` and `semilattice_inf_mk'` agree
if `sup` and `inf` satisfy the lattice absorption laws `sup_inf_self` (`a ⊔ a ⊓ b = a`)
and `inf_sup_self` (`a ⊓ (a ⊔ b) = a`). -/
lemma semilattice_sup_mk'_partial_order_eq_semilattice_inf_mk'_partial_order {α : Type*}
  [has_sup α] [has_inf α]
  (sup_comm : ∀ (a b : α), a ⊔ b = b ⊔ a)
  (sup_assoc : ∀ (a b c : α), a ⊔ b ⊔ c = a ⊔ (b ⊔ c))
  (sup_idem : ∀ (a : α), a ⊔ a = a)
  (inf_comm : ∀ (a b : α), a ⊓ b = b ⊓ a)
  (inf_assoc : ∀ (a b c : α), a ⊓ b ⊓ c = a ⊓ (b ⊓ c))
  (inf_idem : ∀ (a : α), a ⊓ a = a)
  (sup_inf_self : ∀ (a b : α), a ⊔ a ⊓ b = a)
  (inf_sup_self : ∀ (a b : α), a ⊓ (a ⊔ b) = a) :
  @semilattice_sup.to_partial_order _ (semilattice_sup.mk' sup_comm sup_assoc sup_idem) =
    @semilattice_inf.to_partial_order _ (semilattice_inf.mk' inf_comm inf_assoc inf_idem) :=
partial_order.ext $ λ a b, show a ⊔ b = b ↔ b ⊓ a = a, from
  ⟨λ h, by rw [←h, inf_comm, inf_sup_self],
   λ h, by rw [←h, sup_comm, sup_inf_self]⟩

/--
A type with a pair of commutative and associative binary operations which satisfy two absorption
laws relating the two operations has the structure of a lattice.

The partial order is defined so that `a ≤ b` unfolds to `a ⊔ b = b`; cf. `sup_eq_right`.
-/
def lattice.mk' {α : Type*} [has_sup α] [has_inf α]
  (sup_comm : ∀ (a b : α), a ⊔ b = b ⊔ a)
  (sup_assoc : ∀ (a b c : α), a ⊔ b ⊔ c = a ⊔ (b ⊔ c))
  (inf_comm : ∀ (a b : α), a ⊓ b = b ⊓ a)
  (inf_assoc : ∀ (a b c : α), a ⊓ b ⊓ c = a ⊓ (b ⊓ c))
  (sup_inf_self : ∀ (a b : α), a ⊔ a ⊓ b = a)
  (inf_sup_self : ∀ (a b : α), a ⊓ (a ⊔ b) = a) : lattice α :=
have sup_idem : ∀ (b : α), b ⊔ b = b := λ b,
  calc b ⊔ b = b ⊔ b ⊓ (b ⊔ b) : by rw inf_sup_self
         ... = b               : by rw sup_inf_self,
have inf_idem : ∀ (b : α), b ⊓ b = b := λ b,
  calc b ⊓ b = b ⊓ (b ⊔ b ⊓ b) : by rw sup_inf_self
         ... = b               : by rw inf_sup_self,
let semilatt_inf_inst := semilattice_inf.mk' inf_comm inf_assoc inf_idem,
    semilatt_sup_inst := semilattice_sup.mk' sup_comm sup_assoc sup_idem,
-- here we help Lean to see that the two partial orders are equal
  partial_order_inst := @semilattice_sup.to_partial_order _ semilatt_sup_inst in
have partial_order_eq :
  partial_order_inst = @semilattice_inf.to_partial_order _ semilatt_inf_inst :=
  semilattice_sup_mk'_partial_order_eq_semilattice_inf_mk'_partial_order _ _ _ _ _ _
    sup_inf_self inf_sup_self,
{ inf_le_left  := λ a b, by { rw partial_order_eq, apply inf_le_left },
  inf_le_right := λ a b, by { rw partial_order_eq, apply inf_le_right },
  le_inf := λ a b c, by { rw partial_order_eq, apply le_inf },
  ..partial_order_inst,
  ..semilatt_sup_inst,
  ..semilatt_inf_inst, }

section lattice
variables [lattice α] {a b c d : α}

/-!
#### Distributivity laws
-/
/- TODO: better names? -/
theorem sup_inf_le : a ⊔ (b ⊓ c) ≤ (a ⊔ b) ⊓ (a ⊔ c) :=
le_inf (sup_le_sup_left inf_le_left _) (sup_le_sup_left inf_le_right _)

theorem le_inf_sup : (a ⊓ b) ⊔ (a ⊓ c) ≤ a ⊓ (b ⊔ c) :=
sup_le (inf_le_inf_left _ le_sup_left) (inf_le_inf_left _ le_sup_right)

theorem inf_sup_self : a ⊓ (a ⊔ b) = a :=
by simp

theorem sup_inf_self : a ⊔ (a ⊓ b) = a :=
by simp

theorem sup_eq_iff_inf_eq : a ⊔ b = b ↔ a ⊓ b = a :=
by rw [sup_eq_right, ←inf_eq_left]

theorem lattice.ext {α} {A B : lattice α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
begin
  have SS : @lattice.to_semilattice_sup α A =
            @lattice.to_semilattice_sup α B := semilattice_sup.ext H,
  have II := semilattice_inf.ext H,
  casesI A, casesI B,
  injection SS; injection II; congr'
end

end lattice

/-!
### Distributive lattices
-/

/-- A distributive lattice is a lattice that satisfies any of four
equivalent distributive properties (of `sup` over `inf` or `inf` over `sup`,
on the left or right).

The definition here chooses `le_sup_inf`: `(x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ (y ⊓ z)`.

A classic example of a distributive lattice
is the lattice of subsets of a set, and in fact this example is
generic in the sense that every distributive lattice is realizable
as a sublattice of a powerset lattice. -/
class distrib_lattice α extends lattice α :=
(le_sup_inf : ∀x y z : α, (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ (y ⊓ z))

/- TODO: alternative constructors from the other distributive properties,
and perhaps a `tfae` statement -/

section distrib_lattice
variables [distrib_lattice α] {x y z : α}

theorem le_sup_inf : ∀{x y z : α}, (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ (y ⊓ z) :=
distrib_lattice.le_sup_inf

theorem sup_inf_left : x ⊔ (y ⊓ z) = (x ⊔ y) ⊓ (x ⊔ z) :=
le_antisymm sup_inf_le le_sup_inf

theorem sup_inf_right : (y ⊓ z) ⊔ x = (y ⊔ x) ⊓ (z ⊔ x) :=
by simp only [sup_inf_left, λy:α, @sup_comm α _ y x, eq_self_iff_true]

theorem inf_sup_left : x ⊓ (y ⊔ z) = (x ⊓ y) ⊔ (x ⊓ z) :=
calc x ⊓ (y ⊔ z) = (x ⊓ (x ⊔ z)) ⊓ (y ⊔ z)       : by rw [inf_sup_self]
             ... = x ⊓ ((x ⊓ y) ⊔ z)             : by simp only [inf_assoc, sup_inf_right,
                                                                 eq_self_iff_true]
             ... = (x ⊔ (x ⊓ y)) ⊓ ((x ⊓ y) ⊔ z) : by rw [sup_inf_self]
             ... = ((x ⊓ y) ⊔ x) ⊓ ((x ⊓ y) ⊔ z) : by rw [sup_comm]
             ... = (x ⊓ y) ⊔ (x ⊓ z)             : by rw [sup_inf_left]

instance (α : Type*) [distrib_lattice α] : distrib_lattice (order_dual α) :=
{ le_sup_inf := assume x y z, le_of_eq inf_sup_left.symm,
  .. order_dual.lattice α }

theorem inf_sup_right : (y ⊔ z) ⊓ x = (y ⊓ x) ⊔ (z ⊓ x) :=
by simp only [inf_sup_left, λy:α, @inf_comm α _ y x, eq_self_iff_true]

lemma le_of_inf_le_sup_le (h₁ : x ⊓ z ≤ y ⊓ z) (h₂ : x ⊔ z ≤ y ⊔ z) : x ≤ y :=
calc x ≤ (y ⊓ z) ⊔ x : le_sup_right
... = (y ⊔ x) ⊓ (x ⊔ z) : by rw [sup_inf_right, @sup_comm _ _ x]
... ≤ (y ⊔ x) ⊓ (y ⊔ z) : inf_le_inf_left _ h₂
... = y ⊔ (x ⊓ z) : sup_inf_left.symm
... ≤ y ⊔ (y ⊓ z) : sup_le_sup_left h₁ _
... ≤ _ : sup_le (le_refl y) inf_le_left

lemma eq_of_inf_eq_sup_eq {α : Type u} [distrib_lattice α] {a b c : α}
  (h₁ : b ⊓ a = c ⊓ a) (h₂ : b ⊔ a = c ⊔ a) : b = c :=
le_antisymm
  (le_of_inf_le_sup_le (le_of_eq h₁) (le_of_eq h₂))
  (le_of_inf_le_sup_le (le_of_eq h₁.symm) (le_of_eq h₂.symm))

end distrib_lattice

/-!
### Lattices derived from linear orders
-/

@[priority 100] -- see Note [lower instance priority]
instance lattice_of_linear_order {α : Type u} [o : linear_order α] :
  lattice α :=
{ sup          := max,
  le_sup_left  := le_max_left,
  le_sup_right := le_max_right,
  sup_le       := assume a b c, max_le,

  inf          := min,
  inf_le_left  := min_le_left,
  inf_le_right := min_le_right,
  le_inf       := assume a b c, le_min,
  ..o }

theorem sup_eq_max [linear_order α] {x y : α} : x ⊔ y = max x y := rfl
theorem inf_eq_min [linear_order α] {x y : α} : x ⊓ y = min x y := rfl

@[priority 100] -- see Note [lower instance priority]
instance distrib_lattice_of_linear_order {α : Type u} [o : linear_order α] :
  distrib_lattice α :=
{ le_sup_inf := assume a b c,
    match le_total b c with
    | or.inl h := inf_le_left_of_le $ sup_le_sup_left (le_inf (le_refl b) h) _
    | or.inr h := inf_le_right_of_le $ sup_le_sup_left (le_inf h (le_refl c)) _
    end,
  ..lattice_of_linear_order }

instance nat.distrib_lattice : distrib_lattice ℕ :=
by apply_instance

/-!
### Monotone functions and lattices
-/
namespace monotone

lemma le_map_sup [semilattice_sup α] [semilattice_sup β]
  {f : α → β} (h : monotone f) (x y : α) :
  f x ⊔ f y ≤ f (x ⊔ y) :=
sup_le (h le_sup_left) (h le_sup_right)

lemma map_sup [semilattice_sup α] [is_total α (≤)] [semilattice_sup β] {f : α → β}
  (hf : monotone f) (x y : α) :
  f (x ⊔ y) = f x ⊔ f y :=
(is_total.total x y).elim
  (λ h : x ≤ y, by simp only [h, hf h, sup_of_le_right])
  (λ h, by simp only [h, hf h, sup_of_le_left])

lemma map_inf_le [semilattice_inf α] [semilattice_inf β]
  {f : α → β} (h : monotone f) (x y : α) :
  f (x ⊓ y) ≤ f x ⊓ f y :=
le_inf (h inf_le_left) (h inf_le_right)

lemma map_inf [semilattice_inf α] [is_total α (≤)] [semilattice_inf β] {f : α → β}
  (hf : monotone f) (x y : α) :
  f (x ⊓ y) = f x ⊓ f y :=
@monotone.map_sup (order_dual α) _ _ _ _ _ hf.order_dual x y

end monotone

/-!
### Products of (semi-)lattices
-/

namespace prod
variables (α β)

instance [has_sup α] [has_sup β] : has_sup (α × β) := ⟨λp q, ⟨p.1 ⊔ q.1, p.2 ⊔ q.2⟩⟩
instance [has_inf α] [has_inf β] : has_inf (α × β) := ⟨λp q, ⟨p.1 ⊓ q.1, p.2 ⊓ q.2⟩⟩

instance [semilattice_sup α] [semilattice_sup β] : semilattice_sup (α × β) :=
{ sup_le := assume a b c h₁ h₂, ⟨sup_le h₁.1 h₂.1, sup_le h₁.2 h₂.2⟩,
  le_sup_left  := assume a b, ⟨le_sup_left, le_sup_left⟩,
  le_sup_right := assume a b, ⟨le_sup_right, le_sup_right⟩,
  .. prod.partial_order α β, .. prod.has_sup α β }

instance [semilattice_inf α] [semilattice_inf β] : semilattice_inf (α × β) :=
{ le_inf := assume a b c h₁ h₂, ⟨le_inf h₁.1 h₂.1, le_inf h₁.2 h₂.2⟩,
  inf_le_left  := assume a b, ⟨inf_le_left, inf_le_left⟩,
  inf_le_right := assume a b, ⟨inf_le_right, inf_le_right⟩,
  .. prod.partial_order α β, .. prod.has_inf α β }

instance [lattice α] [lattice β] : lattice (α × β) :=
{ .. prod.semilattice_inf α β, .. prod.semilattice_sup α β }

instance [distrib_lattice α] [distrib_lattice β] : distrib_lattice (α × β) :=
{ le_sup_inf := assume a b c, ⟨le_sup_inf, le_sup_inf⟩,
  .. prod.lattice α β }

end prod

/-!
### Subtypes of (semi-)lattices
-/

namespace subtype

/-- A subtype forms a `⊔`-semilattice if `⊔` preserves the property. -/
protected def semilattice_sup [semilattice_sup α] {P : α → Prop}
  (Psup : ∀⦃x y⦄, P x → P y → P (x ⊔ y)) : semilattice_sup {x : α // P x} :=
{ sup := λ x y, ⟨x.1 ⊔ y.1, Psup x.2 y.2⟩,
  le_sup_left := λ x y, @le_sup_left _ _ (x : α) y,
  le_sup_right := λ x y, @le_sup_right _ _ (x : α) y,
  sup_le := λ x y z h1 h2, @sup_le α _ _ _ _ h1 h2,
  ..subtype.partial_order P }

/-- A subtype forms a `⊓`-semilattice if `⊓` preserves the property. -/
protected def semilattice_inf [semilattice_inf α] {P : α → Prop}
  (Pinf : ∀⦃x y⦄, P x → P y → P (x ⊓ y)) : semilattice_inf {x : α // P x} :=
{ inf := λ x y, ⟨x.1 ⊓ y.1, Pinf x.2 y.2⟩,
  inf_le_left := λ x y, @inf_le_left _ _ (x : α) y,
  inf_le_right := λ x y, @inf_le_right _ _ (x : α) y,
  le_inf := λ x y z h1 h2, @le_inf α _ _ _ _ h1 h2,
  ..subtype.partial_order P }

/-- A subtype forms a lattice if `⊔` and `⊓` preserve the property. -/
protected def lattice [lattice α] {P : α → Prop}
  (Psup : ∀⦃x y⦄, P x → P y → P (x ⊔ y)) (Pinf : ∀⦃x y⦄, P x → P y → P (x ⊓ y)) :
  lattice {x : α // P x} :=
{ ..subtype.semilattice_inf Pinf, ..subtype.semilattice_sup Psup }

end subtype


import linear_algebra.basic
notation f ` ⊚ `:80 g:80 :=  linear_map.comp f g
set_option pp.generalized_field_notation false
universes u v v'
variables {R : Type u}[comm_ring R]{M : Type v}[add_comm_group M] [module R M ](f : M →ₗ[R]M)
open linear_map
open_locale big_operators

def  is_projector (p : M →ₗ[R] M) := p * p = p

lemma is_projector_iff {p : M →ₗ[R]M} :  is_projector p ↔ p * p = p := iff.rfl
/--
    if `p² = p` then `(1-p)² = 1 - p - p +p² = ... = 1-p`
-/

lemma Complementary (p : M →ₗ[R]M) (hyp : is_projector p) : is_projector (id - p) :=
begin
    change linear_map.id - p with 1 -p,
    have R : ( 1- p) * (1 -p) = 1 - p -(p - p * p),
        exact mul_sub (1 - p) 1 p,
    unfold is_projector,
    rw R,
    rw is_projector_iff.mp hyp,
    simp,
end
variables (p : M→ₗ[R]M)

lemma Projector_apply (x : M) :  p ∘ p =  ⇑(p * p) := rfl

/--
        Helper : cause i use element.
-/
lemma image_in_range (x : M) : p x ∈ range p :=  mem_range.mpr  ⟨x , rfl ⟩

lemma ker_eq_im_comp (hyp : is_projector p) : range p = ker (id-p) :=
begin
    apply submodule.ext,intros x,split,rintros ⟨y,hyp  ⟩, rw mem_ker, change x- p x = 0, rw ← hyp.2,
    change (p - p * p) y = 0, rw is_projector_iff.mp, rw sub_self, exact rfl,assumption,
    intros hyp, rw mem_ker at hyp, change x-p x = 0 at hyp, rw mem_range, use x,
    have R : x - p x + p x = p x,
        rw hyp_1,
        rw zero_add,
    rw ← R,simp,
  end

def has_projector (P : submodule R M) :=
        ∃ p : M →ₗ[R]M, is_projector p ∧ linear_map.range (p : M→ₗ[R]M)  = P

lemma projector_ker (p : M →ₗ[R]M) (hyp : is_projector p) : ∀ m : M, p m ∈ ker (id - p) :=
begin
    rw ← ker_eq_im_comp, exact image_in_range p,assumption,
end
lemma  calcul : linear_map.id - (id - p) = p := begin exact sub_sub_self id p, end

lemma projector_range (p : M →ₗ[R]M) (hyp : is_projector p) : ∀ m : M, m - p m ∈ ker (p) :=
begin
    let H := projector_ker (id-p) (Complementary p hyp),
    -- let H := specialize (proj_ker (id - p)) (Complementary p hyp)  -- unknown identifier 'specialize'
    rw calcul at H,
    exact H,
end
/--
   `is_projector p` then `∀ m ∈ M,  ∃ m_im ∈ range p, ∃ m_ker ∈ ker p`
    s.t `m = m_ker+ m_im`
-/
lemma projector_decomposition_existence (p : M →ₗ[R]M) (hyp : is_projector p) :
    ∀ m : M,∃ m_im ∈ range p, ∃ m_ker ∈ ker p, m = m_ker+ m_im  :=
 begin
    intros m,
    use p m,
    split,
        {apply image_in_range},
        {use m - p m,split,
            {apply projector_range p hyp},
            {exact eq_add_of_sub_eq rfl}},
end
lemma projector_decomposition_unicity (hyp : is_projector p) : (range p)  ⊓ (ker p)= ⊥ :=  begin
    rw eq_bot_iff,
    rw submodule.le_def', intros x, rw submodule.mem_bot, intros,
    rw submodule.mem_inf at H,
    rcases H with ⟨  IM, KER ⟩ ,
    rw mem_ker at KER, rw mem_range at IM, rcases IM with ⟨ y,hyp_y⟩ ,
    rw ← hyp_y at KER, change (p * p) y = 0 at KER, rw is_projector_iff.mp at KER, rw hyp_y at KER,
assumption, assumption,
end

lemma projector.mem_range (x : M)(hyp : is_projector p) : x ∈ range p ↔  p x = x :=
begin
    split,
        intro hyp,
        rw mem_range at hyp, rcases hyp with ⟨y,hyp_y ⟩, rw ← hyp_y, change p( p y) with (p *p) y, rw (is_projector_iff.mp hyp),
        intro hyp, rw ← hyp,
        apply image_in_range,
end

lemma projector_im_eq (p q : M→ₗ[R] M) (hyp_p : is_projector p) (hyp_q : is_projector q) :
            range  p =  range q ↔  ( p * q = q) ∧  (q * p = p) := begin
        split,
        intro hyp,
            split,
                {ext,rw mul_app, rw ← projector.mem_range, rw hyp,refine image_in_range q _, assumption},
                {ext, rw mul_app,rw ← projector.mem_range,rw ← hyp,refine image_in_range p _, assumption},
            intro,
            apply submodule.ext,
            intro x, split,
                {intro,rw ←  a.2 at a_1,rw mem_range at *,rcases a_1,use p a_1_w, exact a_1_h,},
                {intro,rw ←  a.1 at a_1,rw mem_range at *,rcases a_1,use q a_1_w, exact a_1_h,},
end
/--
   if  `∀ x : range p, p x = x `  then  `is_projector p`
-/
theorem is_projector_range_id (p : M→ₗ[R]M) : (∀ x : range p, p x = x ) → is_projector p := begin
    intro hyp, apply is_projector_iff.mpr,
    ext,rw mul_app,
    exact hyp ⟨p x , image_in_range p x ⟩,
end
lemma range_le_submodule_iff (p : M→ₗ[R]M) (W : submodule R M) : range p ≤ W ↔  ∀ x : M,  p x ∈ W :=
begin
    split, intros hyp, intro x, let R := image_in_range p x,
    rw submodule.le_def' at hyp,
    exact hyp (p x) R,
    intro,
    rw submodule.le_def', intro x, intro hyp_range, rw mem_range at hyp_range, rcases hyp_range,
    rw ← hyp_range_h, exact a hyp_range_w,
end
/--
    if `range p ≤ W ∧ ∀ w ∈ W, p w = w`  then  `is_projector p ∧ range p = W`
-/
theorem is_projector_range_le_and_id (p : M→ₗ[R]M) (W : submodule R M) : (range p ≤ W ∧ ∀ w ∈ W, p w = w) → (is_projector p
∧ range p = W) :=
begin
    intros hyp,
    split,
        apply is_projector_range_id,
            intro y,
                apply hyp.2 y, -- ici un peu long
        rw submodule.le_def' at hyp,
        apply hyp.1 y,
        exact y.property,
        apply le_antisymm ,
            exact hyp.1,
            rintros w,
            intro hyp_w,
            change w ∈ range p,
            change w ∈ W at hyp_w,
            rw mem_range,
            use w,
            rw hyp.2,assumption,
end

lemma sum_range (X :Type v')[fintype X](φ : X → (M →ₗ[R] M))(W : submodule R M) :
    (∀ x : X, range (φ x) ≤ W)  → linear_map.range (finset.sum finset.univ φ ) ≤ W :=
begin
    intros hyp,
    rw submodule.le_def',
    intros m,
    intros, rw linear_map.mem_range at H,
    rcases H with ⟨y,hyp_y ⟩,
    rw ← hyp_y,
    rw linear_map.sum_apply,
    apply submodule.sum_mem,
    intros c,  intros,
    let hyp := hyp c, rw submodule.le_def' at hyp,
    apply hyp, exact image_in_range (φ c) y,
end

lemma range_smulll (a : R)(b : R) (hyp : a * b = 1)  : range (a • p) = range p :=
begin
    apply le_antisymm,
    rw submodule.le_def',
    intros x, intros hyp, rw linear_map.mem_range at *, rcases hyp with ⟨ y, hyp_y ⟩,
    use  a • y,
    rw linear_map.map_smul,  exact hyp_y,
    rw submodule.le_def',
     intros x, intros hyp, rw linear_map.mem_range at *, rcases hyp with ⟨y, hyp_y  ⟩,
     use b • y,
     rw linear_map.map_smul, erw ← mul_smul, rw mul_comm, rw hyp, rw one_smul, assumption,
end

lemma sum_proj (X  : Type v')[fintype X](W  : submodule R M)(a : R)
(inve : a * (((fintype.card X) : ℤ)  : R) = 1) (φ : X → (M →ₗ[R]M)) (hyp : ∀ x : X, is_projector (φ x))
(hyp_2 : ∀ x : X, range (φ x) = W) :
  is_projector ( a • (finset.sum finset.univ φ)) ∧ range ( a • (finset.sum finset.univ φ)) = W   :=
begin
    apply is_projector_range_le_and_id,
    split,
    rw range_smulll,
    swap, use inve,
    apply sum_range,
    intros x,
    rw hyp_2 x,
    rw submodule.le_def,
    intros x, intros hyp',
    change a • _ =x,
    rw linear_map.sum_apply,
    have R' : (λ d, φ d x) = (λ d, x),
        funext,
        rw ← projector.mem_range (φ d) x (hyp d),
        rw hyp_2 d,
        assumption,
    rw R',
    rw finset.sum_const,
    change a • (( fintype.card X) • x) = x,
    rw   semimodule.smul_eq_smul R,
    rw ← mul_smul,
    erw inve, rw one_smul,
end


theorem add_right_cancel (a t b : mynat) : a + t = b + t → a = b :=
begin
intro h,
induction t with h hd,
rw ← add_zero a,
rw ← add_zero b,
exact h,
apply hd,
rw add_succ at h,
rw add_succ at h,
exact succ_inj(h),
end


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

! This file was ported from Lean 3 source module topology.uniform_space.absolute_value
! leanprover-community/mathlib commit e1a7bdeb4fd826b7e71d130d34988f0a2d26a177
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Order.AbsoluteValue
import Mathbin.Topology.UniformSpace.Basic

/-!
# Uniform structure induced by an absolute value

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

We build a uniform space structure on a commutative ring `R` equipped with an absolute value into
a linear ordered field `𝕜`. Of course in the case `R` is `ℚ`, `ℝ` or `ℂ` and
`𝕜 = ℝ`, we get the same thing as the metric space construction, and the general construction
follows exactly the same path.

## Implementation details

Note that we import `data.real.cau_seq` because this is where absolute values are defined, but
the current file does not depend on real numbers. TODO: extract absolute values from that
`data.real` folder.

## References

* [N. Bourbaki, *Topologie générale*][bourbaki1966]

## Tags

absolute value, uniform spaces
-/

open Set Function Filter UniformSpace

open Filter Topology

namespace AbsoluteValue

variable {𝕜 : Type _} [LinearOrderedField 𝕜]

variable {R : Type _} [CommRing R] (abv : AbsoluteValue R 𝕜)

#print AbsoluteValue.uniformSpace /-
/-- The uniform space structure coming from an absolute value. -/
protected def uniformSpace : UniformSpace R :=
  UniformSpace.ofFun (fun x y => abv (y - x)) (by simp) (fun x y => abv.map_sub y x)
    (fun x y z => (abv.sub_le _ _ _).trans_eq (add_comm _ _)) fun ε ε0 =>
    ⟨ε / 2, half_pos ε0, fun _ h₁ _ h₂ => (add_lt_add h₁ h₂).trans_eq (add_halves ε)⟩
#align absolute_value.uniform_space AbsoluteValue.uniformSpace
-/

/- warning: absolute_value.has_basis_uniformity -> AbsoluteValue.hasBasis_uniformity is a dubious translation:
lean 3 declaration is
  forall {𝕜 : Type.{u1}} [_inst_1 : LinearOrderedField.{u1} 𝕜] {R : Type.{u2}} [_inst_2 : CommRing.{u2} R] (abv : AbsoluteValue.{u2, u1} R 𝕜 (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R _inst_2)) (StrictOrderedSemiring.toOrderedSemiring.{u1} 𝕜 (StrictOrderedRing.toStrictOrderedSemiring.{u1} 𝕜 (LinearOrderedRing.toStrictOrderedRing.{u1} 𝕜 (LinearOrderedCommRing.toLinearOrderedRing.{u1} 𝕜 (LinearOrderedField.toLinearOrderedCommRing.{u1} 𝕜 _inst_1)))))), Filter.HasBasis.{u2, succ u1} (Prod.{u2, u2} R R) 𝕜 (uniformity.{u2} R (AbsoluteValue.uniformSpace.{u1, u2} 𝕜 _inst_1 R _inst_2 abv)) (fun (ε : 𝕜) => LT.lt.{u1} 𝕜 (Preorder.toLT.{u1} 𝕜 (PartialOrder.toPreorder.{u1} 𝕜 (OrderedAddCommGroup.toPartialOrder.{u1} 𝕜 (StrictOrderedRing.toOrderedAddCommGroup.{u1} 𝕜 (LinearOrderedRing.toStrictOrderedRing.{u1} 𝕜 (LinearOrderedCommRing.toLinearOrderedRing.{u1} 𝕜 (LinearOrderedField.toLinearOrderedCommRing.{u1} 𝕜 _inst_1))))))) (OfNat.ofNat.{u1} 𝕜 0 (OfNat.mk.{u1} 𝕜 0 (Zero.zero.{u1} 𝕜 (MulZeroClass.toHasZero.{u1} 𝕜 (NonUnitalNonAssocSemiring.toMulZeroClass.{u1} 𝕜 (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} 𝕜 (NonAssocRing.toNonUnitalNonAssocRing.{u1} 𝕜 (Ring.toNonAssocRing.{u1} 𝕜 (StrictOrderedRing.toRing.{u1} 𝕜 (LinearOrderedRing.toStrictOrderedRing.{u1} 𝕜 (LinearOrderedCommRing.toLinearOrderedRing.{u1} 𝕜 (LinearOrderedField.toLinearOrderedCommRing.{u1} 𝕜 _inst_1)))))))))))) ε) (fun (ε : 𝕜) => setOf.{u2} (Prod.{u2, u2} R R) (fun (p : Prod.{u2, u2} R R) => LT.lt.{u1} 𝕜 (Preorder.toLT.{u1} 𝕜 (PartialOrder.toPreorder.{u1} 𝕜 (OrderedAddCommGroup.toPartialOrder.{u1} 𝕜 (StrictOrderedRing.toOrderedAddCommGroup.{u1} 𝕜 (LinearOrderedRing.toStrictOrderedRing.{u1} 𝕜 (LinearOrderedCommRing.toLinearOrderedRing.{u1} 𝕜 (LinearOrderedField.toLinearOrderedCommRing.{u1} 𝕜 _inst_1))))))) (coeFn.{max (succ u2) (succ u1), max (succ u2) (succ u1)} (AbsoluteValue.{u2, u1} R 𝕜 (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R _inst_2)) (StrictOrderedSemiring.toOrderedSemiring.{u1} 𝕜 (StrictOrderedRing.toStrictOrderedSemiring.{u1} 𝕜 (LinearOrderedRing.toStrictOrderedRing.{u1} 𝕜 (LinearOrderedCommRing.toLinearOrderedRing.{u1} 𝕜 (LinearOrderedField.toLinearOrderedCommRing.{u1} 𝕜 _inst_1)))))) (fun (f : AbsoluteValue.{u2, u1} R 𝕜 (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R _inst_2)) (StrictOrderedSemiring.toOrderedSemiring.{u1} 𝕜 (StrictOrderedRing.toStrictOrderedSemiring.{u1} 𝕜 (LinearOrderedRing.toStrictOrderedRing.{u1} 𝕜 (LinearOrderedCommRing.toLinearOrderedRing.{u1} 𝕜 (LinearOrderedField.toLinearOrderedCommRing.{u1} 𝕜 _inst_1)))))) => R -> 𝕜) (AbsoluteValue.hasCoeToFun.{u2, u1} R 𝕜 (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R _inst_2)) (StrictOrderedSemiring.toOrderedSemiring.{u1} 𝕜 (StrictOrderedRing.toStrictOrderedSemiring.{u1} 𝕜 (LinearOrderedRing.toStrictOrderedRing.{u1} 𝕜 (LinearOrderedCommRing.toLinearOrderedRing.{u1} 𝕜 (LinearOrderedField.toLinearOrderedCommRing.{u1} 𝕜 _inst_1)))))) abv (HSub.hSub.{u2, u2, u2} R R R (instHSub.{u2} R (SubNegMonoid.toHasSub.{u2} R (AddGroup.toSubNegMonoid.{u2} R (AddGroupWithOne.toAddGroup.{u2} R (AddCommGroupWithOne.toAddGroupWithOne.{u2} R (Ring.toAddCommGroupWithOne.{u2} R (CommRing.toRing.{u2} R _inst_2))))))) (Prod.snd.{u2, u2} R R p) (Prod.fst.{u2, u2} R R p))) ε))
but is expected to have type
  forall {𝕜 : Type.{u1}} [_inst_1 : LinearOrderedField.{u1} 𝕜] {R : Type.{u2}} [_inst_2 : CommRing.{u2} R] (abv : AbsoluteValue.{u2, u1} R 𝕜 (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R _inst_2)) (OrderedCommSemiring.toOrderedSemiring.{u1} 𝕜 (StrictOrderedCommSemiring.toOrderedCommSemiring.{u1} 𝕜 (LinearOrderedCommSemiring.toStrictOrderedCommSemiring.{u1} 𝕜 (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} 𝕜 (LinearOrderedField.toLinearOrderedSemifield.{u1} 𝕜 _inst_1)))))), Filter.HasBasis.{u2, succ u1} (Prod.{u2, u2} R R) 𝕜 (uniformity.{u2} R (AbsoluteValue.uniformSpace.{u1, u2} 𝕜 _inst_1 R _inst_2 abv)) (fun (ε : 𝕜) => LT.lt.{u1} 𝕜 (Preorder.toLT.{u1} 𝕜 (PartialOrder.toPreorder.{u1} 𝕜 (StrictOrderedRing.toPartialOrder.{u1} 𝕜 (LinearOrderedRing.toStrictOrderedRing.{u1} 𝕜 (LinearOrderedCommRing.toLinearOrderedRing.{u1} 𝕜 (LinearOrderedField.toLinearOrderedCommRing.{u1} 𝕜 _inst_1)))))) (OfNat.ofNat.{u1} 𝕜 0 (Zero.toOfNat0.{u1} 𝕜 (CommMonoidWithZero.toZero.{u1} 𝕜 (CommGroupWithZero.toCommMonoidWithZero.{u1} 𝕜 (Semifield.toCommGroupWithZero.{u1} 𝕜 (LinearOrderedSemifield.toSemifield.{u1} 𝕜 (LinearOrderedField.toLinearOrderedSemifield.{u1} 𝕜 _inst_1))))))) ε) (fun (ε : 𝕜) => setOf.{u2} (Prod.{u2, u2} R R) (fun (p : Prod.{u2, u2} R R) => LT.lt.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => 𝕜) (HSub.hSub.{u2, u2, u2} R R R (instHSub.{u2} R (Ring.toSub.{u2} R (CommRing.toRing.{u2} R _inst_2))) (Prod.snd.{u2, u2} R R p) (Prod.fst.{u2, u2} R R p))) (Preorder.toLT.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => 𝕜) (HSub.hSub.{u2, u2, u2} R R R (instHSub.{u2} R (Ring.toSub.{u2} R (CommRing.toRing.{u2} R _inst_2))) (Prod.snd.{u2, u2} R R p) (Prod.fst.{u2, u2} R R p))) (PartialOrder.toPreorder.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => 𝕜) (HSub.hSub.{u2, u2, u2} R R R (instHSub.{u2} R (Ring.toSub.{u2} R (CommRing.toRing.{u2} R _inst_2))) (Prod.snd.{u2, u2} R R p) (Prod.fst.{u2, u2} R R p))) (StrictOrderedRing.toPartialOrder.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => 𝕜) (HSub.hSub.{u2, u2, u2} R R R (instHSub.{u2} R (Ring.toSub.{u2} R (CommRing.toRing.{u2} R _inst_2))) (Prod.snd.{u2, u2} R R p) (Prod.fst.{u2, u2} R R p))) (LinearOrderedRing.toStrictOrderedRing.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => 𝕜) (HSub.hSub.{u2, u2, u2} R R R (instHSub.{u2} R (Ring.toSub.{u2} R (CommRing.toRing.{u2} R _inst_2))) (Prod.snd.{u2, u2} R R p) (Prod.fst.{u2, u2} R R p))) (LinearOrderedCommRing.toLinearOrderedRing.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => 𝕜) (HSub.hSub.{u2, u2, u2} R R R (instHSub.{u2} R (Ring.toSub.{u2} R (CommRing.toRing.{u2} R _inst_2))) (Prod.snd.{u2, u2} R R p) (Prod.fst.{u2, u2} R R p))) (LinearOrderedField.toLinearOrderedCommRing.{u1} ((fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => 𝕜) (HSub.hSub.{u2, u2, u2} R R R (instHSub.{u2} R (Ring.toSub.{u2} R (CommRing.toRing.{u2} R _inst_2))) (Prod.snd.{u2, u2} R R p) (Prod.fst.{u2, u2} R R p))) _inst_1)))))) (FunLike.coe.{max (succ u1) (succ u2), succ u2, succ u1} (AbsoluteValue.{u2, u1} R 𝕜 (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R _inst_2)) (OrderedCommSemiring.toOrderedSemiring.{u1} 𝕜 (StrictOrderedCommSemiring.toOrderedCommSemiring.{u1} 𝕜 (LinearOrderedCommSemiring.toStrictOrderedCommSemiring.{u1} 𝕜 (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} 𝕜 (LinearOrderedField.toLinearOrderedSemifield.{u1} 𝕜 _inst_1)))))) R (fun (f : R) => (fun (x._@.Mathlib.Algebra.Order.Hom.Basic._hyg.99 : R) => 𝕜) f) (SubadditiveHomClass.toFunLike.{max u1 u2, u2, u1} (AbsoluteValue.{u2, u1} R 𝕜 (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R _inst_2)) (OrderedCommSemiring.toOrderedSemiring.{u1} 𝕜 (StrictOrderedCommSemiring.toOrderedCommSemiring.{u1} 𝕜 (LinearOrderedCommSemiring.toStrictOrderedCommSemiring.{u1} 𝕜 (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} 𝕜 (LinearOrderedField.toLinearOrderedSemifield.{u1} 𝕜 _inst_1)))))) R 𝕜 (Distrib.toAdd.{u2} R (NonUnitalNonAssocSemiring.toDistrib.{u2} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} R (Semiring.toNonAssocSemiring.{u2} R (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R _inst_2)))))) (Distrib.toAdd.{u1} 𝕜 (NonUnitalNonAssocSemiring.toDistrib.{u1} 𝕜 (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} 𝕜 (Semiring.toNonAssocSemiring.{u1} 𝕜 (OrderedSemiring.toSemiring.{u1} 𝕜 (OrderedCommSemiring.toOrderedSemiring.{u1} 𝕜 (StrictOrderedCommSemiring.toOrderedCommSemiring.{u1} 𝕜 (LinearOrderedCommSemiring.toStrictOrderedCommSemiring.{u1} 𝕜 (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} 𝕜 (LinearOrderedField.toLinearOrderedSemifield.{u1} 𝕜 _inst_1)))))))))) (Preorder.toLE.{u1} 𝕜 (PartialOrder.toPreorder.{u1} 𝕜 (OrderedSemiring.toPartialOrder.{u1} 𝕜 (OrderedCommSemiring.toOrderedSemiring.{u1} 𝕜 (StrictOrderedCommSemiring.toOrderedCommSemiring.{u1} 𝕜 (LinearOrderedCommSemiring.toStrictOrderedCommSemiring.{u1} 𝕜 (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} 𝕜 (LinearOrderedField.toLinearOrderedSemifield.{u1} 𝕜 _inst_1)))))))) (AbsoluteValue.subadditiveHomClass.{u2, u1} R 𝕜 (Ring.toSemiring.{u2} R (CommRing.toRing.{u2} R _inst_2)) (OrderedCommSemiring.toOrderedSemiring.{u1} 𝕜 (StrictOrderedCommSemiring.toOrderedCommSemiring.{u1} 𝕜 (LinearOrderedCommSemiring.toStrictOrderedCommSemiring.{u1} 𝕜 (LinearOrderedSemifield.toLinearOrderedCommSemiring.{u1} 𝕜 (LinearOrderedField.toLinearOrderedSemifield.{u1} 𝕜 _inst_1))))))) abv (HSub.hSub.{u2, u2, u2} R R R (instHSub.{u2} R (Ring.toSub.{u2} R (CommRing.toRing.{u2} R _inst_2))) (Prod.snd.{u2, u2} R R p) (Prod.fst.{u2, u2} R R p))) ε))
Case conversion may be inaccurate. Consider using '#align absolute_value.has_basis_uniformity AbsoluteValue.hasBasis_uniformityₓ'. -/
theorem hasBasis_uniformity :
    𝓤[abv.UniformSpace].HasBasis (fun ε : 𝕜 => 0 < ε) fun ε =>
      { p : R × R | abv (p.2 - p.1) < ε } :=
  UniformSpace.hasBasis_ofFun (exists_gt _) _ _ _ _ _
#align absolute_value.has_basis_uniformity AbsoluteValue.hasBasis_uniformity

end AbsoluteValue


/-
Chapter 3: More Connectives: Not & Or
Author: Billy Price
-/
import definitions

namespace nat_deduction

variables {p q r s : ℕ}

example : {p} ≻ ¬¬p :=
begin
  apply ¬I,
  apply ¬E p; assump
end

example : {p ⟹ r, q ⟹ s} ≻ (p ⋀ q) ⟹ (r ⋀ s) :=
begin
  apply ⟹I,
  apply ⋀I,
  { apply ⟹E p, assump,
    apply ⋀E₁ p q, assump },
  { apply ⟹E q, assump,
    apply ⋀E₂ p q, assump }
end

example : {p ⟹ r, q ⟹ s} ≻ (p ⋁ q) ⟹ (r ⋁ s) :=
begin
  apply ⟹I,
  apply ⋁E p q, assump,
  { apply ⋁I₁, apply ⟹E p; assump},
  { apply ⋁I₂, apply ⟹E q; assump}
end

example : {(¬p) ⋁ (¬q)} ≻ ¬(p ⋀ q) :=
begin
  apply ¬I,
  apply ⋁E ¬p ¬q, assump,
  apply ¬E p, assump, apply ⋀E₁ p q, assump,
  apply ¬E q, assump, apply ⋀E₂ p q, assump
end

example : {¬¬¬p} ≻ ¬p :=
begin
  apply ¬I,
  apply ¬E (¬¬p), assump,
  apply ¬I,
  apply ¬E p; assump
end

variable {X : set Form}
variables {A B C : Form}

def explosion (A : Form) {B} : (X ≻ ¬A) → (X ≻ A) → (X ≻ B) :=
begin
  intros dnA dA,
  apply ⊥E,
  apply ¬E A; assumption
end

def distribution : (X ≻ A ⋀ (B ⋁ C)) → (X ≻ (A ⋀ B) ⋁ (A ⋀ C)) :=
begin
  intro dA_BC,
  apply ⋁E B C, exact ⋀E₂ A _ dA_BC,
    { apply ⋁I₁,
      apply ⋀I,
        { apply ⋀E₁ _ (B ⋁ C),
          exact weaken_union_right dA_BC },
        assump },
    { apply ⋁I₂,
      apply ⋀I,
        { apply ⋀E₁ _ (B ⋁ C),
          exact weaken_union_right dA_BC },
        assump },
end

def modus_tollens : (X ≻ A ⟹ B) → (X ≻ ¬B) → (X ≻ ¬ A) :=
begin
  intros dAB dnB,
  apply ¬I,
  apply ¬E B, exact weaken_union_right dnB,
  apply ⟹E A, exact weaken_union_right dAB,
  assump
end

def intro_neg_and : (X ≻ ¬A) → (X ≻ ¬(A ⋀ B)) :=
begin
  intro dnA,
  apply ¬I,
  apply ¬E A,
  exact weaken_union_right dnA,
  apply ⋀E₁ A B, assump
end

def or_imp : (X ≻ A ⟹ C) → (X ≻ B ⟹ C) → (X ≻ (A ⋁ B) ⟹ C) :=
begin
  intros dAC dBC,
  apply ⟹I,
  apply ⋁E A B, assump,
  apply ⟹E A, rw set.union_assoc, exact weaken_union_right dAC,
  assump,
  apply ⟹E B, rw set.union_assoc, exact weaken_union_right dBC,
  assump
end

def disjunctive_syllogism : (X ≻ A ⋁ B) → (X ≻ ¬A) → (X ≻ B) :=
begin
  intros dAB dnA,
  apply ⋁E A B dAB,
  { apply ⊥E,
    apply ¬E A,
    exact weaken_union_right dnA,
    assump },
  assump
end

end nat_deduction


def diag : Bool → Bool → Bool → Nat
| b,  true, false => 1
| false, b,  true => 2
| true, false, b  => 3
| b1, b2, b3 => default

theorem diag1 (a : Bool) : diag a true false = 1 :=
match a with
| true  => rfl
| false => rfl

theorem diag2 (a : Bool) : diag false a true = 2 :=
by cases a; exact rfl; exact rfl

theorem diag3 (a : Bool) : diag true false a = 3 :=
by cases a; exact rfl; exact rfl

theorem diag4_1 : diag false false false = default :=
rfl

theorem diag4_2 : diag true true true = default :=
rfl

def f : Nat → Nat → Nat
| n, 0 => 0
| 0, n => 1
| n, m => default

theorem f_zero_right : (a : Nat) → f a 0 = 0
| 0   => rfl
| a+1 => rfl

theorem f_zero_succ (a : Nat) : f 0 (a+1) = 1 :=
rfl

theorem f_succ_succ (a b : Nat) : f (a+1) (b+1) = default :=
rfl

def app {α} : List α → List α → List α
| [],   l => l
| h::t, l => h :: (app t l)

theorem app_nil {α} (l : List α) : app [] l = l :=
rfl

theorem app_cons {α} (h : α) (t l : List α) : app (h :: t) l = h :: (app t l) :=
rfl

theorem ex : app [1, 2] [3,4,5] = [1,2,3,4,5] :=
rfl


/-
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 analysis.calculus.deriv
import measure_theory.borel_space

/-!
# Derivative is measurable

In this file we prove that the derivative of any function with complete codomain is a measurable
function. Namely, we prove:

* `measurable_set_of_differentiable_at`: the set `{x | differentiable_at 𝕜 f x}` is measurable;
* `measurable_fderiv`: the function `fderiv 𝕜 f` is measurable;
* `measurable_fderiv_apply_const`: for a fixed vector `y`, the function `λ x, fderiv 𝕜 f x y`
  is measurable;
* `measurable_deriv`: the function `deriv f` is measurable (for `f : 𝕜 → F`).

## Implementation

We give a proof that avoids second-countability issues, by expressing the differentiability set
as a function of open sets in the following way. Define `A (L, r, ε)` to be the set of points
where, on a ball of radius roughly `r` around `x`, the function is uniformly approximated by the
linear map `L`, up to `ε r`. It is an open set.
Let also `B (L, r, s, ε) = A (L, r, ε) ∩ A (L, s, ε)`: we require that at two possibly different
scales `r` and `s`, the function is well approximated by the linear map `L`. It is also open.

We claim that the differentiability set of `f` is exactly
`D = ⋂ ε > 0, ⋃ δ > 0, ⋂ r, s < δ, ⋃ L, B (L, r, s, ε)`.
In other words, for any `ε > 0`, we require that there is a size `δ` such that, for any two scales
below this size, the function is well approximated by a linear map, common to the two scales.

The set `⋃ L, B (L, r, s, ε)` is open, as a union of open sets. Converting the intersections and
unions to countable ones (using real numbers of the form `2 ^ (-n)`), it follows that the
differentiability set is measurable.

To prove the claim, there are two inclusions. One is trivial: if the function is differentiable
at `x`, then `x` belongs to `D` (just take `L` to be the derivative, and use that the
differentiability exactly says that the map is well approximated by `L`). This is proved in
`mem_A_of_differentiable` and `differentiable_set_subset_D`.

For the other direction, the difficulty is that `L` in the union may depend on `ε, r, s`. The key
point is that, in fact, it doesn't depend too much on them. First, if `x` belongs both to
`A (L, r, ε)` and `A (L', r, ε)`, then `L` and `L'` have to be close on a shell, and thus
`∥L - L'∥` is bounded by `ε` (see `norm_sub_le_of_mem_A`). Assume now `x ∈ D`. If one has two maps
`L` and `L'` such that `x` belongs to `A (L, r, ε)` and to `A (L', r', ε')`, one deduces that `L` is
close to `L'` by arguing as follows. Consider another scale `s` smaller than `r` and `r'`. Take a
linear map `L₁` that approximates `f` around `x` both at scales `r` and `s` w.r.t. `ε` (it exists as
`x` belongs to `D`). Take also `L₂` that approximates `f` around `x` both at scales `r'` and `s`
w.r.t. `ε'`. Then `L₁` is close to `L` (as they are close on a shell of radius `r`), and `L₂` is
close to `L₁` (as they are close on a shell of radius `s`), and `L'` is close to `L₂` (as they are
close on a shell of radius `r'`). It follows that `L` is close to `L'`, as we claimed.

It follows that the different approximating linear maps that show up form a Cauchy sequence when
`ε` tends to `0`. When the target space is complete, this sequence converges, to a limit `f'`.
With the same kind of arguments, one checks that `f` is differentiable with derivative `f'`.

To show that the derivative itself is measurable, add in the definition of `B` and `D` a set
`K` of continuous linear maps to which `L` should belong. Then, when `K` is complete, the set `D K`
is exactly the set of points where `f` is differentiable with a derivative in `K`.

## Tags

derivative, measurable function, Borel σ-algebra
-/

noncomputable theory

open set metric asymptotics filter continuous_linear_map
open topological_space (second_countable_topology)
open_locale topological_space

namespace continuous_linear_map

variables {𝕜 E F : Type*} [nondiscrete_normed_field 𝕜]
  [normed_group E] [normed_space 𝕜 E] [normed_group F] [normed_space 𝕜 F]

lemma measurable_apply₂ [measurable_space E] [opens_measurable_space E]
  [second_countable_topology E] [second_countable_topology (E →L[𝕜] F)]
  [measurable_space F] [borel_space F] :
  measurable (λ p : (E →L[𝕜] F) × E, p.1 p.2) :=
is_bounded_bilinear_map_apply.continuous.measurable

end continuous_linear_map

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
variables {E : Type*} [normed_group E] [normed_space 𝕜 E]
variables {F : Type*} [normed_group F] [normed_space 𝕜 F]
variables {f : E → F} (K : set (E →L[𝕜] F))

namespace fderiv_measurable_aux

/-- The set `A f L r ε` is the set of points `x` around which the function `f` is well approximated
at scale `r` by the linear map `L`, up to an error `ε`. We tweak the definition to make sure that
this is an open set.-/
def A (f : E → F) (L : E →L[𝕜] F) (r ε : ℝ) : set E :=
{x | ∃ r' ∈ Ioc (r/2) r, ∀ y z ∈ ball x r', ∥f z - f y - L (z-y)∥ ≤ ε * r}

/-- The set `B f K r s ε` is the set of points `x` around which there exists a continuous linear map
`L` belonging to `K` (a given set of continuous linear maps) that approximates well the
function `f` (up to an error `ε`), simultaneously at scales `r` and `s`. -/
def B (f : E → F) (K : set (E →L[𝕜] F)) (r s ε : ℝ) : set E :=
⋃ (L ∈ K), (A f L r ε) ∩ (A f L s ε)

/-- The set `D f K` is a complicated set constructed using countable intersections and unions. Its
main use is that, when `K` is complete, it is exactly the set of points where `f` is differentiable,
with a derivative in `K`. -/
def D (f : E → F) (K : set (E →L[𝕜] F)) : set E :=
⋂ (e : ℕ), ⋃ (n : ℕ), ⋂ (p ≥ n) (q ≥ n), B f K ((1/2) ^ p) ((1/2) ^ q) ((1/2) ^ e)

lemma is_open_A (L : E →L[𝕜] F) (r ε : ℝ) : is_open (A f L r ε) :=
begin
  rw metric.is_open_iff,
  rintros x ⟨r', r'_mem, hr'⟩,
  obtain ⟨s, s_gt, s_lt⟩ : ∃ (s : ℝ), r / 2 < s ∧ s < r' := exists_between r'_mem.1,
  have : s ∈ Ioc (r/2) r := ⟨s_gt, le_of_lt (s_lt.trans_le r'_mem.2)⟩,
  refine ⟨r' - s, by linarith, λ x' hx', ⟨s, this, _⟩⟩,
  have B : ball x' s ⊆ ball x r' := ball_subset (le_of_lt hx'),
  assume y z hy hz,
  exact hr' y z (B hy) (B hz)
end

lemma is_open_B {K : set (E →L[𝕜] F)} {r s ε : ℝ} : is_open (B f K r s ε) :=
by simp [B, is_open_Union, is_open_inter, is_open_A]

lemma A_mono (L : E →L[𝕜] F) (r : ℝ) {ε δ : ℝ} (h : ε ≤ δ) :
  A f L r ε ⊆ A f L r δ :=
begin
  rintros x ⟨r', r'r, hr'⟩,
  refine ⟨r', r'r, λ y z hy hz, _⟩,
  apply le_trans (hr' y z hy hz),
  apply mul_le_mul_of_nonneg_right h,
  linarith [mem_ball.1 hy, r'r.2, @dist_nonneg _ _ y x],
end

lemma mem_A_of_differentiable {ε : ℝ} (hε : 0 < ε) {x : E} (hx : differentiable_at 𝕜 f x) :
  ∃ R > 0, ∀ r ∈ Ioo (0 : ℝ) R, x ∈ A f (fderiv 𝕜 f x) r ε :=
begin
  have := hx.has_fderiv_at,
  simp only [has_fderiv_at, has_fderiv_at_filter, is_o_iff] at this,
  rcases eventually_nhds_iff_ball.1 (this (half_pos hε)) with ⟨R, R_pos, hR⟩,
  refine ⟨R, R_pos, λ r hr, _⟩,
  have : r ∈ Ioc (r/2) r := ⟨half_lt_self hr.1, le_refl _⟩,
  refine ⟨r, this, λ y z hy hz, _⟩,
  calc  ∥f z - f y - (fderiv 𝕜 f x) (z - y)∥
      = ∥(f z - f x - (fderiv 𝕜 f x) (z - x)) - (f y - f x - (fderiv 𝕜 f x) (y - x))∥ :
    by { congr' 1, simp only [continuous_linear_map.map_sub], abel }
  ... ≤ ∥(f z - f x - (fderiv 𝕜 f x) (z - x))∥ + ∥f y - f x - (fderiv 𝕜 f x) (y - x)∥ :
    norm_sub_le _ _
  ... ≤ ε / 2 * ∥z - x∥ + ε / 2 * ∥y - x∥ :
    add_le_add (hR _ (lt_trans (mem_ball.1 hz) hr.2)) (hR _ (lt_trans (mem_ball.1 hy) hr.2))
  ... ≤ ε / 2 * r + ε / 2 * r :
    add_le_add
      (mul_le_mul_of_nonneg_left (le_of_lt (mem_ball_iff_norm.1 hz)) (le_of_lt (half_pos hε)))
      (mul_le_mul_of_nonneg_left (le_of_lt (mem_ball_iff_norm.1 hy)) (le_of_lt (half_pos hε)))
  ... = ε * r : by ring
end

lemma norm_sub_le_of_mem_A {c : 𝕜} (hc : 1 < ∥c∥)
  {r ε : ℝ} (hε : 0 < ε) (hr : 0 < r) {x : E} {L₁ L₂ : E →L[𝕜] F}
  (h₁ : x ∈ A f L₁ r ε) (h₂ : x ∈ A f L₂ r ε) : ∥L₁ - L₂∥ ≤ 4 * ∥c∥ * ε :=
begin
  have : 0 ≤ 4 * ∥c∥ * ε :=
    mul_nonneg (mul_nonneg (by norm_num : (0 : ℝ) ≤ 4) (norm_nonneg _)) hε.le,
  apply op_norm_le_of_shell (half_pos hr) this hc,
  assume y ley ylt,
  rw [div_div_eq_div_mul,
      div_le_iff' (mul_pos (by norm_num : (0 : ℝ) < 2) (zero_lt_one.trans hc))] at ley,
  calc ∥(L₁ - L₂) y∥
        = ∥(f (x + y) - f x - L₂ ((x + y) - x)) - (f (x + y) - f x - L₁ ((x + y) - x))∥ : by simp
    ... ≤ ∥(f (x + y) - f x - L₂ ((x + y) - x))∥ + ∥(f (x + y) - f x - L₁ ((x + y) - x))∥ :
      norm_sub_le _ _
    ... ≤ ε * r + ε * r :
      begin
        apply add_le_add,
        { apply le_of_mem_A h₂,
          { simp only [le_of_lt (half_pos hr), mem_closed_ball, dist_self] },
          { simp only [dist_eq_norm, add_sub_cancel', mem_closed_ball, ylt.le], } },
        { apply le_of_mem_A h₁,
          { simp only [le_of_lt (half_pos hr), mem_closed_ball, dist_self] },
          { simp only [dist_eq_norm, add_sub_cancel', mem_closed_ball, ylt.le] } },
      end
    ... = 2 * ε * r : by ring
    ... ≤ 2 * ε * (2 * ∥c∥ * ∥y∥) : mul_le_mul_of_nonneg_left ley (mul_nonneg (by norm_num) hε.le)
    ... = 4 * ∥c∥ * ε * ∥y∥ : by ring
end

/-- Easy inclusion: a differentiability point with derivative in `K` belongs to `D f K`. -/
lemma differentiable_set_subset_D : {x | differentiable_at 𝕜 f x ∧ fderiv 𝕜 f x ∈ K} ⊆ D f K :=
begin
  assume x hx,
  rw [D, mem_Inter],
  assume e,
  have : (0 : ℝ) < (1/2) ^ e := pow_pos (by norm_num) _,
  rcases mem_A_of_differentiable this hx.1 with ⟨R, R_pos, hR⟩,
  obtain ⟨n, hn⟩ : ∃ (n : ℕ), (1/2) ^ n < R :=
    exists_pow_lt_of_lt_one R_pos (by norm_num : (1 : ℝ)/2 < 1),
  simp only [mem_Union, mem_Inter, B, mem_inter_eq],
  refine ⟨n, λ p hp q hq, ⟨fderiv 𝕜 f x, hx.2, ⟨_, _⟩⟩⟩;
  { refine hR _ ⟨pow_pos (by norm_num) _, lt_of_le_of_lt _ hn⟩,
    exact pow_le_pow_of_le_one (by norm_num) (by norm_num) (by assumption) }
end

/-- Harder inclusion: at a point in `D f K`, the function `f` has a derivative, in `K`. -/
lemma D_subset_differentiable_set {K : set (E →L[𝕜] F)} (hK : is_complete K) :
  D f K ⊆ {x | differentiable_at 𝕜 f x ∧ fderiv 𝕜 f x ∈ K} :=
begin
  have P : ∀ {n : ℕ}, (0 : ℝ) < (1/2) ^ n := pow_pos (by norm_num),
  rcases normed_field.exists_one_lt_norm 𝕜 with ⟨c, hc⟩,
  have cpos : 0 < ∥c∥ := lt_trans zero_lt_one hc,
  assume x hx,
  have : ∀ (e : ℕ), ∃ (n : ℕ), ∀ p q, n ≤ p → n ≤ q → ∃ L ∈ K,
    x ∈ A f L ((1/2) ^ p) ((1/2) ^ e) ∩ A f L ((1/2) ^ q) ((1/2) ^ e),
  { assume e,
    have := mem_Inter.1 hx e,
    rcases mem_Union.1 this with ⟨n, hn⟩,
    refine ⟨n, λ p q hp hq, _⟩,
    simp only [mem_Inter, ge_iff_le] at hn,
    rcases mem_Union.1 (hn p hp q hq) with ⟨L, hL⟩,
    exact ⟨L, mem_Union.1 hL⟩, },
  /- Recast the assumptions: for each `e`, there exist `n e` and linear maps `L e p q` in `K`
  such that, for `p, q ≥ n e`, then `f` is well approximated by `L e p q` at scale `2 ^ (-p)` and
  `2 ^ (-q)`, with an error `2 ^ (-e)`. -/
  choose! n L hn using this,
  /- All the operators `L e p q` that show up are close to each other. To prove this, we argue
    that `L e p q` is close to `L e p r` (where `r` is large enough), as both approximate `f` at
    scale `2 ^(- p)`. And `L e p r` is close to `L e' p' r` as both approximate `f` at scale
    `2 ^ (- r)`. And `L e' p' r` is close to `L e' p' q'` as both approximate `f` at scale
    `2 ^ (- p')`. -/
  have M : ∀ e p q e' p' q', n e ≤ p → n e ≤ q → n e' ≤ p' → n e' ≤ q' → e ≤ e' →
    ∥L e p q - L e' p' q'∥ ≤ 12 * ∥c∥ * (1/2) ^ e,
  { assume e p q e' p' q' hp hq hp' hq' he',
    let r := max (n e) (n e'),
    have I : ((1:ℝ)/2)^e' ≤ (1/2)^e := pow_le_pow_of_le_one (by norm_num) (by norm_num) he',
    have J1 : ∥L e p q - L e p r∥ ≤ 4 * ∥c∥ * (1/2)^e,
    { have I1 : x ∈ A f (L e p q) ((1 / 2) ^ p) ((1/2)^e) :=
        (hn e p q hp hq).2.1,
      have I2 : x ∈ A f (L e p r) ((1 / 2) ^ p) ((1/2)^e) :=
        (hn e p r hp (le_max_left _ _)).2.1,
      exact norm_sub_le_of_mem_A hc P P I1 I2 },
    have J2 : ∥L e p r - L e' p' r∥ ≤ 4 * ∥c∥ * (1/2)^e,
    { have I1 : x ∈ A f (L e p r) ((1 / 2) ^ r) ((1/2)^e) :=
        (hn e p r hp (le_max_left _ _)).2.2,
      have I2 : x ∈ A f (L e' p' r) ((1 / 2) ^ r) ((1/2)^e') :=
        (hn e' p' r hp' (le_max_right _ _)).2.2,
      exact norm_sub_le_of_mem_A hc P P I1 (A_mono _ _ I I2) },
    have J3 : ∥L e' p' r - L e' p' q'∥ ≤ 4 * ∥c∥ * (1/2)^e,
    { have I1 : x ∈ A f (L e' p' r) ((1 / 2) ^ p') ((1/2)^e') :=
        (hn e' p' r hp' (le_max_right _ _)).2.1,
      have I2 : x ∈ A f (L e' p' q') ((1 / 2) ^ p') ((1/2)^e') :=
        (hn e' p' q' hp' hq').2.1,
      exact norm_sub_le_of_mem_A hc P P (A_mono _ _ I I1) (A_mono _ _ I I2) },
    calc ∥L e p q - L e' p' q'∥
          = ∥(L e p q - L e p r) + (L e p r - L e' p' r) + (L e' p' r - L e' p' q')∥ :
        by { congr' 1, abel }
      ... ≤ ∥L e p q - L e p r∥ + ∥L e p r - L e' p' r∥ + ∥L e' p' r - L e' p' q'∥ :
        le_trans (norm_add_le _ _) (add_le_add_right (norm_add_le _ _) _)
      ... ≤ 4 * ∥c∥ * (1/2)^e + 4 * ∥c∥ * (1/2)^e + 4 * ∥c∥ * (1/2)^e :
        by apply_rules [add_le_add]
      ... = 12 * ∥c∥ * (1/2)^e : by ring },
  /- For definiteness, use `L0 e = L e (n e) (n e)`, to have a single sequence. We claim that this
  is a Cauchy sequence. -/
  let L0 : ℕ → (E →L[𝕜] F) := λ e, L e (n e) (n e),
  have : cauchy_seq L0,
  { rw cauchy_seq_iff',
    assume ε εpos,
    obtain ⟨e, he⟩ : ∃ (e : ℕ), (1/2) ^ e < ε / (12 * ∥c∥) :=
      exists_pow_lt_of_lt_one (div_pos εpos (mul_pos (by norm_num) cpos)) (by norm_num),
    refine ⟨e, λ e' he', _⟩,
    rw [dist_comm, dist_eq_norm],
    calc ∥L0 e - L0 e'∥
          ≤ 12 * ∥c∥ * (1/2)^e : M _ _ _ _ _ _ (le_refl _) (le_refl _) (le_refl _) (le_refl _) he'
      ... < 12 * ∥c∥ * (ε / (12 * ∥c∥)) :
        mul_lt_mul' (le_refl _) he (le_of_lt P) (mul_pos (by norm_num) cpos)
      ... = ε : by { field_simp [(by norm_num : (12 : ℝ) ≠ 0), ne_of_gt cpos], ring } },
  /- As it is Cauchy, the sequence `L0` converges, to a limit `f'` in `K`.-/
  obtain ⟨f', f'K, hf'⟩ : ∃ f' ∈ K, tendsto L0 at_top (𝓝 f') :=
    cauchy_seq_tendsto_of_is_complete hK (λ e, (hn e (n e) (n e) (le_refl _) (le_refl _)).1) this,
  have Lf' : ∀ e p, n e ≤ p → ∥L e (n e) p - f'∥ ≤ 12 * ∥c∥ * (1/2)^e,
  { assume e p hp,
    apply le_of_tendsto (tendsto_const_nhds.sub hf').norm,
    rw eventually_at_top,
    exact ⟨e, λ e' he', M _ _ _ _ _ _ (le_refl _) hp (le_refl _) (le_refl _) he'⟩ },
  /- Let us show that `f` has derivative `f'` at `x`. -/
  have : has_fderiv_at f f' x,
  { simp only [has_fderiv_at_iff_is_o_nhds_zero, is_o_iff],
    /- to get an approximation with a precision `ε`, we will replace `f` with `L e (n e) m` for
    some large enough `e` (yielding a small error by uniform approximation). As one can vary `m`,
    this makes it possible to cover all scales, and thus to obtain a good linear approximation in
    the whole ball of radius `(1/2)^(n e)`. -/
    assume ε εpos,
    have pos : 0 < 4 + 12 * ∥c∥ :=
      add_pos_of_pos_of_nonneg (by norm_num) (mul_nonneg (by norm_num) (norm_nonneg _)),
    obtain ⟨e, he⟩ : ∃ (e : ℕ), (1 / 2) ^ e < ε / (4 + 12 * ∥c∥) :=
      exists_pow_lt_of_lt_one (div_pos εpos pos) (by norm_num),
    rw eventually_nhds_iff_ball,
    refine ⟨(1/2) ^ (n e + 1), P, λ y hy, _⟩,
    -- We need to show that `f (x + y) - f x - f' y` is small. For this, we will work at scale
    -- `k` where `k` is chosen with `∥y∥ ∼ 2 ^ (-k)`.
    by_cases y_pos : y = 0, {simp [y_pos] },
    have yzero : 0 < ∥y∥ := norm_pos_iff.mpr y_pos,
    have y_lt : ∥y∥ < (1/2) ^ (n e + 1), by simpa using mem_ball_iff_norm.1 hy,
    have yone : ∥y∥ ≤ 1 :=
      le_trans (y_lt.le) (pow_le_one _ (by norm_num) (by norm_num)),
    -- define the scale `k`.
    obtain ⟨k, hk, h'k⟩ : ∃ (k : ℕ), (1/2) ^ (k + 1) < ∥y∥ ∧ ∥y∥ ≤ (1/2) ^ k :=
      exists_nat_pow_near_of_lt_one yzero yone (by norm_num : (0 : ℝ) < 1/2)
      (by norm_num : (1 : ℝ)/2 < 1),
    -- the scale is large enough (as `y` is small enough)
    have k_gt : n e < k,
    { have : ((1:ℝ)/2) ^ (k + 1) < (1/2) ^ (n e + 1) := lt_trans hk y_lt,
      rw pow_lt_pow_iff_of_lt_one (by norm_num : (0 : ℝ) < 1/2) (by norm_num) at this,
      linarith },
    set m := k - 1 with hl,
    have m_ge : n e ≤ m := nat.le_pred_of_lt k_gt,
    have km : k = m + 1 := (nat.succ_pred_eq_of_pos (lt_of_le_of_lt (zero_le _) k_gt)).symm,
    rw km at hk h'k,
    -- `f` is well approximated by `L e (n e) k` at the relevant scale
    -- (in fact, we use `m = k - 1` instead of `k` because of the precise definition of `A`).
    have J1 : ∥f (x + y) - f x - L e (n e) m ((x + y) - x)∥ ≤ (1/2) ^ e * (1/2) ^ m,
    { apply le_of_mem_A (hn e (n e) m (le_refl _) m_ge).2.2,
      { simp only [mem_closed_ball, dist_self],
        exact div_nonneg (le_of_lt P) (zero_le_two) },
      { simp [dist_eq_norm],
        convert h'k,
        field_simp,
        ring_exp } },
    have J2 : ∥f (x + y) - f x - L e (n e) m y∥ ≤ 4 * (1/2) ^ e * ∥y∥ := calc
      ∥f (x + y) - f x - L e (n e) m y∥ ≤ (1/2) ^ e * (1/2) ^ m :
        by simpa only [add_sub_cancel'] using J1
      ... = 4 * (1/2) ^ e * (1/2) ^ (m + 2) : by { field_simp, ring_exp }
      ... ≤ 4 * (1/2) ^ e * ∥y∥ :
        mul_le_mul_of_nonneg_left (le_of_lt hk) (mul_nonneg (by norm_num) (le_of_lt P)),
    -- use the previous estimates to see that `f (x + y) - f x - f' y` is small.
    calc ∥f (x + y) - f x - f' y∥
        = ∥(f (x + y) - f x - L e (n e) m y) + (L e (n e) m - f') y∥ :
      by { congr' 1, simp, abel }
    ... ≤ ∥f (x + y) - f x - L e (n e) m y∥ + ∥(L e (n e) m - f') y∥ :
      norm_add_le _ _
    ... ≤ 4 * (1/2) ^ e * ∥y∥ + 12 * ∥c∥ * (1/2) ^ e * ∥y∥ :
      add_le_add J2
        (le_trans (le_op_norm _ _) (mul_le_mul_of_nonneg_right (Lf' _ _ m_ge) (norm_nonneg _)))
    ... = (4 + 12 * ∥c∥) * ∥y∥ * (1/2) ^ e : by ring
    ... ≤ (4 + 12 * ∥c∥) * ∥y∥ * (ε / (4 + 12 * ∥c∥)) :
      mul_le_mul_of_nonneg_left he.le
        (mul_nonneg (add_nonneg (by norm_num) (mul_nonneg (by norm_num) (norm_nonneg _)))
          (norm_nonneg _))
    ... = ε * ∥y∥ : by { field_simp [ne_of_gt pos], ring } },
  rw ← this.fderiv at f'K,
  exact ⟨this.differentiable_at, f'K⟩
end

theorem differentiable_set_eq_D (hK : is_complete K) :
  {x | differentiable_at 𝕜 f x ∧ fderiv 𝕜 f x ∈ K} = D f K :=
subset.antisymm (differentiable_set_subset_D _) (D_subset_differentiable_set hK)

end fderiv_measurable_aux

open fderiv_measurable_aux

variables [measurable_space E] [opens_measurable_space E]
variables (𝕜 f)

/-- The set of differentiability points of a function, with derivative in a given complete set,
is Borel-measurable. -/
theorem measurable_set_of_differentiable_at_of_is_complete
  {K : set (E →L[𝕜] F)} (hK : is_complete K) :
  measurable_set {x | differentiable_at 𝕜 f x ∧ fderiv 𝕜 f x ∈ K} :=
by simp [differentiable_set_eq_D K hK, D, is_open_B.measurable_set, measurable_set.Inter_Prop,
         measurable_set.Inter, measurable_set.Union]

variable [complete_space F]

/-- The set of differentiability points of a function taking values in a complete space is
Borel-measurable. -/
theorem measurable_set_of_differentiable_at :
  measurable_set {x | differentiable_at 𝕜 f x} :=
begin
  have : is_complete (univ : set (E →L[𝕜] F)) := complete_univ,
  convert measurable_set_of_differentiable_at_of_is_complete 𝕜 f this,
  simp
end

lemma measurable_fderiv : measurable (fderiv 𝕜 f) :=
begin
  refine measurable_of_is_closed (λ s hs, _),
  have : fderiv 𝕜 f ⁻¹' s = {x | differentiable_at 𝕜 f x ∧ fderiv 𝕜 f x ∈ s} ∪
    {x | (0 : E →L[𝕜] F) ∈ s} ∩ {x | ¬differentiable_at 𝕜 f x} :=
    set.ext (λ x, mem_preimage.trans fderiv_mem_iff),
  rw this,
  exact (measurable_set_of_differentiable_at_of_is_complete _ _ hs.is_complete).union
    ((measurable_set.const _).inter (measurable_set_of_differentiable_at _ _).compl)
end

lemma measurable_fderiv_apply_const [measurable_space F] [borel_space F] (y : E) :
  measurable (λ x, fderiv 𝕜 f x y) :=
(continuous_linear_map.measurable_apply y).comp (measurable_fderiv 𝕜 f)

variable {𝕜}

lemma measurable_deriv [measurable_space 𝕜] [opens_measurable_space 𝕜] [measurable_space F]
  [borel_space F] (f : 𝕜 → F) : measurable (deriv f) :=
by simpa only [fderiv_deriv] using measurable_fderiv_apply_const 𝕜 f 1


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.finset.locally_finite

/-!
# Intervals of finsets as finsets

This file provides the `locally_finite_order` instance for `finset α` and calculates the cardinality
of finite intervals of finsets.

If `s t : finset α`, then `finset.Icc s t` is the finset of finsets which include `s` and are
included in `t`. For example,
`finset.Icc {0, 1} {0, 1, 2, 3} = {{0, 1}, {0, 1, 2}, {0, 1, 3}, {0, 1, 2, 3}}`
and
`finset.Icc {0, 1, 2} {0, 1, 3} = {}`.
-/

variables {α : Type*}

namespace finset
variables [decidable_eq α] (s t : finset α)

instance : locally_finite_order (finset α) :=
{ finset_Icc := λ s t, t.powerset.filter ((⊆) s),
  finset_Ico := λ s t, t.ssubsets.filter ((⊆) s),
  finset_Ioc := λ s t, t.powerset.filter ((⊂) s),
  finset_Ioo := λ s t, t.ssubsets.filter ((⊂) s),
  finset_mem_Icc := λ s t u, by {rw [mem_filter, mem_powerset], exact and_comm _ _ },
  finset_mem_Ico := λ s t u, by {rw [mem_filter, mem_ssubsets], exact and_comm _ _ },
  finset_mem_Ioc := λ s t u, by {rw [mem_filter, mem_powerset], exact and_comm _ _ },
  finset_mem_Ioo := λ s t u, by {rw [mem_filter, mem_ssubsets], exact and_comm _ _ } }

lemma Icc_eq_filter_powerset : Icc s t = t.powerset.filter ((⊆) s) := rfl
lemma Ico_eq_filter_ssubsets : Ico s t = t.ssubsets.filter ((⊆) s) := rfl
lemma Ioc_eq_filter_powerset : Ioc s t = t.powerset.filter ((⊂) s) := rfl
lemma Ioo_eq_filter_ssubsets : Ioo s t = t.ssubsets.filter ((⊂) s) := rfl

lemma Iic_eq_powerset : Iic s = s.powerset := filter_true_of_mem $ λ t _, empty_subset t
lemma Iio_eq_ssubsets : Iio s = s.ssubsets := filter_true_of_mem $ λ t _, empty_subset t

variables {s t}

lemma Icc_eq_image_powerset (h : s ⊆ t) : Icc s t = (t \ s).powerset.image ((∪) s) :=
begin
  ext u,
  simp_rw [mem_Icc, mem_image, exists_prop, mem_powerset],
  split,
  { rintro ⟨hs, ht⟩,
    exact ⟨u \ s, sdiff_le_sdiff_right ht, sup_sdiff_cancel_right hs⟩ },
  { rintro ⟨v, hv, rfl⟩,
    exact ⟨le_sup_left, union_subset h $ hv.trans $ sdiff_subset _ _⟩ }
end

lemma Ico_eq_image_ssubsets (h : s ⊆ t) : Ico s t = (t \ s).ssubsets.image ((∪) s) :=
begin
  ext u,
  simp_rw [mem_Ico, mem_image, exists_prop, mem_ssubsets],
  split,
  { rintro ⟨hs, ht⟩,
    exact ⟨u \ s, sdiff_lt_sdiff_right ht hs, sup_sdiff_cancel_right hs⟩ },
  { rintro ⟨v, hv, rfl⟩,
    exact ⟨le_sup_left, sup_lt_of_lt_sdiff_left hv h⟩ }
end

/-- Cardinality of a non-empty `Icc` of finsets. -/
lemma card_Icc_finset (h : s ⊆ t) : (Icc s t).card = 2 ^ (t.card - s.card) :=
begin
  rw [←card_sdiff h, ←card_powerset, Icc_eq_image_powerset h, finset.card_image_iff],
  rintro u hu v hv (huv : s ⊔ u = s ⊔ v),
  rw [mem_coe, mem_powerset] at hu hv,
  rw [←(disjoint_sdiff.mono_right hu : disjoint s u).sup_sdiff_cancel_left,
    ←(disjoint_sdiff.mono_right hv : disjoint s v).sup_sdiff_cancel_left, huv],
end

/-- Cardinality of an `Ico` of finsets. -/
lemma card_Ico_finset (h : s ⊆ t) : (Ico s t).card = 2 ^ (t.card - s.card) - 1 :=
by rw [card_Ico_eq_card_Icc_sub_one, card_Icc_finset h]

/-- Cardinality of an `Ioc` of finsets. -/
lemma card_Ioc_finset (h : s ⊆ t) : (Ioc s t).card = 2 ^ (t.card - s.card) - 1 :=
by rw [card_Ioc_eq_card_Icc_sub_one, card_Icc_finset h]

/-- Cardinality of an `Ioo` of finsets. -/
lemma card_Ioo_finset (h : s ⊆ t) : (Ioo s t).card = 2 ^ (t.card - s.card) - 2 :=
by rw [card_Ioo_eq_card_Icc_sub_two, card_Icc_finset h]

/-- Cardinality of an `Iic` of finsets. -/
lemma card_Iic_finset : (Iic s).card = 2 ^ s.card :=
by rw [Iic_eq_powerset, card_powerset]

/-- Cardinality of an `Iio` of finsets. -/
lemma card_Iio_finset : (Iio s).card = 2 ^ s.card - 1 :=
by rw [Iio_eq_ssubsets, ssubsets, card_erase_of_mem (mem_powerset_self _), card_powerset]

end finset


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import data.polynomial.coeff

/-!
# Theory of univariate polynomials

The main results are `induction_on` and `as_sum`.
-/

noncomputable theory

open finsupp finset

namespace polynomial
universes u v w x y z
variables {R : Type u} {S : Type v} {T : Type w} {ι : Type x} {k : Type y} {A : Type z}
  {a b : R} {m n : ℕ}

section semiring
variables [semiring R] {p q r : polynomial R}

lemma sum_C_mul_X_eq (p : polynomial R) : p.sum (λn a, C a * X^n) = p :=
begin
  ext n,
  simp only [polynomial.sum, X_pow_eq_monomial, coeff_monomial, mul_one, finset_sum_coeff,
    C_mul_monomial, not_not, mem_support_iff, finset.sum_ite_eq', ite_eq_left_iff],
  exact λ h, h.symm
end

lemma sum_monomial_eq (p : polynomial R) : p.sum (λn a, monomial n a) = p :=
by simp only [monomial_eq_C_mul_X, sum_C_mul_X_eq]

@[elab_as_eliminator] protected lemma induction_on {M : polynomial R → Prop} (p : polynomial R)
  (h_C : ∀a, M (C a))
  (h_add : ∀p q, M p → M q → M (p + q))
  (h_monomial : ∀(n : ℕ) (a : R), M (C a * X^n) → M (C a * X^(n+1))) :
  M p :=
begin
  have A : ∀{n:ℕ} {a}, M (C a * X^n),
  { assume n a,
    induction n with n ih,
    { simp only [pow_zero, mul_one, h_C] },
    { exact h_monomial _ _ ih } },
  have B : ∀ (s : finset ℕ), M (s.sum (λ (n : ℕ), C (p.coeff n) * X ^ n)),
  { apply finset.induction,
    { convert h_C 0, exact C_0.symm },
    { assume n s ns ih, rw sum_insert ns, exact h_add _ _ A ih, } },
  rw [← sum_C_mul_X_eq p, polynomial.sum],
  exact B _
end

/--
To prove something about polynomials,
it suffices to show the condition is closed under taking sums,
and it holds for monomials.
-/
@[elab_as_eliminator] protected lemma induction_on' {M : polynomial R → Prop} (p : polynomial R)
  (h_add : ∀p q, M p → M q → M (p + q))
  (h_monomial : ∀(n : ℕ) (a : R), M (monomial n a)) :
  M p :=
polynomial.induction_on p (h_monomial 0) h_add
(λ n a h, by { rw ← monomial_eq_C_mul_X at ⊢, exact h_monomial _ _ })

section coeff

theorem coeff_mul_monomial (p : polynomial R) (n d : ℕ) (r : R) :
  coeff (p * monomial n r) (d + n) = coeff p d * r :=
by rw [monomial_eq_C_mul_X, ←X_pow_mul, ←mul_assoc, coeff_mul_C, coeff_mul_X_pow]

theorem coeff_monomial_mul (p : polynomial R) (n d : ℕ) (r : R) :
  coeff (monomial n r * p) (d + n) = r * coeff p d :=
by rw [monomial_eq_C_mul_X, mul_assoc, coeff_C_mul, X_pow_mul, coeff_mul_X_pow]

-- This can already be proved by `simp`.
theorem coeff_mul_monomial_zero (p : polynomial R) (d : ℕ) (r : R) :
  coeff (p * monomial 0 r) d = coeff p d * r :=
coeff_mul_monomial p 0 d r

-- This can already be proved by `simp`.
theorem coeff_monomial_zero_mul (p : polynomial R) (d : ℕ) (r : R) :
  coeff (monomial 0 r * p) d = r * coeff p d :=
coeff_monomial_mul p 0 d r

end coeff

open submodule polynomial set
variables {f : polynomial R} {I : submodule (polynomial R) (polynomial R)}

/--  If the coefficients of a polynomial belong to n ideal contains the submodule span of the
coefficients of a polynomial. -/
lemma span_le_of_coeff_mem_C_inverse (cf : ∀ (i : ℕ), f.coeff i ∈ (C ⁻¹' I.carrier)) :
  (span (polynomial R) {g | ∃ i, g = C (f.coeff i)}) ≤ I :=
begin
  refine bInter_subset_of_mem _,
  rintros _ ⟨i, rfl⟩,
  exact set_like.mem_coe.mpr (cf i),
end

lemma mem_span_C_coeff :
  f ∈ span (polynomial R) {g : polynomial R | ∃ i : ℕ, g = (C (coeff f i))} :=
begin
  let p := span (polynomial R) {g : polynomial R | ∃ i : ℕ, g = (C (coeff f i))},
  nth_rewrite 0 (sum_C_mul_X_eq f).symm,
  refine submodule.sum_mem _ (λ n hn, _),
  dsimp,
  have : C (coeff f n) ∈ p, by { apply subset_span, simp },
  have : (monomial n (1 : R)) • C (coeff f n) ∈ p := p.smul_mem _ this,
  convert this using 1,
  simp only [monomial_mul_C, one_mul, smul_eq_mul],
  rw monomial_eq_C_mul_X,
end

lemma exists_coeff_not_mem_C_inverse :
  f ∉ I → ∃ i : ℕ , coeff f i ∉ (C ⁻¹'  I.carrier) :=
imp_of_not_imp_not _ _
  (λ cf, not_not.mpr ((span_le_of_coeff_mem_C_inverse (not_exists_not.mp cf)) mem_span_C_coeff))

end semiring

end polynomial


/-
Copyright (c) 2021 Eric Weiser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.algebra.operations
import algebra.algebra.subalgebra.basic
import ring_theory.subring.pointwise
import ring_theory.adjoin.basic

/-!
# Pointwise actions on subalgebras.

If `R'` acts on an `R`-algebra `A` (so that `R'` and `R` actions commute)
then we get an `R'` action on the collection of `R`-subalgebras.
-/

namespace subalgebra

section pointwise
variables {R : Type*} {A : Type*} [comm_semiring R] [semiring A] [algebra R A]

theorem mul_to_submodule_le (S T : subalgebra R A) :
  S.to_submodule * T.to_submodule ≤ (S ⊔ T).to_submodule :=
begin
  rw submodule.mul_le,
  intros y hy z hz,
  exact mul_mem _ (algebra.mem_sup_left hy) (algebra.mem_sup_right hz),
end

/-- As submodules, subalgebras are idempotent. -/
@[simp] theorem mul_self  (S : subalgebra R A) : S.to_submodule * S.to_submodule = S.to_submodule :=
begin
  apply le_antisymm,
  { refine (mul_to_submodule_le _ _).trans_eq _,
    rw sup_idem },
  { intros x hx1,
    rw ← mul_one x,
    exact submodule.mul_mem_mul hx1 (one_mem S) }
end

/-- When `A` is commutative, `subalgebra.mul_to_submodule_le` is strict. -/
theorem mul_to_submodule {R : Type*} {A : Type*} [comm_semiring R] [comm_semiring A] [algebra R A]
  (S T : subalgebra R A) :
  S.to_submodule * T.to_submodule = (S ⊔ T).to_submodule :=
begin
  refine le_antisymm (mul_to_submodule_le _ _) _,
  rintros x (hx : x ∈ algebra.adjoin R (S ∪ T : set A)),
  refine algebra.adjoin_induction hx (λ x hx, _) (λ r, _) (λ _ _, submodule.add_mem _)
    (λ x y hx hy, _),
  { cases hx with hxS hxT,
    { rw ← mul_one x,
      exact submodule.mul_mem_mul hxS (one_mem T) },
    { rw ← one_mul x,
      exact submodule.mul_mem_mul (one_mem S) hxT } },
  { rw ← one_mul (algebra_map _ _ _),
    exact submodule.mul_mem_mul (one_mem S) (algebra_map_mem _ _) },
  have := submodule.mul_mem_mul hx hy,
  rwa [mul_assoc, mul_comm _ T.to_submodule, ←mul_assoc _ _ S.to_submodule, mul_self,
    mul_comm T.to_submodule, ←mul_assoc, mul_self] at this,
end

variables {R' : Type*} [semiring R'] [mul_semiring_action R' A] [smul_comm_class R' R A]

/-- The action on a subalgebra corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
protected def pointwise_mul_action : mul_action R' (subalgebra R A) :=
{ smul := λ a S, S.map (mul_semiring_action.to_alg_hom _ _ a),
  one_smul := λ S,
    (congr_arg (λ f, S.map f) (alg_hom.ext $ by exact one_smul R')).trans S.map_id,
  mul_smul := λ a₁ a₂ S,
    (congr_arg (λ f, S.map f) (alg_hom.ext $ by exact mul_smul _ _)).trans (S.map_map _ _).symm }

localized "attribute [instance] subalgebra.pointwise_mul_action" in pointwise
open_locale pointwise

@[simp] lemma coe_pointwise_smul (m : R') (S : subalgebra R A) : ↑(m • S) = m • (S : set A) := rfl

@[simp] lemma pointwise_smul_to_subsemiring (m : R') (S : subalgebra R A) :
  (m • S).to_subsemiring = m • S.to_subsemiring := rfl

@[simp] lemma pointwise_smul_to_submodule (m : R') (S : subalgebra R A) :
  (m • S).to_submodule = m • S.to_submodule := rfl

@[simp] lemma pointwise_smul_to_subring {R' R A : Type*} [semiring R'] [comm_ring R] [ring A]
  [mul_semiring_action R' A] [algebra R A] [smul_comm_class R' R A] (m : R') (S : subalgebra R A) :
  (m • S).to_subring = m • S.to_subring := rfl

lemma smul_mem_pointwise_smul (m : R') (r : A) (S : subalgebra R A) : r ∈ S → m • r ∈ m • S :=
(set.smul_mem_smul_set : _ → _ ∈ m • (S : set A))

end pointwise

end subalgebra


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import data.fin.vec_notation
import data.equiv.basic
import tactic.norm_num

/-!
# Equivalences for `fin n`
-/

universes u

variables {m n : ℕ}

/-- Equivalence between `fin 0` and `empty`. -/
def fin_zero_equiv : fin 0 ≃ empty :=
equiv.equiv_empty _

/-- Equivalence between `fin 0` and `pempty`. -/
def fin_zero_equiv' : fin 0 ≃ pempty.{u} :=
equiv.equiv_pempty _

/-- Equivalence between `fin 1` and `unit`. -/
def fin_one_equiv : fin 1 ≃ unit :=
equiv_punit_of_unique

/-- Equivalence between `fin 2` and `bool`. -/
def fin_two_equiv : fin 2 ≃ bool :=
⟨@fin.cases 1 (λ_, bool) ff (λ_, tt),
  λb, cond b 1 0,
  begin
    refine fin.cases _ _, by norm_num,
    refine fin.cases _ _, by norm_num,
    exact λi, fin_zero_elim i
  end,
  begin
    rintro ⟨_|_⟩,
    { refl },
    { rw ← fin.succ_zero_eq_one, refl }
  end⟩

/-- `Π i : fin 2, α i` is equivalent to `α 0 × α 1`. See also `fin_two_arrow_equiv` for a
non-dependent version and `prod_equiv_pi_fin_two` for a version with inputs `α β : Type u`. -/
@[simps {fully_applied := ff}] def pi_fin_two_equiv (α : fin 2 → Type u) : (Π i, α i) ≃ α 0 × α 1 :=
{ to_fun := λ f, (f 0, f 1),
  inv_fun := λ p, fin.cons p.1 $ fin.cons p.2 fin_zero_elim,
  left_inv := λ f, funext $ fin.forall_fin_two.2 ⟨rfl, rfl⟩,
  right_inv := λ ⟨x, y⟩, rfl }

lemma fin.preimage_apply_01_prod {α : fin 2 → Type u} (s : set (α 0)) (t : set (α 1)) :
  (λ f : Π i, α i, (f 0, f 1)) ⁻¹' (s.prod t) =
    set.pi set.univ (fin.cons s $ fin.cons t fin.elim0) :=
begin
  ext f,
  have : (fin.cons s (fin.cons t fin.elim0) : Π i, set (α i)) 1 = t := rfl,
  simp [fin.forall_fin_two, this]
end

lemma fin.preimage_apply_01_prod' {α : Type u} (s t : set α) :
  (λ f : fin 2 → α, (f 0, f 1)) ⁻¹' (s.prod t) = set.pi set.univ ![s, t] :=
fin.preimage_apply_01_prod s t

/-- A product space `α × β` is equivalent to the space `Π i : fin 2, γ i`, where
`γ = fin.cons α (fin.cons β fin_zero_elim)`. See also `pi_fin_two_equiv` and
`fin_two_arrow_equiv`. -/
@[simps {fully_applied := ff }] def prod_equiv_pi_fin_two (α β : Type u) :
  α × β ≃ Π i : fin 2, ![α, β] i :=
(pi_fin_two_equiv (fin.cons α (fin.cons β fin_zero_elim))).symm

/-- The space of functions `fin 2 → α` is equivalent to `α × α`. See also `pi_fin_two_equiv` and
`prod_equiv_pi_fin_two`. -/
@[simps { fully_applied := ff }] def fin_two_arrow_equiv (α : Type*) : (fin 2 → α) ≃ α × α :=
{ inv_fun := λ x, ![x.1, x.2],
  .. pi_fin_two_equiv (λ _, α) }

/-- `Π i : fin 2, α i` is order equivalent to `α 0 × α 1`. See also `order_iso.fin_two_arrow_equiv`
for a non-dependent version. -/
def order_iso.pi_fin_two_iso (α : fin 2 → Type u) [Π i, preorder (α i)] :
  (Π i, α i) ≃o α 0 × α 1 :=
{ to_equiv := pi_fin_two_equiv α,
  map_rel_iff' := λ f g, iff.symm fin.forall_fin_two }

/-- The space of functions `fin 2 → α` is order equivalent to `α × α`. See also
`order_iso.pi_fin_two_iso`. -/
def order_iso.fin_two_arrow_iso (α : Type*) [preorder α] : (fin 2 → α) ≃o α × α :=
{ to_equiv := fin_two_arrow_equiv α, .. order_iso.pi_fin_two_iso (λ _, α) }

/-- The 'identity' equivalence between `fin n` and `fin m` when `n = m`. -/
def fin_congr {n m : ℕ} (h : n = m) : fin n ≃ fin m :=
(fin.cast h).to_equiv

@[simp] lemma fin_congr_apply_mk {n m : ℕ} (h : n = m) (k : ℕ) (w : k < n) :
  fin_congr h ⟨k, w⟩ = ⟨k, by { subst h, exact w }⟩ :=
rfl

@[simp] lemma fin_congr_symm {n m : ℕ} (h : n = m) :
  (fin_congr h).symm = fin_congr h.symm := rfl

@[simp] lemma fin_congr_apply_coe {n m : ℕ} (h : n = m) (k : fin n) :
  (fin_congr h k : ℕ) = k :=
by { cases k, refl, }

lemma fin_congr_symm_apply_coe {n m : ℕ} (h : n = m) (k : fin m) :
  ((fin_congr h).symm k : ℕ) = k :=
by { cases k, refl, }

/-- An equivalence that removes `i` and maps it to `none`.
This is a version of `fin.pred_above` that produces `option (fin n)` instead of
mapping both `i.cast_succ` and `i.succ` to `i`. -/
def fin_succ_equiv' {n : ℕ} (i : fin (n + 1)) :
  fin (n + 1) ≃ option (fin n) :=
{ to_fun := i.insert_nth none some,
  inv_fun := λ x, x.cases_on' i (fin.succ_above i),
  left_inv := λ x, fin.succ_above_cases i (by simp) (λ j, by simp) x,
  right_inv := λ x, by cases x; dsimp; simp }

@[simp] lemma fin_succ_equiv'_at {n : ℕ} (i : fin (n + 1)) :
  (fin_succ_equiv' i) i = none := by simp [fin_succ_equiv']

@[simp] lemma fin_succ_equiv'_succ_above {n : ℕ} (i : fin (n + 1)) (j : fin n) :
  fin_succ_equiv' i (i.succ_above j) = some j :=
@fin.insert_nth_apply_succ_above n (λ _, option (fin n)) i _ _ _

lemma fin_succ_equiv'_below {n : ℕ} {i : fin (n + 1)} {m : fin n} (h : m.cast_succ < i) :
  (fin_succ_equiv' i) m.cast_succ = some m :=
by rw [← fin.succ_above_below _ _ h, fin_succ_equiv'_succ_above]

lemma fin_succ_equiv'_above {n : ℕ} {i : fin (n + 1)} {m : fin n} (h : i ≤ m.cast_succ) :
  (fin_succ_equiv' i) m.succ = some m :=
by rw [← fin.succ_above_above _ _ h, fin_succ_equiv'_succ_above]

@[simp] lemma fin_succ_equiv'_symm_none {n : ℕ} (i : fin (n + 1)) :
  (fin_succ_equiv' i).symm none = i := rfl

@[simp] lemma fin_succ_equiv'_symm_some {n : ℕ} (i : fin (n + 1)) (j : fin n) :
  (fin_succ_equiv' i).symm (some j) = i.succ_above j :=
rfl

lemma fin_succ_equiv'_symm_some_below {n : ℕ} {i : fin (n + 1)} {m : fin n} (h : m.cast_succ < i) :
  (fin_succ_equiv' i).symm (some m) = m.cast_succ :=
fin.succ_above_below i m h

lemma fin_succ_equiv'_symm_some_above {n : ℕ} {i : fin (n + 1)} {m : fin n} (h : i ≤ m.cast_succ) :
  (fin_succ_equiv' i).symm (some m) = m.succ :=
fin.succ_above_above i m h

lemma fin_succ_equiv'_symm_coe_below {n : ℕ} {i : fin (n + 1)} {m : fin n} (h : m.cast_succ < i) :
  (fin_succ_equiv' i).symm m = m.cast_succ :=
fin_succ_equiv'_symm_some_below h

lemma fin_succ_equiv'_symm_coe_above {n : ℕ} {i : fin (n + 1)} {m : fin n} (h : i ≤ m.cast_succ) :
  (fin_succ_equiv' i).symm m = m.succ :=
fin_succ_equiv'_symm_some_above h

/-- Equivalence between `fin (n + 1)` and `option (fin n)`.
This is a version of `fin.pred` that produces `option (fin n)` instead of
requiring a proof that the input is not `0`. -/
def fin_succ_equiv (n : ℕ) : fin (n + 1) ≃ option (fin n) :=
fin_succ_equiv' 0

@[simp] lemma fin_succ_equiv_zero {n : ℕ} :
  (fin_succ_equiv n) 0 = none :=
by cases n; refl

@[simp] lemma fin_succ_equiv_succ {n : ℕ} (m : fin n):
  (fin_succ_equiv n) m.succ = some m :=
fin_succ_equiv'_above (fin.zero_le _)

@[simp] lemma fin_succ_equiv_symm_none {n : ℕ} :
  (fin_succ_equiv n).symm none = 0 :=
fin_succ_equiv'_symm_none _

@[simp] lemma fin_succ_equiv_symm_some {n : ℕ} (m : fin n) :
  (fin_succ_equiv n).symm (some m) = m.succ :=
congr_fun fin.succ_above_zero m

@[simp] lemma fin_succ_equiv_symm_coe {n : ℕ} (m : fin n) :
  (fin_succ_equiv n).symm m = m.succ :=
fin_succ_equiv_symm_some m

/-- The equiv version of `fin.pred_above_zero`. -/
lemma fin_succ_equiv'_zero {n : ℕ} :
  fin_succ_equiv' (0 : fin (n + 1)) = fin_succ_equiv n := rfl

/-- `equiv` between `fin (n + 1)` and `option (fin n)` sending `fin.last n` to `none` -/
def fin_succ_equiv_last {n : ℕ} : fin (n + 1) ≃ option (fin n) :=
fin_succ_equiv' (fin.last n)

@[simp] lemma fin_succ_equiv_last_cast_succ {n : ℕ} (i : fin n) :
  fin_succ_equiv_last i.cast_succ = some i :=
fin_succ_equiv'_below i.2

@[simp] lemma fin_succ_equiv_last_last {n : ℕ} :
  fin_succ_equiv_last (fin.last n) = none :=
by simp [fin_succ_equiv_last]

@[simp] lemma fin_succ_equiv_last_symm_some {n : ℕ} (i : fin n) :
  fin_succ_equiv_last.symm (some i) = i.cast_succ :=
fin_succ_equiv'_symm_some_below i.2

@[simp] lemma fin_succ_equiv_last_symm_coe {n : ℕ} (i : fin n) :
  fin_succ_equiv_last.symm ↑i = i.cast_succ :=
fin_succ_equiv'_symm_some_below i.2

@[simp] lemma fin_succ_equiv_last_symm_none {n : ℕ}  :
  fin_succ_equiv_last.symm none = fin.last n :=
fin_succ_equiv'_symm_none _

/-- Equivalence between `fin m ⊕ fin n` and `fin (m + n)` -/
def fin_sum_fin_equiv : fin m ⊕ fin n ≃ fin (m + n) :=
{ to_fun := sum.elim (fin.cast_add n) (fin.nat_add m),
  inv_fun := λ i, @fin.add_cases m n (λ _, fin m ⊕ fin n) sum.inl sum.inr i,
  left_inv := λ x, by { cases x with y y; dsimp; simp },
  right_inv := λ x, by refine fin.add_cases (λ i, _) (λ i, _) x; simp }

@[simp] lemma fin_sum_fin_equiv_apply_left (i : fin m) :
  (fin_sum_fin_equiv (sum.inl i) : fin (m + n)) = fin.cast_add n i := rfl

@[simp] lemma fin_sum_fin_equiv_apply_right (i : fin n) :
  (fin_sum_fin_equiv (sum.inr i) : fin (m + n)) = fin.nat_add m i := rfl

@[simp] lemma fin_sum_fin_equiv_symm_apply_cast_add (x : fin m) :
  fin_sum_fin_equiv.symm (fin.cast_add n x) = sum.inl x :=
fin_sum_fin_equiv.symm_apply_apply (sum.inl x)

@[simp] lemma fin_sum_fin_equiv_symm_apply_nat_add (x : fin n) :
  fin_sum_fin_equiv.symm (fin.nat_add m x) = sum.inr x :=
fin_sum_fin_equiv.symm_apply_apply (sum.inr x)

/-- The equivalence between `fin (m + n)` and `fin (n + m)` which rotates by `n`. -/
def fin_add_flip : fin (m + n) ≃ fin (n + m) :=
(fin_sum_fin_equiv.symm.trans (equiv.sum_comm _ _)).trans fin_sum_fin_equiv

@[simp] lemma fin_add_flip_apply_cast_add (k : fin m) (n : ℕ) :
  fin_add_flip (fin.cast_add n k) = fin.nat_add n k :=
by simp [fin_add_flip]

@[simp] lemma fin_add_flip_apply_nat_add (k : fin n) (m : ℕ) :
  fin_add_flip (fin.nat_add m k) = fin.cast_add m k :=
by simp [fin_add_flip]

@[simp] lemma fin_add_flip_apply_mk_left {k : ℕ} (h : k < m)
  (hk : k < m + n := nat.lt_add_right k m n h)
  (hnk : n + k < n + m := add_lt_add_left h n) :
  fin_add_flip (⟨k, hk⟩ : fin (m + n)) = ⟨n + k, hnk⟩ :=
by convert fin_add_flip_apply_cast_add ⟨k, h⟩ n

@[simp] lemma fin_add_flip_apply_mk_right {k : ℕ} (h₁ : m ≤ k) (h₂ : k < m + n) :
  fin_add_flip (⟨k, h₂⟩ : fin (m + n)) = ⟨k - m, tsub_le_self.trans_lt $ add_comm m n ▸ h₂⟩ :=
begin
  convert fin_add_flip_apply_nat_add ⟨k - m, (tsub_lt_iff_right h₁).2 _⟩ m,
  { simp [add_tsub_cancel_of_le h₁] },
  { rwa add_comm }
end

/-- Rotate `fin n` one step to the right. -/
def fin_rotate : Π n, equiv.perm (fin n)
| 0 := equiv.refl _
| (n+1) := fin_add_flip.trans (fin_congr (add_comm _ _))

lemma fin_rotate_of_lt {k : ℕ} (h : k < n) :
  fin_rotate (n+1) ⟨k, lt_of_lt_of_le h (nat.le_succ _)⟩ = ⟨k + 1, nat.succ_lt_succ h⟩ :=
begin
  dsimp [fin_rotate],
  simp [h, add_comm],
end

lemma fin_rotate_last' : fin_rotate (n+1) ⟨n, lt_add_one _⟩ = ⟨0, nat.zero_lt_succ _⟩ :=
begin
  dsimp [fin_rotate],
  rw fin_add_flip_apply_mk_right,
  simp,
end

lemma fin_rotate_last : fin_rotate (n+1) (fin.last _) = 0 :=
fin_rotate_last'

lemma fin.snoc_eq_cons_rotate {α : Type*} (v : fin n → α) (a : α) :
  @fin.snoc _ (λ _, α) v a = (λ i, @fin.cons _ (λ _, α) a v (fin_rotate _ i)) :=
begin
  ext ⟨i, h⟩,
  by_cases h' : i < n,
  { rw [fin_rotate_of_lt h', fin.snoc, fin.cons, dif_pos h'],
    refl, },
  { have h'' : n = i,
    { simp only [not_lt] at h', exact (nat.eq_of_le_of_lt_succ h' h).symm, },
    subst h'',
    rw [fin_rotate_last', fin.snoc, fin.cons, dif_neg (lt_irrefl _)],
    refl, }
end

@[simp] lemma fin_rotate_zero : fin_rotate 0 = equiv.refl _ := rfl

@[simp] lemma fin_rotate_one : fin_rotate 1 = equiv.refl _ :=
subsingleton.elim _ _

@[simp] lemma fin_rotate_succ_apply {n : ℕ} (i : fin n.succ) :
  fin_rotate n.succ i = i + 1 :=
begin
  cases n,
  { simp },
  rcases i.le_last.eq_or_lt with rfl|h,
  { simp [fin_rotate_last] },
  { cases i,
    simp only [fin.lt_iff_coe_lt_coe, fin.coe_last, fin.coe_mk] at h,
    simp [fin_rotate_of_lt h, fin.eq_iff_veq, fin.add_def, nat.mod_eq_of_lt (nat.succ_lt_succ h)] },
end

@[simp] lemma fin_rotate_apply_zero {n : ℕ} : fin_rotate n.succ 0 = 1 :=
by rw [fin_rotate_succ_apply, zero_add]

lemma coe_fin_rotate_of_ne_last {n : ℕ} {i : fin n.succ} (h : i ≠ fin.last n) :
  (fin_rotate n.succ i : ℕ) = i + 1 :=
begin
  rw fin_rotate_succ_apply,
  have : (i : ℕ) < n := lt_of_le_of_ne (nat.succ_le_succ_iff.mp i.2) (fin.coe_injective.ne h),
  exact fin.coe_add_one_of_lt this
end

lemma coe_fin_rotate {n : ℕ} (i : fin n.succ) :
  (fin_rotate n.succ i : ℕ) = if i = fin.last n then 0 else i + 1 :=
by rw [fin_rotate_succ_apply, fin.coe_add_one i]

/-- Equivalence between `fin m × fin n` and `fin (m * n)` -/
@[simps]
def fin_prod_fin_equiv : fin m × fin n ≃ fin (m * n) :=
{ to_fun := λ x, ⟨x.2 + n * x.1,
    calc x.2.1 + n * x.1.1 + 1
        = x.1.1 * n + x.2.1 + 1 : by ac_refl
    ... ≤ x.1.1 * n + n : nat.add_le_add_left x.2.2 _
    ... = (x.1.1 + 1) * n : eq.symm $ nat.succ_mul _ _
    ... ≤ m * n : nat.mul_le_mul_right _ x.1.2⟩,
  inv_fun := λ x, (x.div_nat, x.mod_nat),
  left_inv := λ ⟨x, y⟩,
    have H : 0 < n, from nat.pos_of_ne_zero $ λ H, nat.not_lt_zero y.1 $ H ▸ y.2,
    prod.ext
      (fin.eq_of_veq $ calc
              (y.1 + n * x.1) / n
            = y.1 / n + x.1 : nat.add_mul_div_left _ _ H
        ... = 0 + x.1 : by rw nat.div_eq_of_lt y.2
        ... = x.1 : nat.zero_add x.1)
      (fin.eq_of_veq $ calc
              (y.1 + n * x.1) % n
            = y.1 % n : nat.add_mul_mod_self_left _ _ _
        ... = y.1 : nat.mod_eq_of_lt y.2),
  right_inv := λ x, fin.eq_of_veq $ nat.mod_add_div _ _ }

/-- Promote a `fin n` into a larger `fin m`, as a subtype where the underlying
values are retained. This is the `order_iso` version of `fin.cast_le`. -/
@[simps apply symm_apply]
def fin.cast_le_order_iso {n m : ℕ} (h : n ≤ m) : fin n ≃o {i : fin m // (i : ℕ) < n} :=
{ to_fun := λ i, ⟨fin.cast_le h i, by simpa using i.is_lt⟩,
  inv_fun := λ i, ⟨i, i.prop⟩,
  left_inv := λ _, by simp,
  right_inv := λ _, by simp,
  map_rel_iff' := λ _ _, by simp }

/-- `fin 0` is a subsingleton. -/
instance subsingleton_fin_zero : subsingleton (fin 0) :=
fin_zero_equiv.subsingleton

/-- `fin 1` is a subsingleton. -/
instance subsingleton_fin_one : subsingleton (fin 1) :=
fin_one_equiv.subsingleton


/-
  Alex Sanchez
  This file formalizes the first ** problem in Herstein's
  celebrated text, "Topics in Algebra".
-/

import tactic -- tactics
import group_theory.subgroup.basic -- subgroups
import group_theory.order_of_element -- elemental order
import data.nat.factorization.basic -- prime factorization

variables (G : Type) [comm_group G]

-- tests
example (a : ℕ) : nat.lcm (0 : ℕ) a = (0 : ℕ) :=
begin
  exact nat.lcm_zero_left a,
end

-- proofs

theorem single_star (h h' : G) : ∃ g : G, order_of g = nat.lcm (order_of h) (order_of h') :=
begin
  --break into cases with both nonzero, otherwise etc.
  let m : ℕ := order_of h,
  let n : ℕ := order_of h',
  by_cases hyp : m = 0 ∨ n = 0, { --trivial case
    cases hyp, {
      use h,
      conv
      begin
        congr, {
          change m,
          rw hyp,
        }, {
          congr, {
            change m,
            rw hyp,
          }, {
            change n,
          }
        }
      end,
      exact (nat.lcm_zero_left n).symm,
    }, {
      use h',
      conv
      begin
        congr, {
          change n,
          rw hyp,
        }, {
          congr, {
            change m,
          }, {
            change n,
            rw hyp,
          }
        }
      end,
      exact (nat.lcm_zero_right m).symm,
    },
  }, { --nontrivial case
    -- get nice forms of assumptions

    -- refactor to get both
    have fin_h : m > 0 :=
    begin
      have temp : ¬m=0 :=
      begin
        rw not_or_distrib at hyp,
        exact hyp.left,
      end,
      have temp_two : m ≥ 0 := zero_le m,
      have temp_three : m > 0 ∨ m = 0 :=
      begin
        have temp_temp : m > 0 ∨ m = 0 ∨ m < 0 := trichotomous m 0,
        cases temp_temp with a b, {
          left,
          exact a,
        }, {
          cases b with c d, {
            right,
            exact c,
          }, {
            exfalso,
            apply not_lt.mpr temp_two,
            exact d,
          },
        },
      end,
      cases temp_three with a b, {
        exact a,
      }, {
        exfalso,
        exact temp b,
      },
    end,
    let ps_m := nat.factorization m,
    let ps_n := nat.factorization n,
    -- find some way to identify the finite support

    sorry,
  },
end

theorem double_star (H H' : subgroup G) : ∃ H'' : subgroup G, nat.card H'' = nat.lcm (nat.card H) (nat.card H') :=
begin

  sorry,
end