import algebra.field
import gtm106.weierstrass_equation.basic
import gtm106.weierstrass_equation.point
import myhelper.mypoly.basic
import tactic

namespace weierstrass_equation

/--
intersection of `y^2 + a1*x*y + a3*y = x^3 + a2*x^2 + a4*x + a6`
and `y = A*x + B`
-/
@[ext]
structure intersection_with_line (K : Type*) [field K] :=
mk :: (E : weierstrass_equation K)
(A B : K)

namespace intersection_with_line

/--
intersection of `y^2 + a1*x*y + a3*y = x^3 + a2*x^2 + a4*x + a6`
and `y - y0 = A*(x - x0)`
-/
def from_point {K : Type*} [field K]
(E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K)
: intersection_with_line K
:= ⟨ E, A, P.y - A * P.x ⟩

@[simp]
lemma from_point.E {K : Type*} [field K]
(E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K)
: (from_point E P A).E = E := rfl

@[simp]
lemma from_point.A {K : Type*} [field K]
(E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K)
: (from_point E P A).A = A := rfl

section

parameters {K : Type*} [field K] (L : intersection_with_line K)

def a : K := L.E.a2 - (L.A + L.E.a1) * L.A
def b : K := L.E.a4 - (2 * L.A + L.E.a1) * L.B - L.A * L.E.a3
def c : K := L.E.a6 - (L.B + L.E.a3) * L.B
def poly : monic_cubic_poly K := ⟨ L.a, L.b, L.c ⟩
def point (x : K) : affine_plane_point K := ⟨ x, L.A * x + L.B ⟩

lemma from_point' (x : K)
: from_point L.E (L.point x) L.A = L :=
begin
  simp [from_point, point, intersection_with_line.ext_iff],
end

lemma eval_at' (x : K)
: L.poly.eval_at x = - L.E.eval_at_affine_point (L.point x) :=
sub_eq_zero.1 begin
  simp only [monic_cubic_poly.eval_at, poly, a, b, c, eval_at_affine_point, point],
  ring,
end

lemma eval_dx_at' (x : K)
: L.poly.eval_dx_at x = - L.E.eval_dx_at_affine_point (L.point x) - L.A * L.E.eval_dy_at_affine_point (L.point x) :=
sub_eq_zero.1 begin
  simp only [monic_cubic_poly.eval_dx_at, poly, a, b, c,
    eval_dx_at_affine_point, eval_dy_at_affine_point, point],
  ring,
end

lemma is_on' (x : K)
: L.poly.is_root x ↔ L.E.affine_point_on_curve (L.point x) :=
begin
  simp [monic_cubic_poly.is_root, affine_point_on_curve, eval_at'],
end

lemma is_on_2' (x : K)
: L.poly.is_multiple_root x
↔ L.E.affine_point_on_curve (L.point x)
∧ - L.E.eval_dx_at_affine_point (L.point x) = L.A * L.E.eval_dy_at_affine_point (L.point x) :=
begin
  simp [monic_cubic_poly.is_multiple_root, affine_point_on_curve,
    eval_at', eval_dx_at', sub_eq_zero],
end

end

lemma point_this {K : Type*} [field K]
(E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K)
: (from_point E P A).point P.x = P :=
begin
  simp [from_point, point, affine_plane_point.ext_iff],
end

lemma is_on_this {K : Type*} [field K]
(E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K)
: (from_point E P A).poly.is_root P.x ↔ E.affine_point_on_curve P :=
begin
  rw [is_on', point_this],
  simp [from_point],
end

lemma from_point'' {K : Type*} [field K]
(E : weierstrass_equation K)
(P : affine_plane_point K)
(A x : K)
: from_point E ((from_point E P A).point x) A = from_point E P A :=
begin
  have := from_point' (from_point E P A) x,
  simp at this,
  exact this,
end

end intersection_with_line

end weierstrass_equation


/-
Copyright (c) 2021 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth
-/
import analysis.normed_space.add_torsor
import analysis.normed_space.linear_isometry

/-!
# Affine isometries

In this file we define `affine_isometry 𝕜 P P₂` to be an affine isometric embedding of normed
add-torsors `P` into `P₂` over normed `𝕜`-spaces and `affine_isometry_equiv` to be an affine
isometric equivalence between `P` and `P₂`.

We also prove basic lemmas and provide convenience constructors.  The choice of these lemmas and
constructors is closely modelled on those for the `linear_isometry` and `affine_map` theories.

Since many elementary properties don't require `∥x∥ = 0 → x = 0` we initially set up the theory for
`semi_normed_add_torsor` and specialize to `normed_add_torsor` only when needed.

## Notation

We introduce the notation `P →ᵃⁱ[𝕜] P₂` for `affine_isometry 𝕜 P P₂`, and `P ≃ᵃⁱ[𝕜] P₂` for
`affine_isometry_equiv 𝕜 P P₂`.  In contrast with the notation `→ₗᵢ` for linear isometries, `≃ᵢ`
for isometric equivalences, etc., the "i" here is a superscript.  This is for aesthetic reasons to
match the superscript "a" (note that in mathlib `→ᵃ` is an affine map, since `→ₐ` has been taken by
algebra-homomorphisms.)

-/
open function set

variables (𝕜 : Type*) {V V₁ V₂ V₃ V₄ : Type*} {P₁ : Type*} (P P₂ : Type*) {P₃ P₄ : Type*}
    [normed_field 𝕜]
  [semi_normed_group V] [normed_group V₁] [semi_normed_group V₂] [semi_normed_group V₃]
    [semi_normed_group V₄]
  [semi_normed_space 𝕜 V] [normed_space 𝕜 V₁] [semi_normed_space 𝕜 V₂] [semi_normed_space 𝕜 V₃]
    [semi_normed_space 𝕜 V₄]
  [pseudo_metric_space P] [metric_space P₁] [pseudo_metric_space P₂] [pseudo_metric_space P₃]
    [pseudo_metric_space P₄]
  [semi_normed_add_torsor V P] [normed_add_torsor V₁ P₁] [semi_normed_add_torsor V₂ P₂]
    [semi_normed_add_torsor V₃ P₃] [semi_normed_add_torsor V₄ P₄]

include V V₂

/-- An `𝕜`-affine isometric embedding of one normed add-torsor over a normed `𝕜`-space into
another. -/
structure affine_isometry extends P →ᵃ[𝕜] P₂ :=
(norm_map : ∀ x : V, ∥linear x∥ = ∥x∥)

omit V V₂
variables {𝕜 P P₂}

-- `→ᵃᵢ` would be more consistent with the linear isometry notation, but it is uglier
notation P ` →ᵃⁱ[`:25 𝕜:25 `] `:0 P₂:0 := affine_isometry 𝕜 P P₂

namespace affine_isometry
variables (f : P →ᵃⁱ[𝕜] P₂)

/-- The underlying linear map of an affine isometry is in fact a linear isometry. -/
protected def linear_isometry : V →ₗᵢ[𝕜] V₂ :=
{ norm_map' := f.norm_map,
  .. f.linear }

@[simp] lemma linear_eq_linear_isometry : f.linear = f.linear_isometry.to_linear_map :=
by { ext, refl }

include V V₂
instance : has_coe_to_fun (P →ᵃⁱ[𝕜] P₂) (λ _, P → P₂) := ⟨λ f, f.to_fun⟩
omit V V₂

@[simp] lemma coe_to_affine_map : ⇑f.to_affine_map = f := rfl

include V V₂
lemma to_affine_map_injective : injective (to_affine_map : (P →ᵃⁱ[𝕜] P₂) → (P →ᵃ[𝕜] P₂))
| ⟨f, _⟩ ⟨g, _⟩ rfl := rfl

lemma coe_fn_injective : @injective (P →ᵃⁱ[𝕜] P₂) (P → P₂) coe_fn :=
affine_map.coe_fn_injective.comp to_affine_map_injective

@[ext] lemma ext {f g : P →ᵃⁱ[𝕜] P₂} (h : ∀ x, f x = g x) : f = g :=
coe_fn_injective $ funext h
omit V V₂

end affine_isometry

namespace linear_isometry
variables (f : V →ₗᵢ[𝕜] V₂)

/-- Reinterpret a linear isometry as an affine isometry. -/
def to_affine_isometry : V →ᵃⁱ[𝕜] V₂ :=
{ norm_map := f.norm_map,
  .. f.to_linear_map.to_affine_map }

@[simp] lemma coe_to_affine_isometry : ⇑(f.to_affine_isometry : V →ᵃⁱ[𝕜] V₂) = f := rfl

@[simp] lemma to_affine_isometry_linear_isometry : f.to_affine_isometry.linear_isometry = f :=
by { ext, refl }

-- somewhat arbitrary choice of simp direction
@[simp] lemma to_affine_isometry_to_affine_map :
  f.to_affine_isometry.to_affine_map = f.to_linear_map.to_affine_map :=
rfl

end linear_isometry

namespace affine_isometry

/-- We use `f₁` when we need the domain to be a `normed_space`. -/
variables (f : P →ᵃⁱ[𝕜] P₂) (f₁ : P₁ →ᵃⁱ[𝕜] P₂)

@[simp] lemma map_vadd (p : P) (v : V) : f (v +ᵥ p) = f.linear_isometry v +ᵥ f p :=
f.to_affine_map.map_vadd p v

@[simp] lemma map_vsub (p1 p2 : P) : f.linear_isometry (p1 -ᵥ p2) = f p1 -ᵥ f p2 :=
f.to_affine_map.linear_map_vsub p1 p2

@[simp] lemma dist_map (x y : P) : dist (f x) (f y) = dist x y :=
by rw [dist_eq_norm_vsub V₂, dist_eq_norm_vsub V, ← map_vsub, f.linear_isometry.norm_map]

@[simp] lemma nndist_map (x y : P) : nndist (f x) (f y) = nndist x y := by simp [nndist_dist]

@[simp] lemma edist_map (x y : P) : edist (f x) (f y) = edist x y := by simp [edist_dist]

protected lemma isometry : isometry f := f.edist_map

protected lemma injective : injective f₁ := f₁.isometry.injective

@[simp] lemma map_eq_iff {x y : P₁} : f₁ x = f₁ y ↔ x = y := f₁.injective.eq_iff

lemma map_ne {x y : P₁} (h : x ≠ y) : f₁ x ≠ f₁ y := f₁.injective.ne h

protected lemma lipschitz : lipschitz_with 1 f := f.isometry.lipschitz

protected lemma antilipschitz : antilipschitz_with 1 f := f.isometry.antilipschitz

@[continuity] protected lemma continuous : continuous f := f.isometry.continuous

lemma ediam_image (s : set P) : emetric.diam (f '' s) = emetric.diam s :=
f.isometry.ediam_image s

lemma ediam_range : emetric.diam (range f) = emetric.diam (univ : set P) :=
f.isometry.ediam_range

lemma diam_image (s : set P) : metric.diam (f '' s) = metric.diam s :=
f.isometry.diam_image s

lemma diam_range : metric.diam (range f) = metric.diam (univ : set P) :=
f.isometry.diam_range

@[simp] lemma comp_continuous_iff {α : Type*} [topological_space α] {g : α → P} :
  continuous (f ∘ g) ↔ continuous g :=
f.isometry.comp_continuous_iff

include V
/-- The identity affine isometry. -/
def id : P →ᵃⁱ[𝕜] P := ⟨affine_map.id 𝕜 P, λ x, rfl⟩

@[simp] lemma coe_id : ⇑(id : P →ᵃⁱ[𝕜] P) = _root_.id := rfl

@[simp] lemma id_apply (x : P) : (affine_isometry.id : P →ᵃⁱ[𝕜] P) x = x := rfl

@[simp] lemma id_to_affine_map : (id.to_affine_map : P →ᵃ[𝕜] P) = affine_map.id 𝕜 P := rfl

instance : inhabited (P →ᵃⁱ[𝕜] P) := ⟨id⟩

include V₂ V₃
/-- Composition of affine isometries. -/
def comp (g : P₂ →ᵃⁱ[𝕜] P₃) (f : P →ᵃⁱ[𝕜] P₂) : P →ᵃⁱ[𝕜] P₃ :=
⟨g.to_affine_map.comp f.to_affine_map, λ x, (g.norm_map _).trans (f.norm_map _)⟩

@[simp] lemma coe_comp (g : P₂ →ᵃⁱ[𝕜] P₃) (f : P →ᵃⁱ[𝕜] P₂) :
  ⇑(g.comp f) = g ∘ f :=
rfl

omit V V₂ V₃

@[simp] lemma id_comp : (id : P₂ →ᵃⁱ[𝕜] P₂).comp f = f := ext $ λ x, rfl

@[simp] lemma comp_id : f.comp id = f := ext $ λ x, rfl

include V V₂ V₃ V₄
lemma comp_assoc (f : P₃ →ᵃⁱ[𝕜] P₄) (g : P₂ →ᵃⁱ[𝕜] P₃) (h : P →ᵃⁱ[𝕜] P₂) :
  (f.comp g).comp h = f.comp (g.comp h) :=
rfl
omit V₂ V₃ V₄

instance : monoid (P →ᵃⁱ[𝕜] P) :=
{ one := id,
  mul := comp,
  mul_assoc := comp_assoc,
  one_mul := id_comp,
  mul_one := comp_id }

@[simp] lemma coe_one : ⇑(1 : P →ᵃⁱ[𝕜] P) = _root_.id := rfl
@[simp] lemma coe_mul (f g : P →ᵃⁱ[𝕜] P) : ⇑(f * g) = f ∘ g := rfl

end affine_isometry

-- remark: by analogy with the `linear_isometry` file from which this is adapted, there should
-- follow here a section defining an "inclusion" affine isometry from `p : affine_subspace 𝕜 P`
-- into `P`; we omit this for now

variables (𝕜 P P₂)
include V V₂

/-- A affine isometric equivalence between two normed vector spaces. -/
structure affine_isometry_equiv extends P ≃ᵃ[𝕜] P₂ :=
(norm_map : ∀ x, ∥linear x∥ = ∥x∥)

variables {𝕜 P P₂}
omit V V₂

-- `≃ᵃᵢ` would be more consistent with the linear isometry equiv notation, but it is uglier
notation P ` ≃ᵃⁱ[`:25 𝕜:25 `] `:0 P₂:0 := affine_isometry_equiv 𝕜 P P₂

namespace affine_isometry_equiv

variables (e : P ≃ᵃⁱ[𝕜] P₂)

/-- The underlying linear equiv of an affine isometry equiv is in fact a linear isometry equiv. -/
protected def linear_isometry_equiv : V ≃ₗᵢ[𝕜] V₂ :=
{ norm_map' := e.norm_map,
  .. e.linear }

@[simp] lemma linear_eq_linear_isometry : e.linear = e.linear_isometry_equiv.to_linear_equiv :=
by { ext, refl }

include V V₂
instance : has_coe_to_fun (P ≃ᵃⁱ[𝕜] P₂) (λ _, P → P₂) := ⟨λ f, f.to_fun⟩

@[simp] lemma coe_mk (e : P ≃ᵃ[𝕜] P₂) (he : ∀ x, ∥e.linear x∥ = ∥x∥) :
  ⇑(mk e he) = e :=
rfl

@[simp] lemma coe_to_affine_equiv (e : P ≃ᵃⁱ[𝕜] P₂) : ⇑e.to_affine_equiv = e := rfl

lemma to_affine_equiv_injective : injective (to_affine_equiv : (P ≃ᵃⁱ[𝕜] P₂) → (P ≃ᵃ[𝕜] P₂))
| ⟨e, _⟩ ⟨_, _⟩ rfl := rfl

@[ext] lemma ext {e e' : P ≃ᵃⁱ[𝕜] P₂} (h : ∀ x, e x = e' x) : e = e' :=
to_affine_equiv_injective $ affine_equiv.ext h
omit V V₂

/-- Reinterpret a `affine_isometry_equiv` as a `affine_isometry`. -/
def to_affine_isometry : P →ᵃⁱ[𝕜] P₂ := ⟨e.1.to_affine_map, e.2⟩

@[simp] lemma coe_to_affine_isometry : ⇑e.to_affine_isometry = e := rfl

/-- Construct an affine isometry equivalence by verifying the relation between the map and its
linear part at one base point. Namely, this function takes a map `e : P₁ → P₂`, a linear isometry
equivalence `e' : V₁ ≃ᵢₗ[k] V₂`, and a point `p` such that for any other point `p'` we have
`e p' = e' (p' -ᵥ p) +ᵥ e p`. -/
def mk' (e : P₁ → P₂) (e' : V₁ ≃ₗᵢ[𝕜] V₂) (p : P₁) (h : ∀ p' : P₁, e p' = e' (p' -ᵥ p) +ᵥ e p) :
  P₁ ≃ᵃⁱ[𝕜] P₂ :=
{ norm_map := e'.norm_map,
  .. affine_equiv.mk' e e'.to_linear_equiv p h }

