/-
Copyright (c) 2020 Yury Kudryashov All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Moritz Doll
-/
import linear_algebra.basic
import linear_algebra.prod

/-!
# Partially defined linear maps

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

A `linear_pmap R E F` or `E →ₗ.[R] F` is a linear map from a submodule of `E` to `F`.
We define a `semilattice_inf` with `order_bot` instance on this this, and define three operations:

* `mk_span_singleton` defines a partial linear map defined on the span of a singleton.
* `sup` takes two partial linear maps `f`, `g` that agree on the intersection of their
  domains, and returns the unique partial linear map on `f.domain ⊔ g.domain` that
  extends both `f` and `g`.
* `Sup` takes a `directed_on (≤)` set of partial linear maps, and returns the unique
  partial linear map on the `Sup` of their domains that extends all these maps.

Moreover, we define
* `linear_pmap.graph` is the graph of the partial linear map viewed as a submodule of `E × F`.

Partially defined maps are currently used in `mathlib` to prove Hahn-Banach theorem
and its variations. Namely, `linear_pmap.Sup` implies that every chain of `linear_pmap`s
is bounded above.
They are also the basis for the theory of unbounded operators.

-/

open set

universes u v w

/-- A `linear_pmap R E F` or `E →ₗ.[R] F` is a linear map from a submodule of `E` to `F`. -/
structure linear_pmap (R : Type u) [ring R] (E : Type v) [add_comm_group E] [module R E]
  (F : Type w) [add_comm_group F] [module R F] :=
(domain : submodule R E)
(to_fun : domain →ₗ[R] F)

notation E ` →ₗ.[`:25 R:25 `] `:0 F:0 := linear_pmap R E F

variables {R : Type*} [ring R] {E : Type*} [add_comm_group E] [module R E]
  {F : Type*} [add_comm_group F] [module R F]
  {G : Type*} [add_comm_group G] [module R G]

namespace linear_pmap

open submodule

instance : has_coe_to_fun (E →ₗ.[R] F) (λ f : E →ₗ.[R] F, f.domain → F) :=
⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe (f : E →ₗ.[R] F) (x : f.domain) :
  f.to_fun x = f x := rfl