@[simp] lemma coe_mk' (e : P₁ → P₂) (e' : V₁ ≃ₗᵢ[𝕜] V₂) (p h) : ⇑(mk' e e' p h) = e := rfl
@[simp] lemma linear_isometry_equiv_mk' (e : P₁ → P₂) (e' : V₁ ≃ₗᵢ[𝕜] V₂) (p h) :
  (mk' e e' p h).linear_isometry_equiv = e' := by { ext, refl }

end affine_isometry_equiv

namespace linear_isometry_equiv
variables (e : V ≃ₗᵢ[𝕜] V₂)

/-- Reinterpret a linear isometry equiv as an affine isometry equiv. -/
def to_affine_isometry_equiv  : V ≃ᵃⁱ[𝕜] V₂ :=
{ norm_map := e.norm_map,
  .. e.to_linear_equiv.to_affine_equiv }

@[simp] lemma coe_to_affine_isometry_equiv : ⇑(e.to_affine_isometry_equiv : V ≃ᵃⁱ[𝕜] V₂) = e := rfl

@[simp] lemma to_affine_isometry_equiv_linear_isometry_equiv :
  e.to_affine_isometry_equiv.linear_isometry_equiv = e :=
by { ext, refl }

-- somewhat arbitrary choice of simp direction
@[simp] lemma to_affine_isometry_equiv_to_affine_equiv :
  e.to_affine_isometry_equiv.to_affine_equiv = e.to_linear_equiv.to_affine_equiv :=
rfl

-- somewhat arbitrary choice of simp direction
@[simp] lemma to_affine_isometry_equiv_to_affine_isometry :
  e.to_affine_isometry_equiv.to_affine_isometry = e.to_linear_isometry.to_affine_isometry :=
rfl

end linear_isometry_equiv

namespace affine_isometry_equiv
variables (e : P ≃ᵃⁱ[𝕜] P₂)

protected lemma isometry : isometry e := e.to_affine_isometry.isometry

/-- Reinterpret a `affine_isometry_equiv` as an `isometric`. -/
def to_isometric : P ≃ᵢ P₂ := ⟨e.to_affine_equiv.to_equiv, e.isometry⟩

@[simp] lemma coe_to_isometric : ⇑e.to_isometric = e := rfl

include V V₂
lemma range_eq_univ (e : P ≃ᵃⁱ[𝕜] P₂) : set.range e = set.univ :=
by { rw ← coe_to_isometric, exact isometric.range_eq_univ _, }
omit V V₂

/-- Reinterpret a `affine_isometry_equiv` as an `homeomorph`. -/
def to_homeomorph : P ≃ₜ P₂ := e.to_isometric.to_homeomorph

@[simp] lemma coe_to_homeomorph : ⇑e.to_homeomorph = e := rfl

protected lemma continuous : continuous e := e.isometry.continuous
protected lemma continuous_at {x} : continuous_at e x := e.continuous.continuous_at
protected lemma continuous_on {s} : continuous_on e s := e.continuous.continuous_on

protected lemma continuous_within_at {s x} : continuous_within_at e s x :=
e.continuous.continuous_within_at

variables (𝕜 P)
include V

/-- Identity map as a `affine_isometry_equiv`. -/
def refl : P ≃ᵃⁱ[𝕜] P := ⟨affine_equiv.refl 𝕜 P, λ x, rfl⟩

variables {𝕜 P}

instance : inhabited (P ≃ᵃⁱ[𝕜] P) := ⟨refl 𝕜 P⟩

@[simp] lemma coe_refl : ⇑(refl 𝕜 P) = id := rfl
@[simp] lemma to_affine_equiv_refl : (refl 𝕜 P).to_affine_equiv = affine_equiv.refl 𝕜 P := rfl
@[simp] lemma to_isometric_refl : (refl 𝕜 P).to_isometric = isometric.refl P := rfl
@[simp] lemma to_homeomorph_refl : (refl 𝕜 P).to_homeomorph = homeomorph.refl P := rfl
omit V

/-- The inverse `affine_isometry_equiv`. -/
def symm : P₂ ≃ᵃⁱ[𝕜] P :=
{ norm_map := e.linear_isometry_equiv.symm.norm_map,
  .. e.to_affine_equiv.symm }

@[simp] lemma apply_symm_apply (x : P₂) : e (e.symm x) = x := e.to_affine_equiv.apply_symm_apply x
@[simp] lemma symm_apply_apply (x : P) : e.symm (e x) = x := e.to_affine_equiv.symm_apply_apply x
@[simp] lemma symm_symm : e.symm.symm = e := ext $ λ x, rfl

@[simp] lemma to_affine_equiv_symm : e.to_affine_equiv.symm = e.symm.to_affine_equiv := rfl
@[simp] lemma to_isometric_symm : e.to_isometric.symm = e.symm.to_isometric := rfl
@[simp] lemma to_homeomorph_symm : e.to_homeomorph.symm = e.symm.to_homeomorph := rfl

include V₃
/-- Composition of `affine_isometry_equiv`s as a `affine_isometry_equiv`. -/
def trans (e' : P₂ ≃ᵃⁱ[𝕜] P₃) : P ≃ᵃⁱ[𝕜] P₃ :=
⟨e.to_affine_equiv.trans e'.to_affine_equiv, λ x, (e'.norm_map _).trans (e.norm_map _)⟩

include V V₂
@[simp] lemma coe_trans (e₁ : P ≃ᵃⁱ[𝕜] P₂) (e₂ : P₂ ≃ᵃⁱ[𝕜] P₃) : ⇑(e₁.trans e₂) = e₂ ∘ e₁ := rfl
omit V V₂ V₃

@[simp] lemma trans_refl : e.trans (refl 𝕜 P₂) = e := ext $ λ x, rfl
@[simp] lemma refl_trans : (refl 𝕜 P).trans e = e := ext $ λ x, rfl
@[simp] lemma self_trans_symm : e.trans e.symm = refl 𝕜 P := ext e.symm_apply_apply
@[simp] lemma symm_trans_self : e.symm.trans e = refl 𝕜 P₂ := ext e.apply_symm_apply

include V V₂ V₃
@[simp] lemma coe_symm_trans (e₁ : P ≃ᵃⁱ[𝕜] P₂) (e₂ : P₂ ≃ᵃⁱ[𝕜] P₃) :
  ⇑(e₁.trans e₂).symm = e₁.symm ∘ e₂.symm :=
rfl