@[ext] lemma ext {f g : E →ₗ.[R] F} (h : f.domain = g.domain)
  (h' : ∀ ⦃x : f.domain⦄ ⦃y : g.domain⦄ (h : (x:E) = y), f x = g y) : f = g :=
begin
  rcases f with ⟨f_dom, f⟩,
  rcases g with ⟨g_dom, g⟩,
  obtain rfl : f_dom = g_dom := h,
  obtain rfl : f = g := linear_map.ext (λ x, h' rfl),
  refl,
end

@[simp] lemma map_zero (f : E →ₗ.[R] F) : f 0 = 0 := f.to_fun.map_zero

lemma ext_iff {f g : E →ₗ.[R] F} :
  f = g ↔
  ∃ (domain_eq : f.domain = g.domain),
    ∀ ⦃x : f.domain⦄ ⦃y : g.domain⦄ (h : (x:E) = y), f x = g y :=
⟨λ EQ, EQ ▸ ⟨rfl, λ x y h, by { congr, exact_mod_cast h }⟩, λ ⟨deq, feq⟩, ext deq feq⟩

lemma ext' {s : submodule R E} {f g : s →ₗ[R] F} (h : f = g) : mk s f = mk s g := h ▸ rfl

lemma map_add (f : E →ₗ.[R] F) (x y : f.domain) : f (x + y) = f x + f y :=
f.to_fun.map_add x y

lemma map_neg (f : E →ₗ.[R] F) (x : f.domain) : f (-x) = -f x :=
f.to_fun.map_neg x

lemma map_sub (f : E →ₗ.[R] F) (x y : f.domain) : f (x - y) = f x - f y :=
f.to_fun.map_sub x y

lemma map_smul (f : E →ₗ.[R] F) (c : R) (x : f.domain) : f (c • x) = c • f x :=
f.to_fun.map_smul c x

@[simp] lemma mk_apply (p : submodule R E) (f : p →ₗ[R] F) (x : p) :
  mk p f x = f x := rfl

/-- The unique `linear_pmap` on `R ∙ x` that sends `x` to `y`. This version works for modules
over rings, and requires a proof of `∀ c, c • x = 0 → c • y = 0`. -/
noncomputable def mk_span_singleton' (x : E) (y : F) (H : ∀ c : R, c • x = 0 → c • y = 0) :
  E →ₗ.[R] F :=
{ domain := R ∙ x,
  to_fun :=
  have H : ∀ c₁ c₂ : R, c₁ • x = c₂ • x → c₁ • y = c₂ • y,
  { intros c₁ c₂ h,
    rw [← sub_eq_zero, ← sub_smul] at h ⊢,
    exact H _ h },
  { to_fun := λ z, (classical.some (mem_span_singleton.1 z.prop) • y),
    map_add' := λ y z, begin
      rw [← add_smul],
      apply H,
      simp only [add_smul, sub_smul, classical.some_spec (mem_span_singleton.1 _)],
      apply coe_add
    end,
    map_smul' := λ c z, begin
      rw [smul_smul],
      apply H,
      simp only [mul_smul, classical.some_spec (mem_span_singleton.1 _)],
      apply coe_smul
    end } }

@[simp] lemma domain_mk_span_singleton (x : E) (y : F) (H : ∀ c : R, c • x = 0 → c • y = 0) :
  (mk_span_singleton' x y H).domain = R ∙ x := rfl

@[simp] lemma mk_span_singleton'_apply (x : E) (y : F) (H : ∀ c : R, c • x = 0 → c • y = 0)
  (c : R) (h) :
  mk_span_singleton' x y H ⟨c • x, h⟩ = c • y :=
begin
  dsimp [mk_span_singleton'],
  rw [← sub_eq_zero, ← sub_smul],
  apply H,
  simp only [sub_smul, one_smul, sub_eq_zero],
  apply classical.some_spec (mem_span_singleton.1 h),
end

@[simp] lemma mk_span_singleton'_apply_self (x : E) (y : F) (H : ∀ c : R, c • x = 0 → c • y = 0)
  (h) :
  mk_span_singleton' x y H ⟨x, h⟩ = y :=
by convert mk_span_singleton'_apply x y H 1 _; rwa one_smul

/-- The unique `linear_pmap` on `span R {x}` that sends a non-zero vector `x` to `y`.
This version works for modules over division rings. -/
@[reducible] noncomputable def mk_span_singleton {K E F : Type*} [division_ring K]
  [add_comm_group E] [module K E] [add_comm_group F] [module K F] (x : E) (y : F) (hx : x ≠ 0) :
  E →ₗ.[K] F :=
mk_span_singleton' x y $ λ c hc, (smul_eq_zero.1 hc).elim
  (λ hc, by rw [hc, zero_smul]) (λ hx', absurd hx' hx)

lemma mk_span_singleton_apply (K : Type*) {E F : Type*} [division_ring K]
  [add_comm_group E] [module K E] [add_comm_group F] [module K F] {x : E} (hx : x ≠ 0) (y : F) :
  mk_span_singleton x y hx
    ⟨x, (submodule.mem_span_singleton_self x : x ∈ submodule.span K {x})⟩ = y :=
linear_pmap.mk_span_singleton'_apply_self _ _ _ _

/-- Projection to the first coordinate as a `linear_pmap` -/
protected def fst (p : submodule R E) (p' : submodule R F) : (E × F) →ₗ.[R] E :=
{ domain := p.prod p',
  to_fun := (linear_map.fst R E F).comp (p.prod p').subtype }

@[simp] lemma fst_apply (p : submodule R E) (p' : submodule R F) (x : p.prod p') :
  linear_pmap.fst p p' x = (x : E × F).1 := rfl

/-- Projection to the second coordinate as a `linear_pmap` -/
protected def snd (p : submodule R E) (p' : submodule R F) : (E × F) →ₗ.[R] F :=
{ domain := p.prod p',
  to_fun := (linear_map.snd R E F).comp (p.prod p').subtype }

@[simp] lemma snd_apply (p : submodule R E) (p' : submodule R F) (x : p.prod p') :
  linear_pmap.snd p p' x = (x : E × F).2 := rfl

instance : has_neg (E →ₗ.[R] F) :=
⟨λ f, ⟨f.domain, -f.to_fun⟩⟩

@[simp] lemma neg_apply (f : E →ₗ.[R] F) (x) : (-f) x = -(f x) := rfl

instance : has_le (E →ₗ.[R] F) :=
⟨λ f g, f.domain ≤ g.domain ∧ ∀ ⦃x : f.domain⦄ ⦃y : g.domain⦄ (h : (x:E) = y), f x = g y⟩

lemma apply_comp_of_le {T S : E →ₗ.[R] F} (h : T ≤ S) (x : T.domain) :
  T x = S (submodule.of_le h.1 x) :=
h.2 rfl

lemma exists_of_le {T S : E →ₗ.[R] F} (h : T ≤ S) (x : T.domain) :
  ∃ (y : S.domain), (x : E) = y ∧ T x = S y :=
⟨⟨x.1, h.1 x.2⟩, ⟨rfl, h.2 rfl⟩⟩

lemma eq_of_le_of_domain_eq {f g : E →ₗ.[R] F} (hle : f ≤ g) (heq : f.domain = g.domain) :
  f = g :=
ext heq hle.2

/-- Given two partial linear maps `f`, `g`, the set of points `x` such that
both `f` and `g` are defined at `x` and `f x = g x` form a submodule. -/
def eq_locus (f g : E →ₗ.[R] F) : submodule R E :=
{ carrier   := {x | ∃ (hf : x ∈ f.domain) (hg : x ∈ g.domain), f ⟨x, hf⟩ = g ⟨x, hg⟩},
  zero_mem' := ⟨zero_mem _, zero_mem _, f.map_zero.trans g.map_zero.symm⟩,
  add_mem'  := λ x y ⟨hfx, hgx, hx⟩ ⟨hfy, hgy, hy⟩, ⟨add_mem hfx hfy, add_mem hgx hgy,
    by erw [f.map_add ⟨x, hfx⟩ ⟨y, hfy⟩, g.map_add ⟨x, hgx⟩ ⟨y, hgy⟩, hx, hy]⟩,
  smul_mem' := λ c x ⟨hfx, hgx, hx⟩, ⟨smul_mem _ c hfx, smul_mem _ c hgx,
    by erw [f.map_smul c ⟨x, hfx⟩, g.map_smul c ⟨x, hgx⟩, hx]⟩ }

instance : has_inf (E →ₗ.[R] F) :=
⟨λ f g, ⟨f.eq_locus g, f.to_fun.comp $ of_le $ λ x hx, hx.fst⟩⟩

instance : has_bot (E →ₗ.[R] F) := ⟨⟨⊥, 0⟩⟩

instance : inhabited (E →ₗ.[R] F) := ⟨⊥⟩

instance : semilattice_inf (E →ₗ.[R] F) :=
{ le := (≤),
  le_refl := λ f, ⟨le_refl f.domain, λ x y h, subtype.eq h ▸ rfl⟩,
  le_trans := λ f g h ⟨fg_le, fg_eq⟩ ⟨gh_le, gh_eq⟩,
    ⟨le_trans fg_le gh_le, λ x z hxz,
      have hxy : (x:E) = of_le fg_le x, from rfl,
      (fg_eq hxy).trans (gh_eq $ hxy.symm.trans hxz)⟩,
  le_antisymm := λ f g fg gf, eq_of_le_of_domain_eq fg (le_antisymm fg.1 gf.1),
  inf := (⊓),
  le_inf := λ f g h ⟨fg_le, fg_eq⟩ ⟨fh_le, fh_eq⟩,
    ⟨λ x hx, ⟨fg_le hx, fh_le hx,
      by refine (fg_eq _).symm.trans (fh_eq _); [exact ⟨x, hx⟩, refl, refl]⟩,
    λ x ⟨y, yg, hy⟩ h, by { apply fg_eq, exact h }⟩,
  inf_le_left := λ f g, ⟨λ x hx, hx.fst,
    λ x y h, congr_arg f $ subtype.eq $ by exact h⟩,
  inf_le_right := λ f g, ⟨λ x hx, hx.snd.fst,
    λ ⟨x, xf, xg, hx⟩ y h, hx.trans $ congr_arg g $ subtype.eq $ by exact h⟩ }

instance : order_bot (E →ₗ.[R] F) :=
{ bot := ⊥,
  bot_le := λ f, ⟨bot_le, λ x y h,
    have hx : x = 0, from subtype.eq ((mem_bot R).1 x.2),
    have hy : y = 0, from subtype.eq (h.symm.trans (congr_arg _ hx)),
    by rw [hx, hy, map_zero, map_zero]⟩ }

lemma le_of_eq_locus_ge {f g : E →ₗ.[R] F} (H : f.domain ≤ f.eq_locus g) :
  f ≤ g :=
suffices f ≤ f ⊓ g, from le_trans this inf_le_right,
⟨H, λ x y hxy, ((inf_le_left : f ⊓ g ≤ f).2 hxy.symm).symm⟩

lemma domain_mono : strict_mono (@domain R _ E _ _ F _ _) :=
λ f g hlt, lt_of_le_of_ne hlt.1.1 $ λ heq, ne_of_lt hlt $
eq_of_le_of_domain_eq (le_of_lt hlt) heq

private lemma sup_aux (f g : E →ₗ.[R] F)
  (h : ∀ (x : f.domain) (y : g.domain), (x:E) = y → f x = g y) :
  ∃ fg : ↥(f.domain ⊔ g.domain) →ₗ[R] F,
    ∀ (x : f.domain) (y : g.domain) (z),
      (x:E) + y = ↑z → fg z = f x + g y :=
begin
  choose x hx y hy hxy using λ z : f.domain ⊔ g.domain, mem_sup.1 z.prop,
  set fg := λ z, f ⟨x z, hx z⟩ + g ⟨y z, hy z⟩,
  have fg_eq : ∀ (x' : f.domain) (y' : g.domain) (z' : f.domain ⊔ g.domain) (H : (x':E) + y' = z'),
    fg z' = f x' + g y',
  { intros x' y' z' H,
    dsimp [fg],
    rw [add_comm, ← sub_eq_sub_iff_add_eq_add, eq_comm, ← map_sub, ← map_sub],
    apply h,
    simp only [← eq_sub_iff_add_eq] at hxy,
    simp only [add_subgroup_class.coe_sub, coe_mk, coe_mk, hxy, ← sub_add, ← sub_sub, sub_self,
      zero_sub, ← H],
    apply neg_add_eq_sub },
  refine ⟨{ to_fun := fg, .. }, fg_eq⟩,
  { rintros ⟨z₁, hz₁⟩ ⟨z₂, hz₂⟩,
    rw [← add_assoc, add_right_comm (f _), ← map_add, add_assoc, ← map_add],
    apply fg_eq,
    simp only [coe_add, coe_mk, ← add_assoc],
    rw [add_right_comm (x _), hxy, add_assoc, hxy, coe_mk, coe_mk] },
  { intros c z,
    rw [smul_add, ← map_smul, ← map_smul],
    apply fg_eq,
    simp only [coe_smul, coe_mk, ← smul_add, hxy, ring_hom.id_apply] },
end

/-- Given two partial linear maps that agree on the intersection of their domains,
`f.sup g h` is the unique partial linear map on `f.domain ⊔ g.domain` that agrees
with `f` and `g`. -/
protected noncomputable def sup (f g : E →ₗ.[R] F)
  (h : ∀ (x : f.domain) (y : g.domain), (x:E) = y → f x = g y) :
  E →ₗ.[R] F :=
⟨_, classical.some (sup_aux f g h)⟩

@[simp] lemma domain_sup (f g : E →ₗ.[R] F)
  (h : ∀ (x : f.domain) (y : g.domain), (x:E) = y → f x = g y) :
  (f.sup g h).domain = f.domain ⊔ g.domain :=
rfl

lemma sup_apply {f g : E →ₗ.[R] F}
  (H : ∀ (x : f.domain) (y : g.domain), (x:E) = y → f x = g y)
  (x y z) (hz : (↑x:E) + ↑y = ↑z) :
  f.sup g H z = f x + g y :=
classical.some_spec (sup_aux f g H) x y z hz

protected lemma left_le_sup (f g : E →ₗ.[R] F)
  (h : ∀ (x : f.domain) (y : g.domain), (x:E) = y → f x = g y) :
  f ≤ f.sup g h :=
begin
  refine ⟨le_sup_left, λ z₁ z₂ hz, _⟩,
  rw [← add_zero (f _), ← g.map_zero],
  refine (sup_apply h _ _ _ _).symm,
  simpa
end

protected lemma right_le_sup (f g : E →ₗ.[R] F)
  (h : ∀ (x : f.domain) (y : g.domain), (x:E) = y → f x = g y) :
  g ≤ f.sup g h :=
begin
  refine ⟨le_sup_right, λ z₁ z₂ hz, _⟩,
  rw [← zero_add (g _), ← f.map_zero],
  refine (sup_apply h _ _ _ _).symm,
  simpa
end

protected lemma sup_le {f g h : E →ₗ.[R] F}
  (H : ∀ (x : f.domain) (y : g.domain), (x:E) = y → f x = g y)
  (fh : f ≤ h) (gh : g ≤ h) :
  f.sup g H ≤ h :=
have Hf : f ≤ (f.sup g H) ⊓ h, from le_inf (f.left_le_sup g H) fh,
have Hg : g ≤ (f.sup g H) ⊓ h, from le_inf (f.right_le_sup g H) gh,
le_of_eq_locus_ge $ sup_le Hf.1 Hg.1

/-- Hypothesis for `linear_pmap.sup` holds, if `f.domain` is disjoint with `g.domain`. -/
lemma sup_h_of_disjoint (f g : E →ₗ.[R] F) (h : disjoint f.domain g.domain)
  (x : f.domain) (y : g.domain) (hxy : (x:E) = y) :
  f x = g y :=
begin
  rw [disjoint_def] at h,
  have hy : y = 0, from subtype.eq (h y (hxy ▸ x.2) y.2),
  have hx : x = 0, from subtype.eq (hxy.trans $ congr_arg _ hy),
  simp [*]
end

section smul

variables {M N : Type*} [monoid M] [distrib_mul_action M F] [smul_comm_class R M F]
variables [monoid N] [distrib_mul_action N F] [smul_comm_class R N F]

instance : has_smul M (E →ₗ.[R] F) :=
⟨λ a f,
  { domain := f.domain,
    to_fun := a • f.to_fun }⟩

@[simp] lemma smul_domain (a : M) (f : E →ₗ.[R] F) : (a • f).domain = f.domain := rfl

lemma smul_apply (a : M) (f : E →ₗ.[R] F) (x : ((a • f).domain)) :
  (a • f) x = a • f x := rfl

@[simp] lemma coe_smul (a : M) (f : E →ₗ.[R] F) : ⇑(a • f) = a • f := rfl

instance [smul_comm_class M N F] : smul_comm_class M N (E →ₗ.[R] F) :=
⟨λ a b f, ext' $ smul_comm a b f.to_fun⟩

instance [has_smul M N] [is_scalar_tower M N F] : is_scalar_tower M N (E →ₗ.[R] F) :=
⟨λ a b f, ext' $ smul_assoc a b f.to_fun⟩

instance : mul_action M (E →ₗ.[R] F) :=
{ smul := (•),
  one_smul := λ ⟨s, f⟩, ext' $ one_smul M f,
  mul_smul := λ a b f, ext' $ mul_smul a b f.to_fun }

end smul

section vadd

instance : has_vadd (E →ₗ[R] F) (E →ₗ.[R] F) :=
⟨λ f g,
  { domain := g.domain,
    to_fun := f.comp g.domain.subtype + g.to_fun }⟩

@[simp] lemma vadd_domain (f : E →ₗ[R] F) (g : E →ₗ.[R] F) : (f +ᵥ g).domain = g.domain := rfl

lemma vadd_apply (f : E →ₗ[R] F) (g : E →ₗ.[R] F) (x : (f +ᵥ g).domain) :
  (f +ᵥ g) x = f x + g x := rfl

@[simp] lemma coe_vadd (f : E →ₗ[R] F) (g : E →ₗ.[R] F) :
  ⇑(f +ᵥ g) = f.comp g.domain.subtype + g := rfl

instance : add_action (E →ₗ[R] F) (E →ₗ.[R] F) :=
{ vadd := (+ᵥ),
  zero_vadd := λ ⟨s, f⟩, ext' $ zero_add _,
  add_vadd := λ f₁ f₂ ⟨s, g⟩, ext' $ linear_map.ext $ λ x, add_assoc _ _ _ }

end vadd

section

variables {K : Type*} [division_ring K] [module K E] [module K F]

/-- Extend a `linear_pmap` to `f.domain ⊔ K ∙ x`. -/
noncomputable def sup_span_singleton (f : E →ₗ.[K] F) (x : E) (y : F) (hx : x ∉ f.domain) :
  E →ₗ.[K] F :=
f.sup (mk_span_singleton x y (λ h₀, hx $ h₀.symm ▸ f.domain.zero_mem)) $
  sup_h_of_disjoint _ _ $ by simpa [disjoint_span_singleton]

@[simp] lemma domain_sup_span_singleton (f : E →ₗ.[K] F) (x : E) (y : F)
  (hx : x ∉ f.domain) :
  (f.sup_span_singleton x y hx).domain = f.domain ⊔ K ∙ x := rfl

@[simp] lemma sup_span_singleton_apply_mk (f : E →ₗ.[K] F) (x : E) (y : F)
  (hx : x ∉ f.domain) (x' : E) (hx' : x' ∈ f.domain) (c : K) :
  f.sup_span_singleton x y hx ⟨x' + c • x,
    mem_sup.2 ⟨x', hx', _, mem_span_singleton.2 ⟨c, rfl⟩, rfl⟩⟩ = f ⟨x', hx'⟩ + c • y :=
begin
  erw [sup_apply _ ⟨x', hx'⟩ ⟨c • x, _⟩, mk_span_singleton'_apply],
  refl,
  exact mem_span_singleton.2 ⟨c, rfl⟩
end

end

private lemma Sup_aux (c : set (E →ₗ.[R] F)) (hc : directed_on (≤) c) :
  ∃ f : ↥(Sup (domain '' c)) →ₗ[R] F, (⟨_, f⟩ : E →ₗ.[R] F) ∈ upper_bounds c :=
begin
  cases c.eq_empty_or_nonempty with ceq cne, { subst c, simp },
  have hdir : directed_on (≤) (domain '' c),
    from directed_on_image.2 (hc.mono domain_mono.monotone),
  have P : Π x : Sup (domain '' c), {p : c // (x : E) ∈ p.val.domain },
  { rintros x,
    apply classical.indefinite_description,
    have := (mem_Sup_of_directed (cne.image _) hdir).1 x.2,
    rwa [bex_image_iff, set_coe.exists'] at this },
  set f : Sup (domain '' c) → F := λ x, (P x).val.val ⟨x, (P x).property⟩,
  have f_eq : ∀ (p : c) (x : Sup (domain '' c)) (y : p.1.1) (hxy : (x : E) = y), f x = p.1 y,
  { intros p x y hxy,
    rcases hc (P x).1.1 (P x).1.2 p.1 p.2 with ⟨q, hqc, hxq, hpq⟩,
    refine (hxq.2 _).trans (hpq.2 _).symm,
    exacts [of_le hpq.1 y, hxy, rfl] },
  refine ⟨{ to_fun := f, .. }, _⟩,
  { intros x y,
    rcases hc (P x).1.1 (P x).1.2 (P y).1.1 (P y).1.2 with ⟨p, hpc, hpx, hpy⟩,
    set x' := of_le hpx.1 ⟨x, (P x).2⟩,
    set y' := of_le hpy.1 ⟨y, (P y).2⟩,
    rw [f_eq ⟨p, hpc⟩ x x' rfl, f_eq ⟨p, hpc⟩ y y' rfl, f_eq ⟨p, hpc⟩ (x + y) (x' + y') rfl,
      map_add] },
  { intros c x,
    simp [f_eq (P x).1 (c • x) (c • ⟨x, (P x).2⟩) rfl, ← map_smul] },
  { intros p hpc,
    refine ⟨le_Sup $ mem_image_of_mem domain hpc, λ x y hxy, eq.symm _⟩,
    exact f_eq ⟨p, hpc⟩ _ _ hxy.symm }
end

/-- Glue a collection of partially defined linear maps to a linear map defined on `Sup`
of these submodules. -/
protected noncomputable def Sup (c : set (E →ₗ.[R] F)) (hc : directed_on (≤) c) :
  E →ₗ.[R] F :=
⟨_, classical.some $ Sup_aux c hc⟩

protected lemma le_Sup {c : set (E →ₗ.[R] F)} (hc : directed_on (≤) c)
  {f : E →ₗ.[R] F} (hf : f ∈ c) : f ≤ linear_pmap.Sup c hc :=
classical.some_spec (Sup_aux c hc) hf

protected lemma Sup_le {c : set (E →ₗ.[R] F)} (hc : directed_on (≤) c)
  {g : E →ₗ.[R] F} (hg : ∀ f ∈ c, f ≤ g) : linear_pmap.Sup c hc ≤ g :=
le_of_eq_locus_ge $ Sup_le $ λ _ ⟨f, hf, eq⟩, eq ▸
have f ≤ (linear_pmap.Sup c hc) ⊓ g, from le_inf (linear_pmap.le_Sup _ hf) (hg f hf),
this.1

protected lemma Sup_apply {c : set (E →ₗ.[R] F)} (hc : directed_on (≤) c)
  {l : E →ₗ.[R] F} (hl : l ∈ c) (x : l.domain) :
  (linear_pmap.Sup c hc) ⟨x, (linear_pmap.le_Sup hc hl).1 x.2⟩ = l x :=
begin
  symmetry,
  apply (classical.some_spec (Sup_aux c hc) hl).2,
  refl,
end

end linear_pmap

namespace linear_map

/-- Restrict a linear map to a submodule, reinterpreting the result as a `linear_pmap`. -/
def to_pmap (f : E →ₗ[R] F) (p : submodule R E) : E →ₗ.[R] F :=
⟨p, f.comp p.subtype⟩

@[simp] lemma to_pmap_apply (f : E →ₗ[R] F) (p : submodule R E) (x : p) :
  f.to_pmap p x = f x := rfl

/-- Compose a linear map with a `linear_pmap` -/
def comp_pmap (g : F →ₗ[R] G) (f : E →ₗ.[R] F) : E →ₗ.[R] G :=
{ domain := f.domain,
  to_fun := g.comp f.to_fun }

@[simp] lemma comp_pmap_apply (g : F →ₗ[R] G) (f : E →ₗ.[R] F) (x) :
  g.comp_pmap f x = g (f x) := rfl

end linear_map

namespace linear_pmap

/-- Restrict codomain of a `linear_pmap` -/
def cod_restrict (f : E →ₗ.[R] F) (p : submodule R F) (H : ∀ x, f x ∈ p) : E →ₗ.[R] p :=
{ domain := f.domain,
  to_fun := f.to_fun.cod_restrict p H }

/-- Compose two `linear_pmap`s -/
def comp (g : F →ₗ.[R] G) (f : E →ₗ.[R] F)
  (H : ∀ x : f.domain, f x ∈ g.domain) : E →ₗ.[R] G :=
g.to_fun.comp_pmap $ f.cod_restrict _ H

/-- `f.coprod g` is the partially defined linear map defined on `f.domain × g.domain`,
and sending `p` to `f p.1 + g p.2`. -/
def coprod (f : E →ₗ.[R] G) (g : F →ₗ.[R] G) : (E × F) →ₗ.[R] G :=
{ domain := f.domain.prod g.domain,
  to_fun := (f.comp (linear_pmap.fst f.domain g.domain) (λ x, x.2.1)).to_fun +
    (g.comp (linear_pmap.snd f.domain g.domain) (λ x, x.2.2)).to_fun }

@[simp] lemma coprod_apply (f : E →ₗ.[R] G) (g : F →ₗ.[R] G) (x) :
  f.coprod g x = f ⟨(x : E × F).1, x.2.1⟩ + g ⟨(x : E × F).2, x.2.2⟩ :=
rfl

/-- Restrict a partially defined linear map to a submodule of `E` contained in `f.domain`. -/
def dom_restrict (f : E →ₗ.[R] F) (S : submodule R E) :
  E →ₗ.[R] F :=
⟨S ⊓ f.domain, f.to_fun.comp (submodule.of_le (by simp))⟩

@[simp] lemma dom_restrict_domain (f : E →ₗ.[R] F) {S : submodule R E} :
  (f.dom_restrict S).domain = S ⊓ f.domain := rfl

lemma dom_restrict_apply {f : E →ₗ.[R] F} {S : submodule R E}
  ⦃x : S ⊓ f.domain⦄ ⦃y : f.domain⦄ (h : (x : E) = y) :
  f.dom_restrict S x = f y :=
begin
  have : submodule.of_le (by simp) x = y :=
  by { ext, simp[h] },
  rw ←this,
  exact linear_pmap.mk_apply _ _ _,
end

lemma dom_restrict_le {f : E →ₗ.[R] F} {S : submodule R E} : f.dom_restrict S ≤ f :=
⟨by simp, λ x y hxy, dom_restrict_apply hxy⟩

/-! ### Graph -/
section graph

/-- The graph of a `linear_pmap` viewed as a submodule on `E × F`. -/
def graph (f : E →ₗ.[R] F) : submodule R (E × F) :=
f.to_fun.graph.map (f.domain.subtype.prod_map (linear_map.id : F →ₗ[R] F))

lemma mem_graph_iff' (f : E →ₗ.[R] F) {x : E × F} :
  x ∈ f.graph ↔ ∃ y : f.domain, (↑y, f y) = x :=
by simp [graph]

@[simp] lemma mem_graph_iff (f : E →ₗ.[R] F) {x : E × F} :
  x ∈ f.graph ↔ ∃ y : f.domain, (↑y : E) = x.1 ∧ f y = x.2 :=
by { cases x, simp_rw [mem_graph_iff', prod.mk.inj_iff] }

/-- The tuple `(x, f x)` is contained in the graph of `f`. -/
lemma mem_graph (f : E →ₗ.[R] F) (x : domain f) : ((x : E), f x) ∈ f.graph :=
by simp

variables {M : Type*} [monoid M] [distrib_mul_action M F] [smul_comm_class R M F] (y : M)

/-- The graph of `z • f` as a pushforward. -/
lemma smul_graph (f : E →ₗ.[R] F) (z : M) :
  (z • f).graph =
    f.graph.map ((linear_map.id : E →ₗ[R] E).prod_map (z • (linear_map.id : F →ₗ[R] F))) :=
begin
  ext x, cases x,
  split; intros h,
  { rw mem_graph_iff at h,
    rcases h with ⟨y, hy, h⟩,
    rw linear_pmap.smul_apply at h,
    rw submodule.mem_map,
    simp only [mem_graph_iff, linear_map.prod_map_apply, linear_map.id_coe, id.def,
      linear_map.smul_apply, prod.mk.inj_iff, prod.exists, exists_exists_and_eq_and],
    use [x_fst, y],
    simp [hy, h] },
  rw submodule.mem_map at h,
  rcases h with ⟨x', hx', h⟩,
  cases x',
  simp only [linear_map.prod_map_apply, linear_map.id_coe, id.def, linear_map.smul_apply,
    prod.mk.inj_iff] at h,
  rw mem_graph_iff at hx' ⊢,
  rcases hx' with ⟨y, hy, hx'⟩,
  use y,
  rw [←h.1, ←h.2],
  simp[hy, hx'],
end

/-- The graph of `-f` as a pushforward. -/
lemma neg_graph (f : E →ₗ.[R] F) :
  (-f).graph = f.graph.map ((linear_map.id : E →ₗ[R] E).prod_map (-(linear_map.id : F →ₗ[R] F))) :=
begin
  ext, cases x,
  split; intros h,
  { rw mem_graph_iff at h,
    rcases h with ⟨y, hy, h⟩,
    rw linear_pmap.neg_apply at h,
    rw submodule.mem_map,
    simp only [mem_graph_iff, linear_map.prod_map_apply, linear_map.id_coe, id.def,
      linear_map.neg_apply, prod.mk.inj_iff, prod.exists, exists_exists_and_eq_and],
    use [x_fst, y],
    simp [hy, h] },
  rw submodule.mem_map at h,
  rcases h with ⟨x', hx', h⟩,
  cases x',
  simp only [linear_map.prod_map_apply, linear_map.id_coe, id.def, linear_map.neg_apply,
    prod.mk.inj_iff] at h,
  rw mem_graph_iff at hx' ⊢,
  rcases hx' with ⟨y, hy, hx'⟩,
  use y,
  rw [←h.1, ←h.2],
  simp [hy, hx'],
end

lemma mem_graph_snd_inj (f : E →ₗ.[R] F) {x y : E} {x' y' : F} (hx : (x,x') ∈ f.graph)
  (hy : (y,y') ∈ f.graph) (hxy : x = y) : x' = y' :=
begin
  rw [mem_graph_iff] at hx hy,
  rcases hx with ⟨x'', hx1, hx2⟩,
  rcases hy with ⟨y'', hy1, hy2⟩,
  simp only at hx1 hx2 hy1 hy2,
  rw [←hx1, ←hy1, set_like.coe_eq_coe] at hxy,
  rw [←hx2, ←hy2, hxy],
end

lemma mem_graph_snd_inj' (f : E →ₗ.[R] F) {x y : E × F} (hx : x ∈ f.graph) (hy : y ∈ f.graph)
  (hxy : x.1 = y.1) : x.2 = y.2 :=
by { cases x, cases y, exact f.mem_graph_snd_inj hx hy hxy }

/-- The property that `f 0 = 0` in terms of the graph. -/

lemma mem_domain_iff {f : E →ₗ.[R] F} {x : E} : x ∈ f.domain ↔ ∃ y : F, (x,y) ∈ f.graph :=
begin
  split; intro h,
  { use f ⟨x, h⟩,
    exact f.mem_graph ⟨x, h⟩ },
  cases h with y h,
  rw mem_graph_iff at h,
  cases h with x' h,
  simp only at h,
  rw ←h.1,
  simp,
end

lemma mem_domain_of_mem_graph {f : E →ₗ.[R] F} {x : E} {y : F} (h : (x,y) ∈ f.graph) :
  x ∈ f.domain :=
by { rw mem_domain_iff, exact ⟨y, h⟩ }

lemma image_iff {f : E →ₗ.[R] F} {x : E} {y : F} (hx : x ∈ f.domain) :
  y = f ⟨x, hx⟩ ↔ (x, y) ∈ f.graph :=
begin
  rw mem_graph_iff,
  split; intro h,
  { use ⟨x, hx⟩,
    simp [h] },
  rcases h with ⟨⟨x', hx'⟩, ⟨h1, h2⟩⟩,
  simp only [submodule.coe_mk] at h1 h2,
  simp only [←h2, h1],
end

lemma mem_range_iff {f : E →ₗ.[R] F} {y : F} : y ∈ set.range f ↔ ∃ x : E, (x,y) ∈ f.graph :=
begin
  split; intro h,
  { rw set.mem_range at h,
    rcases h with ⟨⟨x, hx⟩, h⟩,
    use x,
    rw ←h,
    exact f.mem_graph ⟨x, hx⟩ },
  cases h with x h,
  rw mem_graph_iff at h,
  cases h with x h,
  rw set.mem_range,
  use x,
  simp only at h,
  rw h.2,
end

lemma mem_domain_iff_of_eq_graph {f g : E →ₗ.[R] F} (h : f.graph = g.graph) {x : E} :
  x ∈ f.domain ↔ x ∈ g.domain :=
by simp_rw [mem_domain_iff, h]

lemma le_of_le_graph {f g : E →ₗ.[R] F} (h : f.graph ≤ g.graph) : f ≤ g :=
begin
  split,
  { intros x hx,
    rw mem_domain_iff at hx ⊢,
    cases hx with y hx,
    use y,
    exact h hx },
  rintros ⟨x, hx⟩ ⟨y, hy⟩ hxy,
  rw image_iff,
  refine h _,
  simp only [submodule.coe_mk] at hxy,
  rw hxy at hx,
  rw ←image_iff hx,
  simp [hxy],
end

lemma le_graph_of_le {f g : E →ₗ.[R] F} (h : f ≤ g) : f.graph ≤ g.graph :=
begin
  intros x hx,
  rw mem_graph_iff at hx ⊢,
  cases hx with y hx,
  use y,
  { exact h.1 y.2 },
  simp only [hx, submodule.coe_mk, eq_self_iff_true, true_and],
  convert hx.2,
  refine (h.2 _).symm,
  simp only [hx.1, submodule.coe_mk],
end

lemma le_graph_iff {f g : E →ₗ.[R] F} : f.graph ≤ g.graph ↔ f ≤ g :=
⟨le_of_le_graph, le_graph_of_le⟩

lemma eq_of_eq_graph {f g : E →ₗ.[R] F} (h : f.graph = g.graph) : f = g :=
by {ext, exact mem_domain_iff_of_eq_graph h, exact (le_of_le_graph h.le).2 }

end graph

end linear_pmap

namespace submodule

section submodule_to_linear_pmap

lemma exists_unique_from_graph {g : submodule R (E × F)}
  (hg : ∀ {x : E × F} (hx : x ∈ g) (hx' : x.fst = 0), x.snd = 0) {a : E}
  (ha : a ∈ g.map (linear_map.fst R E F)) :
  ∃! (b : F), (a,b) ∈ g :=
begin
  refine exists_unique_of_exists_of_unique _ _,
  { convert ha, simp },
  intros y₁ y₂ hy₁ hy₂,
  have hy : ((0 : E), y₁ - y₂) ∈ g :=
  begin
    convert g.sub_mem hy₁ hy₂,
    exact (sub_self _).symm,
  end,
  exact sub_eq_zero.mp (hg hy (by simp)),
end

/-- Auxiliary definition to unfold the existential quantifier. -/
noncomputable
def val_from_graph {g : submodule R (E × F)}
  (hg : ∀ (x : E × F) (hx : x ∈ g) (hx' : x.fst = 0), x.snd = 0) {a : E}
  (ha : a ∈ g.map (linear_map.fst R E F)) : F :=
(exists_of_exists_unique (exists_unique_from_graph hg ha)).some

lemma val_from_graph_mem {g : submodule R (E × F)}
  (hg : ∀ (x : E × F) (hx : x ∈ g) (hx' : x.fst = 0), x.snd = 0) {a : E}
  (ha : a ∈ g.map (linear_map.fst R E F)) : (a, val_from_graph hg ha) ∈ g :=
(exists_of_exists_unique (exists_unique_from_graph hg ha)).some_spec

/-- Define a `linear_pmap` from its graph. -/
noncomputable
def to_linear_pmap (g : submodule R (E × F))
  (hg : ∀ (x : E × F) (hx : x ∈ g) (hx' : x.fst = 0), x.snd = 0) : E →ₗ.[R] F :=
{ domain := g.map (linear_map.fst R E F),
  to_fun :=
  { to_fun := λ x, val_from_graph hg x.2,
    map_add' := λ v w, begin
      have hadd := (g.map (linear_map.fst R E F)).add_mem v.2 w.2,
      have hvw := val_from_graph_mem hg hadd,
      have hvw' := g.add_mem (val_from_graph_mem hg v.2) (val_from_graph_mem hg w.2),
      rw [prod.mk_add_mk] at hvw',
      exact (exists_unique_from_graph hg hadd).unique hvw hvw',
    end,
    map_smul' := λ a v, begin
      have hsmul := (g.map (linear_map.fst R E F)).smul_mem a v.2,
      have hav := val_from_graph_mem hg hsmul,
      have hav' := g.smul_mem a (val_from_graph_mem hg v.2),
      rw [prod.smul_mk] at hav',
      exact (exists_unique_from_graph hg hsmul).unique hav hav',
    end } }

lemma mem_graph_to_linear_pmap (g : submodule R (E × F))
  (hg : ∀ (x : E × F) (hx : x ∈ g) (hx' : x.fst = 0), x.snd = 0)
  (x : g.map (linear_map.fst R E F)) : (x.val, g.to_linear_pmap hg x) ∈ g :=
val_from_graph_mem hg x.2

@[simp] lemma to_linear_pmap_graph_eq (g : submodule R (E × F))
  (hg : ∀ (x : E × F) (hx : x ∈ g) (hx' : x.fst = 0), x.snd = 0) :
  (g.to_linear_pmap hg).graph = g :=
begin
  ext,
  split; intro hx,
  { rw [linear_pmap.mem_graph_iff] at hx,
    rcases hx with ⟨y,hx1,hx2⟩,
    convert g.mem_graph_to_linear_pmap hg y,
    rw [subtype.val_eq_coe],
    exact prod.ext hx1.symm hx2.symm },
  rw linear_pmap.mem_graph_iff,
  cases x,
  have hx_fst : x_fst ∈ g.map (linear_map.fst R E F) :=
  begin
    simp only [mem_map, linear_map.fst_apply, prod.exists, exists_and_distrib_right,
      exists_eq_right],
    exact ⟨x_snd, hx⟩,
  end,
  refine ⟨⟨x_fst, hx_fst⟩, subtype.coe_mk x_fst hx_fst, _⟩,
  exact (exists_unique_from_graph hg hx_fst).unique (val_from_graph_mem hg hx_fst) hx,
end

end submodule_to_linear_pmap

end submodule


import separation_world.level2 -- hide

/-
# Level 3: Lemma about intersection of open sets
-/

variables {X : Type} -- hide
variables [topological_space X] -- hide

namespace topological_space -- hide
open set -- hide

/- Lemma
Let τ be a topological space. τ is a frechet space if only if for all the points in the topology, their singletons are closed sets.
-/
lemma union_disjont_open_sets [T1_space X] {x : X}: ⋃₀ {U : set X | (x ∉ U) ∧ (is_open U)} = {x}ᶜ :=
begin
  apply subset.antisymm; intros t ht,
  { rcases ht with ⟨A,⟨hxA, hA⟩, htA⟩,
    rw [mem_compl_eq, mem_singleton_iff],
    rintro rfl,
    contradiction},
  { obtain ⟨U, hU, hh⟩ := T1_space.t1 t x (mem_compl_singleton_iff.mp ht).symm,
    exact ⟨U, ⟨hh.2, hU⟩, hh.1⟩},
end

end topological_space -- hide


/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers, Manuel Candales

! This file was ported from Lean 3 source module geometry.euclidean.triangle
! leanprover-community/mathlib commit 46b633fd842bef9469441c0209906f6dddd2b4f5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Geometry.Euclidean.Angle.Oriented.Affine
import Mathbin.Geometry.Euclidean.Angle.Unoriented.Affine
import Mathbin.Tactic.IntervalCases

/-!
# Triangles

This file proves basic geometrical results about distances and angles
in (possibly degenerate) triangles in real inner product spaces and
Euclidean affine spaces.  More specialized results, and results
developed for simplices in general rather than just for triangles, are
in separate files.  Definitions and results that make sense in more
general affine spaces rather than just in the Euclidean case go under
`linear_algebra.affine_space`.

## Implementation notes

Results in this file are generally given in a form with only those
non-degeneracy conditions needed for the particular result, rather
than requiring affine independence of the points of a triangle
unnecessarily.

## References

* https://en.wikipedia.org/wiki/Law_of_cosines
* https://en.wikipedia.org/wiki/Pons_asinorum
* https://en.wikipedia.org/wiki/Sum_of_angles_of_a_triangle

-/

noncomputable section

open BigOperators

open Classical

open Real

open RealInnerProductSpace

namespace InnerProductGeometry

/-!
### Geometrical results on triangles in real inner product spaces

This section develops some results on (possibly degenerate) triangles
in real inner product spaces, where those definitions and results can
most conveniently be developed in terms of vectors and then used to
deduce corresponding results for Euclidean affine spaces.
-/

variable {V : Type _} [NormedAddCommGroup V] [InnerProductSpace ℝ V]

/-- Law of cosines (cosine rule), vector angle form. -/
theorem norm_sub_sq_eq_norm_sq_add_norm_sq_sub_two_mul_norm_mul_norm_mul_cos_angle (x y : V) :
    ‖x - y‖ * ‖x - y‖ = ‖x‖ * ‖x‖ + ‖y‖ * ‖y‖ - 2 * ‖x‖ * ‖y‖ * Real.cos (angle x y) := by
  rw [show 2 * ‖x‖ * ‖y‖ * Real.cos (angle x y) = 2 * (Real.cos (angle x y) * (‖x‖ * ‖y‖)) by ring,
    cos_angle_mul_norm_mul_norm, ← real_inner_self_eq_norm_mul_norm, ←
    real_inner_self_eq_norm_mul_norm, ← real_inner_self_eq_norm_mul_norm, real_inner_sub_sub_self,
    sub_add_eq_add_sub]
#align inner_product_geometry.norm_sub_sq_eq_norm_sq_add_norm_sq_sub_two_mul_norm_mul_norm_mul_cos_angle InnerProductGeometry.norm_sub_sq_eq_norm_sq_add_norm_sq_sub_two_mul_norm_mul_norm_mul_cos_angle

/-- Pons asinorum, vector angle form. -/
theorem angle_sub_eq_angle_sub_rev_of_norm_eq {x y : V} (h : ‖x‖ = ‖y‖) :
    angle x (x - y) = angle y (y - x) :=
  by
  refine' Real.injOn_cos ⟨angle_nonneg _ _, angle_le_pi _ _⟩ ⟨angle_nonneg _ _, angle_le_pi _ _⟩ _
  rw [cos_angle, cos_angle, h, ← neg_sub, norm_neg, neg_sub, inner_sub_right, inner_sub_right,
    real_inner_self_eq_norm_mul_norm, real_inner_self_eq_norm_mul_norm, h, real_inner_comm x y]
#align inner_product_geometry.angle_sub_eq_angle_sub_rev_of_norm_eq InnerProductGeometry.angle_sub_eq_angle_sub_rev_of_norm_eq

/-- Converse of pons asinorum, vector angle form. -/
theorem norm_eq_of_angle_sub_eq_angle_sub_rev_of_angle_ne_pi {x y : V}
    (h : angle x (x - y) = angle y (y - x)) (hpi : angle x y ≠ π) : ‖x‖ = ‖y‖ :=
  by
  replace h :=
    Real.arccos_injOn (abs_le.mp (abs_real_inner_div_norm_mul_norm_le_one x (x - y)))
      (abs_le.mp (abs_real_inner_div_norm_mul_norm_le_one y (y - x))) h
  by_cases hxy : x = y
  · rw [hxy]
  · rw [← norm_neg (y - x), neg_sub, mul_comm, mul_comm ‖y‖, div_eq_mul_inv, div_eq_mul_inv,
      mul_inv_rev, mul_inv_rev, ← mul_assoc, ← mul_assoc] at h
    replace h :=
      mul_right_cancel₀ (inv_ne_zero fun hz => hxy (eq_of_sub_eq_zero (norm_eq_zero.1 hz))) h
    rw [inner_sub_right, inner_sub_right, real_inner_comm x y, real_inner_self_eq_norm_mul_norm,
      real_inner_self_eq_norm_mul_norm, mul_sub_right_distrib, mul_sub_right_distrib,
      mul_self_mul_inv, mul_self_mul_inv, sub_eq_sub_iff_sub_eq_sub, ← mul_sub_left_distrib] at h
    by_cases hx0 : x = 0
    · rw [hx0, norm_zero, inner_zero_left, MulZeroClass.zero_mul, zero_sub, neg_eq_zero] at h
      rw [hx0, norm_zero, h]
    · by_cases hy0 : y = 0
      · rw [hy0, norm_zero, inner_zero_right, MulZeroClass.zero_mul, sub_zero] at h
        rw [hy0, norm_zero, h]
      · rw [inv_sub_inv (fun hz => hx0 (norm_eq_zero.1 hz)) fun hz => hy0 (norm_eq_zero.1 hz), ←
          neg_sub, ← mul_div_assoc, mul_comm, mul_div_assoc, ← mul_neg_one] at h
        symm
        by_contra hyx
        replace h := (mul_left_cancel₀ (sub_ne_zero_of_ne hyx) h).symm
        rw [real_inner_div_norm_mul_norm_eq_neg_one_iff, ← angle_eq_pi_iff] at h
        exact hpi h
#align inner_product_geometry.norm_eq_of_angle_sub_eq_angle_sub_rev_of_angle_ne_pi InnerProductGeometry.norm_eq_of_angle_sub_eq_angle_sub_rev_of_angle_ne_pi

/-- The cosine of the sum of two angles in a possibly degenerate
triangle (where two given sides are nonzero), vector angle form. -/
theorem cos_angle_sub_add_angle_sub_rev_eq_neg_cos_angle {x y : V} (hx : x ≠ 0) (hy : y ≠ 0) :
    Real.cos (angle x (x - y) + angle y (y - x)) = -Real.cos (angle x y) :=
  by
  by_cases hxy : x = y
  · rw [hxy, angle_self hy]
    simp
  · rw [Real.cos_add, cos_angle, cos_angle, cos_angle]
    have hxn : ‖x‖ ≠ 0 := fun h => hx (norm_eq_zero.1 h)
    have hyn : ‖y‖ ≠ 0 := fun h => hy (norm_eq_zero.1 h)
    have hxyn : ‖x - y‖ ≠ 0 := fun h => hxy (eq_of_sub_eq_zero (norm_eq_zero.1 h))
    apply mul_right_cancel₀ hxn
    apply mul_right_cancel₀ hyn
    apply mul_right_cancel₀ hxyn
    apply mul_right_cancel₀ hxyn
    have H1 :
      Real.sin (angle x (x - y)) * Real.sin (angle y (y - x)) * ‖x‖ * ‖y‖ * ‖x - y‖ * ‖x - y‖ =
        Real.sin (angle x (x - y)) * (‖x‖ * ‖x - y‖) *
          (Real.sin (angle y (y - x)) * (‖y‖ * ‖x - y‖)) :=
      by ring
    have H2 :
      ⟪x, x⟫ * (⟪x, x⟫ - ⟪x, y⟫ - (⟪x, y⟫ - ⟪y, y⟫)) - (⟪x, x⟫ - ⟪x, y⟫) * (⟪x, x⟫ - ⟪x, y⟫) =
        ⟪x, x⟫ * ⟪y, y⟫ - ⟪x, y⟫ * ⟪x, y⟫ :=
      by ring
    have H3 :
      ⟪y, y⟫ * (⟪y, y⟫ - ⟪x, y⟫ - (⟪x, y⟫ - ⟪x, x⟫)) - (⟪y, y⟫ - ⟪x, y⟫) * (⟪y, y⟫ - ⟪x, y⟫) =
        ⟪x, x⟫ * ⟪y, y⟫ - ⟪x, y⟫ * ⟪x, y⟫ :=
      by ring
    rw [mul_sub_right_distrib, mul_sub_right_distrib, mul_sub_right_distrib, mul_sub_right_distrib,
      H1, sin_angle_mul_norm_mul_norm, norm_sub_rev x y, sin_angle_mul_norm_mul_norm,
      norm_sub_rev y x, inner_sub_left, inner_sub_left, inner_sub_right, inner_sub_right,
      inner_sub_right, inner_sub_right, real_inner_comm x y, H2, H3,
      Real.mul_self_sqrt (sub_nonneg_of_le (real_inner_mul_inner_self_le x y)),
      real_inner_self_eq_norm_mul_norm, real_inner_self_eq_norm_mul_norm,
      real_inner_eq_norm_mul_self_add_norm_mul_self_sub_norm_sub_mul_self_div_two]
    field_simp [hxn, hyn, hxyn]
    ring
#align inner_product_geometry.cos_angle_sub_add_angle_sub_rev_eq_neg_cos_angle InnerProductGeometry.cos_angle_sub_add_angle_sub_rev_eq_neg_cos_angle

/-- The sine of the sum of two angles in a possibly degenerate
triangle (where two given sides are nonzero), vector angle form. -/
theorem sin_angle_sub_add_angle_sub_rev_eq_sin_angle {x y : V} (hx : x ≠ 0) (hy : y ≠ 0) :
    Real.sin (angle x (x - y) + angle y (y - x)) = Real.sin (angle x y) :=
  by
  by_cases hxy : x = y
  · rw [hxy, angle_self hy]
    simp
  · rw [Real.sin_add, cos_angle, cos_angle]
    have hxn : ‖x‖ ≠ 0 := fun h => hx (norm_eq_zero.1 h)
    have hyn : ‖y‖ ≠ 0 := fun h => hy (norm_eq_zero.1 h)
    have hxyn : ‖x - y‖ ≠ 0 := fun h => hxy (eq_of_sub_eq_zero (norm_eq_zero.1 h))
    apply mul_right_cancel₀ hxn
    apply mul_right_cancel₀ hyn
    apply mul_right_cancel₀ hxyn
    apply mul_right_cancel₀ hxyn
    have H1 :
      Real.sin (angle x (x - y)) * (⟪y, y - x⟫ / (‖y‖ * ‖y - x‖)) * ‖x‖ * ‖y‖ * ‖x - y‖ =
        Real.sin (angle x (x - y)) * (‖x‖ * ‖x - y‖) * (⟪y, y - x⟫ / (‖y‖ * ‖y - x‖)) * ‖y‖ :=
      by ring
    have H2 :
      ⟪x, x - y⟫ / (‖x‖ * ‖y - x‖) * Real.sin (angle y (y - x)) * ‖x‖ * ‖y‖ * ‖y - x‖ =
        ⟪x, x - y⟫ / (‖x‖ * ‖y - x‖) * (Real.sin (angle y (y - x)) * (‖y‖ * ‖y - x‖)) * ‖x‖ :=
      by ring
    have H3 :
      ⟪x, x⟫ * (⟪x, x⟫ - ⟪x, y⟫ - (⟪x, y⟫ - ⟪y, y⟫)) - (⟪x, x⟫ - ⟪x, y⟫) * (⟪x, x⟫ - ⟪x, y⟫) =
        ⟪x, x⟫ * ⟪y, y⟫ - ⟪x, y⟫ * ⟪x, y⟫ :=
      by ring
    have H4 :
      ⟪y, y⟫ * (⟪y, y⟫ - ⟪x, y⟫ - (⟪x, y⟫ - ⟪x, x⟫)) - (⟪y, y⟫ - ⟪x, y⟫) * (⟪y, y⟫ - ⟪x, y⟫) =
        ⟪x, x⟫ * ⟪y, y⟫ - ⟪x, y⟫ * ⟪x, y⟫ :=
      by ring
    rw [right_distrib, right_distrib, right_distrib, right_distrib, H1, sin_angle_mul_norm_mul_norm,
      norm_sub_rev x y, H2, sin_angle_mul_norm_mul_norm, norm_sub_rev y x,
      mul_assoc (Real.sin (angle x y)), sin_angle_mul_norm_mul_norm, inner_sub_left, inner_sub_left,
      inner_sub_right, inner_sub_right, inner_sub_right, inner_sub_right, real_inner_comm x y, H3,
      H4, real_inner_self_eq_norm_mul_norm, real_inner_self_eq_norm_mul_norm,
      real_inner_eq_norm_mul_self_add_norm_mul_self_sub_norm_sub_mul_self_div_two]
    field_simp [hxn, hyn, hxyn]
    ring
#align inner_product_geometry.sin_angle_sub_add_angle_sub_rev_eq_sin_angle InnerProductGeometry.sin_angle_sub_add_angle_sub_rev_eq_sin_angle

/-- The cosine of the sum of the angles of a possibly degenerate
triangle (where two given sides are nonzero), vector angle form. -/
theorem cos_angle_add_angle_sub_add_angle_sub_eq_neg_one {x y : V} (hx : x ≠ 0) (hy : y ≠ 0) :
    Real.cos (angle x y + angle x (x - y) + angle y (y - x)) = -1 := by
  rw [add_assoc, Real.cos_add, cos_angle_sub_add_angle_sub_rev_eq_neg_cos_angle hx hy,
    sin_angle_sub_add_angle_sub_rev_eq_sin_angle hx hy, mul_neg, ← neg_add', add_comm, ← sq, ← sq,
    Real.sin_sq_add_cos_sq]
#align inner_product_geometry.cos_angle_add_angle_sub_add_angle_sub_eq_neg_one InnerProductGeometry.cos_angle_add_angle_sub_add_angle_sub_eq_neg_one

/-- The sine of the sum of the angles of a possibly degenerate
triangle (where two given sides are nonzero), vector angle form. -/
theorem sin_angle_add_angle_sub_add_angle_sub_eq_zero {x y : V} (hx : x ≠ 0) (hy : y ≠ 0) :
    Real.sin (angle x y + angle x (x - y) + angle y (y - x)) = 0 :=
  by
  rw [add_assoc, Real.sin_add, cos_angle_sub_add_angle_sub_rev_eq_neg_cos_angle hx hy,
    sin_angle_sub_add_angle_sub_rev_eq_sin_angle hx hy]
  ring
#align inner_product_geometry.sin_angle_add_angle_sub_add_angle_sub_eq_zero InnerProductGeometry.sin_angle_add_angle_sub_add_angle_sub_eq_zero

/-- The sum of the angles of a possibly degenerate triangle (where the
two given sides are nonzero), vector angle form. -/
theorem angle_add_angle_sub_add_angle_sub_eq_pi {x y : V} (hx : x ≠ 0) (hy : y ≠ 0) :
    angle x y + angle x (x - y) + angle y (y - x) = π :=
  by
  have hcos := cos_angle_add_angle_sub_add_angle_sub_eq_neg_one hx hy
  have hsin := sin_angle_add_angle_sub_add_angle_sub_eq_zero hx hy
  rw [Real.sin_eq_zero_iff] at hsin
  cases' hsin with n hn
  symm at hn
  have h0 : 0 ≤ angle x y + angle x (x - y) + angle y (y - x) :=
    add_nonneg (add_nonneg (angle_nonneg _ _) (angle_nonneg _ _)) (angle_nonneg _ _)
  have h3 : angle x y + angle x (x - y) + angle y (y - x) ≤ π + π + π :=
    add_le_add (add_le_add (angle_le_pi _ _) (angle_le_pi _ _)) (angle_le_pi _ _)
  have h3lt : angle x y + angle x (x - y) + angle y (y - x) < π + π + π :=
    by
    by_contra hnlt
    have hxy : angle x y = π := by
      by_contra hxy
      exact
        hnlt
          (add_lt_add_of_lt_of_le
            (add_lt_add_of_lt_of_le (lt_of_le_of_ne (angle_le_pi _ _) hxy) (angle_le_pi _ _))
            (angle_le_pi _ _))
    rw [hxy] at hnlt
    rw [angle_eq_pi_iff] at hxy
    rcases hxy with ⟨hx, ⟨r, ⟨hr, hxr⟩⟩⟩
    rw [hxr, ← one_smul ℝ x, ← mul_smul, mul_one, ← sub_smul, one_smul, sub_eq_add_neg,
      angle_smul_right_of_pos _ _ (add_pos zero_lt_one (neg_pos_of_neg hr)), angle_self hx,
      add_zero] at hnlt
    apply hnlt
    rw [add_assoc]
    exact add_lt_add_left (lt_of_le_of_lt (angle_le_pi _ _) (lt_add_of_pos_right π Real.pi_pos)) _
  have hn0 : 0 ≤ n :=
    by
    rw [hn, mul_nonneg_iff_left_nonneg_of_pos Real.pi_pos] at h0
    norm_cast  at h0
    exact h0
  have hn3 : n < 3 := by
    rw [hn, show π + π + π = 3 * π by ring] at h3lt
    replace h3lt := lt_of_mul_lt_mul_right h3lt (le_of_lt Real.pi_pos)
    norm_cast  at h3lt
    exact h3lt
  interval_cases
  · rw [hn] at hcos
    simp at hcos
    norm_num at hcos
  · rw [hn]
    norm_num
  · rw [hn] at hcos
    simp at hcos
    norm_num at hcos
#align inner_product_geometry.angle_add_angle_sub_add_angle_sub_eq_pi InnerProductGeometry.angle_add_angle_sub_add_angle_sub_eq_pi

end InnerProductGeometry

namespace EuclideanGeometry

/-!
### Geometrical results on triangles in Euclidean affine spaces

This section develops some geometrical definitions and results on
(possible degenerate) triangles in Euclidean affine spaces.
-/

open InnerProductGeometry

open EuclideanGeometry

variable {V : Type _} {P : Type _} [NormedAddCommGroup V] [InnerProductSpace ℝ V] [MetricSpace P]
  [NormedAddTorsor V P]

include V

/-- **Law of cosines** (cosine rule), angle-at-point form. -/
theorem dist_sq_eq_dist_sq_add_dist_sq_sub_two_mul_dist_mul_dist_mul_cos_angle (p1 p2 p3 : P) :
    dist p1 p3 * dist p1 p3 =
      dist p1 p2 * dist p1 p2 + dist p3 p2 * dist p3 p2 -
        2 * dist p1 p2 * dist p3 p2 * Real.cos (∠ p1 p2 p3) :=
  by
  rw [dist_eq_norm_vsub V p1 p3, dist_eq_norm_vsub V p1 p2, dist_eq_norm_vsub V p3 p2]
  unfold angle
  convert norm_sub_sq_eq_norm_sq_add_norm_sq_sub_two_mul_norm_mul_norm_mul_cos_angle (p1 -ᵥ p2 : V)
      (p3 -ᵥ p2 : V)
  · exact (vsub_sub_vsub_cancel_right p1 p3 p2).symm
  · exact (vsub_sub_vsub_cancel_right p1 p3 p2).symm
#align euclidean_geometry.dist_sq_eq_dist_sq_add_dist_sq_sub_two_mul_dist_mul_dist_mul_cos_angle EuclideanGeometry.dist_sq_eq_dist_sq_add_dist_sq_sub_two_mul_dist_mul_dist_mul_cos_angle

alias dist_sq_eq_dist_sq_add_dist_sq_sub_two_mul_dist_mul_dist_mul_cos_angle ← law_cos
#align euclidean_geometry.law_cos EuclideanGeometry.law_cos

/-- **Isosceles Triangle Theorem**: Pons asinorum, angle-at-point form. -/
theorem angle_eq_angle_of_dist_eq {p1 p2 p3 : P} (h : dist p1 p2 = dist p1 p3) :
    ∠ p1 p2 p3 = ∠ p1 p3 p2 :=
  by
  rw [dist_eq_norm_vsub V p1 p2, dist_eq_norm_vsub V p1 p3] at h
  unfold angle
  convert angle_sub_eq_angle_sub_rev_of_norm_eq h
  · exact (vsub_sub_vsub_cancel_left p3 p2 p1).symm
  · exact (vsub_sub_vsub_cancel_left p2 p3 p1).symm
#align euclidean_geometry.angle_eq_angle_of_dist_eq EuclideanGeometry.angle_eq_angle_of_dist_eq

/-- Converse of pons asinorum, angle-at-point form. -/
theorem dist_eq_of_angle_eq_angle_of_angle_ne_pi {p1 p2 p3 : P} (h : ∠ p1 p2 p3 = ∠ p1 p3 p2)
    (hpi : ∠ p2 p1 p3 ≠ π) : dist p1 p2 = dist p1 p3 :=
  by
  unfold angle at h hpi
  rw [dist_eq_norm_vsub V p1 p2, dist_eq_norm_vsub V p1 p3]
  rw [← angle_neg_neg, neg_vsub_eq_vsub_rev, neg_vsub_eq_vsub_rev] at hpi
  rw [← vsub_sub_vsub_cancel_left p3 p2 p1, ← vsub_sub_vsub_cancel_left p2 p3 p1] at h
  exact norm_eq_of_angle_sub_eq_angle_sub_rev_of_angle_ne_pi h hpi
#align euclidean_geometry.dist_eq_of_angle_eq_angle_of_angle_ne_pi EuclideanGeometry.dist_eq_of_angle_eq_angle_of_angle_ne_pi

/-- The **sum of the angles of a triangle** (possibly degenerate, where the
given vertex is distinct from the others), angle-at-point. -/
theorem angle_add_angle_add_angle_eq_pi {p1 p2 p3 : P} (h2 : p2 ≠ p1) (h3 : p3 ≠ p1) :
    ∠ p1 p2 p3 + ∠ p2 p3 p1 + ∠ p3 p1 p2 = π :=
  by
  rw [add_assoc, add_comm, add_comm (∠ p2 p3 p1), angle_comm p2 p3 p1]
  unfold angle
  rw [← angle_neg_neg (p1 -ᵥ p3), ← angle_neg_neg (p1 -ᵥ p2), neg_vsub_eq_vsub_rev,
    neg_vsub_eq_vsub_rev, neg_vsub_eq_vsub_rev, neg_vsub_eq_vsub_rev, ←
    vsub_sub_vsub_cancel_right p3 p2 p1, ← vsub_sub_vsub_cancel_right p2 p3 p1]
  exact
    angle_add_angle_sub_add_angle_sub_eq_pi (fun he => h3 (vsub_eq_zero_iff_eq.1 he)) fun he =>
      h2 (vsub_eq_zero_iff_eq.1 he)
#align euclidean_geometry.angle_add_angle_add_angle_eq_pi EuclideanGeometry.angle_add_angle_add_angle_eq_pi

/-- The **sum of the angles of a triangle** (possibly degenerate, where the triangle is a line),
oriented angles at point. -/
theorem oangle_add_oangle_add_oangle_eq_pi [Module.Oriented ℝ V (Fin 2)]
    [Fact (FiniteDimensional.finrank ℝ V = 2)] {p1 p2 p3 : P} (h21 : p2 ≠ p1) (h32 : p3 ≠ p2)
    (h13 : p1 ≠ p3) : ∡ p1 p2 p3 + ∡ p2 p3 p1 + ∡ p3 p1 p2 = π := by
  simpa only [neg_vsub_eq_vsub_rev] using
    positive_orientation.oangle_add_cyc3_neg_left (vsub_ne_zero.mpr h21) (vsub_ne_zero.mpr h32)
      (vsub_ne_zero.mpr h13)
#align euclidean_geometry.oangle_add_oangle_add_oangle_eq_pi EuclideanGeometry.oangle_add_oangle_add_oangle_eq_pi

/-- **Stewart's Theorem**. -/
theorem dist_sq_mul_dist_add_dist_sq_mul_dist (a b c p : P) (h : ∠ b p c = π) :
    dist a b ^ 2 * dist c p + dist a c ^ 2 * dist b p =
      dist b c * (dist a p ^ 2 + dist b p * dist c p) :=
  by
  rw [pow_two, pow_two, law_cos a p b, law_cos a p c,
    eq_sub_of_add_eq (angle_add_angle_eq_pi_of_angle_eq_pi a h), Real.cos_pi_sub,
    dist_eq_add_dist_of_angle_eq_pi h]
  ring
#align euclidean_geometry.dist_sq_mul_dist_add_dist_sq_mul_dist EuclideanGeometry.dist_sq_mul_dist_add_dist_sq_mul_dist

/-- **Apollonius's Theorem**. -/
theorem dist_sq_add_dist_sq_eq_two_mul_dist_midpoint_sq_add_half_dist_sq (a b c : P) :
    dist a b ^ 2 + dist a c ^ 2 = 2 * (dist a (midpoint ℝ b c) ^ 2 + (dist b c / 2) ^ 2) :=
  by
  by_cases hbc : b = c
  · simp [hbc, midpoint_self, dist_self, two_mul]
  · let m := midpoint ℝ b c
    have : dist b c ≠ 0 := (dist_pos.mpr hbc).ne'
    have hm := dist_sq_mul_dist_add_dist_sq_mul_dist a b c m (angle_midpoint_eq_pi b c hbc)
    simp only [dist_left_midpoint, dist_right_midpoint, Real.norm_two] at hm
    calc
      dist a b ^ 2 + dist a c ^ 2 =
          2 / dist b c * (dist a b ^ 2 * (2⁻¹ * dist b c) + dist a c ^ 2 * (2⁻¹ * dist b c)) :=
        by
        field_simp
        ring
      _ = 2 * (dist a (midpoint ℝ b c) ^ 2 + (dist b c / 2) ^ 2) :=
        by
        rw [hm]
        field_simp
        ring

#align euclidean_geometry.dist_sq_add_dist_sq_eq_two_mul_dist_midpoint_sq_add_half_dist_sq EuclideanGeometry.dist_sq_add_dist_sq_eq_two_mul_dist_midpoint_sq_add_half_dist_sq

theorem dist_mul_of_eq_angle_of_dist_mul (a b c a' b' c' : P) (r : ℝ) (h : ∠ a' b' c' = ∠ a b c)
    (hab : dist a' b' = r * dist a b) (hcb : dist c' b' = r * dist c b) :
    dist a' c' = r * dist a c :=
  by
  have h' : dist a' c' ^ 2 = (r * dist a c) ^ 2
  calc
    dist a' c' ^ 2 =
        dist a' b' ^ 2 + dist c' b' ^ 2 - 2 * dist a' b' * dist c' b' * Real.cos (∠ a' b' c') :=
      by simp [pow_two, law_cos a' b' c']
    _ = r ^ 2 * (dist a b ^ 2 + dist c b ^ 2 - 2 * dist a b * dist c b * Real.cos (∠ a b c)) :=
      by
      rw [h, hab, hcb]
      ring
    _ = (r * dist a c) ^ 2 := by simp [pow_two, ← law_cos a b c, mul_pow]

  by_cases hab₁ : a = b
  · have hab'₁ : a' = b' := by
      rw [← dist_eq_zero, hab, dist_eq_zero.mpr hab₁, MulZeroClass.mul_zero r]
    rw [hab₁, hab'₁, dist_comm b' c', dist_comm b c, hcb]
  · have h1 : 0 ≤ r * dist a b := by
      rw [← hab]
      exact dist_nonneg
    have h2 : 0 ≤ r := nonneg_of_mul_nonneg_left h1 (dist_pos.mpr hab₁)
    exact (sq_eq_sq dist_nonneg (mul_nonneg h2 dist_nonneg)).mp h'
#align euclidean_geometry.dist_mul_of_eq_angle_of_dist_mul EuclideanGeometry.dist_mul_of_eq_angle_of_dist_mul

end EuclideanGeometry


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/

import group_theory.subgroup
import algebra.ring

universes u v

open group

variables {R : Type u} [ring R]

/-- `S` is a subring: a set containing 1 and closed under multiplication, addition and and additive inverse. -/
class is_subring (S : set R) extends is_add_subgroup S, is_submonoid S : Prop.

instance subset.ring {S : set R} [is_subring S] : ring S :=
by subtype_instance

instance subtype.ring {S : set R} [is_subring S] : ring (subtype S) := subset.ring

namespace is_ring_hom

instance {S : set R} [is_subring S] : is_ring_hom (@subtype.val R S) :=
by refine {..} ; intros ; refl

instance is_subring_set_range {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R → S) [is_ring_hom f] : is_subring (set.range f) :=
{ zero_mem := ⟨0, is_ring_hom.map_zero f⟩,
  one_mem := ⟨1, is_ring_hom.map_one f⟩,
  neg_mem := λ x ⟨p, hp⟩, ⟨-p, hp ▸ is_ring_hom.map_neg f⟩,
  add_mem := λ x y ⟨p, hp⟩ ⟨q, hq⟩, ⟨p + q, hp ▸ hq ▸ is_ring_hom.map_add f⟩,
  mul_mem := λ x y ⟨p, hp⟩ ⟨q, hq⟩, ⟨p * q, hp ▸ hq ▸ is_ring_hom.map_mul f⟩, }

end is_ring_hom

variables {cR : Type u} [comm_ring cR]

instance subset.comm_ring {S : set cR} [is_subring S] : comm_ring S :=
by subtype_instance

instance subtype.comm_ring {S : set cR} [is_subring S] : comm_ring (subtype S) := subset.comm_ring

instance subring.domain {D : Type*} [integral_domain D] (S : set D) [is_subring S] : integral_domain S :=
by subtype_instance

namespace ring

def closure (s : set R) := add_group.closure (monoid.closure s)

variable {s : set R}

local attribute [reducible] closure

theorem exists_list_of_mem_closure {a : R} (h : a ∈ closure s) :
  (∃ L : list (list R), (∀ l ∈ L, ∀ x ∈ l, x ∈ s ∨ x = (-1:R)) ∧ (L.map list.prod).sum = a) :=
add_group.in_closure.rec_on h
  (λ x hx, match x, monoid.exists_list_of_mem_closure hx with
    | _, ⟨L, h1, rfl⟩ := ⟨[L], list.forall_mem_singleton.2 (λ r hr, or.inl (h1 r hr)), zero_add _⟩
    end)
  ⟨[], list.forall_mem_nil _, rfl⟩
  (λ b _ ih, match b, ih with
    | _, ⟨L1, h1, rfl⟩ := ⟨L1.map (list.cons (-1)),
      λ L2 h2, match L2, list.mem_map.1 h2 with
        | _, ⟨L3, h3, rfl⟩ := list.forall_mem_cons.2 ⟨or.inr rfl, h1 L3 h3⟩
        end,
      by simp only [list.map_map, (∘), list.prod_cons, neg_one_mul];
      exact list.rec_on L1 neg_zero.symm (λ hd tl ih,
        by rw [list.map_cons, list.sum_cons, ih, list.map_cons, list.sum_cons, neg_add])⟩
    end)
  (λ r1 r2 hr1 hr2 ih1 ih2, match r1, r2, ih1, ih2 with
    | _, _, ⟨L1, h1, rfl⟩, ⟨L2, h2, rfl⟩ := ⟨L1 ++ L2, list.forall_mem_append.2 ⟨h1, h2⟩,
      by rw [list.map_append, list.sum_append]⟩
    end)

@[elab_as_eliminator]
protected theorem in_closure.rec_on {C : R → Prop} {x : R} (hx : x ∈ closure s)
  (h1 : C 1) (hneg1 : C (-1)) (hs : ∀ z ∈ s, ∀ n, C n → C (z * n))
  (ha : ∀ {x y}, C x → C y → C (x + y)) : C x :=
begin
  have h0 : C 0 := add_neg_self (1:R) ▸ ha h1 hneg1,
  rcases exists_list_of_mem_closure hx with ⟨L, HL, rfl⟩, clear hx,
  induction L with hd tl ih, { exact h0 },
  rw list.forall_mem_cons at HL,
  suffices : C (list.prod hd),
  { rw [list.map_cons, list.sum_cons],
    exact ha this (ih HL.2) },
  replace HL := HL.1, clear ih tl,
  suffices : ∃ L : list R, (∀ x ∈ L, x ∈ s) ∧ (list.prod hd = list.prod L ∨ list.prod hd = -list.prod L),
  { rcases this with ⟨L, HL', HP | HP⟩,
    { rw HP, clear HP HL hd, induction L with hd tl ih, { exact h1 },
      rw list.forall_mem_cons at HL',
      rw list.prod_cons,
      exact hs _ HL'.1 _ (ih HL'.2) },
    rw HP, clear HP HL hd, induction L with hd tl ih, { exact hneg1 },
    rw [list.prod_cons, neg_mul_eq_mul_neg],
    rw list.forall_mem_cons at HL',
    exact hs _ HL'.1 _ (ih HL'.2) },
  induction hd with hd tl ih,
  { exact ⟨[], list.forall_mem_nil _, or.inl rfl⟩ },
  rw list.forall_mem_cons at HL,
  rcases ih HL.2 with ⟨L, HL', HP | HP⟩; cases HL.1 with hhd hhd,
  { exact ⟨hd :: L, list.forall_mem_cons.2 ⟨hhd, HL'⟩, or.inl $
      by rw [list.prod_cons, list.prod_cons, HP]⟩ },
  { exact ⟨L, HL', or.inr $ by rw [list.prod_cons, hhd, neg_one_mul, HP]⟩ },
  { exact ⟨hd :: L, list.forall_mem_cons.2 ⟨hhd, HL'⟩, or.inr $
      by rw [list.prod_cons, list.prod_cons, HP, neg_mul_eq_mul_neg]⟩ },
  { exact ⟨L, HL', or.inl $ by rw [list.prod_cons, hhd, HP, neg_one_mul, neg_neg]⟩ }
end

instance : is_subring (closure s) :=
{ one_mem := add_group.mem_closure (is_submonoid.one_mem _),
  mul_mem := λ a b ha hb, add_group.in_closure.rec_on hb
    (λ b hb, add_group.in_closure.rec_on ha
      (λ a ha, add_group.subset_closure (is_submonoid.mul_mem ha hb))
      ((zero_mul b).symm ▸ is_add_submonoid.zero_mem _)
      (λ a ha hab, (neg_mul_eq_neg_mul a b) ▸ is_add_subgroup.neg_mem hab)
      (λ a c ha hc hab hcb, (add_mul a c b).symm ▸ is_add_submonoid.add_mem hab hcb))
    ((mul_zero a).symm ▸ is_add_submonoid.zero_mem _)
    (λ b hb hab, (neg_mul_eq_mul_neg a b) ▸ is_add_subgroup.neg_mem hab)
    (λ b c hb hc hab hac, (mul_add a b c).symm ▸ is_add_submonoid.add_mem hab hac),
  .. add_group.closure.is_add_subgroup _ }

theorem mem_closure {a : R} : a ∈ s → a ∈ closure s :=
add_group.mem_closure ∘ @monoid.subset_closure _ _ _ _

theorem subset_closure : s ⊆ closure s :=
λ _, mem_closure

theorem closure_subset {t : set R} [is_subring t] : s ⊆ t → closure s ⊆ t :=
add_group.closure_subset ∘ monoid.closure_subset

theorem closure_subset_iff (s t : set R) [is_subring t] : closure s ⊆ t ↔ s ⊆ t :=
(add_group.closure_subset_iff _ t).trans
  ⟨set.subset.trans monoid.subset_closure, monoid.closure_subset⟩

theorem closure_mono {s t : set R} (H : s ⊆ t) : closure s ⊆ closure t :=
closure_subset $ set.subset.trans H subset_closure

end ring


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.nodup
import Mathlib.PostPort

universes u

namespace Mathlib

namespace list

/- erase duplicates function -/

@[simp] theorem erase_dup_nil {α : Type u} [DecidableEq α] : erase_dup [] = [] :=
  rfl

theorem erase_dup_cons_of_mem' {α : Type u} [DecidableEq α] {a : α} {l : List α} (h : a ∈ erase_dup l) : erase_dup (a :: l) = erase_dup l := sorry

theorem erase_dup_cons_of_not_mem' {α : Type u} [DecidableEq α] {a : α} {l : List α} (h : ¬a ∈ erase_dup l) : erase_dup (a :: l) = a :: erase_dup l :=
  pw_filter_cons_of_pos (eq.mpr (id (propext forall_mem_ne)) (eq.mp (Eq.refl (¬a ∈ erase_dup l)) h))

@[simp] theorem mem_erase_dup {α : Type u} [DecidableEq α] {a : α} {l : List α} : a ∈ erase_dup l ↔ a ∈ l := sorry

@[simp] theorem erase_dup_cons_of_mem {α : Type u} [DecidableEq α] {a : α} {l : List α} (h : a ∈ l) : erase_dup (a :: l) = erase_dup l :=
  erase_dup_cons_of_mem' (iff.mpr mem_erase_dup h)

@[simp] theorem erase_dup_cons_of_not_mem {α : Type u} [DecidableEq α] {a : α} {l : List α} (h : ¬a ∈ l) : erase_dup (a :: l) = a :: erase_dup l :=
  erase_dup_cons_of_not_mem' (mt (iff.mp mem_erase_dup) h)

theorem erase_dup_sublist {α : Type u} [DecidableEq α] (l : List α) : erase_dup l <+ l :=
  pw_filter_sublist

theorem erase_dup_subset {α : Type u} [DecidableEq α] (l : List α) : erase_dup l ⊆ l :=
  pw_filter_subset

theorem subset_erase_dup {α : Type u} [DecidableEq α] (l : List α) : l ⊆ erase_dup l :=
  fun (a : α) => iff.mpr mem_erase_dup

theorem nodup_erase_dup {α : Type u} [DecidableEq α] (l : List α) : nodup (erase_dup l) :=
  pairwise_pw_filter

theorem erase_dup_eq_self {α : Type u} [DecidableEq α] {l : List α} : erase_dup l = l ↔ nodup l :=
  pw_filter_eq_self

@[simp] theorem erase_dup_idempotent {α : Type u} [DecidableEq α] {l : List α} : erase_dup (erase_dup l) = erase_dup l :=
  pw_filter_idempotent

theorem erase_dup_append {α : Type u} [DecidableEq α] (l₁ : List α) (l₂ : List α) : erase_dup (l₁ ++ l₂) = l₁ ∪ erase_dup l₂ := sorry


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jens Wagemaker

GCD domain and integral domains with normalization functions

TODO: abstract the domains to to semi domains (i.e. domains on semirings) to include ℕ and ℕ[X] etc.
-/
import algebra.ring

variables {α : Type*}

set_option old_structure_cmd true

/-- Normalization domain: multiplying with `norm_unit` gives a normal form for associated elements. -/
class normalization_domain (α : Type*) extends integral_domain α :=
(norm_unit : α → units α)
(norm_unit_zero      : norm_unit 0 = 1)
(norm_unit_mul       : ∀a b, a ≠ 0 → b ≠ 0 → norm_unit (a * b) = norm_unit a * norm_unit b)
(norm_unit_coe_units : ∀(u : units α), norm_unit u = u⁻¹)

export normalization_domain (norm_unit norm_unit_zero norm_unit_mul norm_unit_coe_units)

attribute [simp] norm_unit_coe_units norm_unit_zero norm_unit_mul

section normalization_domain
variable [normalization_domain α]

@[simp] theorem norm_unit_one : norm_unit (1:α) = 1 :=
norm_unit_coe_units 1

theorem norm_unit_mul_norm_unit (a : α) : norm_unit (a * norm_unit a) = 1 :=
classical.by_cases (assume : a = 0, by simp [this]) $
  assume h, by rw [norm_unit_mul _ _ h (units.ne_zero _), norm_unit_coe_units, mul_inv_eq_one]

theorem associated_of_dvd_of_dvd : ∀{a b : α}, a ∣ b → b ∣ a → ∃u:units α, a * u = b
| a b ⟨c, rfl⟩ ⟨d, hd⟩ :=
  classical.by_cases (assume : c = 0, ⟨1, by simp * at *⟩) $ assume hc : c ≠ 0,
  classical.by_cases (assume : a = 0, ⟨1, by simp * at *⟩) $ assume ha : a ≠ 0,
  have a * 1 = a * (c * d), by simpa [mul_assoc] using hd,
  have 1 = c * d, from eq_of_mul_eq_mul_left ha this,
  ⟨units.mk_of_mul_eq_one c d this.symm, rfl⟩

theorem mul_norm_unit_eq_mul_norm_unit {a b : α}
  (hab : a ∣ b) (hba : b ∣ a) : a * norm_unit a = b * norm_unit b :=
begin
  rcases associated_of_dvd_of_dvd hab hba with ⟨u, rfl⟩,
  refine classical.by_cases (assume : a = 0, by simp [this] at *) (assume ha : a ≠ 0, _),
  suffices : a * ↑(norm_unit a) = a * ↑u * ↑(norm_unit a) * ↑u⁻¹, by simpa [ha, mul_assoc],
  calc a * ↑(norm_unit a) = a * ↑(norm_unit a) * ↑ u * ↑u⁻¹: by simp
    ... = a * ↑u * ↑(norm_unit a) * ↑u⁻¹ : by ac_refl
end

theorem dvd_antisymm_of_norm {a b : α}
  (ha : norm_unit a = 1) (hb : norm_unit b = 1) (hab : a ∣ b) (hba : b ∣ a) :
  a = b :=
have a * norm_unit a = b * norm_unit b, from mul_norm_unit_eq_mul_norm_unit hab hba,
by simpa [ha, hb]

end normalization_domain

/-- GCD domain: an integral domain with normalization and `gcd` (greatest common divisor) and
`lcm` (least common multiple) operations. In this setting `gcd` and `lcm` form a bounded lattice on
the associated elements where `gcd` is the infimum, `lcm` is the supremum, `1` is bottom, and
`0` is top. The type class focuses on `gcd` and we derive the correpsonding `lcm` facts from `gcd`.
-/
class gcd_domain (α : Type*) extends normalization_domain α :=
(gcd : α → α → α)
(lcm : α → α → α)
(gcd_dvd_left   : ∀a b, gcd a b ∣ a)
(gcd_dvd_right  : ∀a b, gcd a b ∣ b)
(dvd_gcd        : ∀{a b c}, a ∣ c → a ∣ b → a ∣ gcd c b)
(norm_unit_gcd  : ∀a b, norm_unit (gcd a b) = 1)
(gcd_mul_lcm    : ∀a b, gcd a b * lcm a b = a * b * norm_unit (a * b))
(lcm_zero_left  : ∀a, lcm 0 a = 0)
(lcm_zero_right : ∀a, lcm a 0 = 0)

export gcd_domain (gcd lcm gcd_dvd_left gcd_dvd_right dvd_gcd  lcm_zero_left lcm_zero_right)

attribute [simp] lcm_zero_left lcm_zero_right

section gcd_domain
variables [gcd_domain α]

@[simp] theorem norm_unit_gcd : ∀a b:α, norm_unit (gcd a b) = 1 :=
gcd_domain.norm_unit_gcd

@[simp] theorem gcd_mul_lcm : ∀a b:α, gcd a b * lcm a b = a * b * norm_unit (a * b) :=
gcd_domain.gcd_mul_lcm

section gcd

theorem dvd_gcd_iff (a b c : α) : a ∣ gcd b c ↔ (a ∣ b ∧ a ∣ c) :=
iff.intro
  (assume h, ⟨dvd_trans h (gcd_dvd_left _ _), dvd_trans h (gcd_dvd_right _ _)⟩)
  (assume ⟨hab, hac⟩, dvd_gcd hab hac)

theorem gcd_comm (a b : α) : gcd a b = gcd b a :=
dvd_antisymm_of_norm (norm_unit_gcd _ _) (norm_unit_gcd _ _)
  (dvd_gcd (gcd_dvd_right _ _) (gcd_dvd_left _ _))
  (dvd_gcd (gcd_dvd_right _ _) (gcd_dvd_left _ _))

theorem gcd_assoc (m n k : α) : gcd (gcd m n) k = gcd m (gcd n k) :=
dvd_antisymm_of_norm (norm_unit_gcd _ _) (norm_unit_gcd _ _)
  (dvd_gcd
    (dvd.trans (gcd_dvd_left (gcd m n) k) (gcd_dvd_left m n))
    (dvd_gcd (dvd.trans (gcd_dvd_left (gcd m n) k) (gcd_dvd_right m n)) (gcd_dvd_right (gcd m n) k)))
  (dvd_gcd
    (dvd_gcd (gcd_dvd_left m (gcd n k)) (dvd.trans (gcd_dvd_right m (gcd n k)) (gcd_dvd_left n k)))
    (dvd.trans (gcd_dvd_right m (gcd n k)) (gcd_dvd_right n k)))

instance : is_commutative α gcd := ⟨gcd_comm⟩
instance : is_associative α gcd := ⟨gcd_assoc⟩

theorem gcd_eq_mul_norm_unit {a b c : α} (habc : gcd a b ∣ c) (hcab : c ∣ gcd a b) :
  gcd a b = c * norm_unit c :=
suffices gcd a b * norm_unit (gcd a b) = c * norm_unit c, by simpa,
mul_norm_unit_eq_mul_norm_unit habc hcab

@[simp] theorem gcd_zero_left (a : α) : gcd 0 a = a * norm_unit a :=
gcd_eq_mul_norm_unit (gcd_dvd_right 0 a) (dvd_gcd (dvd_zero _) (dvd_refl a))

@[simp] theorem gcd_zero_right (a : α) : gcd a 0 = a * norm_unit a :=
gcd_eq_mul_norm_unit (gcd_dvd_left a 0) (dvd_gcd (dvd_refl a) (dvd_zero _))

@[simp] theorem gcd_eq_zero_iff (a b : α) : gcd a b = 0 ↔ a = 0 ∧ b = 0 :=
iff.intro
  (assume h, let ⟨ca, ha⟩ := gcd_dvd_left a b, ⟨cb, hb⟩ := gcd_dvd_right a b in
    by simp [h] at ha hb; exact ⟨ha, hb⟩)
  (assume ⟨ha, hb⟩, by simp [ha, hb])

@[simp] theorem gcd_one_left (a : α) : gcd 1 a = 1 :=
dvd_antisymm_of_norm (norm_unit_gcd _ _) norm_unit_one (gcd_dvd_left _ _)
  (dvd_gcd (dvd_refl 1) (one_dvd _))

@[simp] theorem gcd_one_right (a : α) : gcd a 1 = 1 :=
dvd_antisymm_of_norm (norm_unit_gcd _ _) norm_unit_one (gcd_dvd_right _ _)
  (dvd_gcd (one_dvd _) (dvd_refl 1))

theorem gcd_dvd_gcd {a b c d: α} (hab : a ∣ b) (hcd : c ∣ d) : gcd a c ∣ gcd b d :=
dvd_gcd (dvd.trans (gcd_dvd_left _ _) hab) (dvd.trans (gcd_dvd_right _ _) hcd)

@[simp] theorem gcd_same (a : α) : gcd a a = a * norm_unit a :=
gcd_eq_mul_norm_unit (gcd_dvd_left _ _) (dvd_gcd (dvd_refl a) (dvd_refl a))

@[simp] theorem gcd_mul_left (a b c : α) : gcd (a * b) (a * c) = (a * norm_unit a) * gcd b c :=
classical.by_cases (assume h : a = 0, by simp [h]) $ assume ha : a ≠ 0,
classical.by_cases (assume h : gcd b c = 0, by simp * at *) $ assume hbc : gcd b c ≠ 0,
  suffices gcd (a * b) (a * c) = a * gcd b c * norm_unit (a * gcd b c),
    by simpa [mul_comm, mul_assoc, mul_left_comm, norm_unit_mul a _ ha hbc],
  let ⟨d, eq⟩ := dvd_gcd (dvd_mul_right a b) (dvd_mul_right a c) in
  gcd_eq_mul_norm_unit
    (eq.symm ▸ mul_dvd_mul_left a $ show d ∣ gcd b c, from
      dvd_gcd
        ((mul_dvd_mul_iff_left ha).1 $ eq ▸ gcd_dvd_left _ _)
        ((mul_dvd_mul_iff_left ha).1 $ eq ▸ gcd_dvd_right _ _))
    (dvd_gcd
      (mul_dvd_mul_left a $ gcd_dvd_left _ _)
      (mul_dvd_mul_left a $ gcd_dvd_right _ _))

@[simp] theorem gcd_mul_right (a b c : α) : gcd (b * a) (c * a) = gcd b c * (a * norm_unit a) :=
by simp [mul_comm]

theorem gcd_eq_left_iff (a b : α) (h : norm_unit a = 1) : gcd a b = a ↔ a ∣ b :=
iff.intro (assume eq, eq ▸ gcd_dvd_right _ _) $
  assume hab, dvd_antisymm_of_norm (norm_unit_gcd _ _) h (gcd_dvd_left _ _) (dvd_gcd (dvd_refl a) hab)

theorem gcd_eq_right_iff (a b : α) (h : norm_unit b = 1) : gcd a b = b ↔ b ∣ a :=
by simpa [gcd_comm a b] using gcd_eq_left_iff b a h

theorem gcd_dvd_gcd_mul_left (m n k : α) : gcd m n ∣ gcd (k * m) n :=
gcd_dvd_gcd (dvd_mul_left _ _) (dvd_refl _)

theorem gcd_dvd_gcd_mul_right (m n k : α) : gcd m n ∣ gcd (m * k) n :=
gcd_dvd_gcd (dvd_mul_right _ _) (dvd_refl _)

theorem gcd_dvd_gcd_mul_left_right (m n k : α) : gcd m n ∣ gcd m (k * n) :=
gcd_dvd_gcd (dvd_refl _) (dvd_mul_left _ _)

theorem gcd_dvd_gcd_mul_right_right (m n k : α) : gcd m n ∣ gcd m (n * k) :=
gcd_dvd_gcd (dvd_refl _) (dvd_mul_right _ _)

end gcd

section lcm

lemma lcm_dvd_iff (a b c : α) : lcm a b ∣ c ↔ a ∣ c ∧ b ∣ c :=
classical.by_cases
  (assume : a = 0 ∨ b = 0, by cases this with h h; simp [h, iff_def] {contextual := tt})
  (assume this : ¬ (a = 0 ∨ b = 0),
    have a ≠ 0 ∧ b ≠ 0, by simpa [not_or_distrib] using this,
    have h : gcd a b ≠ 0, by simp [gcd_eq_zero_iff, this],
    by rw [← mul_dvd_mul_iff_left h, gcd_mul_lcm, units.coe_mul_dvd,
        ← units.dvd_coe_mul _ _ (norm_unit c), mul_assoc, mul_comm (gcd a b),
        ← gcd_mul_left, dvd_gcd_iff, mul_comm c a, mul_dvd_mul_iff_left this.1,
        mul_dvd_mul_iff_right this.2, and_comm])

lemma dvd_lcm_left (a b : α) : a ∣ lcm a b :=
have a ∣ lcm a b ∧ b ∣ lcm a b, from (lcm_dvd_iff _ _ _).1 (dvd_refl _),
this.1

lemma dvd_lcm_right (a b : α) : b ∣ lcm a b :=
have a ∣ lcm a b ∧ b ∣ lcm a b, from (lcm_dvd_iff _ _ _).1 (dvd_refl _),
this.2

lemma lcm_dvd {a b c : α} (hab : a ∣ b) (hcb : c ∣ b) : lcm a c ∣ b :=
(lcm_dvd_iff _ _ _).2 ⟨hab, hcb⟩

@[simp] theorem lcm_eq_zero_iff (a b : α) : lcm a b = 0 ↔ a = 0 ∨ b = 0 :=
iff.intro
  (assume h : lcm a b = 0,
    have a * b * norm_unit (a * b) = 0,
      by rw [← gcd_mul_lcm _ _, h, mul_zero],
    by simpa [mul_eq_zero])
  (by simp [or_imp_distrib] {contextual := tt})

@[simp] lemma norm_unit_lcm (a b : α) : norm_unit (lcm a b) = 1 :=
classical.by_cases (assume : lcm a b = 0, by simp [this]) $
  assume h_lcm : lcm a b ≠ 0,
  have gcd a b ≠ 0, by simp [*, not_or_distrib] at *,
  have norm_unit (gcd a b * lcm a b) = 1,
    by rw [gcd_mul_lcm, norm_unit_mul_norm_unit],
  by simp [norm_unit_mul, *, -gcd_mul_lcm] at *

theorem lcm_comm (a b : α) : lcm a b = lcm b a :=
dvd_antisymm_of_norm (norm_unit_lcm _ _) (norm_unit_lcm _ _)
  (lcm_dvd (dvd_lcm_right _ _) (dvd_lcm_left _ _))
  (lcm_dvd (dvd_lcm_right _ _) (dvd_lcm_left _ _))

theorem lcm_assoc (m n k : α) : lcm (lcm m n) k = lcm m (lcm n k) :=
dvd_antisymm_of_norm (norm_unit_lcm _ _) (norm_unit_lcm _ _)
  (lcm_dvd
    (lcm_dvd (dvd_lcm_left _ _) (dvd.trans (dvd_lcm_left _ _) (dvd_lcm_right _ _)))
    (dvd.trans (dvd_lcm_right _ _) (dvd_lcm_right _ _)))
  (lcm_dvd
    (dvd.trans (dvd_lcm_left _ _) (dvd_lcm_left _ _))
    (lcm_dvd (dvd.trans (dvd_lcm_right _ _) (dvd_lcm_left _ _)) (dvd_lcm_right _ _)))

instance : is_commutative α lcm := ⟨lcm_comm⟩
instance : is_associative α lcm := ⟨lcm_assoc⟩

lemma lcm_eq_mul_norm_unit {a b c : α} (habc : lcm a b ∣ c) (hcab : c ∣ lcm a b) :
  lcm a b = c * norm_unit c :=
dvd_antisymm_of_norm (norm_unit_lcm _ _) (norm_unit_mul_norm_unit _)
  ((units.dvd_coe_mul _ _ _).2 $ habc)
  ((units.coe_mul_dvd _ _ _).2 $ hcab)

theorem lcm_dvd_lcm {a b c d : α} (hab : a ∣ b) (hcd : c ∣ d) : lcm a c ∣ lcm b d :=
lcm_dvd (dvd.trans hab (dvd_lcm_left _ _)) (dvd.trans hcd (dvd_lcm_right _ _))

@[simp] theorem lcm_units_coe_left (u : units α) (a : α) : lcm ↑u a = a * norm_unit a :=
lcm_eq_mul_norm_unit (lcm_dvd (units.coe_dvd _ _) (dvd_refl _)) (dvd_lcm_right _ _)

@[simp] theorem lcm_units_coe_right (a : α) (u : units α) : lcm a ↑u = a * norm_unit a :=
by rw [lcm_comm a, lcm_units_coe_left]

@[simp] theorem lcm_one_left (a : α) : lcm 1 a = a * norm_unit a :=
lcm_units_coe_left 1 a

@[simp] theorem lcm_one_right (a : α) : lcm a 1 = a * norm_unit a :=
lcm_units_coe_right a 1

@[simp] theorem lcm_same (a : α) : lcm a a = a * norm_unit a :=
lcm_eq_mul_norm_unit (lcm_dvd (dvd_refl _) (dvd_refl _)) (dvd_lcm_left _ _)

@[simp] theorem lcm_eq_one_iff (a b : α) : lcm a b = 1 ↔ a ∣ 1 ∧ b ∣ 1 :=
iff.intro
  (assume eq, eq ▸ ⟨dvd_lcm_left _ _, dvd_lcm_right _ _⟩)
  (assume ⟨⟨c, hc⟩, ⟨d, hd⟩⟩,
    show lcm (units.mk_of_mul_eq_one a c hc.symm : α) (units.mk_of_mul_eq_one b d hd.symm) = 1,
      by simp)

@[simp] theorem lcm_mul_left (a b c : α) : lcm (a * b) (a * c) = (a * norm_unit a) * lcm b c :=
classical.by_cases (assume : a = 0, by simp * at *) $ assume ha : a ≠ 0,
classical.by_cases (assume : lcm b c = 0, by simp [*, mul_eq_zero] at *) $ assume hbc : lcm b c ≠ 0,
  suffices lcm (a * b) (a * c) = a * lcm b c * norm_unit (a * lcm b c),
    by simpa [ha, hbc, norm_unit_mul, mul_assoc, mul_comm, mul_left_comm],
  have a ∣ lcm (a * b) (a * c), from dvd.trans (dvd_mul_right _ _) (dvd_lcm_left _ _),
  let ⟨d, eq⟩ := this in
  lcm_eq_mul_norm_unit
    (lcm_dvd (mul_dvd_mul_left a (dvd_lcm_left _ _)) (mul_dvd_mul_left a (dvd_lcm_right _ _)))
    (eq.symm ▸ (mul_dvd_mul_left a $ lcm_dvd
      ((mul_dvd_mul_iff_left ha).1 $ eq ▸ dvd_lcm_left _ _)
      ((mul_dvd_mul_iff_left ha).1 $ eq ▸ dvd_lcm_right _ _)))

@[simp] theorem lcm_mul_right (a b c : α) : lcm (b * a) (c * a) = lcm b c * (a * norm_unit a) :=
by simp [mul_comm]

theorem lcm_eq_left_iff (a b : α) (h : norm_unit a = 1) : lcm a b = a ↔ b ∣ a :=
iff.intro (assume eq, eq ▸ dvd_lcm_right _ _) $
  assume hab, dvd_antisymm_of_norm (norm_unit_lcm _ _) h (lcm_dvd (dvd_refl a) hab) (dvd_lcm_left _ _)

theorem lcm_eq_right_iff (a b : α) (h : norm_unit b = 1) : lcm a b = b ↔ a ∣ b :=
by simpa [lcm_comm b a] using lcm_eq_left_iff b a h

theorem lcm_dvd_lcm_mul_left (m n k : α) : lcm m n ∣ lcm (k * m) n :=
lcm_dvd_lcm (dvd_mul_left _ _) (dvd_refl _)

theorem lcm_dvd_lcm_mul_right (m n k : α) : lcm m n ∣ lcm (m * k) n :=
lcm_dvd_lcm (dvd_mul_right _ _) (dvd_refl _)

theorem lcm_dvd_lcm_mul_left_right (m n k : α) : lcm m n ∣ lcm m (k * n) :=
lcm_dvd_lcm (dvd_refl _) (dvd_mul_left _ _)

theorem lcm_dvd_lcm_mul_right_right (m n k : α) : lcm m n ∣ lcm m (n * k) :=
lcm_dvd_lcm (dvd_refl _) (dvd_mul_right _ _)

end lcm

end gcd_domain


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import data.enat.lattice
import order.order_iso_nat
import tactic.tfae

/-!

# Maximal length of chains

This file contains lemmas to work with the maximal length of strictly descending finite
sequences (chains) in a partial order.

## Main definition

- `set.subchain`: The set of strictly ascending lists of `α` contained in a `set α`.
- `set.chain_height`: The maximal length of a strictly ascending sequence in a partial order.
This is defined as the maximum of the lengths of `set.subchain`s, valued in `ℕ∞`.

## Main results

- `set.exists_chain_of_le_chain_height`: For each `n : ℕ` such that `n ≤ s.chain_height`, there
  exists `s.subchain` of length `n`.
- `set.chain_height_mono`: If `s ⊆ t` then `s.chain_height ≤ t.chain_height`.
- `set.chain_height_image`: If `f` is an order embedding, then
  `(f '' s).chain_height = s.chain_height`.
- `set.chain_height_insert_of_forall_lt`: If `∀ y ∈ s, y < x`, then
  `(insert x s).chain_height = s.chain_height + 1`.
- `set.chain_height_insert_of_lt_forall`: If `∀ y ∈ s, x < y`, then
  `(insert x s).chain_height = s.chain_height + 1`.
- `set.chain_height_union_eq`: If `∀ x ∈ s, ∀ y ∈ t, s ≤ t`, then
  `(s ∪ t).chain_height = s.chain_height + t.chain_height`.
- `set.well_founded_gt_of_chain_height_ne_top`:
  If `s` has finite height, then `>` is well-founded on `s`.
- `set.well_founded_lt_of_chain_height_ne_top`:
  If `s` has finite height, then `<` is well-founded on `s`.

-/

open list order_dual

universes u v
variables {α β : Type*}

namespace set
section has_lt
variables [has_lt α] [has_lt β] (s t : set α)

/-- The set of strictly ascending lists of `α` contained in a `set α`. -/
def subchain : set (list α) := {l | l.chain' (<) ∧ ∀ i ∈ l, i ∈ s}

lemma nil_mem_subchain : [] ∈ s.subchain := ⟨trivial, λ x hx, hx.elim⟩

variables {s} {l : list α} {a : α}

lemma cons_mem_subchain_iff :
  a :: l ∈ s.subchain ↔ a ∈ s ∧ l ∈ s.subchain ∧ ∀ b ∈ l.head', a < b :=
begin
  refine ⟨λ h, ⟨h.2 _ (or.inl rfl), ⟨(chain'_cons'.mp h.1).2, λ i hi, h.2 _ (or.inr hi)⟩,
      (chain'_cons'.mp h.1).1⟩, _⟩,
  rintro ⟨h₁, h₂, h₃⟩,
  split,
  { rw chain'_cons',
    exact ⟨h₃, h₂.1⟩ },
  { rintro i (rfl|hi),
    exacts [h₁, h₂.2 _ hi] }
end

instance : nonempty s.subchain := ⟨⟨[], s.nil_mem_subchain⟩⟩

variables (s)

/-- The maximal length of a strictly ascending sequence in a partial order. -/
noncomputable def chain_height : ℕ∞ := ⨆ l ∈ s.subchain, length l

lemma chain_height_eq_supr_subtype : s.chain_height = ⨆ l : s.subchain, l.1.length := supr_subtype'

lemma exists_chain_of_le_chain_height {n : ℕ} (hn : ↑n ≤ s.chain_height) :
  ∃ l ∈ s.subchain, length l = n :=
begin
  cases (le_top : s.chain_height ≤ ⊤).eq_or_lt with ha ha; rw chain_height_eq_supr_subtype at ha,
  { obtain ⟨_, ⟨⟨l, h₁, h₂⟩, rfl⟩, h₃⟩ :=
      not_bdd_above_iff'.mp ((with_top.supr_coe_eq_top _).mp ha) n,
    exact ⟨l.take n, ⟨h₁.take _, λ x h, h₂ _ $ take_subset _ _ h⟩,
      (l.length_take n).trans $ min_eq_left $ le_of_not_ge h₃⟩ },
  { rw with_top.supr_coe_lt_top at ha,
    obtain ⟨⟨l, h₁, h₂⟩, e : l.length = _⟩ := nat.Sup_mem (set.range_nonempty _) ha,
    refine ⟨l.take n, ⟨h₁.take _, λ x h, h₂ _ $ take_subset _ _ h⟩,
      (l.length_take n).trans $ min_eq_left $ _⟩,
    rwa [e, ←with_top.coe_le_coe, Sup_range, with_top.coe_supr _ ha,
      ←chain_height_eq_supr_subtype] }
end

lemma le_chain_height_tfae (n : ℕ) :
  tfae [↑n ≤ s.chain_height,
    ∃ l ∈ s.subchain, length l = n,
    ∃ l ∈ s.subchain, n ≤ length l] :=
begin
  tfae_have : 1 → 2, { exact s.exists_chain_of_le_chain_height },
  tfae_have : 2 → 3, { rintro ⟨l, hls, he⟩, exact ⟨l, hls, he.ge⟩ },
  tfae_have : 3 → 1, { rintro ⟨l, hs, hn⟩, exact le_supr₂_of_le l hs (with_top.coe_le_coe.2 hn) },
  tfae_finish,
end

variables {s t}

lemma le_chain_height_iff {n : ℕ} :
  ↑n ≤ s.chain_height ↔ ∃ l ∈ s.subchain, length l = n :=
(le_chain_height_tfae s n).out 0 1

lemma length_le_chain_height_of_mem_subchain (hl : l ∈ s.subchain) : ↑l.length ≤ s.chain_height :=
le_chain_height_iff.mpr ⟨l, hl, rfl⟩

lemma chain_height_eq_top_iff : s.chain_height = ⊤ ↔ ∀ n, ∃ l ∈ s.subchain, length l = n :=
begin
  refine ⟨λ h n, le_chain_height_iff.1 (le_top.trans_eq h.symm), λ h, _⟩,
  contrapose! h, obtain ⟨n, hn⟩ := with_top.ne_top_iff_exists.1 h,
  exact ⟨n + 1, λ l hs, (nat.lt_succ_iff.2 $ with_top.coe_le_coe.1 $
    (length_le_chain_height_of_mem_subchain hs).trans_eq hn.symm).ne⟩,
end

@[simp]
lemma one_le_chain_height_iff : 1 ≤ s.chain_height ↔ s.nonempty :=
begin
  change ((1 : ℕ) : enat) ≤ _ ↔ _,
  rw set.le_chain_height_iff,
  split,
  { rintro ⟨_|⟨x, xs⟩, ⟨h₁, h₂⟩, h₃⟩,
    { cases h₃ },
    { exact ⟨x, h₂ _ (or.inl rfl)⟩ } },
  { rintro ⟨x, hx⟩,
    exact ⟨[x], ⟨chain.nil, λ y h, (list.mem_singleton.mp h).symm ▸ hx⟩, rfl⟩ }
end

@[simp] lemma chain_height_eq_zero_iff : s.chain_height = 0 ↔ s = ∅ :=
by rw [←not_iff_not, ←ne.def, ←bot_eq_zero, ←bot_lt_iff_ne_bot, bot_eq_zero, ←enat.one_le_iff_pos,
  one_le_chain_height_iff, nonempty_iff_ne_empty]

@[simp] lemma chain_height_empty : (∅ : set α).chain_height = 0 := chain_height_eq_zero_iff.2 rfl

@[simp] lemma chain_height_of_is_empty [is_empty α] : s.chain_height = 0 :=
chain_height_eq_zero_iff.mpr (subsingleton.elim _ _)

lemma le_chain_height_add_nat_iff {n m : ℕ} :
  ↑n ≤ s.chain_height + m ↔ ∃ l ∈ s.subchain, n ≤ length l + m :=
by simp_rw [← tsub_le_iff_right, ← with_top.coe_sub, (le_chain_height_tfae s (n - m)).out 0 2]

lemma chain_height_add_le_chain_height_add (s : set α) (t : set β) (n m : ℕ) :
  s.chain_height + n ≤ t.chain_height + m ↔
    ∀ l ∈ s.subchain, ∃ l' ∈ t.subchain, length l + n ≤ length l' + m :=
begin
  refine ⟨λ e l h, le_chain_height_add_nat_iff.1
    ((add_le_add_right (length_le_chain_height_of_mem_subchain h) _).trans e), λ H, _⟩,
  by_cases s.chain_height = ⊤,
  { suffices : t.chain_height = ⊤, { rw [this, top_add], exact le_top },
    rw chain_height_eq_top_iff at h ⊢,
    intro k, rw (le_chain_height_tfae t k).out 1 2,
    obtain ⟨l, hs, hl⟩ := h (k + m),
    obtain ⟨l', ht, hl'⟩ := H l hs,
    exact ⟨l', ht, (add_le_add_iff_right m).1 $ trans (hl.symm.trans_le le_self_add) hl'⟩ },
  { obtain ⟨k, hk⟩ := with_top.ne_top_iff_exists.1 h,
    obtain ⟨l, hs, hl⟩ := le_chain_height_iff.1 hk.le,
    rw [← hk, ← hl],
    exact le_chain_height_add_nat_iff.2 (H l hs) },
end

lemma chain_height_le_chain_height_tfae (s : set α) (t : set β) :
  tfae [s.chain_height ≤ t.chain_height,
    ∀ l ∈ s.subchain, ∃ l' ∈ t.subchain, length l = length l',
    ∀ l ∈ s.subchain, ∃ l' ∈ t.subchain, length l ≤ length l'] :=
begin
  tfae_have : 1 ↔ 3, { convert ← chain_height_add_le_chain_height_add s t 0 0; apply add_zero },
  tfae_have : 2 ↔ 3, { refine forall₂_congr (λ l hl, _),
    simp_rw [← (le_chain_height_tfae t l.length).out 1 2, eq_comm] },
  tfae_finish
end

lemma chain_height_le_chain_height_iff {t : set β} :
  s.chain_height ≤ t.chain_height ↔
    ∀ l ∈ s.subchain, ∃ l' ∈ t.subchain, length l = length l' :=
(chain_height_le_chain_height_tfae s t).out 0 1

lemma chain_height_le_chain_height_iff_le {t : set β} :
  s.chain_height ≤ t.chain_height ↔
    ∀ l ∈ s.subchain, ∃ l' ∈ t.subchain, length l ≤ length l' :=
(chain_height_le_chain_height_tfae s t).out 0 2

lemma chain_height_mono (h : s ⊆ t) : s.chain_height ≤ t.chain_height :=
chain_height_le_chain_height_iff.2 $ λ l hl, ⟨l, ⟨hl.1, λ i hi, h $ hl.2 i hi⟩, rfl⟩

lemma chain_height_image
  (f : α → β) (hf : ∀ {x y}, x < y ↔ f x < f y) (s : set α) :
  (f '' s).chain_height = s.chain_height :=
begin
  apply le_antisymm; rw chain_height_le_chain_height_iff,
  { suffices : ∀ l ∈ (f '' s).subchain, ∃ l' ∈ s.subchain, map f l' = l,
    { intros l hl, obtain ⟨l', h₁, rfl⟩ := this l hl, exact ⟨l', h₁, length_map _ _⟩ },
    intro l,
    induction l with x xs hx,
    { exact λ _, ⟨nil, ⟨trivial, λ _ h, h.elim⟩, rfl⟩ },
    { intros h,
      rw cons_mem_subchain_iff at h,
      obtain ⟨⟨x, hx', rfl⟩, h₁, h₂⟩ := h,
      obtain ⟨l', h₃, rfl⟩ := hx h₁,
      refine ⟨x :: l', set.cons_mem_subchain_iff.mpr ⟨hx', h₃, _⟩, rfl⟩,
      cases l', { simp }, { simpa [← hf] using h₂ } } },
  { intros l hl,
    refine ⟨l.map f, ⟨_, _⟩, _⟩,
    { simp_rw [chain'_map, ← hf], exact hl.1 },
    { intros _ e, obtain ⟨a, ha, rfl⟩ := mem_map.mp e, exact set.mem_image_of_mem _ (hl.2 _ ha) },
    { rw length_map } },
end

variables (s)

@[simp] lemma chain_height_dual : (of_dual ⁻¹' s).chain_height = s.chain_height :=
begin
  apply le_antisymm;
  { rw chain_height_le_chain_height_iff,
    rintro l ⟨h₁, h₂⟩,
    exact ⟨l.reverse, ⟨chain'_reverse.mpr h₁,
      λ i h, h₂ i (mem_reverse.mp h)⟩, (length_reverse _).symm⟩ }
end

end has_lt

section preorder
variables (s t : set α) [preorder α]

lemma chain_height_eq_supr_Ici : s.chain_height = ⨆ i ∈ s, (s ∩ set.Ici i).chain_height :=
begin
  apply le_antisymm,
  { refine supr₂_le _,
    rintro (_ | ⟨x, xs⟩) h,
    { exact zero_le _ },
    { apply le_trans _ (le_supr₂ x (cons_mem_subchain_iff.mp h).1),
      apply length_le_chain_height_of_mem_subchain,
      refine ⟨h.1, λ i hi, ⟨h.2 i hi, _⟩⟩,
      cases hi, { exact hi.symm.le },
      cases chain'_iff_pairwise.mp h.1 with _ _ h',
      exact (h' _ hi).le } },
  { exact supr₂_le (λ i hi, chain_height_mono $ set.inter_subset_left _ _) }
end

variables {s t}

lemma chain_height_insert_of_forall_gt (a : α) (hx : ∀ b ∈ s, a < b) :
  (insert a s).chain_height = s.chain_height + 1 :=
begin
  rw ← add_zero (insert a s).chain_height,
  change (insert a s).chain_height + (0 : ℕ) = s.chain_height + (1 : ℕ),
  apply le_antisymm; rw chain_height_add_le_chain_height_add,
  { rintro (_|⟨y, ys⟩) h,
    { exact ⟨[], nil_mem_subchain _, zero_le _⟩ },
    { have h' := cons_mem_subchain_iff.mp h,
      refine ⟨ys, ⟨h'.2.1.1, λ i hi, _⟩, by simp⟩,
      apply (h'.2.1.2 i hi).resolve_left,
      rintro rfl,
      cases chain'_iff_pairwise.mp h.1 with _ _ hy,
      cases h'.1 with h' h',
      exacts [(hy _ hi).ne h', not_le_of_gt (hy _ hi) (hx _ h').le] } },
  { intros l hl,
    refine ⟨a :: l, ⟨_, _⟩, by simp⟩,
    { rw chain'_cons', exact ⟨λ y hy, hx _ (hl.2 _ (mem_of_mem_head' hy)), hl.1⟩ },
    { rintro x (rfl|hx), exacts [or.inl (set.mem_singleton x), or.inr (hl.2 x hx)] } }
end

lemma chain_height_insert_of_forall_lt (a : α) (ha : ∀ b ∈ s, b < a) :
  (insert a s).chain_height = s.chain_height + 1 :=
by { rw [←chain_height_dual, ←chain_height_dual s], exact chain_height_insert_of_forall_gt _ ha }

lemma chain_height_union_le : (s ∪ t).chain_height ≤ s.chain_height + t.chain_height :=
begin
  classical,
  refine supr₂_le (λ l hl, _),
  let l₁ := l.filter (∈ s), let l₂ := l.filter (∈ t),
  have hl₁ : ↑l₁.length ≤ s.chain_height,
  { apply set.length_le_chain_height_of_mem_subchain,
    exact ⟨hl.1.sublist (filter_sublist _), λ i h, (of_mem_filter h : _)⟩ },
  have hl₂ : ↑l₂.length ≤ t.chain_height,
  { apply set.length_le_chain_height_of_mem_subchain,
    exact ⟨hl.1.sublist (filter_sublist _), λ i h, (of_mem_filter h : _)⟩ },
  refine le_trans _ (add_le_add hl₁ hl₂),
  simp_rw [← with_top.coe_add, with_top.coe_le_coe, ← multiset.coe_card,
    ← multiset.card_add, ← multiset.coe_filter],
  rw [multiset.filter_add_filter, multiset.filter_eq_self.mpr, multiset.card_add],
  exacts [le_add_right rfl.le, hl.2]
end

lemma chain_height_union_eq (s t : set α) (H : ∀ (a ∈ s) (b ∈ t), a < b) :
  (s ∪ t).chain_height = s.chain_height + t.chain_height :=
begin
  cases h : t.chain_height,
  { rw [with_top.none_eq_top, add_top, eq_top_iff, ← with_top.none_eq_top, ← h],
    exact set.chain_height_mono (set.subset_union_right _ _) },
  apply le_antisymm,
  { rw ← h,
    exact chain_height_union_le },
  rw [with_top.some_eq_coe, ← add_zero (s ∪ t).chain_height, ← with_top.coe_zero,
    chain_height_add_le_chain_height_add],
  intros l hl,
  obtain ⟨l', hl', rfl⟩ := exists_chain_of_le_chain_height t h.symm.le,
  refine ⟨l ++ l', ⟨chain'.append hl.1 hl'.1 $ λ x hx y hy, _, λ i hi, _⟩, by simp⟩,
  { exact H x (hl.2 _ $ mem_of_mem_last' hx) y (hl'.2 _ $ mem_of_mem_head' hy) },
  { rw mem_append at hi, cases hi, exacts [or.inl (hl.2 _ hi), or.inr (hl'.2 _ hi)] }
end

lemma well_founded_gt_of_chain_height_ne_top (s : set α) (hs : s.chain_height ≠ ⊤) :
  well_founded_gt s :=
begin
  obtain ⟨n, hn⟩ := with_top.ne_top_iff_exists.1 hs,
  refine ⟨rel_embedding.well_founded_iff_no_descending_seq.2 ⟨λ f, _⟩⟩,
  refine n.lt_succ_self.not_le (with_top.coe_le_coe.1 $ hn.symm ▸ _),
  refine le_supr₂_of_le _ ⟨chain'_map_of_chain' coe (λ _ _, id)
    (chain'_iff_pairwise.2 $ pairwise_of_fn.2 $ λ i j, f.map_rel_iff.2), λ i h, _⟩ _,
  { exact n.succ },
  { obtain ⟨a, ha, rfl⟩ := mem_map.1 h, exact a.prop },
  { rw [length_map, length_of_fn], exact le_rfl },
end

lemma well_founded_lt_of_chain_height_ne_top (s : set α) (hs : s.chain_height ≠ ⊤) :
  well_founded_lt s :=
well_founded_gt_of_chain_height_ne_top (of_dual ⁻¹' s) $ by rwa chain_height_dual

end preorder

end set