include V₄
lemma trans_assoc (ePP₂ : P ≃ᵃⁱ[𝕜] P₂) (eP₂G : P₂ ≃ᵃⁱ[𝕜] P₃) (eGG' : P₃ ≃ᵃⁱ[𝕜] P₄) :
  ePP₂.trans (eP₂G.trans eGG') = (ePP₂.trans eP₂G).trans eGG' :=
rfl
omit V₂ V₃ V₄

/-- The group of affine isometries of a `normed_add_torsor`, `P`. -/
instance : group (P ≃ᵃⁱ[𝕜] P) :=
{ mul := λ e₁ e₂, e₂.trans e₁,
  one := refl _ _,
  inv := symm,
  one_mul := trans_refl,
  mul_one := refl_trans,
  mul_assoc := λ _ _ _, trans_assoc _ _ _,
  mul_left_inv := self_trans_symm }

@[simp] lemma coe_one : ⇑(1 : P ≃ᵃⁱ[𝕜] P) = id := rfl
@[simp] lemma coe_mul (e e' : P ≃ᵃⁱ[𝕜] P) : ⇑(e * e') = e ∘ e' := rfl
@[simp] lemma coe_inv (e : P ≃ᵃⁱ[𝕜] P) : ⇑(e⁻¹) = e.symm := rfl

omit V

@[simp] lemma map_vadd (p : P) (v : V) : e (v +ᵥ p) = e.linear_isometry_equiv v +ᵥ e p :=
e.to_affine_isometry.map_vadd p v

@[simp] lemma map_vsub (p1 p2 : P) : e.linear_isometry_equiv (p1 -ᵥ p2) = e p1 -ᵥ e p2 :=
e.to_affine_isometry.map_vsub p1 p2

@[simp] lemma dist_map (x y : P) : dist (e x) (e y) = dist x y :=
e.to_affine_isometry.dist_map x y

@[simp] lemma edist_map (x y : P) : edist (e x) (e y) = edist x y :=
e.to_affine_isometry.edist_map x y

protected lemma bijective : bijective e := e.1.bijective
protected lemma injective : injective e := e.1.injective
protected lemma surjective : surjective e := e.1.surjective

@[simp] lemma map_eq_iff {x y : P} : e x = e y ↔ x = y := e.injective.eq_iff

lemma map_ne {x y : P} (h : x ≠ y) : e x ≠ e y := e.injective.ne h

protected lemma lipschitz : lipschitz_with 1 e := e.isometry.lipschitz

protected lemma antilipschitz : antilipschitz_with 1 e := e.isometry.antilipschitz

@[simp] lemma ediam_image (s : set P) : emetric.diam (e '' s) = emetric.diam s :=
e.isometry.ediam_image s

@[simp] lemma diam_image (s : set P) : metric.diam (e '' s) = metric.diam s :=
e.isometry.diam_image s

variables {α : Type*} [topological_space α]

@[simp] lemma comp_continuous_on_iff {f : α → P} {s : set α} :
  continuous_on (e ∘ f) s ↔ continuous_on f s :=
e.isometry.comp_continuous_on_iff

@[simp] lemma comp_continuous_iff {f : α → P} :
  continuous (e ∘ f) ↔ continuous f :=
e.isometry.comp_continuous_iff

section constructions

variables (𝕜)
/-- The map `v ↦ v +ᵥ p` as an affine isometric equivalence between `V` and `P`. -/
def vadd_const (p : P) : V ≃ᵃⁱ[𝕜] P :=
{ norm_map := λ x, rfl,
  .. affine_equiv.vadd_const 𝕜 p }
variables {𝕜}

include V
@[simp] lemma coe_vadd_const (p : P) : ⇑(vadd_const 𝕜 p) = λ v, v +ᵥ p := rfl

@[simp] lemma coe_vadd_const_symm (p : P) : ⇑(vadd_const 𝕜 p).symm = λ p', p' -ᵥ p :=
rfl

@[simp] lemma vadd_const_to_affine_equiv (p : P) :
  (vadd_const 𝕜 p).to_affine_equiv = affine_equiv.vadd_const 𝕜 p :=
rfl
omit V

variables (𝕜)
/-- `p' ↦ p -ᵥ p'` as an affine isometric equivalence. -/
def const_vsub (p : P) : P ≃ᵃⁱ[𝕜] V :=
{ norm_map := norm_neg,
  .. affine_equiv.const_vsub 𝕜 p }
variables {𝕜}

include V
@[simp] lemma coe_const_vsub (p : P) : ⇑(const_vsub 𝕜 p) = (-ᵥ) p := rfl

@[simp] lemma symm_const_vsub (p : P) :
  (const_vsub 𝕜 p).symm
  = (linear_isometry_equiv.neg 𝕜).to_affine_isometry_equiv.trans (vadd_const 𝕜 p) :=
by { ext, refl }
omit V

variables (𝕜 P)
/-- Translation by `v` (that is, the map `p ↦ v +ᵥ p`) as an affine isometric automorphism of `P`.
-/
def const_vadd (v : V) : P ≃ᵃⁱ[𝕜] P :=
{ norm_map := λ x, rfl,
  .. affine_equiv.const_vadd 𝕜 P v }
variables {𝕜 P}

@[simp] lemma coe_const_vadd (v : V) : ⇑(const_vadd 𝕜 P v : P ≃ᵃⁱ[𝕜] P) = (+ᵥ) v := rfl

@[simp] lemma const_vadd_zero : const_vadd 𝕜 P (0:V) = refl 𝕜 P := ext $ zero_vadd V

include 𝕜 V
/-- The map `g` from `V` to `V₂` corresponding to a map `f` from `P` to `P₂`, at a base point `p`,
is an isometry if `f` is one. -/
lemma vadd_vsub {f : P → P₂} (hf : isometry f) {p : P} {g : V → V₂}
  (hg : ∀ v, g v = f (v +ᵥ p) -ᵥ f p) : isometry g :=
begin
  convert (vadd_const 𝕜 (f p)).symm.isometry.comp (hf.comp (vadd_const 𝕜 p).isometry),
  exact funext hg
end
omit 𝕜

variables (𝕜)
/-- Point reflection in `x` as an affine isometric automorphism. -/
def point_reflection (x : P) : P ≃ᵃⁱ[𝕜] P := (const_vsub 𝕜 x).trans (vadd_const 𝕜 x)
variables {𝕜}

lemma point_reflection_apply (x y : P) : (point_reflection 𝕜 x) y = x -ᵥ y +ᵥ x := rfl

@[simp] lemma point_reflection_to_affine_equiv (x : P) :
  (point_reflection 𝕜 x).to_affine_equiv = affine_equiv.point_reflection 𝕜 x := rfl

@[simp] lemma point_reflection_self (x : P) : point_reflection 𝕜 x x = x :=
affine_equiv.point_reflection_self 𝕜 x

lemma point_reflection_involutive (x : P) : function.involutive (point_reflection 𝕜 x) :=
equiv.point_reflection_involutive x

@[simp] lemma point_reflection_symm (x : P) : (point_reflection 𝕜 x).symm = point_reflection 𝕜 x :=
to_affine_equiv_injective $ affine_equiv.point_reflection_symm 𝕜 x

@[simp] lemma dist_point_reflection_fixed (x y : P) :
  dist (point_reflection 𝕜 x y) x = dist y x :=
by rw [← (point_reflection 𝕜 x).dist_map y x, point_reflection_self]

lemma dist_point_reflection_self' (x y : P) :
  dist (point_reflection 𝕜 x y) y = ∥bit0 (x -ᵥ y)∥ :=
by rw [point_reflection_apply, dist_eq_norm_vsub V, vadd_vsub_assoc, bit0]

lemma dist_point_reflection_self (x y : P) :
  dist (point_reflection 𝕜 x y) y = ∥(2:𝕜)∥ * dist x y :=
by rw [dist_point_reflection_self', ← two_smul' 𝕜 (x -ᵥ y), norm_smul, ← dist_eq_norm_vsub V]

lemma point_reflection_fixed_iff [invertible (2:𝕜)] {x y : P} :
  point_reflection 𝕜 x y = y ↔ y = x :=
affine_equiv.point_reflection_fixed_iff_of_module 𝕜

variables [semi_normed_space ℝ V]

lemma dist_point_reflection_self_real (x y : P) :
  dist (point_reflection ℝ x y) y = 2 * dist x y :=
by { rw [dist_point_reflection_self, real.norm_two] }

@[simp] lemma point_reflection_midpoint_left (x y : P) :
  point_reflection ℝ (midpoint ℝ x y) x = y :=
affine_equiv.point_reflection_midpoint_left x y

@[simp] lemma point_reflection_midpoint_right (x y : P) :
  point_reflection ℝ (midpoint ℝ x y) y = x :=
affine_equiv.point_reflection_midpoint_right x y

end constructions

end affine_isometry_equiv

include V V₂

/-- If `f` is an affine map, then its linear part is continuous iff `f` is continuous. -/
lemma affine_map.continuous_linear_iff {f : P →ᵃ[𝕜] P₂} :
  continuous f.linear ↔ continuous f :=
begin
  inhabit P,
  have : (f.linear : V → V₂) =
    (affine_isometry_equiv.vadd_const 𝕜 $ f $ default P).to_homeomorph.symm ∘ f ∘
      (affine_isometry_equiv.vadd_const 𝕜 $ default P).to_homeomorph,
  { ext v, simp },
  rw this,
  simp only [homeomorph.comp_continuous_iff, homeomorph.comp_continuous_iff'],
end

/-- If `f` is an affine map, then its linear part is an open map iff `f` is an open map. -/
lemma affine_map.is_open_map_linear_iff {f : P →ᵃ[𝕜] P₂} :
  is_open_map f.linear ↔ is_open_map f :=
begin
  inhabit P,
  have : (f.linear : V → V₂) =
    (affine_isometry_equiv.vadd_const 𝕜 $ f $ default P).to_homeomorph.symm ∘ f ∘
      (affine_isometry_equiv.vadd_const 𝕜 $ default P).to_homeomorph,
  { ext v, simp },
  rw this,
  simp only [homeomorph.comp_is_open_map_iff, homeomorph.comp_is_open_map_iff'],
end


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import order.filter.basic

/-!
# Minimum and maximum w.r.t. a filter and on a aet

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

## Main Definitions

This file defines six predicates of the form `is_A_B`, where `A` is `min`, `max`, or `extr`,
and `B` is `filter` or `on`.

* `is_min_filter f l a` means that `f a ≤ f x` in some `l`-neighborhood of `a`;
* `is_max_filter f l a` means that `f x ≤ f a` in some `l`-neighborhood of `a`;
* `is_extr_filter f l a` means `is_min_filter f l a` or `is_max_filter f l a`.

Similar predicates with `_on` suffix are particular cases for `l = 𝓟 s`.

## Main statements

### Change of the filter (set) argument

* `is_*_filter.filter_mono` : replace the filter with a smaller one;
* `is_*_filter.filter_inf` : replace a filter `l` with `l ⊓ l'`;
* `is_*_on.on_subset` : restrict to a smaller set;
* `is_*_on.inter` : replace a set `s` wtih `s ∩ t`.

### Composition

* `is_*_*.comp_mono` : if `x` is an extremum for `f` and `g` is a monotone function,
  then `x` is an extremum for `g ∘ f`;
* `is_*_*.comp_antitone` : similarly for the case of antitone `g`;
* `is_*_*.bicomp_mono` : if `x` is an extremum of the same type for `f` and `g`
  and a binary operation `op` is monotone in both arguments, then `x` is an extremum
  of the same type for `λ x, op (f x) (g x)`.
* `is_*_filter.comp_tendsto` : if `g x` is an extremum for `f` w.r.t. `l'` and `tendsto g l l'`,
  then `x` is an extremum for `f ∘ g` w.r.t. `l`.
* `is_*_on.on_preimage` : if `g x` is an extremum for `f` on `s`, then `x` is an extremum
  for `f ∘ g` on `g ⁻¹' s`.

### Algebraic operations

* `is_*_*.add` : if `x` is an extremum of the same type for two functions,
  then it is an extremum of the same type for their sum;
* `is_*_*.neg` : if `x` is an extremum for `f`, then it is an extremum
  of the opposite type for `-f`;
* `is_*_*.sub` : if `x` is an a minimum for `f` and a maximum for `g`,
  then it is a minimum for `f - g` and a maximum for `g - f`;
* `is_*_*.max`, `is_*_*.min`, `is_*_*.sup`, `is_*_*.inf` : similarly for `is_*_*.add`
  for pointwise `max`, `min`, `sup`, `inf`, respectively.

### Miscellaneous definitions

* `is_*_*_const` : any point is both a minimum and maximum for a constant function;
* `is_min/max_*.is_ext` : any minimum/maximum point is an extremum;
* `is_*_*.dual`, `is_*_*.undual`: conversion between codomains `α` and `dual α`;

## Missing features (TODO)

* Multiplication and division;
* `is_*_*.bicompl` : if `x` is a minimum for `f`, `y` is a minimum for `g`, and `op` is a monotone
  binary operation, then `(x, y)` is a minimum for `uncurry (bicompl op f g)`. From this point
  of view, `is_*_*.bicomp` is a composition
* It would be nice to have a tactic that specializes `comp_(anti)mono` or `bicomp_mono`
  based on a proof of monotonicity of a given (binary) function. The tactic should maintain a `meta`
  list of known (anti)monotone (binary) functions with their names, as well as a list of special
  types of filters, and define the missing lemmas once one of these two lists grows.
-/

universes u v w x

variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type x}

open set filter
open_locale filter

section preorder

variables [preorder β] [preorder γ]

variables (f : α → β) (s : set α) (l : filter α) (a : α)

/-! ### Definitions -/

/-- `is_min_filter f l a` means that `f a ≤ f x` in some `l`-neighborhood of `a` -/
def is_min_filter : Prop := ∀ᶠ x in l, f a ≤ f x

/-- `is_max_filter f l a` means that `f x ≤ f a` in some `l`-neighborhood of `a` -/
def is_max_filter : Prop := ∀ᶠ x in l, f x ≤ f a

/-- `is_extr_filter f l a` means `is_min_filter f l a` or `is_max_filter f l a` -/
def is_extr_filter : Prop := is_min_filter f l a ∨ is_max_filter f l a

/-- `is_min_on f s a` means that `f a ≤ f x` for all `x ∈ a`. Note that we do not assume `a ∈ s`. -/
def is_min_on := is_min_filter f (𝓟 s) a

/-- `is_max_on f s a` means that `f x ≤ f a` for all `x ∈ a`. Note that we do not assume `a ∈ s`. -/
def is_max_on := is_max_filter f (𝓟 s) a

/-- `is_extr_on f s a` means `is_min_on f s a` or `is_max_on f s a` -/
def is_extr_on : Prop := is_extr_filter f (𝓟 s) a

variables {f s a l} {t : set α} {l' : filter α}

lemma is_extr_on.elim {p : Prop} :
  is_extr_on f s a → (is_min_on f s a → p) → (is_max_on f s a → p) → p :=
or.elim

lemma is_min_on_iff : is_min_on f s a ↔ ∀ x ∈ s, f a ≤ f x := iff.rfl

lemma is_max_on_iff : is_max_on f s a ↔ ∀ x ∈ s, f x ≤ f a := iff.rfl

lemma is_min_on_univ_iff : is_min_on f univ a ↔ ∀ x, f a ≤ f x :=
univ_subset_iff.trans eq_univ_iff_forall

lemma is_max_on_univ_iff : is_max_on f univ a ↔ ∀ x, f x ≤ f a :=
univ_subset_iff.trans eq_univ_iff_forall

lemma is_min_filter.tendsto_principal_Ici (h : is_min_filter f l a) :
  tendsto f l (𝓟 $ Ici (f a)) :=
tendsto_principal.2 h

lemma is_max_filter.tendsto_principal_Iic (h : is_max_filter f l a) :
  tendsto f l (𝓟 $ Iic (f a)) :=
tendsto_principal.2 h

/-! ### Conversion to `is_extr_*` -/

lemma is_min_filter.is_extr : is_min_filter f l a → is_extr_filter f l a := or.inl

lemma is_max_filter.is_extr : is_max_filter f l a → is_extr_filter f l a := or.inr

lemma is_min_on.is_extr (h : is_min_on f s a) : is_extr_on f s a := h.is_extr

lemma is_max_on.is_extr (h : is_max_on f s a) : is_extr_on f s a := h.is_extr

/-! ### Constant function -/

lemma is_min_filter_const {b : β} : is_min_filter (λ _, b) l a :=
univ_mem' $ λ _, le_rfl

lemma is_max_filter_const {b : β} : is_max_filter (λ _, b) l a :=
univ_mem' $ λ _, le_rfl

lemma is_extr_filter_const {b : β} : is_extr_filter (λ _, b) l a := is_min_filter_const.is_extr

lemma is_min_on_const {b : β} : is_min_on (λ _, b) s a := is_min_filter_const

lemma is_max_on_const {b : β} : is_max_on (λ _, b) s a := is_max_filter_const

lemma is_extr_on_const {b : β} : is_extr_on (λ _, b) s a := is_extr_filter_const

/-! ### Order dual -/

open order_dual (to_dual)

lemma is_min_filter_dual_iff : is_min_filter (to_dual ∘ f) l a ↔ is_max_filter f l a :=
iff.rfl

lemma is_max_filter_dual_iff : is_max_filter (to_dual ∘ f) l a ↔ is_min_filter f l a :=
iff.rfl

lemma is_extr_filter_dual_iff : is_extr_filter (to_dual ∘ f) l a ↔ is_extr_filter f l a :=
or_comm _ _

alias is_min_filter_dual_iff ↔ is_min_filter.undual is_max_filter.dual
alias is_max_filter_dual_iff ↔ is_max_filter.undual is_min_filter.dual
alias is_extr_filter_dual_iff ↔ is_extr_filter.undual is_extr_filter.dual

lemma is_min_on_dual_iff : is_min_on (to_dual ∘ f) s a ↔ is_max_on f s a := iff.rfl
lemma is_max_on_dual_iff : is_max_on (to_dual ∘ f) s a ↔ is_min_on f s a := iff.rfl
lemma is_extr_on_dual_iff : is_extr_on (to_dual ∘ f) s a ↔ is_extr_on f s a := or_comm _ _

alias is_min_on_dual_iff ↔ is_min_on.undual is_max_on.dual
alias is_max_on_dual_iff ↔ is_max_on.undual is_min_on.dual
alias is_extr_on_dual_iff ↔ is_extr_on.undual is_extr_on.dual

/-! ### Operations on the filter/set -/

lemma is_min_filter.filter_mono (h : is_min_filter f l a) (hl : l' ≤ l) :
  is_min_filter f l' a := hl h

lemma is_max_filter.filter_mono (h : is_max_filter f l a) (hl : l' ≤ l) :
  is_max_filter f l' a := hl h

lemma is_extr_filter.filter_mono (h : is_extr_filter f l a) (hl : l' ≤ l) :
  is_extr_filter f l' a :=
h.elim (λ h, (h.filter_mono hl).is_extr) (λ h, (h.filter_mono hl).is_extr)

lemma is_min_filter.filter_inf (h : is_min_filter f l a) (l') : is_min_filter f (l ⊓ l') a :=
h.filter_mono inf_le_left

lemma is_max_filter.filter_inf (h : is_max_filter f l a) (l') : is_max_filter f (l ⊓ l') a :=
h.filter_mono inf_le_left

lemma is_extr_filter.filter_inf (h : is_extr_filter f l a) (l') : is_extr_filter f (l ⊓ l') a :=
h.filter_mono inf_le_left

lemma is_min_on.on_subset (hf : is_min_on f t a) (h : s ⊆ t) : is_min_on f s a :=
hf.filter_mono $ principal_mono.2 h

lemma is_max_on.on_subset (hf : is_max_on f t a) (h : s ⊆ t) : is_max_on f s a :=
hf.filter_mono $ principal_mono.2 h

lemma is_extr_on.on_subset (hf : is_extr_on f t a) (h : s ⊆ t) : is_extr_on f s a :=
hf.filter_mono $ principal_mono.2 h

lemma is_min_on.inter (hf : is_min_on f s a) (t) : is_min_on f (s ∩ t) a :=
hf.on_subset (inter_subset_left s t)

lemma is_max_on.inter (hf : is_max_on f s a) (t) : is_max_on f (s ∩ t) a :=
hf.on_subset (inter_subset_left s t)

lemma is_extr_on.inter (hf : is_extr_on f s a) (t) : is_extr_on f (s ∩ t) a :=
hf.on_subset (inter_subset_left s t)

/-! ### Composition with (anti)monotone functions -/

lemma is_min_filter.comp_mono (hf : is_min_filter f l a) {g : β → γ} (hg : monotone g) :
  is_min_filter (g ∘ f) l a :=
mem_of_superset hf $ λ x hx, hg hx

lemma is_max_filter.comp_mono (hf : is_max_filter f l a) {g : β → γ} (hg : monotone g) :
  is_max_filter (g ∘ f) l a :=
mem_of_superset hf $ λ x hx, hg hx

lemma is_extr_filter.comp_mono (hf : is_extr_filter f l a) {g : β → γ} (hg : monotone g) :
  is_extr_filter (g ∘ f) l a :=
hf.elim (λ hf, (hf.comp_mono hg).is_extr)  (λ hf, (hf.comp_mono hg).is_extr)

lemma is_min_filter.comp_antitone (hf : is_min_filter f l a) {g : β → γ}
  (hg : antitone g) :
  is_max_filter (g ∘ f) l a :=
hf.dual.comp_mono (λ x y h, hg h)

lemma is_max_filter.comp_antitone (hf : is_max_filter f l a) {g : β → γ}
  (hg : antitone g) :
  is_min_filter (g ∘ f) l a :=
hf.dual.comp_mono (λ x y h, hg h)

lemma is_extr_filter.comp_antitone (hf : is_extr_filter f l a) {g : β → γ}
  (hg : antitone g) :
  is_extr_filter (g ∘ f) l a :=
hf.dual.comp_mono (λ x y h, hg h)

lemma is_min_on.comp_mono (hf : is_min_on f s a) {g : β → γ} (hg : monotone g) :
  is_min_on (g ∘ f) s a :=
hf.comp_mono hg

lemma is_max_on.comp_mono (hf : is_max_on f s a) {g : β → γ} (hg : monotone g) :
  is_max_on (g ∘ f) s a :=
hf.comp_mono hg

lemma is_extr_on.comp_mono (hf : is_extr_on f s a) {g : β → γ} (hg : monotone g) :
  is_extr_on (g ∘ f) s a :=
hf.comp_mono hg

lemma is_min_on.comp_antitone (hf : is_min_on f s a) {g : β → γ}
  (hg : antitone g) :
  is_max_on (g ∘ f) s a :=
hf.comp_antitone hg

lemma is_max_on.comp_antitone (hf : is_max_on f s a) {g : β → γ}
  (hg : antitone g) :
  is_min_on (g ∘ f) s a :=
hf.comp_antitone hg

lemma is_extr_on.comp_antitone (hf : is_extr_on f s a) {g : β → γ}
  (hg : antitone g) :
  is_extr_on (g ∘ f) s a :=
hf.comp_antitone hg

lemma is_min_filter.bicomp_mono [preorder δ] {op : β → γ → δ} (hop : ((≤) ⇒ (≤) ⇒ (≤)) op op)
  (hf : is_min_filter f l a) {g : α → γ} (hg : is_min_filter g l a) :
  is_min_filter (λ x, op (f x) (g x)) l a :=
mem_of_superset (inter_mem hf hg) $ λ x ⟨hfx, hgx⟩, hop hfx hgx

lemma is_max_filter.bicomp_mono [preorder δ] {op : β → γ → δ} (hop : ((≤) ⇒ (≤) ⇒ (≤)) op op)
  (hf : is_max_filter f l a) {g : α → γ} (hg : is_max_filter g l a) :
  is_max_filter (λ x, op (f x) (g x)) l a :=
mem_of_superset (inter_mem hf hg) $ λ x ⟨hfx, hgx⟩, hop hfx hgx

-- No `extr` version because we need `hf` and `hg` to be of the same kind

lemma is_min_on.bicomp_mono [preorder δ] {op : β → γ → δ} (hop : ((≤) ⇒ (≤) ⇒ (≤)) op op)
  (hf : is_min_on f s a) {g : α → γ} (hg : is_min_on g s a) :
  is_min_on (λ x, op (f x) (g x)) s a :=
hf.bicomp_mono hop hg

lemma is_max_on.bicomp_mono [preorder δ] {op : β → γ → δ} (hop : ((≤) ⇒ (≤) ⇒ (≤)) op op)
  (hf : is_max_on f s a) {g : α → γ} (hg : is_max_on g s a) :
  is_max_on (λ x, op (f x) (g x)) s a :=
hf.bicomp_mono hop hg

/-! ### Composition with `tendsto` -/

lemma is_min_filter.comp_tendsto {g : δ → α} {l' : filter δ} {b : δ} (hf : is_min_filter f l (g b))
  (hg : tendsto g l' l) :
  is_min_filter (f ∘ g) l' b :=
hg hf

lemma is_max_filter.comp_tendsto {g : δ → α} {l' : filter δ} {b : δ} (hf : is_max_filter f l (g b))
  (hg : tendsto g l' l) :
  is_max_filter (f ∘ g) l' b :=
hg hf

lemma is_extr_filter.comp_tendsto {g : δ → α} {l' : filter δ} {b : δ}
  (hf : is_extr_filter f l (g b)) (hg : tendsto g l' l) :
  is_extr_filter (f ∘ g) l' b :=
hf.elim (λ hf, (hf.comp_tendsto hg).is_extr) (λ hf, (hf.comp_tendsto hg).is_extr)

lemma is_min_on.on_preimage (g : δ → α) {b : δ} (hf : is_min_on f s (g b)) :
  is_min_on (f ∘ g) (g ⁻¹' s) b :=
hf.comp_tendsto (tendsto_principal_principal.mpr $ subset.refl _)

lemma is_max_on.on_preimage (g : δ → α) {b : δ} (hf : is_max_on f s (g b)) :
  is_max_on (f ∘ g) (g ⁻¹' s) b :=
hf.comp_tendsto (tendsto_principal_principal.mpr $ subset.refl _)

lemma is_extr_on.on_preimage (g : δ → α) {b : δ} (hf : is_extr_on f s (g b)) :
  is_extr_on (f ∘ g) (g ⁻¹' s) b :=
hf.elim (λ hf, (hf.on_preimage g).is_extr) (λ hf, (hf.on_preimage g).is_extr)

lemma is_min_on.comp_maps_to {t : set δ} {g : δ → α} {b : δ} (hf : is_min_on f s a)
  (hg : maps_to g t s) (ha : g b = a) :
  is_min_on (f ∘ g) t b :=
λ y hy, by simpa only [mem_set_of_eq, ha, (∘)] using hf (hg hy)

lemma is_max_on.comp_maps_to {t : set δ} {g : δ → α} {b : δ} (hf : is_max_on f s a)
  (hg : maps_to g t s) (ha : g b = a) :
  is_max_on (f ∘ g) t b :=
hf.dual.comp_maps_to hg ha

lemma is_extr_on.comp_maps_to {t : set δ} {g : δ → α} {b : δ} (hf : is_extr_on f s a)
  (hg : maps_to g t s) (ha : g b = a) :
  is_extr_on (f ∘ g) t b :=
hf.elim (λ h, or.inl $ h.comp_maps_to hg ha) (λ h, or.inr $ h.comp_maps_to hg ha)

end preorder

/-! ### Pointwise addition -/
section ordered_add_comm_monoid

variables [ordered_add_comm_monoid β] {f g : α → β} {a : α} {s : set α} {l : filter α}

lemma is_min_filter.add (hf : is_min_filter f l a) (hg : is_min_filter g l a) :
  is_min_filter (λ x, f x + g x) l a :=
show is_min_filter (λ x, f x + g x) l a,
from hf.bicomp_mono (λ x x' hx y y' hy, add_le_add hx hy) hg

lemma is_max_filter.add (hf : is_max_filter f l a) (hg : is_max_filter g l a) :
  is_max_filter (λ x, f x + g x) l a :=
show is_max_filter (λ x, f x + g x) l a,
from hf.bicomp_mono (λ x x' hx y y' hy, add_le_add hx hy) hg

lemma is_min_on.add (hf : is_min_on f s a) (hg : is_min_on g s a) :
  is_min_on (λ x, f x + g x) s a :=
hf.add hg

lemma is_max_on.add (hf : is_max_on f s a) (hg : is_max_on g s a) :
  is_max_on (λ x, f x + g x) s a :=
hf.add hg

end ordered_add_comm_monoid

/-! ### Pointwise negation and subtraction -/

section ordered_add_comm_group

variables [ordered_add_comm_group β] {f g : α → β} {a : α} {s : set α} {l : filter α}

lemma is_min_filter.neg (hf : is_min_filter f l a) : is_max_filter (λ x, -f x) l a :=
hf.comp_antitone (λ x y hx, neg_le_neg hx)

lemma is_max_filter.neg (hf : is_max_filter f l a) : is_min_filter (λ x, -f x) l a :=
hf.comp_antitone (λ x y hx, neg_le_neg hx)

lemma is_extr_filter.neg (hf : is_extr_filter f l a) : is_extr_filter (λ x, -f x) l a :=
hf.elim (λ hf, hf.neg.is_extr) (λ hf, hf.neg.is_extr)

lemma is_min_on.neg (hf : is_min_on f s a) : is_max_on (λ x, -f x) s a :=
hf.comp_antitone (λ x y hx, neg_le_neg hx)

lemma is_max_on.neg (hf : is_max_on f s a) : is_min_on (λ x, -f x) s a :=
hf.comp_antitone (λ x y hx, neg_le_neg hx)

lemma is_extr_on.neg (hf : is_extr_on f s a) : is_extr_on (λ x, -f x) s a :=
hf.elim (λ hf, hf.neg.is_extr) (λ hf, hf.neg.is_extr)

lemma is_min_filter.sub (hf : is_min_filter f l a) (hg : is_max_filter g l a) :
  is_min_filter (λ x, f x - g x) l a :=
by simpa only [sub_eq_add_neg] using hf.add hg.neg

lemma is_max_filter.sub (hf : is_max_filter f l a) (hg : is_min_filter g l a) :
  is_max_filter (λ x, f x - g x) l a :=
by simpa only [sub_eq_add_neg] using hf.add hg.neg

lemma is_min_on.sub (hf : is_min_on f s a) (hg : is_max_on g s a) :
  is_min_on (λ x, f x - g x) s a :=
by simpa only [sub_eq_add_neg] using hf.add hg.neg

lemma is_max_on.sub (hf : is_max_on f s a) (hg : is_min_on g s a) :
  is_max_on (λ x, f x - g x) s a :=
by simpa only [sub_eq_add_neg] using hf.add hg.neg

end ordered_add_comm_group

/-! ### Pointwise `sup`/`inf` -/

section semilattice_sup

variables [semilattice_sup β] {f g : α → β} {a : α} {s : set α} {l : filter α}

lemma is_min_filter.sup (hf : is_min_filter f l a) (hg : is_min_filter g l a) :
  is_min_filter (λ x, f x ⊔ g x) l a :=
show is_min_filter (λ x, f x ⊔ g x) l a,
from hf.bicomp_mono (λ x x' hx y y' hy, sup_le_sup hx hy) hg

lemma is_max_filter.sup (hf : is_max_filter f l a) (hg : is_max_filter g l a) :
  is_max_filter (λ x, f x ⊔ g x) l a :=
show is_max_filter (λ x, f x ⊔ g x) l a,
from hf.bicomp_mono (λ x x' hx y y' hy, sup_le_sup hx hy) hg

lemma is_min_on.sup (hf : is_min_on f s a) (hg : is_min_on g s a) :
  is_min_on (λ x, f x ⊔ g x) s a :=
hf.sup hg

lemma is_max_on.sup (hf : is_max_on f s a) (hg : is_max_on g s a) :
  is_max_on (λ x, f x ⊔ g x) s a :=
hf.sup hg

end semilattice_sup

section semilattice_inf

variables [semilattice_inf β] {f g : α → β} {a : α} {s : set α} {l : filter α}

lemma is_min_filter.inf (hf : is_min_filter f l a) (hg : is_min_filter g l a) :
  is_min_filter (λ x, f x ⊓ g x) l a :=
show is_min_filter (λ x, f x ⊓ g x) l a,
from hf.bicomp_mono (λ x x' hx y y' hy, inf_le_inf hx hy) hg

lemma is_max_filter.inf (hf : is_max_filter f l a) (hg : is_max_filter g l a) :
  is_max_filter (λ x, f x ⊓ g x) l a :=
show is_max_filter (λ x, f x ⊓ g x) l a,
from hf.bicomp_mono (λ x x' hx y y' hy, inf_le_inf hx hy) hg

lemma is_min_on.inf (hf : is_min_on f s a) (hg : is_min_on g s a) :
  is_min_on (λ x, f x ⊓ g x) s a :=
hf.inf hg

lemma is_max_on.inf (hf : is_max_on f s a) (hg : is_max_on g s a) :
  is_max_on (λ x, f x ⊓ g x) s a :=
hf.inf hg

end semilattice_inf

/-! ### Pointwise `min`/`max` -/

section linear_order

variables [linear_order β] {f g : α → β} {a : α} {s : set α} {l : filter α}

lemma is_min_filter.min (hf : is_min_filter f l a) (hg : is_min_filter g l a) :
  is_min_filter (λ x, min (f x) (g x)) l a :=
show is_min_filter (λ x, min (f x) (g x)) l a,
from hf.bicomp_mono (λ x x' hx y y' hy, min_le_min hx hy) hg

lemma is_max_filter.min (hf : is_max_filter f l a) (hg : is_max_filter g l a) :
  is_max_filter (λ x, min (f x) (g x)) l a :=
show is_max_filter (λ x, min (f x) (g x)) l a,
from hf.bicomp_mono (λ x x' hx y y' hy, min_le_min hx hy) hg

lemma is_min_on.min (hf : is_min_on f s a) (hg : is_min_on g s a) :
  is_min_on (λ x, min (f x) (g x)) s a :=
hf.min hg

lemma is_max_on.min (hf : is_max_on f s a) (hg : is_max_on g s a) :
  is_max_on (λ x, min (f x) (g x)) s a :=
hf.min hg

lemma is_min_filter.max (hf : is_min_filter f l a) (hg : is_min_filter g l a) :
  is_min_filter (λ x, max (f x) (g x)) l a :=
show is_min_filter (λ x, max (f x) (g x)) l a,
from hf.bicomp_mono (λ x x' hx y y' hy, max_le_max hx hy) hg

lemma is_max_filter.max (hf : is_max_filter f l a) (hg : is_max_filter g l a) :
  is_max_filter (λ x, max (f x) (g x)) l a :=
show is_max_filter (λ x, max (f x) (g x)) l a,
from hf.bicomp_mono (λ x x' hx y y' hy, max_le_max hx hy) hg

lemma is_min_on.max (hf : is_min_on f s a) (hg : is_min_on g s a) :
  is_min_on (λ x, max (f x) (g x)) s a :=
hf.max hg

lemma is_max_on.max (hf : is_max_on f s a) (hg : is_max_on g s a) :
  is_max_on (λ x, max (f x) (g x)) s a :=
hf.max hg

end linear_order

section eventually

/-! ### Relation with `eventually` comparisons of two functions -/

lemma filter.eventually_le.is_max_filter {α β : Type*} [preorder β] {f g : α → β} {a : α}
  {l : filter α} (hle : g ≤ᶠ[l] f) (hfga : f a = g a) (h : is_max_filter f l a) :
  is_max_filter g l a :=
begin
  refine hle.mp (h.mono $ λ x hf hgf, _),
  rw ← hfga,
  exact le_trans hgf hf
end

lemma is_max_filter.congr {α β : Type*} [preorder β] {f g : α → β} {a : α} {l : filter α}
  (h : is_max_filter f l a) (heq : f =ᶠ[l] g) (hfga : f a = g a) :
  is_max_filter g l a :=
heq.symm.le.is_max_filter hfga h

lemma filter.eventually_eq.is_max_filter_iff {α β : Type*} [preorder β] {f g : α → β} {a : α}
  {l : filter α} (heq : f =ᶠ[l] g) (hfga : f a = g a) :
  is_max_filter f l a ↔ is_max_filter g l a :=
⟨λ h, h.congr heq hfga, λ h, h.congr heq.symm hfga.symm⟩

lemma filter.eventually_le.is_min_filter {α β : Type*} [preorder β] {f g : α → β} {a : α}
  {l : filter α} (hle : f ≤ᶠ[l] g) (hfga : f a = g a) (h : is_min_filter f l a) :
  is_min_filter g l a :=
@filter.eventually_le.is_max_filter _ βᵒᵈ _ _ _ _ _ hle hfga h

lemma is_min_filter.congr {α β : Type*} [preorder β] {f g : α → β} {a : α} {l : filter α}
  (h : is_min_filter f l a) (heq : f =ᶠ[l] g) (hfga : f a = g a) :
  is_min_filter g l a :=
heq.le.is_min_filter hfga h

lemma filter.eventually_eq.is_min_filter_iff {α β : Type*} [preorder β] {f g : α → β} {a : α}
  {l : filter α} (heq : f =ᶠ[l] g) (hfga : f a = g a) :
  is_min_filter f l a ↔ is_min_filter g l a :=
⟨λ h, h.congr heq hfga, λ h, h.congr heq.symm hfga.symm⟩

lemma is_extr_filter.congr {α β : Type*} [preorder β] {f g : α → β} {a : α} {l : filter α}
  (h : is_extr_filter f l a) (heq : f =ᶠ[l] g) (hfga : f a = g a) :
  is_extr_filter g l a :=
begin
  rw is_extr_filter at *,
  rwa [← heq.is_max_filter_iff hfga, ← heq.is_min_filter_iff hfga],
end

lemma filter.eventually_eq.is_extr_filter_iff {α β : Type*} [preorder β] {f g : α → β} {a : α}
  {l : filter α} (heq : f =ᶠ[l] g) (hfga : f a = g a) :
  is_extr_filter f l a ↔ is_extr_filter g l a :=
⟨λ h, h.congr heq hfga, λ h, h.congr heq.symm hfga.symm⟩

end eventually

/-! ### `is_max_on`/`is_min_on` imply `csupr`/`cinfi` -/

section conditionally_complete_linear_order
variables [conditionally_complete_linear_order α] {f : β → α} {s : set β} {x₀ : β}

lemma is_max_on.supr_eq (hx₀ : x₀ ∈ s) (h : is_max_on f s x₀) :
  (⨆ x : s, f x) = f x₀ :=
begin
  haveI : nonempty s := ⟨⟨x₀, hx₀⟩⟩,
  exact csupr_eq_of_forall_le_of_forall_lt_exists_gt (λ x, h x.prop) (λ w hw, ⟨⟨x₀, hx₀⟩, hw⟩),
end

lemma is_min_on.infi_eq (hx₀ : x₀ ∈ s) (h : is_min_on f s x₀) : (⨅ x : s, f x) = f x₀ :=
@is_max_on.supr_eq αᵒᵈ β _ _ _ _ hx₀ h

end conditionally_complete_linear_order


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import geometry.manifold.diffeomorph
import geometry.manifold.instances.real
import geometry.manifold.partition_of_unity

/-!
# Whitney embedding theorem

In this file we prove a version of the Whitney embedding theorem: for any compact real manifold `M`,
for sufficiently large `n` there exists a smooth embedding `M → ℝ^n`.

## TODO

* Prove the weak Whitney embedding theorem: any `σ`-compact smooth `m`-dimensional manifold can be
  embedded into `ℝ^(2m+1)`. This requires a version of Sard's theorem: for a locally Lipschitz
  continuous map `f : ℝ^m → ℝ^n`, `m < n`, the range has Hausdorff dimension at most `m`, hence it
  has measure zero.

## Tags

partition of unity, smooth bump function, whitney theorem
-/

universes uι uE uH uM
variables {ι : Type uι}
{E : Type uE} [normed_group E] [normed_space ℝ E] [finite_dimensional ℝ E]
{H : Type uH} [topological_space H] {I : model_with_corners ℝ E H}
{M : Type uM} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]

open function filter finite_dimensional set
open_locale topological_space manifold classical filter big_operators

noncomputable theory

namespace smooth_bump_covering

/-!
### Whitney embedding theorem

In this section we prove a version of the Whitney embedding theorem: for any compact real manifold
`M`, for sufficiently large `n` there exists a smooth embedding `M → ℝ^n`.
-/

variables [t2_space M] [fintype ι] {s : set M} (f : smooth_bump_covering ι I M s)

/-- Smooth embedding of `M` into `(E × ℝ) ^ ι`. -/
def embedding_pi_tangent : C^∞⟮I, M; 𝓘(ℝ, ι → (E × ℝ)), ι → (E × ℝ)⟯ :=
{ to_fun := λ x i, (f i x • ext_chart_at I (f.c i) x, f i x),
  times_cont_mdiff_to_fun := times_cont_mdiff_pi_space.2 $ λ i,
    ((f i).smooth_smul times_cont_mdiff_on_ext_chart_at).prod_mk_space ((f i).smooth) }

local attribute [simp] lemma embedding_pi_tangent_coe :
  ⇑f.embedding_pi_tangent = λ x i, (f i x • ext_chart_at I (f.c i) x, f i x) :=
rfl

lemma embedding_pi_tangent_inj_on : inj_on f.embedding_pi_tangent s :=
begin
  intros x hx y hy h,
  simp only [embedding_pi_tangent_coe, funext_iff] at h,
  obtain ⟨h₁, h₂⟩ := prod.mk.inj_iff.1 (h (f.ind x hx)),
  rw [f.apply_ind x hx] at h₂,
  rw [← h₂, f.apply_ind x hx, one_smul, one_smul] at h₁,
  have := f.mem_ext_chart_at_source_of_eq_one h₂.symm,
  exact (ext_chart_at I (f.c _)).inj_on (f.mem_ext_chart_at_ind_source x hx) this h₁
end

lemma embedding_pi_tangent_injective (f : smooth_bump_covering ι I M) :
  injective f.embedding_pi_tangent :=
injective_iff_inj_on_univ.2 f.embedding_pi_tangent_inj_on

lemma comp_embedding_pi_tangent_mfderiv (x : M) (hx : x ∈ s) :
  ((continuous_linear_map.fst ℝ E ℝ).comp
    (@continuous_linear_map.proj ℝ _ ι (λ _, E × ℝ) _ _
      (λ _, infer_instance) (f.ind x hx))).comp
      (mfderiv I 𝓘(ℝ, ι → (E × ℝ)) f.embedding_pi_tangent x) =
  mfderiv I I (chart_at H (f.c (f.ind x hx))) x :=
begin
  set L := ((continuous_linear_map.fst ℝ E ℝ).comp
    (@continuous_linear_map.proj ℝ _ ι (λ _, E × ℝ) _ _ (λ _, infer_instance) (f.ind x hx))),
  have := L.has_mfderiv_at.comp x f.embedding_pi_tangent.mdifferentiable_at.has_mfderiv_at,
  convert has_mfderiv_at_unique this _,
  refine (has_mfderiv_at_ext_chart_at I (f.mem_chart_at_ind_source x hx)).congr_of_eventually_eq _,
  refine (f.eventually_eq_one x hx).mono (λ y hy, _),
  simp only [embedding_pi_tangent_coe, continuous_linear_map.coe_comp', (∘),
    continuous_linear_map.coe_fst', continuous_linear_map.proj_apply],
  rw [hy, pi.one_apply, one_smul]
end

lemma embedding_pi_tangent_ker_mfderiv (x : M) (hx : x ∈ s) :
  (mfderiv I 𝓘(ℝ, ι → (E × ℝ)) f.embedding_pi_tangent x).ker = ⊥ :=
begin
  apply bot_unique,
  rw [← (mdifferentiable_chart I (f.c (f.ind x hx))).ker_mfderiv_eq_bot
    (f.mem_chart_at_ind_source x hx), ← comp_embedding_pi_tangent_mfderiv],
  exact linear_map.ker_le_ker_comp _ _
end

lemma embedding_pi_tangent_injective_mfderiv (x : M) (hx : x ∈ s) :
  injective (mfderiv I 𝓘(ℝ, ι → (E × ℝ)) f.embedding_pi_tangent x) :=
linear_map.ker_eq_bot.1 (f.embedding_pi_tangent_ker_mfderiv x hx)

/-- Baby version of the Whitney weak embedding theorem: if `M` admits a finite covering by
supports of bump functions, then for some `n` it can be immersed into the `n`-dimensional
Euclidean space. -/
lemma exists_immersion_euclidean (f : smooth_bump_covering ι I M) :
  ∃ (n : ℕ) (e : M → euclidean_space ℝ (fin n)), smooth I (𝓡 n) e ∧
    injective e ∧ ∀ x : M, injective (mfderiv I (𝓡 n) e x) :=
begin
  set F := euclidean_space ℝ (fin $ finrank ℝ (ι → (E × ℝ))),
  letI : is_noetherian ℝ (E × ℝ) := is_noetherian.iff_fg.2 infer_instance,
  letI : finite_dimensional ℝ (ι → E × ℝ) := is_noetherian.iff_fg.1 infer_instance,
  set eEF : (ι → (E × ℝ)) ≃L[ℝ] F :=
    continuous_linear_equiv.of_finrank_eq finrank_euclidean_space_fin.symm,
  refine ⟨_, eEF ∘ f.embedding_pi_tangent,
    eEF.to_diffeomorph.smooth.comp f.embedding_pi_tangent.smooth,
    eEF.injective.comp f.embedding_pi_tangent_injective, λ x, _⟩,
  rw [mfderiv_comp _ eEF.differentiable_at.mdifferentiable_at
    f.embedding_pi_tangent.mdifferentiable_at, eEF.mfderiv_eq],
  exact eEF.injective.comp (f.embedding_pi_tangent_injective_mfderiv _ trivial)
end

end smooth_bump_covering

/-- Baby version of the Whitney weak embedding theorem: if `M` admits a finite covering by
supports of bump functions, then for some `n` it can be embedded into the `n`-dimensional
Euclidean space. -/
lemma exists_embedding_euclidean_of_compact [t2_space M] [compact_space M] :
  ∃ (n : ℕ) (e : M → euclidean_space ℝ (fin n)), smooth I (𝓡 n) e ∧
    closed_embedding e ∧ ∀ x : M, injective (mfderiv I (𝓡 n) e x) :=
begin
  rcases smooth_bump_covering.exists_is_subordinate I is_closed_univ (λ (x : M) _, univ_mem)
    with ⟨ι, f, -⟩,
  haveI := f.fintype,
  rcases f.exists_immersion_euclidean with ⟨n, e, hsmooth, hinj, hinj_mfderiv⟩,
  exact ⟨n, e, hsmooth, hsmooth.continuous.closed_embedding hinj, hinj_mfderiv⟩
end


-- This module defines
namespace Nat

-- `forallRange i n f` is true if f holds for all indices j from i to n-1.
def forallRange (i:Nat) (n:Nat) (f: ∀(j:Nat), j < n → Bool) : Bool :=
  if h:i < n then
    f i h && forallRange (i+1) n f
  else
    true
  termination_by forallRange i n f => n-i

-- `forallRange` correctness theorem.
theorem forallRangeImplies'
  (n i j : Nat)
  (f  : ∀(k:Nat), k < n → Bool)
  (eq : i+j = n)
  (p  : forallRange i n f = true)
  (k  : Nat)
  (lb : i ≤ k)
  (ub : k < n)
  : f k ub = true := by
  revert i
  induction j  with
  | zero =>
    intro i eq p lb
    simp at eq
    simp [eq] at lb
    have pr := Nat.not_le_of_gt ub
    contradiction
  | succ j ind =>
    intros i n_eq ltPred lb
    have i_lt_n : i < n := Nat.le_trans (Nat.succ_le_succ lb) ub
    unfold forallRange at ltPred
    simp [i_lt_n] at ltPred
    cases Nat.eq_or_lt_of_le lb with
    | inl hEq =>
      apply Eq.subst
      apply ltPred.left
      simp only [hEq]
    | inr hLt =>
      have succ_i_add_j : succ i + j = n := by
        simp [Nat.succ_add]
        exact n_eq
      apply ind (succ i) succ_i_add_j ltPred.right hLt

-- Correctness theorem for `forallRange`
theorem forallRangeImplies (p:forallRange i n f = true) {j:Nat} (lb:i ≤ j) (ub : j < n)
  : f j ub = true :=
    let h : i+(n-i)=n := Nat.add_sub_of_le (Nat.le_trans lb (Nat.le_of_lt ub))
    forallRangeImplies' n i (n-i) f h p j lb ub

theorem lt_or_eq_of_succ {i j:Nat} (lt : i < Nat.succ j) : i < j ∨ i = j :=
  match lt with
  | Nat.le.step m => Or.inl m
  | Nat.le.refl => Or.inr rfl

-- Introduce strong induction principal for natural numbers.
theorem strong_induction_on {p : Nat → Prop} (n:Nat)
  (h:∀n, (∀ m, m < n → p m) → p n) : p n := by
    suffices ∀n m, m < n → p m from this (succ n) n (Nat.lt_succ_self _)
    intros n
    induction n with
    | zero =>
      intros m h
      contradiction
    | succ i ind =>
      intros m h1
      cases Nat.lt_or_eq_of_succ h1 with
      | inl is_lt =>
        apply ind _ is_lt
      | inr is_eq =>
        apply h
        rw [is_eq]
        apply ind

end Nat

-- Introduce strong induction principal for Fin.
theorem Fin.strong_induction_on {P : Fin w → Prop} (i:Fin w)
  (ind : ∀(i:Fin w), (∀(j:Fin w), j < i → P j) → P i)
 : P i := by
   cases i with
   | mk i i_lt =>
     revert i_lt
     apply @Nat.strong_induction_on (λi => ∀ (i_lt : i < w), P { val := i, isLt := i_lt })
     intros j p j_lt_w
     apply ind ⟨j, j_lt_w⟩
     intros z z_lt_j
     apply p _ z_lt_j

namespace PEG

inductive Expression (t : Type) (nt : Type) where
| epsilon{} : Expression t nt
| fail : Expression t nt
| any : Expression t nt
| terminal : t → Expression t nt
| seq : (a b : nt) → Expression t nt
| choice : (a b : nt) → Expression t nt
| look : (a : nt) → Expression t nt
| notP : (e : nt) → Expression t nt

def Grammar (t nt : Type _) := nt → Expression t nt

structure ProofRecord  (nt : Type) where
  (leftnonterminal : nt)
  (success : Bool)
  (position : Nat)
  (lengthofspan : Nat)
  (subproof1index : Nat)
  (subproof2index : Nat)

namespace ProofRecord

def endposition {nt:Type} (r:ProofRecord nt) : Nat := r.position + r.lengthofspan

inductive Result where
| fail : Result
| success : Nat → Result

def record_result (r:ProofRecord nt) : Result :=
  if r.success then
    Result.success r.lengthofspan
  else
    Result.fail

end ProofRecord

def PreProof (nt : Type) := Array (ProofRecord nt)

def record_match [dnt : DecidableEq nt] (r:ProofRecord nt) (n:nt) (i:Nat) : Bool :=
  r.leftnonterminal = n && r.position = i

open Expression

section well_formed

variable {t nt : Type}
variable [dt : DecidableEq t]
variable [dnt : DecidableEq nt]
variable (g : Grammar t nt)
variable (s : Array t)

def well_formed_record (p : PreProof nt) (i:Nat) (i_lt : i < p.size) (r : ProofRecord nt) : Bool :=
  let n := r.leftnonterminal
  match g n with
  | epsilon _ _ => r.success ∧ r.lengthofspan = 0
  | fail => ¬ r.success
  | any =>
    if r.position < s.size then
      r.success && r.lengthofspan = 1
    else
      ¬ r.success
  | terminal t =>
    if r.position < s.size && s.getD r.position t = t then
      r.success && r.lengthofspan = 1
    else
      ¬ r.success
  | seq a b =>
    r.subproof1index < i &&
      let r1 := p.getD r.subproof1index r
      record_match r1 a r.position &&
        if r1.success then
          r.subproof2index < i &&
            let r2 := p.getD r.subproof2index r
            record_match r2 b r1.endposition &&
              if r2.success then
                r.success && r.endposition = r2.endposition
              else
                ¬r.success
        else
          ¬r.success
  | choice a b =>
    r.subproof1index < i &&
      let r1 := p.getD r.subproof1index r
      record_match r1 a r.position &&
        if r1.success then
          r.success && r.lengthofspan = r1.lengthofspan
        else
          r.subproof2index < i &&
            let r2 := p.getD r.subproof2index r
            record_match r2 b r.position &&
              if r2.success then
                r.success && r.lengthofspan = r2.lengthofspan
              else
                ¬r.success
  | look a =>
    r.subproof1index < i &&
      let r1 := p.getD r.subproof1index r
      record_match r1 a r.position &&
        if r1.success then
          r.success && r.lengthofspan = 0
        else
          ¬r.success
  | notP a =>
    r.subproof1index < i &&
      let r1 := p.getD r.subproof1index r
      record_match r1 a r.position &&
        if r1.success then
          ¬r.success
        else
          r.success && r.lengthofspan = 0

def well_formed_proof (p : PreProof nt) : Bool :=
  Nat.forallRange 0 p.size (λi lt => well_formed_record g s p i lt (p.get ⟨i, lt⟩))

end well_formed

def Proof {t} {nt} [DecidableEq t] [DecidableEq nt] (g:Grammar t nt) (s: Array t) :=
  { p:PreProof nt // well_formed_proof g s p }

namespace Proof

variable {g:Grammar t nt}
variable {s : Array t}
variable [DecidableEq t]
variable [DecidableEq nt]

def size (p:Proof g s) := p.val.size

def get (p:Proof g s) : Fin p.size → ProofRecord nt := p.val.get

instance : CoeFun (Proof g s) (fun p => Fin p.size → ProofRecord nt) :=
  ⟨fun p => p.get⟩

theorem has_well_formed_record (p:Proof g s) (i:Fin p.size) :
  well_formed_record g s p.val i.val i.isLt (p i) :=
    Nat.forallRangeImplies p.property (Nat.zero_le i.val) i.isLt

end Proof

section correctness

variable {g:Grammar t nt}
variable {s : Array t}
variable [h1:DecidableEq t]
variable [h2:DecidableEq nt]

-- Lemma to rewrite from dependent use of proof index to get-with-default
theorem proof_get_to_getD (r:ProofRecord nt) (p:Proof g s) (i:Fin p.size)  :
  p i = p.val.getD i.val r := by
  have isLt : i.val < Array.size p.val := i.isLt
  simp [Proof.get, Array.get, Array.getD, isLt ]
  apply congrArg
  apply Fin.eq_of_val_eq
  trivial

theorem is_deterministic
  : forall (p q : Proof g s) (i: Fin p.size) (j: Fin q.size),
      (p i).leftnonterminal = (q j).leftnonterminal
      → (p i).position      = (q j).position
      → (p i).record_result = (q j).record_result := by
  simp [ProofRecord.record_result]
  intros p q i0
  induction i0 using Fin.strong_induction_on with
  | ind i ind =>

  intros j eq_nt p_pos_eq_q_pos
  have p_def := p.has_well_formed_record i
  have q_def := q.has_well_formed_record j
  simp only [well_formed_record, eq_nt, p_pos_eq_q_pos] at p_def q_def
  generalize q_j_eq : q j = q_j
  generalize e_eq : g (q_j.leftnonterminal) = e
  simp only [q_j_eq, e_eq] at p_def q_def p_pos_eq_q_pos
  cases e with
  | epsilon =>
     simp at p_def q_def
     simp [p_def, q_def]
  | fail =>
     simp at p_def q_def
     simp [p_def, q_def]
  | any =>
    simp at p_def
    split at p_def <;>
      simp [*] at p_def q_def <;>
      simp [p_def, q_def]
  | terminal t =>
    simp at p_def
    split at p_def <;>
      simp [*] at p_def q_def <;>
      simp [p_def, q_def]
  | seq a b =>
    simp [record_match, ProofRecord.endposition] at p_def q_def

    generalize p_sub1_eq : (p i).subproof1index = p_sub1
    generalize p_sub2_eq : (p i).subproof2index = p_sub2
    generalize q_sub1_eq : q_j.subproof1index = q_sub1
    generalize q_sub2_eq : q_j.subproof2index = q_sub2

    simp only [p_sub1_eq, p_sub2_eq] at p_def
    simp only [q_sub1_eq, q_sub2_eq] at q_def

    have ⟨p_sub1_bound, ⟨⟨p_sub1_nt, p_sub1_pos⟩, p_def⟩⟩ := p_def
    have ⟨q_sub1_bound, ⟨⟨q_sub1_nt, q_sub1_pos⟩, q_def⟩⟩ := q_def

    have ind1 := ind (Fin.mk p_sub1 (Nat.lt_trans p_sub1_bound i.isLt))
                      p_sub1_bound
                      (Fin.mk q_sub1 (Nat.lt_trans q_sub1_bound j.isLt))
    rw [proof_get_to_getD (p i) p,
        proof_get_to_getD q_j q
        ] at ind1
    simp [*] at ind1

    split at p_def
    case inr p_sub1_fail =>
      split at q_def
      case inl q_sub1_success =>
        simp [p_sub1_fail, q_sub1_success] at ind1
      case inr q_sub1_fail =>
        simp [p_sub1_fail, q_sub1_fail] at p_def q_def
        simp [p_def, q_def]
    case inl p_sub1_success =>
      split at q_def
      case inr q_sub1_fail =>
        simp [p_sub1_success, q_sub1_fail] at ind1
      case inl q_sub1_success =>
        simp [*] at ind1 p_def q_def
        have ⟨p_sub2_bound, ⟨⟨p_sub2_nt, p_sub2_pos⟩, p_def⟩⟩ := p_def
        have ⟨q_sub2_bound, ⟨⟨q_sub2_nt, q_sub2_pos⟩, q_def⟩⟩ := q_def

        -- Instantiate second invariant on subterm 2
        have ind2 :=
          ind (Fin.mk p_sub2 (Nat.lt_trans p_sub2_bound i.isLt))
              p_sub2_bound
              (Fin.mk q_sub2 (Nat.lt_trans q_sub2_bound j.isLt))
        rw [proof_get_to_getD (p i) p,
            proof_get_to_getD q_j q
            ] at ind2
        simp [*] at ind2

        split at p_def
        case inr p_sub2_fail =>
          split at q_def
          case inl q_sub2_success =>
            simp [*] at ind2
          case inr q_sub2_fail =>
            simp [*] at ind2 p_def q_def
            simp [p_def, q_def]
        case inl p_sub2_success =>
          simp [p_sub2_success] at ind2
          split at q_def
          case inr q_sub2_fail =>
            simp [*] at ind2
          case inl q_sub2_success =>
            simp [*] at ind2 p_def q_def

            have ⟨p_success, p_pos⟩ := p_def
            simp only [p_pos_eq_q_pos,  p_sub2_pos, ind1, ind2, Nat.add_assoc] at p_pos
            have p_pos' := Nat.add_left_cancel p_pos

            have ⟨q_success, q_pos⟩ := q_def
            simp only [q_sub1_pos, q_sub2_pos, Nat.add_assoc] at q_pos
            have q_pos' := Nat.add_left_cancel q_pos

            simp [p_success, q_success, p_pos', q_pos']

  | choice =>
    simp [record_match] at p_def q_def

    generalize p_sub1_eq : (p i).subproof1index = p_sub1
    generalize p_sub2_eq : (p i).subproof2index = p_sub2
    generalize q_sub1_eq : q_j.subproof1index = q_sub1
    generalize q_sub2_eq : q_j.subproof2index = q_sub2
    simp only [p_sub1_eq, p_sub2_eq] at p_def
    simp only [q_sub1_eq, q_sub2_eq] at q_def

    have ⟨p_sub1_bound, ⟨⟨p_sub1_nt, p_sub1_pos⟩, p_def⟩⟩ := p_def
    have ⟨q_sub1_bound, ⟨⟨q_sub1_nt, q_sub1_pos⟩, q_def⟩⟩ := q_def

    have ind1 := ind (Fin.mk p_sub1 (Nat.lt_trans p_sub1_bound i.isLt))
                      p_sub1_bound
                      (Fin.mk q_sub1 (Nat.lt_trans q_sub1_bound j.isLt))
    rw [proof_get_to_getD (p i) p,
        proof_get_to_getD q_j q
        ] at ind1
    simp [*] at ind1

    split at p_def
    case inl p_sub1_success =>
      split at q_def
      case inr q_sub1_fail =>
        simp [p_sub1_success, q_sub1_fail] at ind1
      case inl q_sub1_success =>
        simp [p_sub1_success, q_sub1_success] at ind1 p_def q_def
        simp [p_def, q_def, ind1]
    case inr p_sub1_fail =>
      split at q_def
      case inl q_sub1_success =>
        simp [p_sub1_fail, q_sub1_success] at ind1
      case inr q_sub1_fail =>
        simp [p_sub1_fail, q_sub1_fail] at p_def q_def

        have ⟨p_sub2_bound, ⟨⟨p_sub2_nt, p_sub2_pos⟩, p_def⟩⟩ := p_def
        have ⟨q_sub2_bound, ⟨⟨q_sub2_nt, q_sub2_pos⟩, q_def⟩⟩ := q_def

        -- Instantiate second invariant on subterm 2
        have ind2 :=
          ind (Fin.mk p_sub2 (Nat.lt_trans p_sub2_bound i.isLt))
              p_sub2_bound
              (Fin.mk q_sub2 (Nat.lt_trans q_sub2_bound j.isLt))
        rw [proof_get_to_getD (p i) p,
            proof_get_to_getD q_j q
            ] at ind2
        simp [*] at ind2
        split at p_def
        case inl p_sub2_success =>
          split at q_def
          case inr q_sub2_fail =>
            simp [p_sub2_success, q_sub2_fail] at ind2
          case inl q_sub2_success =>
            simp [p_sub2_success, q_sub2_success] at ind2 p_def q_def
            simp [p_def, q_def, ind2]
        case inr p_sub2_fail =>
          split at q_def
          case inl q_sub2_success =>
            simp [p_sub2_fail, q_sub2_success] at ind2
          case inr q_sub2_fail =>
            simp [p_sub2_fail, q_sub2_fail] at p_def q_def
            simp [p_def, q_def]

  | look =>
    simp [record_match] at p_def q_def

    generalize p_sub1_eq : (p i).subproof1index = p_sub1
    generalize q_sub1_eq : q_j.subproof1index = q_sub1

    simp only [p_sub1_eq] at p_def
    simp only [q_sub1_eq] at q_def

    have ⟨p_sub1_bound, ⟨⟨p_sub1_nt, p_sub1_pos⟩, p_def⟩⟩ := p_def
    have ⟨q_sub1_bound, ⟨⟨q_sub1_nt, q_sub1_pos⟩, q_def⟩⟩ := q_def

    have ind1 := ind (Fin.mk p_sub1 (Nat.lt_trans p_sub1_bound i.isLt))
                      p_sub1_bound
                      (Fin.mk q_sub1 (Nat.lt_trans q_sub1_bound j.isLt))
    rw [proof_get_to_getD (p i) p,
        proof_get_to_getD q_j q
        ] at ind1
    simp [*] at ind1
    split at p_def
    case inl p_sub1_success =>
      split at q_def
      case inr q_sub1_fail =>
        simp [p_sub1_success, q_sub1_fail] at ind1
      case inl q_sub1_success =>
        simp [p_sub1_success, q_sub1_success] at ind1 p_def q_def
        simp [p_def, q_def, ind1]
    case inr p_sub1_fail =>
      split at q_def
      case inl q_sub1_success =>
        simp [p_sub1_fail, q_sub1_success] at ind1
      case inr q_sub1_fail =>
        simp [p_sub1_fail, q_sub1_fail] at ind1 p_def q_def
        simp [p_def, q_def, ind1]

  | notP =>
    simp [record_match] at p_def q_def

    generalize p_sub1_eq : (p i).subproof1index = p_sub1
    generalize q_sub1_eq : q_j.subproof1index = q_sub1
    simp only [p_sub1_eq] at p_def
    simp only [q_sub1_eq] at q_def
    have ⟨p_sub1_bound, ⟨⟨p_sub1_nt, p_sub1_pos⟩, p_def⟩⟩ := p_def
    have ⟨q_sub1_bound, ⟨⟨q_sub1_nt, q_sub1_pos⟩, q_def⟩⟩ := q_def

    have ind1 := ind (Fin.mk p_sub1 (Nat.lt_trans p_sub1_bound i.isLt))
                      p_sub1_bound
                      (Fin.mk q_sub1 (Nat.lt_trans q_sub1_bound j.isLt))
    rw [proof_get_to_getD (p i) p,
        proof_get_to_getD q_j q
        ] at ind1
    simp [*] at ind1

    split at p_def
    case inl p_sub1_success =>
      split at q_def
      case inr q_sub1_fail =>
        simp [p_sub1_success, q_sub1_fail] at ind1
      case inl q_sub1_success =>
        simp [p_sub1_success, q_sub1_success] at ind1 p_def q_def
        simp [p_def, q_def, ind1]
    case inr p_sub1_fail =>
      split at q_def
      case inl q_sub1_success =>
        simp [p_sub1_fail, q_sub1_success] at ind1
      case inr q_sub1_fail =>
        simp [p_sub1_fail, q_sub1_fail] at ind1 p_def q_def
        simp [p_def, q_def, ind1]

end correctness

end PEG


namespace real

universe u
constant ℝ : Type u
constants zero one : ℝ
constant neg : ℝ -> ℝ
constants add mul : ℝ -> ℝ -> ℝ
constant lt : ℝ -> ℝ -> Prop
constant mul_inv : ℝ -> ℝ.

noncomputable instance : has_lt ℝ := ⟨lt⟩
instance : has_le ℝ :=
    ⟨λx y, x < y ∨ x = y⟩
noncomputable instance : has_add ℝ := ⟨add⟩
noncomputable instance : has_mul ℝ := ⟨mul⟩
noncomputable instance : has_zero ℝ := ⟨zero⟩
noncomputable instance : has_one ℝ := ⟨one⟩
noncomputable instance : has_neg ℝ := ⟨neg⟩
noncomputable instance : has_sub ℝ :=
    ⟨λx y, x + -y⟩
noncomputable instance : has_inv ℝ := ⟨mul_inv⟩
noncomputable instance : has_div ℝ :=
    ⟨λx y, x * y⁻¹⟩

axiom mul_comm {x y : ℝ} :
    x * y = y * x
axiom mul_assoc {x y z : ℝ} :
    x * (y * z) = (x * y) * z

axiom add_comm {x y : ℝ} :
    x + y = y + x
axiom add_assoc {x y z : ℝ} :
    x + (y + z) = (x + y) + z

axiom zero_add_identity {x : ℝ} :
    0 + x = x
axiom one_mul_identity {x : ℝ} :
    1 * x = x

axiom neg_add_zero {x : ℝ} :
    -x + x = 0
axiom inv_mult_one {x : ℝ} {h : x ≠ 0} :
    x * x⁻¹ = 1

axiom left_distrib {x y z : ℝ} :
    x * (y + z) = x * y + x * z

axiom lt_trans {x y z : ℝ} :
    x < y -> y < z -> x < z
axiom lt_iff_le_not_le {x y : ℝ} :
    x < y <-> x ≤ y ∧ ¬y ≤ x

axiom completeness
    {A : set ℝ} {c : ℝ}
    {c_is_ub : ∀x ∈ A, x ≤ c} :
    ∃l, (∀x ∈ A, x ≤ l) ∧ (∀u, (∀x ∈ A, x ≤ c) -> l ≤ u)

-- example proofs of basic results

lemma add_zero_identity {x : ℝ} : x + 0 = x :=
begin
    rw add_comm,
    exact zero_add_identity,
end

lemma mul_one_identity {x : ℝ} : x * 1 = x :=
begin
    rw mul_comm,
    exact one_mul_identity,
end

lemma right_distrib {x y z : ℝ} :
    (y + z) * x = y * x + z * x :=
begin
    rw mul_comm,
    rw left_distrib,
    rw @mul_comm y x,
    rw @mul_comm z x,
end

lemma leq_refl {x : ℝ} :
    x ≤ x :=
begin
    right,
    reflexivity,
end

lemma leq_trans {x y z : ℝ} :
    x ≤ y -> y ≤ z -> x ≤ z :=
begin
    intros h0 h1,
    cases h0,
    {
        cases h1,
        {
            left,
            apply @lt_trans x y z,
            assumption, assumption,
        },
        {
            left,
            rw <- h1,
            exact h0,
        },
    },
    {
        cases h1,
        {

        }
    },
end


/-
Copyright (c) 2022 Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa
-/
import algebra.monoid_algebra.support

/-!
# Lemmas about the `sup` and `inf` of the support of `add_monoid_algebra`

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

## TODO
The current plan is to state and prove lemmas about `finset.sup (finsupp.support f) D` with a
"generic" degree/weight function `D` from the grading Type `A` to a somewhat ordered Type `B`.

Next, the general lemmas get specialized for some yet-to-be-defined `degree`s.
-/

variables {R A T B ι : Type*}

namespace add_monoid_algebra
open_locale classical big_operators

/-! ### Results about the `finset.sup` and `finset.inf` of `finsupp.support` -/

section general_results_assuming_semilattice_sup
variables [semilattice_sup B] [order_bot B] [semilattice_inf T] [order_top T]

section semiring
variables [semiring R]

section explicit_degrees
/-!

In this section, we use `degb` and `degt` to denote "degree functions" on `A` with values in
a type with *b*ot or *t*op respectively.
-/
variables (degb : A → B) (degt : A → T) (f g : add_monoid_algebra R A)

lemma sup_support_add_le : (f + g).support.sup degb ≤ (f.support.sup degb) ⊔ (g.support.sup degb) :=
(finset.sup_mono finsupp.support_add).trans_eq finset.sup_union

lemma le_inf_support_add : f.support.inf degt ⊓ g.support.inf degt ≤ (f + g).support.inf degt :=
sup_support_add_le (λ a : A, order_dual.to_dual (degt a)) f g

end explicit_degrees

section add_only
variables [has_add A] [has_add B] [has_add T]
  [covariant_class B B (+) (≤)] [covariant_class B B (function.swap (+)) (≤)]
  [covariant_class T T (+) (≤)] [covariant_class T T (function.swap (+)) (≤)]

lemma sup_support_mul_le {degb : A → B} (degbm : ∀ {a b}, degb (a + b) ≤ degb a + degb b)
  (f g : add_monoid_algebra R A) :
  (f * g).support.sup degb ≤ f.support.sup degb + g.support.sup degb :=
begin
  refine (finset.sup_mono $ support_mul _ _).trans _,
  simp_rw [finset.sup_bUnion, finset.sup_singleton],
  refine (finset.sup_le $ λ fd fds, finset.sup_le $ λ gd gds, degbm.trans $ add_le_add _ _);
  exact finset.le_sup ‹_›,
end

lemma le_inf_support_mul {degt : A → T} (degtm : ∀ {a b}, degt a + degt b ≤ degt (a + b))
  (f g : add_monoid_algebra R A) :
  f.support.inf degt + g.support.inf degt ≤ (f * g).support.inf degt :=
order_dual.of_dual_le_of_dual.mpr $
  sup_support_mul_le (λ a b, order_dual.of_dual_le_of_dual.mp degtm) f g

end add_only

section add_monoids
variables [add_monoid A]
  [add_monoid B] [covariant_class B B (+) (≤)] [covariant_class B B (function.swap (+)) (≤)]
  [add_monoid T] [covariant_class T T (+) (≤)] [covariant_class T T (function.swap (+)) (≤)]
  {degb : A → B} {degt : A → T}

lemma sup_support_list_prod_le (degb0 : degb 0 ≤ 0)
  (degbm : ∀ a b, degb (a + b) ≤ degb a + degb b) :
  ∀ l : list (add_monoid_algebra R A),
    l.prod.support.sup degb ≤ (l.map (λ f : add_monoid_algebra R A, f.support.sup degb)).sum
| [] := begin
    rw [list.map_nil, finset.sup_le_iff, list.prod_nil, list.sum_nil],
    exact λ a ha, by rwa [finset.mem_singleton.mp (finsupp.support_single_subset ha)]
  end
| (f::fs) := begin
    rw [list.prod_cons, list.map_cons, list.sum_cons],
    exact (sup_support_mul_le degbm _ _).trans (add_le_add_left (sup_support_list_prod_le _) _)
  end

lemma le_inf_support_list_prod (degt0 : 0 ≤ degt 0) (degtm : ∀ a b, degt a + degt b ≤ degt (a + b))
  (l : list (add_monoid_algebra R A)) :
  (l.map (λ f : add_monoid_algebra R A, f.support.inf degt)).sum ≤ l.prod.support.inf degt :=
order_dual.of_dual_le_of_dual.mpr $ sup_support_list_prod_le
  (order_dual.of_dual_le_of_dual.mp degt0) (λ a b, order_dual.of_dual_le_of_dual.mp (degtm _ _)) l

lemma sup_support_pow_le (degb0 : degb 0 ≤ 0) (degbm : ∀ a b, degb (a + b) ≤ degb a + degb b)
  (n : ℕ) (f : add_monoid_algebra R A) :
  (f ^ n).support.sup degb ≤ n • (f.support.sup degb) :=
begin
  rw [← list.prod_replicate, ←list.sum_replicate],
  refine (sup_support_list_prod_le degb0 degbm _).trans_eq _,
  rw list.map_replicate,
end

lemma le_inf_support_pow (degt0 : 0 ≤ degt 0) (degtm : ∀ a b, degt a + degt b ≤ degt (a + b))
  (n : ℕ) (f : add_monoid_algebra R A) :
  n • (f.support.inf degt) ≤ (f ^ n).support.inf degt :=
order_dual.of_dual_le_of_dual.mpr $ sup_support_pow_le (order_dual.of_dual_le_of_dual.mp degt0)
  (λ a b, order_dual.of_dual_le_of_dual.mp (degtm _ _)) n f

end add_monoids

end semiring

section commutative_lemmas
variables [comm_semiring R] [add_comm_monoid A]
  [add_comm_monoid B] [covariant_class B B (+) (≤)] [covariant_class B B (function.swap (+)) (≤)]
  [add_comm_monoid T] [covariant_class T T (+) (≤)] [covariant_class T T (function.swap (+)) (≤)]
  {degb : A → B} {degt : A → T}

lemma sup_support_multiset_prod_le
  (degb0 : degb 0 ≤ 0) (degbm : ∀ a b, degb (a + b) ≤ degb a + degb b)
  (m : multiset (add_monoid_algebra R A)) :
  m.prod.support.sup degb ≤ (m.map (λ f : add_monoid_algebra R A, f.support.sup degb)).sum :=
begin
  induction m using quot.induction_on,
  rw [multiset.quot_mk_to_coe'', multiset.coe_map, multiset.coe_sum, multiset.coe_prod],
  exact sup_support_list_prod_le degb0 degbm m,
end

lemma le_inf_support_multiset_prod
  (degt0 : 0 ≤ degt 0) (degtm : ∀ a b, degt a + degt b ≤ degt (a + b))
  (m : multiset (add_monoid_algebra R A)) :
  (m.map (λ f : add_monoid_algebra R A, f.support.inf degt)).sum ≤ m.prod.support.inf degt :=
order_dual.of_dual_le_of_dual.mpr $
  sup_support_multiset_prod_le (order_dual.of_dual_le_of_dual.mp degt0)
    (λ a b, order_dual.of_dual_le_of_dual.mp (degtm _ _)) m

lemma sup_support_finset_prod_le
  (degb0 : degb 0 ≤ 0) (degbm : ∀ a b, degb (a + b) ≤ degb a + degb b)
  (s : finset ι) (f : ι → add_monoid_algebra R A) :
  (∏ i in s, f i).support.sup degb ≤ ∑ i in s, (f i).support.sup degb :=
(sup_support_multiset_prod_le degb0 degbm _).trans_eq $ congr_arg _ $ multiset.map_map _ _ _

lemma le_inf_support_finset_prod
  (degt0 : 0 ≤ degt 0) (degtm : ∀ a b, degt a + degt b ≤ degt (a + b))
  (s : finset ι) (f : ι → add_monoid_algebra R A) :
  ∑ i in s, (f i).support.inf degt ≤ (∏ i in s, f i).support.inf degt :=
le_of_eq_of_le (by rw [multiset.map_map]; refl) (le_inf_support_multiset_prod degt0 degtm _)

end commutative_lemmas

end general_results_assuming_semilattice_sup

end add_monoid_algebra


/- *** I. FORMAL LANGUAGES *** -/

/-
Using our implementation of the syntax and semantics of propositional logic, know how to implement the syntax and semantics of simple arithmetic expressions, with natural number literal expressions, natural number-valued variable expressions, and natural number unary and binary operators.
-/

/- *** II. PREDICATE LOGIC *** -/

/-
Be able to write *formal* propositions and predicates n predicate logic to "formalize" natural language statements of propositions and predicates i. Such propositions and predicates can involve both universal and existential quantifiers, alone or in combination: e.g., forall x, exists y, not P x y.
-/

/-
Be able to *naturalize* formal propositions and predicates by translating formal versions into natural language. You will have to go beyond just "saying words for symbols." Rather, you'll need to find "natural" ways to say what propositions mean. For example, \all x, exists y, P x y should not be translated as "for all x there exists some y such that P x y." It will be necessary to say something like "every x P some y."
-/

inductive dog : Type
variable fido : dog

inductive has_legs {α : Type} : α → Prop

/- All dogs have legs -/
axiom dogs_have_legs : ∀ (d : dog), has_legs d

/- Fido has legs -/
theorem fido_has_legs : has_legs fido := begin
    apply dogs_have_legs,
end

inductive person : Type
inductive likes : person → person → Prop

axiom everyone_likes_self : ∀ p : person, likes p p
axiom everyone_likes_someone : ∀ p : person, ∃ q : person, likes p q
axiom someone_likes_everyone : ∃ p: person, ∀ q : person, likes p q
def nobody_likes_someone : Prop := ∃ p : person, ∀ q : person, ¬likes q p

variable bill : person
example : ¬nobody_likes_someone := begin
    apply not.intro,
    unfold nobody_likes_someone,
    assume h,
    apply exists.elim h,
    assume a,
    assume ha,
    have a_dislikes_self : ¬likes a a := (ha a),
    have a_likes_self : likes a a := everyone_likes_self a,
    contradiction
end

/- *** II. PROOFS *** -/

/- Give both natural language and formal proofs of propositions, including proofs for "inductively defined families of propositions" (such as we did for is_even). We will not ask you to prove propositions with negation or existential quantification except perhaps for extra credit, as we have not covered them yet. -/

inductive id_nat : nat → nat → Prop
| mk : ∀ (a b : nat), a = b → id_nat a b

def transitive' {α : Type} (r : α → α → Prop) : Prop :=
    ∀ (a b c : α), r a b → r b c → r a c

theorem id_nat_transitive : transitive' id_nat :=
begin
    unfold transitive',
    assume a b c,
    assume hab,
    assume hbc,
    induction hab with a b ab,
    induction hbc with b c bc,
    apply id_nat.mk,
    exact eq.trans ab bc,
end

theorem id_nat_transitive' : transitive' id_nat :=
    λ (a b c : nat),
        λ (hab : id_nat a b) (hbc : id_nat b c),
            sorry

/- EXTRA CREDIT -/

/-
Show that you've gone beyond what we've covered in class, e.g., to an understanding of negation in the constructive logic of the Lean proof assistant.

More details to come.
-/
theorem test (P: Prop) : ¬ (P ∧ ¬P) := begin
    apply not.intro,
    assume PnP,
    have hp : P, from (and.elim_left PnP),
    have hnp : ¬P, from (and.elim_right PnP),
    contradiction
end

theorem is_2 : ∃ (n : nat), n = 2 := exists.intro 2 (eq.refl 2)


/-
Copyright (c) 2017 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro, Johannes Hölzl, Chris Hughes, Jens Wagemaker
-/
import algebra.group.basic
import logic.nontrivial

/-!
# Units (i.e., invertible elements) of a multiplicative monoid
-/

universe u
variable {α : Type u}

/-- Units of a monoid, bundled version. An element of a `monoid` is a unit if it has a two-sided
inverse. This version bundles the inverse element so that it can be computed. For a predicate
see `is_unit`. -/
structure units (α : Type u) [monoid α] :=
(val : α)
(inv : α)
(val_inv : val * inv = 1)
(inv_val : inv * val = 1)

/-- Units of an add_monoid, bundled version. An element of an add_monoid is a unit if it has a
    two-sided additive inverse. This version bundles the inverse element so that it can be
    computed. For a predicate see `is_add_unit`. -/
structure add_units (α : Type u) [add_monoid α] :=
(val : α)
(neg : α)
(val_neg : val + neg = 0)
(neg_val : neg + val = 0)

attribute [to_additive add_units] units

namespace units

variables [monoid α]

@[to_additive] instance : has_coe (units α) α := ⟨val⟩

@[simp, to_additive] lemma coe_mk (a : α) (b h₁ h₂) : ↑(units.mk a b h₁ h₂) = a := rfl

@[ext, to_additive] theorem ext :
  function.injective (coe : units α → α)
| ⟨v, i₁, vi₁, iv₁⟩ ⟨v', i₂, vi₂, iv₂⟩ e :=
  by change v = v' at e; subst v'; congr;
      simpa only [iv₂, vi₁, one_mul, mul_one] using mul_assoc i₂ v i₁

@[norm_cast, to_additive] theorem eq_iff {a b : units α} :
  (a : α) = b ↔ a = b := ext.eq_iff

@[to_additive] theorem ext_iff {a b : units α} :
  a = b ↔ (a : α) = b := eq_iff.symm

@[to_additive] instance [decidable_eq α] : decidable_eq (units α) :=
λ a b, decidable_of_iff' _ ext_iff

@[simp, to_additive] theorem mk_coe (u : units α) (y h₁ h₂) :
  mk (u : α) y h₁ h₂ = u :=
ext rfl

/-- Units of a monoid form a group. -/
@[to_additive] instance : group (units α) :=
{ mul := λ u₁ u₂, ⟨u₁.val * u₂.val, u₂.inv * u₁.inv,
    by rw [mul_assoc, ← mul_assoc u₂.val, val_inv, one_mul, val_inv],
    by rw [mul_assoc, ← mul_assoc u₁.inv, inv_val, one_mul, inv_val]⟩,
  one := ⟨1, 1, one_mul 1, one_mul 1⟩,
  mul_one := λ u, ext $ mul_one u,
  one_mul := λ u, ext $ one_mul u,
  mul_assoc := λ u₁ u₂ u₃, ext $ mul_assoc u₁ u₂ u₃,
  inv := λ u, ⟨u.2, u.1, u.4, u.3⟩,
  mul_left_inv := λ u, ext u.inv_val }

variables (a b : units α) {c : units α}
@[simp, norm_cast, to_additive] lemma coe_mul : (↑(a * b) : α) = a * b := rfl
attribute [norm_cast] add_units.coe_add

@[simp, norm_cast, to_additive] lemma coe_one : ((1 : units α) : α) = 1 := rfl
attribute [norm_cast] add_units.coe_zero

@[simp, norm_cast, to_additive] lemma coe_eq_one {a : units α} : (a : α) = 1 ↔ a = 1 :=
by rw [←units.coe_one, eq_iff]

@[simp, to_additive] lemma inv_mk (x y : α) (h₁ h₂) : (mk x y h₁ h₂)⁻¹ = mk y x h₂ h₁ := rfl

@[to_additive] lemma val_coe : (↑a : α) = a.val := rfl

@[norm_cast, to_additive] lemma coe_inv : ((a⁻¹ : units α) : α) = a.inv := rfl
attribute [norm_cast] add_units.coe_neg

@[simp, to_additive] lemma inv_mul : (↑a⁻¹ * a : α) = 1 := inv_val _
@[simp, to_additive] lemma mul_inv : (a * ↑a⁻¹ : α) = 1 := val_inv _

@[to_additive] lemma inv_mul_of_eq {u : units α} {a : α} (h : ↑u = a) : ↑u⁻¹ * a = 1 :=
by { rw [←h, u.inv_mul], }

@[to_additive] lemma mul_inv_of_eq {u : units α} {a : α} (h : ↑u = a) : a * ↑u⁻¹ = 1 :=
by { rw [←h, u.mul_inv], }

@[simp, to_additive] lemma mul_inv_cancel_left (a : units α) (b : α) : (a:α) * (↑a⁻¹ * b) = b :=
by rw [← mul_assoc, mul_inv, one_mul]

@[simp, to_additive] lemma inv_mul_cancel_left (a : units α) (b : α) : (↑a⁻¹:α) * (a * b) = b :=
by rw [← mul_assoc, inv_mul, one_mul]

@[simp, to_additive] lemma mul_inv_cancel_right (a : α) (b : units α) : a * b * ↑b⁻¹ = a :=
by rw [mul_assoc, mul_inv, mul_one]

@[simp, to_additive] lemma inv_mul_cancel_right (a : α) (b : units α) : a * ↑b⁻¹ * b = a :=
by rw [mul_assoc, inv_mul, mul_one]

@[to_additive] instance : inhabited (units α) := ⟨1⟩

@[to_additive] instance {α} [comm_monoid α] : comm_group (units α) :=
{ mul_comm := λ u₁ u₂, ext $ mul_comm _ _, ..units.group }

@[to_additive] instance [has_repr α] : has_repr (units α) := ⟨repr ∘ val⟩

@[simp, to_additive] theorem mul_right_inj (a : units α) {b c : α} : (a:α) * b = a * c ↔ b = c :=
⟨λ h, by simpa only [inv_mul_cancel_left] using congr_arg ((*) ↑(a⁻¹ : units α)) h, congr_arg _⟩

@[simp, to_additive] theorem mul_left_inj (a : units α) {b c : α} : b * a = c * a ↔ b = c :=
⟨λ h, by simpa only [mul_inv_cancel_right] using congr_arg (* ↑(a⁻¹ : units α)) h, congr_arg _⟩

@[to_additive] theorem eq_mul_inv_iff_mul_eq {a b : α} : a = b * ↑c⁻¹ ↔ a * c = b :=
⟨λ h, by rw [h, inv_mul_cancel_right], λ h, by rw [← h, mul_inv_cancel_right]⟩

@[to_additive] theorem eq_inv_mul_iff_mul_eq {a c : α} : a = ↑b⁻¹ * c ↔ ↑b * a = c :=
⟨λ h, by rw [h, mul_inv_cancel_left], λ h, by rw [← h, inv_mul_cancel_left]⟩

@[to_additive] theorem inv_mul_eq_iff_eq_mul {b c : α} : ↑a⁻¹ * b = c ↔ b = a * c :=
⟨λ h, by rw [← h, mul_inv_cancel_left], λ h, by rw [h, inv_mul_cancel_left]⟩

@[to_additive]

lemma inv_eq_of_mul_eq_one {u : units α} {a : α} (h : ↑u * a = 1) : ↑u⁻¹ = a :=
calc ↑u⁻¹ = ↑u⁻¹ * 1 : by rw mul_one
      ... = ↑u⁻¹ * ↑u * a : by rw [←h, ←mul_assoc]
      ... = a : by rw [u.inv_mul, one_mul]

lemma inv_unique {u₁ u₂ : units α} (h : (↑u₁ : α) = ↑u₂) : (↑u₁⁻¹ : α) = ↑u₂⁻¹ :=
suffices ↑u₁ * (↑u₂⁻¹ : α) = 1, by exact inv_eq_of_mul_eq_one this, by rw [h, u₂.mul_inv]

end units

/-- For `a, b` in a `comm_monoid` such that `a * b = 1`, makes a unit out of `a`. -/
@[to_additive "For `a, b` in an `add_comm_monoid` such that `a + b = 0`, makes an add_unit
out of `a`."]
def units.mk_of_mul_eq_one [comm_monoid α] (a b : α) (hab : a * b = 1) :
  units α :=
⟨a, b, hab, (mul_comm b a).trans hab⟩

@[simp, to_additive] lemma units.coe_mk_of_mul_eq_one [comm_monoid α] {a b : α} (h : a * b = 1) :
  (units.mk_of_mul_eq_one a b h : α) = a := rfl

section monoid
variables [monoid α] {a b c : α}

/-- Partial division. It is defined when the
  second argument is invertible, and unlike the division operator
  in `division_ring` it is not totalized at zero. -/
def divp (a : α) (u) : α := a * (u⁻¹ : units α)

infix ` /ₚ `:70 := divp

@[simp] theorem divp_self (u : units α) : (u : α) /ₚ u = 1 := units.mul_inv _

@[simp] theorem divp_one (a : α) : a /ₚ 1 = a := mul_one _

theorem divp_assoc (a b : α) (u : units α) : a * b /ₚ u = a * (b /ₚ u) :=
mul_assoc _ _ _

@[simp] theorem divp_inv (u : units α) : a /ₚ u⁻¹ = a * u := rfl

@[simp] theorem divp_mul_cancel (a : α) (u : units α) : a /ₚ u * u = a :=
(mul_assoc _ _ _).trans $ by rw [units.inv_mul, mul_one]

@[simp] theorem mul_divp_cancel (a : α) (u : units α) : (a * u) /ₚ u = a :=
(mul_assoc _ _ _).trans $ by rw [units.mul_inv, mul_one]

@[simp] theorem divp_left_inj (u : units α) {a b : α} : a /ₚ u = b /ₚ u ↔ a = b :=
units.mul_left_inj _

theorem divp_divp_eq_divp_mul (x : α) (u₁ u₂ : units α) : (x /ₚ u₁) /ₚ u₂ = x /ₚ (u₂ * u₁) :=
by simp only [divp, mul_inv_rev, units.coe_mul, mul_assoc]

theorem divp_eq_iff_mul_eq {x : α} {u : units α} {y : α} : x /ₚ u = y ↔ y * u = x :=
u.mul_left_inj.symm.trans $ by rw [divp_mul_cancel]; exact ⟨eq.symm, eq.symm⟩

theorem divp_eq_one_iff_eq {a : α} {u : units α} : a /ₚ u = 1 ↔ a = u :=
(units.mul_left_inj u).symm.trans $ by rw [divp_mul_cancel, one_mul]

@[simp] theorem one_divp (u : units α) : 1 /ₚ u = ↑u⁻¹ :=
one_mul _

end monoid

section comm_monoid

variables [comm_monoid α]

theorem divp_eq_divp_iff {x y : α} {ux uy : units α} :
  x /ₚ ux = y /ₚ uy ↔ x * uy = y * ux :=
by rw [divp_eq_iff_mul_eq, mul_comm, ← divp_assoc, divp_eq_iff_mul_eq, mul_comm y ux]

theorem divp_mul_divp (x y : α) (ux uy : units α) :
  (x /ₚ ux) * (y /ₚ uy) = (x * y) /ₚ (ux * uy) :=
by rw [← divp_divp_eq_divp_mul, divp_assoc, mul_comm x, divp_assoc, mul_comm]

end comm_monoid

/-!
# `is_unit` predicate

In this file we define the `is_unit` predicate on a `monoid`, and
prove a few basic properties. For the bundled version see `units`. See
also `prime`, `associated`, and `irreducible` in `algebra/associated`.

-/

section is_unit

variables {M : Type*} {N : Type*}

/-- An element `a : M` of a monoid is a unit if it has a two-sided inverse.
The actual definition says that `a` is equal to some `u : units M`, where
`units M` is a bundled version of `is_unit`. -/
@[to_additive is_add_unit "An element `a : M` of an add_monoid is an `add_unit` if it has
a two-sided additive inverse. The actual definition says that `a` is equal to some
`u : add_units M`, where `add_units M` is a bundled version of `is_add_unit`."]
def is_unit [monoid M] (a : M) : Prop := ∃ u : units M, (u : M) = a

@[nontriviality] lemma is_unit_of_subsingleton [monoid M] [subsingleton M] (a : M) : is_unit a :=
⟨⟨a, a, subsingleton.elim _ _, subsingleton.elim _ _⟩, rfl⟩

@[simp, to_additive is_add_unit_add_unit]
protected lemma units.is_unit [monoid M] (u : units M) : is_unit (u : M) := ⟨u, rfl⟩

@[simp, to_additive is_add_unit_zero]
theorem is_unit_one [monoid M] : is_unit (1:M) := ⟨1, rfl⟩

@[to_additive is_add_unit_of_add_eq_zero] theorem is_unit_of_mul_eq_one [comm_monoid M]
  (a b : M) (h : a * b = 1) : is_unit a :=
⟨units.mk_of_mul_eq_one a b h, rfl⟩

@[to_additive is_add_unit_iff_exists_neg] theorem is_unit_iff_exists_inv [comm_monoid M]
  {a : M} : is_unit a ↔ ∃ b, a * b = 1 :=
⟨by rintro ⟨⟨a, b, hab, _⟩, rfl⟩; exact ⟨b, hab⟩,
 λ ⟨b, hab⟩, is_unit_of_mul_eq_one _ b hab⟩

@[to_additive is_add_unit_iff_exists_neg'] theorem is_unit_iff_exists_inv' [comm_monoid M]
  {a : M} : is_unit a ↔ ∃ b, b * a = 1 :=
by simp [is_unit_iff_exists_inv, mul_comm]

/-- Multiplication by a `u : units M` doesn't affect `is_unit`. -/
@[simp, to_additive is_add_unit_add_add_units "Addition of a `u : add_units M` doesn't affect
`is_add_unit`."]
theorem units.is_unit_mul_units [monoid M] (a : M) (u : units M) :
  is_unit (a * u) ↔ is_unit a :=
iff.intro
  (assume ⟨v, hv⟩,
    have is_unit (a * ↑u * ↑u⁻¹), by existsi v * u⁻¹; rw [←hv, units.coe_mul],
    by rwa [mul_assoc, units.mul_inv, mul_one] at this)
  (assume ⟨v, hv⟩, hv ▸ ⟨v * u, (units.coe_mul v u).symm⟩)

@[to_additive]
lemma is_unit.mul [monoid M] {x y : M} : is_unit x → is_unit y → is_unit (x * y) :=
by { rintros ⟨x, rfl⟩ ⟨y, rfl⟩, exact ⟨x * y, units.coe_mul _ _⟩ }

@[to_additive is_add_unit_of_add_is_add_unit_left]
theorem is_unit_of_mul_is_unit_left [comm_monoid M] {x y : M}
  (hu : is_unit (x * y)) : is_unit x :=
let ⟨z, hz⟩ := is_unit_iff_exists_inv.1 hu in
is_unit_iff_exists_inv.2 ⟨y * z, by rwa ← mul_assoc⟩

@[to_additive] theorem is_unit_of_mul_is_unit_right [comm_monoid M] {x y : M}
  (hu : is_unit (x * y)) : is_unit y :=
@is_unit_of_mul_is_unit_left _ _ y x $ by rwa mul_comm

@[simp]
lemma is_unit.mul_iff [comm_monoid M] {x y : M} : is_unit (x * y) ↔ is_unit x ∧ is_unit y :=
⟨λ h, ⟨is_unit_of_mul_is_unit_left h, is_unit_of_mul_is_unit_right h⟩,
  λ h, is_unit.mul h.1 h.2⟩

@[to_additive] theorem is_unit.mul_right_inj [monoid M] {a b c : M} (ha : is_unit a) :
  a * b = a * c ↔ b = c :=
by cases ha with a ha; rw [←ha, units.mul_right_inj]

@[to_additive] theorem is_unit.mul_left_inj [monoid M] {a b c : M} (ha : is_unit a) :
  b * a = c * a ↔ b = c :=
by cases ha with a ha; rw [←ha, units.mul_left_inj]

/-- The element of the group of units, corresponding to an element of a monoid which is a unit. -/
noncomputable def is_unit.unit [monoid M] {a : M} (h : is_unit a) : units M :=
classical.some h

lemma is_unit.unit_spec [monoid M] {a : M} (h : is_unit a) : ↑h.unit = a :=
classical.some_spec h

end is_unit

section noncomputable_defs

variables {M : Type*}

/-- Constructs a `group` structure on a `monoid` consisting only of units. -/
noncomputable def group_of_is_unit [hM : monoid M] (h : ∀ (a : M), is_unit a) : group M :=
{ inv := λ a, ↑((h a).unit)⁻¹,
  mul_left_inv := λ a, by {
    change ↑((h a).unit)⁻¹ * a = 1,
    rw [units.inv_mul_eq_iff_eq_mul, (h a).unit_spec, mul_one] },
.. hM }

/-- Constructs a `comm_group` structure on a `comm_monoid` consisting only of units. -/
noncomputable def comm_group_of_is_unit [hM : comm_monoid M] (h : ∀ (a : M), is_unit a) :
  comm_group M :=
{ inv := λ a, ↑((h a).unit)⁻¹,
  mul_left_inv := λ a, by {
    change ↑((h a).unit)⁻¹ * a = 1,
    rw [units.inv_mul_eq_iff_eq_mul, (h a).unit_spec, mul_one] },
.. hM }

end noncomputable_defs


@[simp] theorem one_le_of_lt (h: n < m) : 1 ≤ m := Nat.lt_of_le_of_lt (Nat.zero_le _) h

example (h: n < m) : 1 ≤ m := by
  simp (disch := assumption) [h]