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

/-!
# Sets in sigma types

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

This file defines `set.sigma`, the indexed sum of sets.
-/

namespace set
variables {ι ι' : Type*} {α β : ι → Type*} {s s₁ s₂ : set ι} {t t₁ t₂ : Π i, set (α i)}
  {u : set (Σ i, α i)} {x : Σ i, α i} {i j : ι} {a : α i}

@[simp] theorem range_sigma_mk (i : ι) :
  range (sigma.mk i : α i → sigma α) = sigma.fst ⁻¹' {i} :=
begin
  apply subset.antisymm,
  { rintros _ ⟨b, rfl⟩, simp },
  { rintros ⟨x, y⟩ (rfl|_),
    exact mem_range_self y }
end

theorem preimage_image_sigma_mk_of_ne (h : i ≠ j) (s : set (α j)) :
  sigma.mk i ⁻¹' (sigma.mk j '' s) = ∅ :=
by { ext x, simp [h.symm] }

lemma image_sigma_mk_preimage_sigma_map_subset {β : ι' → Type*} (f : ι → ι')
  (g : Π i, α i → β (f i)) (i : ι) (s : set (β (f i))) :
  sigma.mk i '' (g i ⁻¹' s) ⊆ sigma.map f g ⁻¹' (sigma.mk (f i) '' s) :=
image_subset_iff.2 $ λ x hx, ⟨g i x, hx, rfl⟩

lemma image_sigma_mk_preimage_sigma_map {β : ι' → Type*} {f : ι → ι'} (hf : function.injective f)
  (g : Π i, α i → β (f i)) (i : ι) (s : set (β (f i))) :
  sigma.mk i '' (g i ⁻¹' s) = sigma.map f g ⁻¹' (sigma.mk (f i) '' s) :=
begin
  refine (image_sigma_mk_preimage_sigma_map_subset f g i s).antisymm _,
  rintro ⟨j, x⟩ ⟨y, hys, hxy⟩,
  simp only [hf.eq_iff, sigma.map] at hxy,
  rcases hxy with ⟨rfl, hxy⟩, rw [heq_iff_eq] at hxy, subst y,
  exact ⟨x, hys, rfl⟩
end

/-- Indexed sum of sets. `s.sigma t` is the set of dependent pairs `⟨i, a⟩` such that `i ∈ s` and
`a ∈ t i`.-/
protected def sigma (s : set ι) (t : Π i, set (α i)) : set (Σ i, α i) := {x | x.1 ∈ s ∧ x.2 ∈ t x.1}

@[simp] lemma mem_sigma_iff : x ∈ s.sigma t ↔ x.1 ∈ s ∧ x.2 ∈ t x.1 := iff.rfl
@[simp] lemma mk_sigma_iff : (⟨i, a⟩ : Σ i, α i) ∈ s.sigma t ↔ i ∈ s ∧ a ∈ t i := iff.rfl

lemma mk_mem_sigma (hi : i ∈ s) (ha : a ∈ t i) : (⟨i, a⟩ : Σ i, α i) ∈ s.sigma t := ⟨hi, ha⟩

lemma sigma_mono (hs : s₁ ⊆ s₂) (ht : ∀ i, t₁ i ⊆ t₂ i) : s₁.sigma t₁ ⊆ s₂.sigma t₂ :=
λ x hx, ⟨hs hx.1, ht _ hx.2⟩

lemma sigma_subset_iff : s.sigma t ⊆ u ↔ ∀ ⦃i⦄, i ∈ s → ∀ ⦃a⦄, a ∈ t i → (⟨i, a⟩ : Σ i, α i) ∈ u :=
⟨λ h i hi a ha, h $ mk_mem_sigma hi ha, λ h ⟨i, a⟩ ha, h ha.1 ha.2⟩

lemma forall_sigma_iff {p : (Σ i, α i) → Prop} :
  (∀ x ∈ s.sigma t, p x) ↔ ∀ ⦃i⦄, i ∈ s → ∀ ⦃a⦄, a ∈ t i → p ⟨i, a⟩ :=
sigma_subset_iff

lemma exists_sigma_iff {p : (Σ i, α i) → Prop} :
  (∃ x ∈ s.sigma t, p x) ↔ ∃ (i ∈ s) (a ∈ t i), p ⟨i, a⟩ :=
⟨λ ⟨⟨i, a⟩, ha, h⟩, ⟨i, ha.1, a, ha.2, h⟩, λ ⟨i, hi, a, ha, h⟩, ⟨⟨i, a⟩, ⟨hi, ha⟩, h⟩⟩

@[simp] lemma sigma_empty : s.sigma (λ i, (∅ : set (α i))) = ∅ := ext $ λ _, and_false _
@[simp] lemma empty_sigma : (∅ : set ι).sigma t = ∅ := ext $ λ _, false_and _
lemma univ_sigma_univ : (@univ ι).sigma (λ _, @univ (α i)) = univ := ext $ λ _, true_and _
@[simp] lemma sigma_univ : s.sigma (λ _, univ : Π i, set (α i)) = sigma.fst ⁻¹' s :=
ext $ λ _, and_true _

@[simp] lemma singleton_sigma : ({i} : set ι).sigma t = sigma.mk i '' t i :=
ext $ λ x, begin
  split,
  { obtain ⟨j, a⟩ := x,
    rintro ⟨(rfl : j = i), ha⟩,
    exact mem_image_of_mem _ ha },
  { rintro ⟨b, hb, rfl⟩,
    exact ⟨rfl, hb⟩ }
end

@[simp] lemma sigma_singleton {a : Π i, α i} :
  s.sigma (λ i, ({a i} : set (α i))) = (λ i, sigma.mk i $ a i) '' s :=
by { ext ⟨x, y⟩, simp [and.left_comm, eq_comm] }

lemma singleton_sigma_singleton {a : Π i, α i} :
  ({i} : set ι).sigma (λ i, ({a i} : set (α i))) = {⟨i, a i⟩} :=
by rw [sigma_singleton, image_singleton]

@[simp] lemma union_sigma : (s₁ ∪ s₂).sigma t = s₁.sigma t ∪ s₂.sigma t :=
ext $ λ _, or_and_distrib_right

@[simp] lemma sigma_union : s.sigma (λ i, t₁ i ∪ t₂ i) = s.sigma t₁ ∪ s.sigma t₂ :=
ext $ λ _, and_or_distrib_left

lemma sigma_inter_sigma : s₁.sigma t₁ ∩ s₂.sigma t₂ = (s₁ ∩ s₂).sigma (λ i, t₁ i ∩ t₂ i) :=
by { ext ⟨x, y⟩, simp [and_assoc, and.left_comm] }

lemma insert_sigma : (insert i s).sigma t = (sigma.mk i '' t i) ∪ s.sigma t :=
by rw [insert_eq, union_sigma, singleton_sigma]

lemma sigma_insert {a : Π i, α i} :
  s.sigma (λ i, insert (a i) (t i)) = ((λ i, ⟨i, a i⟩) '' s) ∪ s.sigma t :=
by simp_rw [insert_eq, sigma_union, sigma_singleton]

lemma sigma_preimage_eq {f : ι' → ι} {g : Π i, β i → α i} :
  (f ⁻¹' s).sigma (λ i, g (f i) ⁻¹' t (f i)) =
    (λ p : Σ i, β (f i), sigma.mk _ (g _ p.2)) ⁻¹' (s.sigma t) := rfl

lemma sigma_preimage_left {f : ι' → ι} :
  (f ⁻¹' s).sigma (λ i, t (f i)) = (λ p : Σ i, α (f i), sigma.mk _ p.2) ⁻¹' (s.sigma t) := rfl

lemma sigma_preimage_right {g : Π i, β i → α i} :
  s.sigma (λ i, g i ⁻¹' t i) = (λ p : Σ i, β i, sigma.mk p.1 (g _ p.2)) ⁻¹' (s.sigma t) := rfl

lemma preimage_sigma_map_sigma {α' : ι' → Type*} (f : ι → ι') (g : Π i, α i → α' (f i)) (s : set ι')
  (t : Π i, set (α' i)) :
  sigma.map f g ⁻¹' (s.sigma t) = (f ⁻¹' s).sigma (λ i, g i ⁻¹' t (f i)) := rfl

@[simp] lemma mk_preimage_sigma (hi : i ∈ s) : sigma.mk i ⁻¹' s.sigma t = t i :=
ext $ λ _, and_iff_right hi

@[simp] lemma mk_preimage_sigma_eq_empty (hi : i ∉ s) : sigma.mk i ⁻¹' s.sigma t = ∅ :=
ext $ λ _, iff_of_false (hi ∘ and.left) id

lemma mk_preimage_sigma_eq_if [decidable_pred (∈ s)] :
  sigma.mk i ⁻¹' s.sigma t = if i ∈ s then t i else ∅ :=
by split_ifs; simp [h]

lemma mk_preimage_sigma_fn_eq_if {β : Type*} [decidable_pred (∈ s)] (g : β → α i) :
  (λ b, sigma.mk i (g b)) ⁻¹' s.sigma t = if i ∈ s then g ⁻¹' t i else ∅ :=
ext $ λ _, by split_ifs; simp [h]

lemma sigma_univ_range_eq {f : Π i, α i → β i} :
  (univ : set ι).sigma (λ i, range (f i)) = range (λ x : Σ i, α i, ⟨x.1, f _ x.2⟩) :=
ext $ by simp [range]

protected lemma nonempty.sigma :
  s.nonempty → (∀ i, (t i).nonempty) → (s.sigma t : set _).nonempty :=
λ ⟨i, hi⟩ h, let ⟨a, ha⟩ := h i in ⟨⟨i, a⟩, hi, ha⟩

lemma nonempty.sigma_fst : (s.sigma t : set _).nonempty → s.nonempty := λ ⟨x, hx⟩, ⟨x.1, hx.1⟩
lemma nonempty.sigma_snd : (s.sigma t : set _).nonempty → ∃ i ∈ s, (t i).nonempty :=
λ ⟨x, hx⟩, ⟨x.1, hx.1, x.2, hx.2⟩

lemma sigma_nonempty_iff : (s.sigma t : set _).nonempty ↔ ∃ i ∈ s, (t i).nonempty :=
⟨nonempty.sigma_snd, λ ⟨i, hi, a, ha⟩, ⟨⟨i, a⟩, hi, ha⟩⟩

lemma sigma_eq_empty_iff : s.sigma t = ∅ ↔ ∀ i ∈ s, t i = ∅ :=
not_nonempty_iff_eq_empty.symm.trans $ sigma_nonempty_iff.not.trans $
  by simp only [not_nonempty_iff_eq_empty, not_exists]

lemma image_sigma_mk_subset_sigma_left {a : Π i, α i} (ha : ∀ i, a i ∈ t i) :
  (λ i, sigma.mk i (a i)) '' s ⊆ s.sigma t :=
image_subset_iff.2 $ λ i hi, ⟨hi, ha _⟩

lemma image_sigma_mk_subset_sigma_right (hi : i ∈ s) : sigma.mk i '' t i ⊆ s.sigma t :=
image_subset_iff.2 $ λ a, and.intro hi

lemma sigma_subset_preimage_fst (s : set ι) (t : Π i, set (α i)) : s.sigma t ⊆ sigma.fst ⁻¹' s :=
λ a, and.left

lemma fst_image_sigma_subset (s : set ι) (t : Π i, set (α i)) : sigma.fst '' s.sigma t ⊆ s :=
image_subset_iff.2 $ λ a, and.left

lemma fst_image_sigma (s : set ι) (ht : ∀ i, (t i).nonempty) : sigma.fst '' s.sigma t = s :=
(fst_image_sigma_subset _ _).antisymm $ λ i hi, let ⟨a, ha⟩ := ht i in ⟨⟨i, a⟩, ⟨hi, ha⟩, rfl⟩

lemma sigma_diff_sigma : s₁.sigma t₁ \ s₂.sigma t₂ = s₁.sigma (t₁ \ t₂) ∪ (s₁ \ s₂).sigma t₁ :=
ext $ λ x, by by_cases h₁ : x.1 ∈ s₁; by_cases h₂ : x.2 ∈ t₁ x.1; simp [*, ←imp_iff_or_not]

end set


import tactic

def Atom := ℕ

inductive FormO : Type
| pos : Atom × ℕ → FormO
| neg : Atom × ℕ → FormO
| tensor : FormO → FormO → FormO
| par : FormO → FormO → FormO

def FormO.negation : FormO → FormO
| (FormO.pos A) := FormO.neg A
| (FormO.neg A) := FormO.pos A
| (FormO.tensor A B) := FormO.par (FormO.negation A) (FormO.negation B)
| (FormO.par A B) := FormO.tensor (FormO.negation A) (FormO.negation B)

infix ` ⊗ `:70 := FormO.tensor
infix ` ⅋ `:65 := FormO.par
prefix `~` := FormO.negation

inductive Link : Type
| ax : Atom × ℕ → Link
| cut : FormO → Link
| tensor : FormO → FormO → Link
| par : FormO → FormO → Link

inductive premise : FormO → Link → Prop
| cut_pos {Ai}         : premise Ai (Link.cut Ai)
| cut_neg {Ai}         : premise (~Ai) (Link.cut Ai)
| tensor_left {Ai Bj}  : premise Ai (Link.tensor Ai Bj)
| tensor_right {Ai Bj} : premise Bj (Link.tensor Ai Bj)
| par_left {Ai Bj}     : premise Ai (Link.par Ai Bj)
| par_right {Ai Bj}    : premise Bj (Link.par Ai Bj)

inductive conclusion : FormO → Link → Prop
| ax_pos {A i}   : conclusion (FormO.pos (A,i)) (Link.ax (A,i))
| ax_neg {A i}   : conclusion (FormO.neg (A,i)) (Link.ax (A,i))
| tensor {Ai Bi} : conclusion (Ai ⊗ Bi) (Link.tensor Ai Bi)
| par {Ai Bi}    : conclusion (Ai ⊗ Bi) (Link.par Ai Bi)

inductive mem_Link (Ai : FormO) (l : Link) : Prop
| prem : premise Ai l → mem_Link
| con : conclusion Ai l → mem_Link

instance : has_mem FormO Link := ⟨mem_Link⟩

structure proof_structure : Type :=
(links : set Link)
(prem_unique : ∀ Ai : FormO, ∀ l₁ l₂ ∈ links, premise Ai l₁ → premise Ai l₂ → l₁ = l₂)
(con_unique : ∀ Ai : FormO, ∀ l₁ l₂ ∈ links, conclusion Ai l₁ → conclusion Ai l₂ → l₁ = l₂)

inductive mem_FormO_ps (Ai : FormO) (ps : proof_structure) : Prop
| mk {l} : l ∈ ps.links → Ai ∈ l → mem_FormO_ps

instance : has_mem FormO proof_structure := ⟨mem_FormO_ps⟩

@[reducible]
def dir := bool

@[pattern] def down := ff
@[pattern] def up := tt

@[pattern] def with_down (Ai : FormO) := (Ai,down)
@[pattern] def with_up (Ai : FormO) := (Ai,up)
postfix `↓`:max_plus := with_down
postfix `↑`:max_plus := with_up

@[reducible]
def switch := bool

@[reducible, pattern] def L := ff
@[reducible, pattern] def R := tt

def switching := Link → switch

@[simp]
def switch.flip {α β} (f : α → α → β) : switch → α → α → β
| L a b := f a b
| R a b := f b a

inductive steps_tensor (Ai Bi : FormO) : FormO × dir → FormO × dir → Prop
| down : steps_tensor Ai↓ (Ai ⊗ Bi)↓
| turn : steps_tensor Bi↓ Ai↑
| up : steps_tensor (Ai ⊗ Bi)↑ Bi↑

inductive steps_par (Ai Bi : FormO) : FormO × dir → FormO × dir → Prop
| down : steps_par Ai↓ (Ai ⅋ Bi)↓
| turn : steps_par Bi↓ Bi↑
| up : steps_par (Ai ⅋ Bi)↑ Ai↑

inductive steps (T : switch) : Link → FormO × dir → FormO × dir → Prop
| ax_pos  {ai} : steps (Link.ax ai) (FormO.pos ai)↑ (FormO.neg ai)↓
| ax_neg  {ai} : steps (Link.ax ai) (FormO.neg ai)↑ (FormO.pos ai)↓
| cut_pos  {Ai} : steps (Link.cut Ai) Ai↓ (~Ai)↑
| cut_neg  {Ai} : steps (Link.cut Ai) (~Ai)↓ Ai↑
| tensor {Ai Bi X Y} :
  T.flip steps_tensor Ai Bi X Y →
  steps (Link.tensor Ai Bi) X Y
| par {Ai Bi X Y} :
  T.flip steps_par Ai Bi X Y →
  steps (Link.par Ai Bi) X Y

inductive trip (ps : proof_structure) (S : switching) : ℕ → FormO × dir → FormO × dir → Prop
| single {Ai d}    : Ai ∈ ps → trip 0 (Ai,d) (Ai,d)
| cons {X Y Z Δ n} : Δ ∈ ps.links → steps (S Δ) Δ X Y → trip n Y Z → trip (n.succ) X Z

inductive journey (ps : proof_structure) (S : switching) : ℕ → FormO × dir → FormO × dir → Type
| trip {n X Y} : trip ps S n X Y → journey 0 X Y
| chain {Ai n m X Z} : (∀ Δ ∈ ps.links, ¬premise Ai Δ) → trip ps S n X Ai↓ → journey m Ai↑ Z → journey m.succ X Z

inductive trip2 (ps : proof_structure) (S : switching) : FormO × dir → FormO × dir → Prop
| single (Ai : FormO) (d : dir) : Ai ∈ ps → trip2 (Ai,d) (Ai,d)
| front (Ai Bi Ci : FormO) (d₁ d₂ d₃ : dir) (Δ : Link) :
  Δ ∈ ps.links → steps (S Δ) Δ (Ai,d₁) (Bi,d₂) → trip2 (Bi,d₂) (Ci, d₃) → trip2 (Ai,d₁) (Ci,d₃)
| back (Ai Bi Ci : FormO) (d₁ d₂ d₃ : dir) (Δ : Link) :
  Δ ∈ ps.links → steps (S Δ) Δ (Bi,d₂) (Ci,d₃) → trip2 (Ai,d₁) (Bi, d₂) → trip2 (Ai,d₁) (Ci,d₃)

inductive list_trip (ps : proof_structure) (S : switching) : list (FormO × dir) → Prop
| emp : list_trip []
| single (Ai : FormO) (d : dir) : Ai ∈ ps → list_trip [(Ai,d)]
| cons (Ai Bi : FormO) (d₁ d₂ : dir) (Γ : list (FormO × dir)) (Δ : Link) :
  Δ ∈ ps.links → steps (S Δ) Δ (Ai,d₁) (Bi,d₂) → list_trip ((Bi,d₂) :: Γ) → list_trip ((Ai,d₁) :: (Bi,d₂) :: Γ)

lemma not_self_dual {Ai} : (~Ai) ≠ Ai :=
  by induction Ai; rintro ⟨_⟩

lemma not_self_sub_left_tensor {Ai Bi} : Ai ≠ Ai ⊗ Bi :=
begin
  intro e,
  apply_fun FormO.sizeof at e,
  refine ne_of_lt _ e,
  rw [FormO.sizeof, nat.add_comm],
  apply nat.lt_of_succ_le,
  rw nat.add_comm, rw nat.add_comm 1,
  apply nat.le_add_right,
end

lemma not_self_sub_right_tensor {Ai Bi} : Bi ≠ Ai ⊗ Bi :=
begin
  intro e,
  apply_fun FormO.sizeof at e,
  refine ne_of_lt _ e,
  rw [FormO.sizeof, nat.add_comm],
  apply nat.lt_of_succ_le,
  rw [←nat.add_assoc],
  apply nat.le_add_right,
end

lemma not_self_sub_left_par {Ai Bi} : Ai ≠ Ai ⅋ Bi :=
begin
  intro e,
  apply_fun FormO.sizeof at e,
  refine ne_of_lt _ e,
  rw [FormO.sizeof, nat.add_comm],
  apply nat.lt_of_succ_le,
  rw nat.add_comm, rw nat.add_comm 1,
  apply nat.le_add_right,
end

lemma not_self_sub_right_par {Ai Bi} : Bi ≠ Ai ⅋ Bi :=
begin
  intro e,
  apply_fun FormO.sizeof at e,
  refine ne_of_lt _ e,
  rw [FormO.sizeof, nat.add_comm],
  apply nat.lt_of_succ_le,
  rw [←nat.add_assoc],
  apply nat.le_add_right,
end

section
  variable {Δ : Link}
  variable {T : switch}
  variables {Ai Bi Ci : FormO}
  variables {X Y Z : FormO × dir}

  lemma steps_tensor_unique_prev : Ai ≠ Bi → steps_tensor Ai Bi X Z → steps_tensor Ai Bi Y Z → X = Y :=
  begin
    intros nAB s₁ s₂,
    generalize_hyp e₁ : Z = Z' at s₂,
    cases s₁;
    cases s₂;
    try {refl};
    try { cases e₁, apply absurd rfl nAB};
    try {generalize_hyp e₃ : Ai ⊗ Bi = AiBi at e₁, cases e₁ },
  end

  lemma steps_tensor_unique_next : Ai ≠ Bi → steps_tensor Ai Bi X Y → steps_tensor Ai Bi X Z → Y = Z :=
  begin
    intros nAB s₁ s₂,
    generalize_hyp e₁ : X = X' at s₂,
    cases s₁;
    cases s₂;
    try {refl};
    try { cases e₁, apply absurd rfl nAB};
    try {generalize_hyp e₃ : Ai ⊗ Bi = AiBi at e₁, cases e₁ },
  end

  lemma steps_par_unique_prev : Ai ≠ Bi → steps_par Ai Bi X Z → steps_par Ai Bi Y Z → X = Y :=
  begin
    intros nAB s₁ s₂,
    generalize_hyp e₁ : Z = Z' at s₂,
    cases s₁;
    cases s₂;
    try {refl};
    try { cases e₁, apply absurd rfl nAB};
    try {generalize_hyp e₃ : Ai ⅋ Bi = AiBi at e₁, cases e₁ },
  end

  lemma steps_par_unique_next : Ai ≠ Bi → steps_par Ai Bi X Y → steps_par Ai Bi X Z → Y = Z :=
  begin
    intros nAB s₁ s₂,
    generalize_hyp e₁ : X = X' at s₂,
    cases s₁;
    cases s₂;
    try {refl};
    try { cases e₁, apply absurd rfl nAB};
    try {generalize_hyp e₃ : Ai ⅋ Bi = AiBi at e₁, cases e₁ },
  end

  theorem steps_unique_prev : steps T Δ X Z → steps T Δ Y Z → X = Y :=
  begin
    intros s₁ s₂,
    cases s₁,
    case steps.ax_pos : ai { cases s₂, refl },
    case steps.ax_neg : ai { cases s₂, refl },
    case steps.cut_pos : Ai {
      generalize_hyp e₁ : (~Ai) = nAi at s₂,
      cases s₂, refl, apply absurd e₁ not_self_dual },
    case steps.cut_neg : Ai {
      generalize_hyp e₁ : (Ai,up) = Aiu at s₂,
      cases s₂,
      generalize_hyp e₂ : (~Ai) = nAi at e₁,
      cases e₁, apply absurd e₂ not_self_dual, refl },
    case steps.tensor : Ai Bi X Z' t₁ {
      rcases s₂ with _ | _ | _ | _ | ⟨_,_,_,_,t₂⟩,
      cases T; simp at t₁ t₂;
      apply steps_tensor_unique_prev _ t₁ t₂,
      cases hΔ, finish,
      intro e, injection e with e1,
      exact not_self_sub_right_tensor e1,
      intro e, injection e with e1,
      exact not_self_sub_left_tensor e1,
      finish,
      intro e, injection e with e1,
      exact not_self_sub_left_tensor e1,
      intro e, injection e with e1,
      exact not_self_sub_right_tensor e1,
    },
    case steps.par : A B ai bi ci X y p₁ {
      rcases s₂ with _ | _ | _ | ⟨_,_,_,_,_,_,_,p₂⟩,
      cases T; simp at p₁ p₂;
      apply steps_par_unique_prev _ _ _ p₁ p₂;
      cases hΔ, finish,
      intro e, injection e with e1,
      exact not_self_sub_right_par e1,
      intro e, injection e with e1,
      exact not_self_sub_left_par e1,
      finish,
      intro e, injection e with e1,
      exact not_self_sub_left_par e1,
      intro e, injection e with e1,
      exact not_self_sub_right_par e1,
    },
  end

  theorem steps_unique_next : valid_link Δ → steps T Δ X Y → steps T Δ X Z → Y = Z :=
  begin
    intros hΔ s₁ s₂,
    cases s₁,
    case steps.ax : A ai ni Bi Ci d₁ {
      cases s₂ with _ _ _ Di _ d₂,
      rw dual_unique_next d₁ d₂ },
    case steps.cut : A ai ni Bi Ci d₁ {
      rcases s₂ with _ | ⟨_,_,_,Di,_,d₂⟩,
      rw dual_unique_next d₂ d₁
    },
    case steps.tensor : A B ai bi ci X y t₁ {
      rcases s₂ with _ | _ | ⟨_,_,_,_,_,_,_,t₂⟩,
      cases T; simp at t₁ t₂;
      apply steps_tensor_unique_next _ _ _ t₁ t₂;
      cases hΔ, finish,
      intro e, injection e with e1,
      exact not_self_sub_right_tensor e1,
      intro e, injection e with e1,
      exact not_self_sub_left_tensor e1,
      finish,
      intro e, injection e with e1,
      exact not_self_sub_left_tensor e1,
      intro e, injection e with e1,
      exact not_self_sub_right_tensor e1,
    },
    case steps.par : A B ai bi ci X y p₁ {
      rcases s₂ with _ | _ | _ | ⟨_,_,_,_,_,_,_,p₂⟩,
      cases T; simp at p₁ p₂;
      apply steps_par_unique_next _ _ _ p₁ p₂;
      cases hΔ, finish,
      intro e, injection e with e1,
      exact not_self_sub_right_par e1,
      intro e, injection e with e1,
      exact not_self_sub_left_par e1,
      finish,
      intro e, injection e with e1,
      exact not_self_sub_left_par e1,
      intro e, injection e with e1,
      exact not_self_sub_right_par e1,
    },
  end

  lemma con_of_steps_up :
    steps T Δ Ai↑ X → conclusion Ai Δ :=
  begin
    intros s, cases s,
    case steps.ax : A i j Ai Bi u { cases u; constructor, },
    case steps.tensor : A B i j k Ci u { cases T; cases u; constructor },
    case steps.par : A B i j k Ci u { cases T; cases u; constructor },
  end

  lemma prem_of_steps_down :
    steps T Δ Ai↓ X → premise Ai Δ :=
  begin
    intros s, cases s,
    case steps.cut : A i j Ai Bi u { cases u; constructor, },
    case steps.tensor : A B i j k Ci u { cases T; cases u; constructor },
    case steps.par : A B i j k Ci u { cases T; cases u; constructor }
  end

  lemma con_of_steps_down :
    steps T Δ X Ai↓ → conclusion Ai Δ :=
  begin
    intros s, cases s,
    case steps.ax : A i j Ai Bi u { cases u; constructor, },
    case steps.tensor : A B i j k Ci u { cases T; cases u; constructor },
    case steps.par : A B i j k Ci u { cases T; cases u; constructor },
  end

  lemma prem_of_steps_up :
    steps T Δ X Ai↑ → premise Ai Δ :=
  begin
    intros s, cases s,
    case steps.cut : A i j Ai Bi u { cases u; constructor, },
    case steps.tensor : A B i j k Ci u { cases T; cases u; constructor },
    case steps.par : A B i j k Ci u { cases T; cases u; constructor }
  end

  lemma mem_ps_of_steps_prev {ps : proof_structure} {d : dir} :
    Δ ∈ ps.links → steps T Δ (Ai,d) X → Ai ∈ ps :=
  begin
    intros hΔ s, cases d,
    case bool.ff : { exact ⟨hΔ, mem_Link.prem $ prem_of_steps_down s⟩, },
    case bool.tt : { exact ⟨hΔ, mem_Link.con $ con_of_steps_up s⟩, },
  end

  lemma mem_ps_of_steps_next {ps : proof_structure} {d : dir} :
    Δ ∈ ps.links → steps T Δ X (Bi,d) → Bi ∈ ps :=
  begin
    intros hΔ s, cases d,
    case bool.ff : { exact ⟨hΔ, mem_Link.con $ con_of_steps_down s⟩, },
    case bool.tt : { exact ⟨hΔ, mem_Link.prem $ prem_of_steps_up s⟩, },
  end

end

section
  variable {ps : proof_structure}
  variable {S : switching}
  variables {X Y Z : FormO × dir}
  variables {n m : ℕ}

  theorem link_unique_of_steps_prev {Δ₁ Δ₂} :
    Δ₁ ∈ ps.links → Δ₂ ∈ ps.links → steps (S Δ₁) Δ₁ X Y → steps (S Δ₂) Δ₂ X Z → Δ₁ = Δ₂ :=
  begin
    intros v₁ v₂ s₁ s₂,
    rcases X with ⟨Ai,⟨_|_⟩⟩,
      apply ps.prem_unique Ai _ _ v₁ v₂ (prem_of_steps_down s₁) (prem_of_steps_down s₂),
    apply ps.con_unique Ai _ _ v₁ v₂ (con_of_steps_up s₁) (con_of_steps_up s₂),
  end

  theorem link_unique_of_steps_next {Δ₁ Δ₂} :
    Δ₁ ∈ ps.links → Δ₂ ∈ ps.links → steps (S Δ₁) Δ₁ X Z → steps (S Δ₂) Δ₂ Y Z → Δ₁ = Δ₂ :=
  begin
    intros v₁ v₂ s₁ s₂,
    rcases Z with ⟨Ci,⟨_|_⟩⟩,
      apply ps.con_unique Ci _ _ v₁ v₂ (con_of_steps_down s₁) (con_of_steps_down s₂),
    apply ps.prem_unique Ci _ _ v₁ v₂ (prem_of_steps_up s₁) (prem_of_steps_up s₂),
  end

  def trip.rcons {Δ} : Δ ∈ ps.links → trip ps S n X Y → steps (S Δ) Δ Y Z → trip ps S n.succ X Z :=
  begin
    revert X Y Z,
    apply nat.strong_induction_on n,
    intros n ih,
    rintros X Y Z hΔ tXY sYZ,
    cases tXY,
    case trip.single : Ai d hA {
      apply trip.cons hΔ sYZ,
      cases Z with Ci d', simp,
      apply trip.single,
      apply mem_ps_of_steps_next hΔ sYZ,
    },
    case trip.cons : _ W _ Δ' k hΔ' sXW tWY {
      apply trip.cons hΔ' sXW, simp,
      apply ih k (lt_add_one k) hΔ tWY sYZ },

  end

  def trip.concat : trip ps S n X Y → trip ps S m Y Z → trip ps S (n + m) X Z :=
  begin
    revert X Y Z n,
    induction m,
    case nat.zero : {
      intros X Y Z _ tXY tYZ,
      cases tYZ,
      exact tXY,
    },
    case nat.succ : m ih {
      intros X Y Z n tXY tYZ,
      rw [nat.add_succ, nat.add_comm, ←nat.add_succ, nat.add_comm],
      cases tYZ with _ _ _ _ W _ Δ' _ hΔ' sYW tWZ,
      apply ih _ tWZ,
      apply trip.rcons hΔ' tXY sYW }
  end

  theorem trip_unique_start : trip ps S n X Z → trip ps S n Y Z → X = Y :=
  begin
    intros tX tY,
    revert X Y,
    induction n,
    case nat.zero : { intros, cases tX; cases tY, refl},
    case nat.succ : n ih {
      rintros X Y tX tY,
      rcases tX with _ | ⟨_,X',_,Δ,_,hΔ,sX,tX'⟩,
      rcases tY with _ | ⟨_,Y',_,Δ',_,hΔ',sY,tY'⟩,
      have : Y' = X', by exact ih tY' tX',
      rw this at sY,
      have : Δ' = Δ, apply link_unique_of_steps_next hΔ' hΔ sY sX,
      rw this at sY,
      exact steps_unique_prev (ps.valid Δ hΔ) sX sY,
      }
  end

  lemma trip_exists_rcons : trip ps S n.succ X Z → ∃ Y Δ, ∃ hΔ : Δ ∈ ps.links, ∃ tXY : trip ps S n X Y, steps (S Δ) Δ Y Z :=
  begin
    revert X,
    induction n,
    case nat.zero : {
      intros X tXZ, cases tXZ with _ _ _ _ Y _ Δ _ hΔ sXY tYZ,
      use X, use Δ, refine ⟨hΔ,_⟩,
      constructor,
      cases X with Ai d,
      constructor,
      apply mem_ps_of_steps_prev hΔ sXY,
      cases tYZ, assumption,
      },
    case nat.succ : n ih {
      intros X tXZ, cases tXZ with _ _ _ _ Y _ Δ _ hΔ sXY tYZ,
      specialize ih tYZ,
      rcases ih with ⟨Y',Δ',hΔ',tYY',sY'Z⟩,
      exact ⟨Y',Δ',hΔ',trip.cons hΔ sXY tYY',sY'Z⟩,
    }
  end

  theorem trip_unique_stop : trip ps S n X Y → trip ps S n X Z → Y = Z :=
  begin
    revert Y Z,
    induction n,
    case nat.zero : { intros _ _ tXY tXZ, cases tXY, cases tXZ, refl },
    case nat.succ : n ih {
      intros Y Z tXY tXZ,
      rcases (trip_exists_rcons tXY) with ⟨U,Δ₁,hΔ₁,tXU, sUY⟩,
      rcases (trip_exists_rcons tXZ) with ⟨V,Δ₂,hΔ₂,tXV, sVZ⟩,
      have : V = U, apply ih tXV tXU,
      rw this at sVZ,
      have : Δ₂ = Δ₁, apply link_unique_of_steps_prev hΔ₂ hΔ₁ sVZ sUY,
      rw this at sVZ,
      apply steps_unique_next (ps.valid Δ₁ hΔ₁) sUY sVZ,
      }
  end

end


import ECTate.Algebra.EllipticCurve.Kronecker
import ECTate.Algebra.EllipticCurve.Model
import ECTate.Algebra.ValuedRing
import ECTate.Data.Nat.Enat
import Mathlib.Data.Int.Basic
import Mathlib.Tactic.LibrarySearch
import Mathlib.Tactic.NormNum
import Mathlib.Tactic.Contrapose
import Aesop
import Mathlib.Tactic.Linarith
import ECTate.Algebra.ResidueRing
-- import ECTate.Tactic.ELinarith
-- import Mathlib.Algebra.Order.Field.Defs

open Enat

variable {R : Type u} [CommRing R] [inst : IsDomain R]

namespace Model

variable {p : R}

def is_local_singular_point (valp : SurjVal p) (e : Model R) (P : R × R) : Prop :=
valp (weierstrass e P) > 0 ∧ valp (dweierstrass_dx e P) > 0 ∧ valp (dweierstrass_dy e P) > 0

lemma mk'_apply [NonAssocRing R] (x : R) (c : RingCon R) : c.mk' x = x := rfl
lemma is_local_singular_point_iff (evr : EnatValRing p) (e : Model R) (P : R × R) :
  is_local_singular_point evr.valtn e P ↔ is_singular_point (e.map evr.RingCon.mk') (P.map evr.RingCon.mk' evr.RingCon.mk')
  := by
  rw [is_singular_point]
  rw [weierstrass_map, dweierstrass_dx_map, dweierstrass_dy_map]
  simp [mk'_apply]
  rw [← RingCon.coe_zero]
  rw [RingCon.eq, RingCon.rel_mk, SurjVal.s.r_eq, congruence_p]
  rw [RingCon.eq, RingCon.rel_mk, SurjVal.s.r_eq, congruence_p]
  rw [RingCon.eq, RingCon.rel_mk, SurjVal.s.r_eq, congruence_p]
  simp
  rfl

lemma singular_of_val_discr (valp : SurjVal p) (e : Model R) (h : valp e.discr > 0) :
  ∃ P, is_local_singular_point valp e P :=
by
  sorry

--TODO norm_reprs here?
def singular_point_on_special [DecidableEq R] (evr : EnatValRing p) (e : Model R) : R × R :=
  if 0 < evr.valtn e.c4 then
    match evr.residue_char with
    | 2 => (evr.pth_root e.a4, evr.pth_root (e.a2 * e.a4 + e.a6))
    | 3 => (evr.pth_root (-(e.a3 ^ 2) - e.a6), e.a1 * evr.pth_root (-(e.a3 ^ 2) - e.a6) + e.a3)
    | _ => (-e.b2 * evr.inv_mod 12, -(-e.a1 * e.b2 * evr.inv_mod 12 + e.a3) * evr.inv_mod 2)
  else
    ((18 * e.b6 - e.b2 * e.b4) * evr.inv_mod e.c4, (e.b2 * e.b5 + 3 * e.b7) * evr.inv_mod e.c4)

def move_singular_point_to_origin_triple [DecidableEq R] (evr : EnatValRing p) (e : Model R) : R × R × R :=
⟨(singular_point_on_special evr e).1, 0, (singular_point_on_special evr e).2⟩

-- def move_singular_point_to_origin_iso [DecidableEq R] (evr : EnatValRing p) (e : Model R) : R × R × R :=
--   match evr.residue_char with
--   | 2 => (evr.norm_repr e.a4, 0, evr.norm_repr (e.a6 + e.a4 * e.a2))
--   | 3 => (evr.norm_repr (-e.b6), 0, evr.norm_repr (e.a3 - e.b6 * e.a1))
--   | _ => (0, 0, 0) --need to fill here

-- def move_singular_point_to_origin_iso [DecidableEq R] (evr : EnatValRing p) (e : Model R) : R × R × R :=
-- rst_triple e (move_singular_point_to_origin_triple e)

def move_singular_point_to_origin_iso [DecidableEq R] (evr : EnatValRing p) (e : Model R) :
  Model R :=
rst_triple e (move_singular_point_to_origin_triple evr e)

lemma move_singular_point_to_origin [DecidableEq R] (evr : EnatValRing p) (e : Model R) :
(∃ P, is_local_singular_point evr.valtn e P) →
  is_local_singular_point evr.valtn (move_singular_point_to_origin_iso evr e) (0, 0) :=
by
  rintro ⟨P, h⟩
  have := Model.Field.move_singular_point_to_origin' (e.map evr.RingCon.mk') ⟨P.map evr.RingCon.mk' evr.RingCon.mk', ?_⟩
  . rw [is_local_singular_point_iff]
    simp
    convert this
    simp [move_singular_point_to_origin_iso, Field.move_singular_point_to_origin_iso,
          move_singular_point_to_origin_triple, Field.move_singular_point_to_origin_triple]
    sorry
  . rwa [is_local_singular_point_iff] at h

lemma a6_of_is_local_singular_point_zero_zero [DecidableEq R] (evr : EnatValRing p) (e : Model R)
  (h : is_local_singular_point evr.valtn e (0, 0)) : 0 < evr.valtn e.a6 :=
by simpa [is_local_singular_point, weierstrass] using h.1

def pi_scaling (evr : EnatValRing p) (e : Model R) : Model R :=
{ a1 := evr.sub_val 1 e.a1
  a2 := evr.sub_val 2 e.a2
  a3 := evr.sub_val 3 e.a3
  a4 := evr.sub_val 4 e.a4
  a6 := evr.sub_val 6 e.a6 }

open SurjVal

lemma pi_scaling_of_b2 (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h2 : evr.valtn e.a2 ≥ 2) :
  evr.sub_val 2 e.b2 = evr.sub_val 1 e.a1 * evr.sub_val 1 e.a1 + 4 * evr.sub_val 2 e.a2 := by
  rw [←evr.sub_val_mul_right h1, ←evr.sub_val_mul_left h1, evr.sub_val_sub_val,
    ←evr.sub_val_mul_right h2, ←evr.sub_val_add _ _]
  . rfl
  . exact val_mul_ge_of_both_ge evr.valtn h1 h1
  . exact val_mul_ge_of_right_ge evr.valtn h2

lemma pi_scaling_of_b4 (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h3 : evr.valtn e.a3 ≥ 3) (h4 : evr.valtn e.a4 ≥ 4) :
  evr.sub_val 4 e.b4 = evr.sub_val 1 e.a1 * evr.sub_val 3 e.a3 + 2 * evr.sub_val 4 e.a4 := by
  rw [←evr.sub_val_mul_right h3, ←evr.sub_val_mul_left h1, evr.sub_val_sub_val,
    ←evr.sub_val_mul_right h4, ←evr.sub_val_add _ _]
  . rfl
  . exact val_mul_ge_of_both_ge evr.valtn h1 h3
  . exact val_mul_ge_of_right_ge evr.valtn h4

lemma pi_scaling_of_b6 (evr : EnatValRing p) (e : Model R) (h3 : evr.valtn e.a3 ≥ 3)
  (h6 : evr.valtn e.a6 ≥ 6) :
  evr.sub_val 6 e.b6 = evr.sub_val 3 e.a3 * evr.sub_val 3 e.a3 + 4 * evr.sub_val 6 e.a6 := by
  rw [←evr.sub_val_mul_right h3, ←evr.sub_val_mul_left h3, evr.sub_val_sub_val,
    ←evr.sub_val_mul_right h6, ←evr.sub_val_add _ _]
  . rfl
  . exact val_mul_ge_of_both_ge evr.valtn h3 h3
  . exact val_mul_ge_of_right_ge evr.valtn h6

lemma pi_scaling_of_b8 (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h2 : evr.valtn e.a2 ≥ 2) (h3 : evr.valtn e.a3 ≥ 3) (h4 : evr.valtn e.a4 ≥ 4)
  (h6 : evr.valtn e.a6 ≥ 6) :
  evr.sub_val 8 e.b8 = evr.sub_val 1 e.a1 * evr.sub_val 1 e.a1 * evr.sub_val 6 e.a6
    - evr.sub_val 1 e.a1 * evr.sub_val 3 e.a3 * evr.sub_val 4 e.a4
    + 4 * evr.sub_val 2 e.a2 * evr.sub_val 6 e.a6
    + evr.sub_val 2 e.a2 * evr.sub_val 3 e.a3 * evr.sub_val 3 e.a3
    - evr.sub_val 4 e.a4 * evr.sub_val 4 e.a4 :=
by
  rw [←evr.sub_val_mul_right h1, ←evr.sub_val_mul_left h1, evr.sub_val_sub_val,
    ←evr.sub_val_mul_right h6, ←evr.sub_val_mul_left (val_mul_ge_of_both_ge evr.valtn h1 h1), evr.sub_val_sub_val]
  rw [←evr.sub_val_mul_right h3, ←evr.sub_val_mul_left h1, evr.sub_val_sub_val,
    ←evr.sub_val_mul_right h4, ←evr.sub_val_mul_left (val_mul_ge_of_both_ge evr.valtn h1 h3), evr.sub_val_sub_val]
  rw [←evr.sub_val_mul_right h2, ←evr.sub_val_mul_right h6,
    ←evr.sub_val_mul_left (val_mul_ge_of_right_ge evr.valtn h2), evr.sub_val_sub_val]
  rw [←evr.sub_val_mul_left h2, ←evr.sub_val_mul_right h3, ←evr.sub_val_mul_right h3,
    evr.sub_val_sub_val, ←evr.sub_val_mul_left (val_mul_ge_of_both_ge evr.valtn h2 h3), evr.sub_val_sub_val]
  rw [←evr.sub_val_mul_right h4, ←evr.sub_val_mul_left h4, evr.sub_val_sub_val]
  have h116 := val_mul_ge_of_both_ge evr.valtn (val_mul_ge_of_both_ge evr.valtn h1 h1) h6
  have h134 := (val_mul_ge_of_both_ge evr.valtn (val_mul_ge_of_both_ge evr.valtn h1 h3) h4)
  have h26 := val_mul_ge_of_both_ge evr.valtn (@val_mul_ge_of_right_ge R _ _ 2 p evr.valtn 4 e.a2 h2) h6
  have h233 := val_mul_ge_of_both_ge evr.valtn (val_mul_ge_of_both_ge evr.valtn h2 h3) h3
  have h44 := val_mul_ge_of_both_ge evr.valtn h4 h4
  simp only [add_ofN] at h116 h134 h44 h26 h233
  rw [←val_neg] at h134
  rw [←val_neg] at h44

  rw [sub_eq_add_neg, sub_eq_add_neg, ←evr.sub_val_neg, ←evr.sub_val_neg,
    ←evr.sub_val_add h116 h134, ←evr.sub_val_add _ h26, ←evr.sub_val_add _ h233,
    ←evr.sub_val_add _ h44, ←sub_eq_add_neg, ←sub_eq_add_neg]
  . rfl
  . exact val_add_ge_of_ge evr.valtn
      (val_add_ge_of_ge evr.valtn (val_add_ge_of_ge evr.valtn h116 h134) h26) h233
  . exact val_add_ge_of_ge evr.valtn (val_add_ge_of_ge evr.valtn h116 h134) h26
  . exact val_add_ge_of_ge evr.valtn h116 h134

open EnatValRing in
lemma pi_scaling_of_discr (evr : EnatValRing p) (e : Model R)
  (hb2 : evr.valtn e.b2 ≥ 2) (hb4 : evr.valtn e.b4 ≥ 4)
  (hb6 : evr.valtn e.b6 ≥ 6) (hb8 : evr.valtn e.b8 ≥ 8) :
  evr.sub_val 12 e.discr = -evr.sub_val 2 e.b2 * evr.sub_val 2 e.b2 * evr.sub_val 8 e.b8
    - 8 * ((evr.sub_val 4 e.b4) ^ 3) - 27 * evr.sub_val 6 e.b6 * evr.sub_val 6 e.b6
    + 9 * evr.sub_val 2 e.b2 * evr.sub_val 4 e.b4 * evr.sub_val 6 e.b6 :=
by
  rw [discr,
      sub_val_add,
      sub_val_sub,
      sub_val_sub,
      sub_val_mul _ _ _ _ _ hb8,
      sub_val_mul _ _ _ _ _ hb2,
      sub_val_mul _ _ _ _ _ hb6,
      sub_val_mul_right _ hb6,
      sub_val_mul _ _ _ _ _ hb6,
      sub_val_mul _ _ _ _ _ hb4,
      sub_val_mul_right _ hb2,
      sub_val_mul_right,
      sub_val_pow _ _ _ _ hb4,
      sub_val_neg]
  . rfl
  . exact val_pow_ge_of_ge evr.valtn 3 hb4
  swap
  . rfl
  . exact val_mul_ge_of_right_ge _ hb2
  . rfl
  . exact val_mul_ge_of_both_ge evr.valtn (val_mul_ge_of_right_ge evr.valtn hb2) hb4
  . rfl
  . exact val_mul_ge_of_right_ge evr.valtn hb6
  swap
  . rfl
  . simpa
  . rfl
  . exact val_mul_ge_of_both_ge evr.valtn (by simpa : evr.valtn (-b2 e) ≥ 2) hb2
  . exact val_mul_ge_of_both_ge evr.valtn
      (val_mul_ge_of_both_ge evr.valtn (by simpa : evr.valtn (-b2 e) ≥ 2) hb2) hb8
  . exact val_mul_ge_of_right_ge evr.valtn $ val_pow_ge_of_ge evr.valtn 3 hb4
  . apply val_sub_ge_of_ge
    . exact val_mul_ge_of_both_ge evr.valtn
        (val_mul_ge_of_both_ge evr.valtn (by simpa : evr.valtn (-b2 e) ≥ 2) hb2) hb8
    . exact val_mul_ge_of_right_ge evr.valtn (val_pow_ge_of_ge evr.valtn 3 hb4)
  . exact val_mul_ge_of_both_ge evr.valtn (val_mul_ge_of_right_ge evr.valtn hb6) hb6
  . repeat' apply val_sub_ge_of_ge
    . exact val_mul_ge_of_both_ge evr.valtn
        (val_mul_ge_of_both_ge evr.valtn (by simpa : evr.valtn (-b2 e) ≥ 2) hb2) hb8
    -- . simp [-ge_iff_le, evr.valtn.v_mul_eq_add_v]
    --   cases h : evr.valtn (b2 e)
    --   . simp [-ge_iff_le]
    --     cases h' : evr.valtn (b8 e)
    --     . simp [-ge_iff_le]
    --       norm_cast
    --       sorry
    --     . simp
    --   . simp
    --   -- refine val_mul_ge_of_both_ge evr.valtn
    --   --   (val_mul_ge_of_both_ge evr.valtn ?_ hb2) hb8

    . apply val_mul_ge_of_right_ge evr.valtn
      exact val_pow_ge_of_ge evr.valtn 3 hb4
    . exact val_mul_ge_of_both_ge evr.valtn (val_mul_ge_of_right_ge evr.valtn hb6) hb6
  . exact val_mul_ge_of_both_ge
      evr.valtn (val_mul_ge_of_both_ge evr.valtn (val_mul_ge_of_right_ge evr.valtn hb2) hb4) hb6

lemma b2_of_pi_scaling (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h2 : evr.valtn e.a2 ≥ 2) : (pi_scaling evr e).b2 = evr.sub_val 2 e.b2 := by
  simp only [b2, pi_scaling]
  exact (pi_scaling_of_b2 evr e h1 h2).symm

lemma b4_of_pi_scaling (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h3 : evr.valtn e.a3 ≥ 3) (h4 : evr.valtn e.a4 ≥ 4) :
  (pi_scaling evr e).b4 = evr.sub_val 4 e.b4 := by
  simp only [b4, pi_scaling]
  exact (pi_scaling_of_b4 evr e h1 h3 h4).symm

lemma b6_of_pi_scaling (evr : EnatValRing p) (e : Model R) (h3 : evr.valtn e.a3 ≥ 3)
  (h6 : evr.valtn e.a6 ≥ 6) :
  (pi_scaling evr e).b6 = evr.sub_val 6 e.b6 := by
  simp only [b6, pi_scaling]
  exact (pi_scaling_of_b6 evr e h3 h6).symm

lemma b8_of_pi_scaling (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h2 : evr.valtn e.a2 ≥ 2) (h3 : evr.valtn e.a3 ≥ 3) (h4 : evr.valtn e.a4 ≥ 4)
  (h6 : evr.valtn e.a6 ≥ 6) : (pi_scaling evr e).b8 = evr.sub_val 8 e.b8 := by
  simp only [b8, pi_scaling]
  exact (pi_scaling_of_b8 evr e h1 h2 h3 h4 h6).symm

lemma val_b2_of_val_a12 (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h2 : evr.valtn e.a2 ≥ 2) : evr.valtn e.b2 ≥ 2 := by
  simp only [b2]
  apply val_add_ge_of_ge
  . apply val_mul_ge_of_both_ge evr.valtn h1 h1
  . apply val_mul_ge_of_right_ge evr.valtn h2

lemma val_b4_of_val_a134 (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h3 : evr.valtn e.a3 ≥ 3) (h4 : evr.valtn e.a4 ≥ 4) : evr.valtn e.b4 ≥ 4 := by
  simp only [b4]
  apply val_add_ge_of_ge
  . apply val_mul_ge_of_both_ge evr.valtn h1 h3
  . apply val_mul_ge_of_right_ge evr.valtn h4

lemma val_b6_of_val_a36 (evr : EnatValRing p) (e : Model R) (h3 : evr.valtn e.a3 ≥ 3)
  (h6 : evr.valtn e.a6 ≥ 6) : evr.valtn e.b6 ≥ 6 := by
  simp only [b6]
  apply val_add_ge_of_ge
  . apply val_mul_ge_of_both_ge evr.valtn h3 h3
  . apply val_mul_ge_of_right_ge evr.valtn h6

lemma val_b8_of_val_ai (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h2 : evr.valtn e.a2 ≥ 2) (h3 : evr.valtn e.a3 ≥ 3) (h4 : evr.valtn e.a4 ≥ 4)
  (h6 : evr.valtn e.a6 ≥ 6) : evr.valtn e.b8 ≥ 8 := by
  simp only [b8, sub_eq_add_neg]
  apply val_add_ge_of_ge
  . apply val_add_ge_of_ge
    . apply val_add_ge_of_ge
      . apply val_add_ge_of_ge
        . apply val_mul_ge_of_both_ge _ (val_mul_ge_of_both_ge _ h1 h1) h6
        . rw [val_neg]
          apply val_mul_ge_of_both_ge _ (val_mul_ge_of_both_ge _ h1 h3) h4
      . rw [mul_assoc]
        apply val_mul_ge_of_right_ge _ (val_mul_ge_of_both_ge _ h2 h6)
    . apply val_mul_ge_of_both_ge _ (val_mul_ge_of_both_ge _ h2 h3) h3
  . rw [val_neg]
    apply val_mul_ge_of_both_ge _ h4 h4

lemma discr_of_pi_scaling (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h2 : evr.valtn e.a2 ≥ 2) (h3 : evr.valtn e.a3 ≥ 3)
  (h4 : evr.valtn e.a4 ≥ 4) (h6 : evr.valtn e.a6 ≥ 6) :
  (pi_scaling evr e).discr = evr.sub_val 12 e.discr := by
  simp only [discr, b2_of_pi_scaling evr e h1 h2, b4_of_pi_scaling evr e h1 h3 h4,
    b6_of_pi_scaling evr e h3 h6, b8_of_pi_scaling evr e h1 h2 h3 h4 h6]
  exact (pi_scaling_of_discr evr e (val_b2_of_val_a12 evr e h1 h2)
    (val_b4_of_val_a134 evr e h1 h3 h4) (val_b6_of_val_a36 evr e h3 h6)
    (val_b8_of_val_ai evr e h1 h2 h3 h4 h6)).symm

lemma val_discr_of_val_ai (evr : EnatValRing p) (e : Model R) (h1 : evr.valtn e.a1 ≥ 1)
  (h2 : evr.valtn e.a2 ≥ 2) (h3 : evr.valtn e.a3 ≥ 3) (h4 : evr.valtn e.a4 ≥ 4)
  (h6 : evr.valtn e.a6 ≥ 6) : evr.valtn e.discr ≥ 12 := by
  have hb2 := val_b2_of_val_a12 evr e h1 h2
  have hb4 := val_b4_of_val_a134 evr e h1 h3 h4
  have hb6 := val_b6_of_val_a36 evr e h3 h6
  have hb8 := val_b8_of_val_ai evr e h1 h2 h3 h4 h6
  simp only [discr, sub_eq_add_neg]
  repeat' apply val_add_ge_of_ge
  . rw [←neg_mul_eq_neg_mul, ←neg_mul_eq_neg_mul, val_neg]
    apply val_mul_ge_of_both_ge _ (val_mul_ge_of_both_ge _ hb2 hb2) hb8
  . rw [val_neg, pow_succ', pow_succ', pow_one]
    apply val_mul_ge_of_right_ge _ (val_mul_ge_of_both_ge _ (val_mul_ge_of_both_ge _ hb4 hb4) hb4)
  . rw [val_neg, mul_assoc]
    apply val_mul_ge_of_right_ge _ (val_mul_ge_of_both_ge _ hb6 hb6)
  . rw [mul_assoc, mul_assoc]
    apply val_mul_ge_of_right_ge _ (val_mul_ge_of_both_ge _ hb2 (val_mul_ge_of_both_ge _ hb4 hb6))

end Model

namespace ValidModel

def pi_scaling (evr : EnatValRing p) (e : ValidModel R) (h1 : evr.valtn e.a1 ≥ 1)
  (h2 : evr.valtn e.a2 ≥ 2) (h3 : evr.valtn e.a3 ≥ 3) (h4 : evr.valtn e.a4 ≥ 4)
  (h6 : evr.valtn e.a6 ≥ 6) : ValidModel R := {
  toModel := Model.pi_scaling evr e.toModel,
  discr_not_zero := by
    rw [Model.discr_of_pi_scaling evr e.toModel h1 h2 h3 h4 h6]
    intro H
    have H' := let_value_eq (fun (x:R) => p ^ 12 * x) H
    simp only [mul_zero] at H'
    rw [←evr.factor_p_of_le_val (Model.val_discr_of_val_ai evr e.toModel h1 h2 h3 h4 h6)] at H'
    apply e.discr_not_zero H' }

@[simp]
theorem pi_scaling_toModel
  (evr : EnatValRing p) (e : ValidModel R) (h1 : SurjVal.v evr.valtn e.toModel.a1 ≥ 1)
  (h2 : SurjVal.v evr.valtn e.toModel.a2 ≥ 2) (h3 : SurjVal.v evr.valtn e.toModel.a3 ≥ 3)
  (h4 : SurjVal.v evr.valtn e.toModel.a4 ≥ 4) (h6 : SurjVal.v evr.valtn e.toModel.a6 ≥ 6) :
  (pi_scaling evr e h1 h2 h3 h4 h6).toModel = Model.pi_scaling evr e.toModel :=
Eq.refl (pi_scaling evr e h1 h2 h3 h4 h6).toModel

open SurjVal

def val_discr_to_nat {p : R} (valp : SurjVal p) (e : ValidModel R) : ℕ :=
nat_of_val valp e.discr_not_zero

@[simp]
lemma iso_rst_val_discr_to_nat {p : R} (valp : SurjVal p) (r s t : R) (e : ValidModel R) :
  val_discr_to_nat valp (rst_iso r s t e) = val_discr_to_nat valp e :=
by simp [val_discr_to_nat, nat_of_val, ValidModel.rst_iso, Model.rst_discr]

lemma ofN_val_discr_to_nat {p : R} (valp : SurjVal p) (e : ValidModel R) :
  val_discr_to_nat valp e = valp e.discr := by
  cases h : valp e.discr with
  | ofN n =>
    rwa [val_discr_to_nat, nat_of_val, ofN_to_nat_eq_self]
  | top =>
    exfalso
    rw [valp.v_eq_top_iff_zero] at h
    exact e.discr_not_zero h

lemma pi_scaling_val_discr_to_nat {p : R} (evr : EnatValRing p) (e : ValidModel R)
  (h1 : evr.valtn e.a1 ≥ 1) (h2 : evr.valtn e.a2 ≥ 2)
  (h3 : evr.valtn e.a3 ≥ 3) (h4 : evr.valtn e.a4 ≥ 4) (h6 : evr.valtn e.a6 ≥ 6) :
  val_discr_to_nat evr.valtn (pi_scaling evr e h1 h2 h3 h4 h6) = val_discr_to_nat evr.valtn e - 12 :=
by
  rw [Enat.eq_ofN, ofN_val_discr_to_nat, pi_scaling_toModel evr e h1 h2 h3 h4 h6,
    Model.discr_of_pi_scaling _ _ h1 h2 h3 h4 h6, evr.val_sub_val_eq]
  rw [ofN_val_discr_to_nat]

lemma v_b2_of_v_a1_a2 {p : R} (valp : SurjVal p) (e : ValidModel R) (h1 : valp e.a1 ≥ 1)
  (h2 : valp e.a2 = 1) : valp e.b2 ≥ 1 :=
  val_add_ge_of_ge valp (val_mul_ge_of_left_ge valp h1) (val_mul_ge_of_right_ge valp (le_of_eq h2.symm))

lemma v_b4_of_v_a1_a3_a4 {p : R} (valp : SurjVal p) (e : ValidModel R) (h1 : valp e.a1 ≥ 1)
  (h3 : valp e.a3 ≥ q) (h4 : valp e.a4 ≥ q + 1) : valp e.b4 ≥ q + 1 := by
  apply val_add_ge_of_ge valp
  . rw [add_comm]
    exact (val_mul_ge_of_both_ge valp h1 h3)
  . exact (val_mul_ge_of_right_ge valp h4)

lemma v_b6_of_v_a3_a6 {p : R} {q : ℕ} (valp : SurjVal p) (e : ValidModel R) (h3 : valp e.a3 ≥ q)
  (h6 : valp e.a6 ≥ 2 * q) : valp e.b6 ≥ 2 * q := by
  apply val_add_ge_of_ge valp
  . simp -- TOOD use powers in defs of bis not mul...
    rw [(show 2 * (q : Enat) = q + q by ring)]
    exact add_le_add h3 h3
  . exact (val_mul_ge_of_right_ge valp h6)

lemma v_b8_of_v_ai {p : R} {q : ℕ} (valp : SurjVal p) (e : ValidModel R) (h1 : valp e.a1 ≥ 1)
  (h2 : valp e.a2 = 1) (h3 : valp e.a3 ≥ q) (h4 : valp e.a4 ≥ q + 1)
  (h6 : valp e.a6 ≥ 2 * q) : valp e.b8 ≥ 2 * q + 1 := by
  simp only [Model.b8]
  rw [sub_eq_add_neg, sub_eq_add_neg]
  repeat apply val_add_ge_of_ge valp
  . simp
    rw [(show 2 * (q : Enat) + 1 = 0 + 1 + 2 * q by ring)]
    repeat' apply add_le_add
    exact zero_le _
    assumption
    assumption
  . simp
    rw [(show 2 * (q : Enat) + 1 = 0 + q + (q + 1) by ring)]
    repeat' apply add_le_add
    exact zero_le _
    assumption
    assumption
  . simp
    rw [(show 2 * (q : Enat) + 1 = 0 + 1 + (2 * q) by ring)]
    repeat' apply add_le_add
    exact zero_le _
    apply le_of_eq
    exact h2.symm
    assumption
  . simp at *
    rw [(show 2 * (q : Enat) + 1 = 1 + q + q by ring)]
    repeat' apply add_le_add
    apply le_of_eq
    exact h2.symm
    assumption
    assumption
  . simp
    rw [(show 2 * (q : Enat) + 1 = q + 1 + q by ring)]
    apply add_le_add
    assumption
    exact le_of_succ_le h4

private lemma aux (n q : ℕ) (h : 1 < q) (hn : 2 * q ≤ n) : 2 * q + 3 ≤ n + n :=
by linarith

private lemma aux' (n q m t : ℕ) (h : 1 < q) (h2': 1 ≤ n) (h4': q + 1 ≤ m) (h6': 2 * q ≤ t) :
  2 * q + 3 ≤ n + (m + t) :=
by linarith

lemma v_discr_of_v_ai {p : R} {q : ℕ} (valp : SurjVal p) (e : ValidModel R) (hq : q > 1)
  (h1 : valp e.a1 ≥ 1) (h2 : valp e.a2 = 1) (h3 : valp e.a3 ≥ q)
  (h4 : valp e.a4 ≥ q + 1) (h6 : valp e.a6 ≥ 2 * q) :
  valp e.discr ≥ 2 * q + 3 := by
  have h2' := v_b2_of_v_a1_a2 valp e h1 h2
  have h4' := v_b4_of_v_a1_a3_a4 valp e h1 h3 h4
  have h6' := v_b6_of_v_a3_a6 valp e h3 h6
  have h8' := v_b8_of_v_ai valp e h1 h2 h3 h4 h6
  simp only [Model.discr]
  rw [sub_eq_add_neg, sub_eq_add_neg]
  repeat' apply val_add_ge_of_ge valp
  . rw [←neg_mul_eq_neg_mul, ←neg_mul_eq_neg_mul, val_neg]
    simp only [v_mul_eq_add_v, ge_iff_le] at *
    rw [(show 2 * (q : Enat) + 3 = 1 + 1 + (2 * q + 1) by ring)]
    repeat' apply add_le_add
    all_goals assumption
  . rw [val_neg, pow_succ', pow_succ', pow_one, ←add_self_eq_mul_two,
      (show (q : Enat) + q + 3 = q + 1 + (q + 1) + 1 by ring)]
    exact val_mul_ge_of_right_ge valp (val_mul_ge_of_both_ge valp
      (val_mul_ge_of_both_ge valp h4' h4') (le_trans ((le_ofN _ _).2 (Nat.le_add_left 1 q)) h4'))
  . simp only [val_neg, v_mul_eq_add_v, ge_iff_le] at *
    cases hh6 : v valp (Model.b6 e.toModel) with
    | ofN n =>
      rw [add_assoc]
      apply le_add_of_nonneg_of_le (zero_le _) _
      simp [hh6] at *
      norm_cast at *
      exact aux n q hq h6' -- TODO linarith doesn't work
    | top =>
      simp
      exact Enat.le_top _
    -- rw [(show 2 * (q : Enat) + 3 = 0 + 1 + (2 * q + 1) by ring)]
    -- rw [val_neg, mul_assoc, (show 3 = 2 + 1 by rfl)]
    -- apply val_mul_ge_of_right_ge valp (val_mul_ge_of_both_ge valp h6' (le_trans ((le_ofN _ _).2 _) h6'))
    -- rw [←add_self_eq_mul_two q]
    -- exact Nat.add_le_add (Nat.succ_le_of_lt hq) (Nat.le_of_lt hq)
  . cases hh2 : v valp (Model.b2 e.toModel) with
    | ofN n =>
      cases hh4 : v valp (Model.b4 e.toModel) with
      | ofN m =>
        cases hh6 : v valp (Model.b6 e.toModel) with
        | ofN t =>
          simp [*] at *
          rw [add_assoc, add_assoc]
          apply le_add_of_nonneg_of_le (zero_le _) _
          norm_cast at *
          exact aux' n q m t hq h2' h4' h6' -- TODO linarith doesn't work
        | top =>
          simp [hh6]
          exact Enat.le_top _
      | top =>
        simp [hh4]
        exact Enat.le_top _
    | top =>
      simp [hh2]
      exact Enat.le_top _
    -- rw [(show 3 = 1 + (1 + 1) by rfl), mul_comm, mul_assoc 9]
    -- exact val_mul_ge_of_both_ge valp h6' (val_mul_ge_of_right_ge valp
    --   (val_mul_ge_of_both_ge valp h2' (le_trans ((le_ofN _ _).2
    --   (Nat.add_le_add (Nat.le_of_lt hq) (le_of_eq rfl))) h4')))

lemma small_char_div_12 {p : R} (hp : p = 2 ∨ p = 3) (valp : SurjVal p) : valp 12 ≥ 1 := by
  cases hp with
  | inl p2 =>
    rw [(show (12 : R) = 2 * 6 by norm_num)]
    apply val_mul_ge_of_left_ge
    rw [←p2]
    exact le_of_eq (valp.v_uniformizer).symm
  | inr p3 =>
    rw [(show (12 : R) = 3 * 4 by norm_num)]
    apply val_mul_ge_of_left_ge
    rw [←p3]
    exact le_of_eq (valp.v_uniformizer).symm

lemma v_rst_b2_of_small_char {p : R} (valp : SurjVal p) (e : ValidModel R) (r s t : R)
  (h_b2 : valp e.b2 ≥ 1) (h_p : valp 12 ≥ 1) : valp (rst_iso r s t e).b2 ≥ 1 := by
  simp only [rst_iso]
  -- aesop
  rw [Model.rst_b2]
  apply val_add_ge_of_ge valp h_b2
  exact val_mul_ge_of_left_ge valp h_p

section cubic

def Δcubic (c : R × R × R) : R :=
18 * c.1 * c.2.1 * c.2.2 - 4 * c.1 ^ 3 * c.2.2 + c.1 ^ 2 * c.2.1 ^ 2 - 4 * c.2.1 ^ 3 - 27 * c.2.2 ^ 2

def model_to_cubic {p : R} (evr : EnatValRing p) (e : ValidModel R) : R × R × R :=
(evr.sub_val 1 e.a2, evr.sub_val 2 e.a4, evr.sub_val 3 e.a6)

def cubic_has_distinct_roots {p : R} (evr : EnatValRing p) (e : ValidModel R) : Prop :=
evr.valtn (Δcubic (model_to_cubic evr e)) = 0

def δmultiplicity (c : R × R × R) : R := 3 * c.2.1 - c.1 ^ 2

def cubic_has_double_root {p : R} (evr : EnatValRing p) (e : ValidModel R) : Prop :=
evr.valtn (Δcubic (model_to_cubic evr e)) > 0 ∧ evr.valtn (δmultiplicity (model_to_cubic evr e)) = 0

def cubic_has_triple_root {p : R} (evr : EnatValRing p) (e : ValidModel R) : Prop :=
evr.valtn (Δcubic (model_to_cubic evr e)) > 0 ∧ evr.valtn (δmultiplicity (model_to_cubic evr e)) > 0

def move_cubic_double_root_to_origin_iso {p : R} (evr : EnatValRing p) (e : ValidModel R) : ValidModel R :=
  let (a2p, a4p2, _) := model_to_cubic evr e
  rst_iso (p * (evr.norm_repr (if evr.residue_char = 2 then a4p2 else evr.inv_mod a2p * evr.pth_root a4p2))) 0 0 e

def cubic_double_root_is_zero {p : R} (evr : EnatValRing p) (e : ValidModel R) : Prop :=
  let (a2p, a4p2, a6p3) := model_to_cubic evr e
  evr.valtn a2p = 0 ∧ evr.valtn a4p2 > 0 ∧ evr.valtn a6p3 > 0

lemma move_cubic_double_root_to_origin {p : R} (evr : EnatValRing p) (e : ValidModel R) :
  cubic_has_double_root evr e → cubic_double_root_is_zero evr (move_cubic_double_root_to_origin_iso evr e) := sorry

def move_cubic_triple_root_to_origin_iso {p : R} (evr : EnatValRing p) (e : ValidModel R) : ValidModel R :=
  let (a2p, _, a6p3) := model_to_cubic evr e
  rst_iso (evr.norm_repr (if evr.residue_char = 3 then -evr.pth_root a6p3 else -a2p * evr.inv_mod 3)) 0 0 e

def cubic_triple_root_is_zero {p : R} (evr : EnatValRing p) (e : ValidModel R) : Prop :=
  let (a2p, a4p2, a6p3) := model_to_cubic evr e
  evr.valtn a2p > 0 ∧ evr.valtn a4p2 > 0 ∧ evr.valtn a6p3 > 0

lemma move_cubic_triple_root_to_origin {p : R} (evr : EnatValRing p) (e : ValidModel R) :
cubic_has_triple_root evr e → cubic_triple_root_is_zero evr (move_cubic_triple_root_to_origin_iso evr e) := sorry

end cubic

end ValidModel


/-
Copyright (c) 2022 Chris Birkbeck. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Birkbeck, David Loeffler

! This file was ported from Lean 3 source module order.filter.zero_and_bounded_at_filter
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Module.Submodule.Basic
import Mathbin.Topology.Algebra.Monoid
import Mathbin.Analysis.Asymptotics.Asymptotics

/-!
# Zero and Bounded at filter

Given a filter `l` we define the notion of a function being `zero_at_filter` as well as being
`bounded_at_filter`. Alongside this we construct the `submodule`, `add_submonoid` of functions
that are `zero_at_filter`. Similarly, we construct the `submodule` and `subalgebra` of functions
that are `bounded_at_filter`.

-/

namespace Filter

variable {α β : Type _}

open Topology

/-- If `l` is a filter on `α`, then a function `f : α → β` is `zero_at_filter l`
  if it tends to zero along `l`. -/
def ZeroAtFilter [Zero β] [TopologicalSpace β] (l : Filter α) (f : α → β) : Prop :=
  Filter.Tendsto f l (𝓝 0)
#align filter.zero_at_filter Filter.ZeroAtFilter

theorem zero_zeroAtFilter [Zero β] [TopologicalSpace β] (l : Filter α) :
    ZeroAtFilter l (0 : α → β) :=
  tendsto_const_nhds
#align filter.zero_zero_at_filter Filter.zero_zeroAtFilter

theorem ZeroAtFilter.add [TopologicalSpace β] [AddZeroClass β] [ContinuousAdd β] {l : Filter α}
    {f g : α → β} (hf : ZeroAtFilter l f) (hg : ZeroAtFilter l g) : ZeroAtFilter l (f + g) := by
  simpa using hf.add hg
#align filter.zero_at_filter.add Filter.ZeroAtFilter.add

theorem ZeroAtFilter.neg [TopologicalSpace β] [AddGroup β] [ContinuousNeg β] {l : Filter α}
    {f : α → β} (hf : ZeroAtFilter l f) : ZeroAtFilter l (-f) := by simpa using hf.neg
#align filter.zero_at_filter.neg Filter.ZeroAtFilter.neg

theorem ZeroAtFilter.smul {𝕜 : Type _} [TopologicalSpace 𝕜] [TopologicalSpace β] [Zero 𝕜] [Zero β]
    [SMulWithZero 𝕜 β] [ContinuousSMul 𝕜 β] {l : Filter α} {f : α → β} (c : 𝕜)
    (hf : ZeroAtFilter l f) : ZeroAtFilter l (c • f) := by simpa using hf.const_smul c
#align filter.zero_at_filter.smul Filter.ZeroAtFilter.smul

/-- `zero_at_filter_submodule l` is the submodule of `f : α → β` which
tend to zero along `l`. -/
def zeroAtFilterSubmodule [TopologicalSpace β] [Semiring β] [ContinuousAdd β] [ContinuousMul β]
    (l : Filter α) : Submodule β (α → β)
    where
  carrier := ZeroAtFilter l
  zero_mem' := zero_zeroAtFilter l
  add_mem' a b ha hb := ha.add hb
  smul_mem' c f hf := hf.smul c
#align filter.zero_at_filter_submodule Filter.zeroAtFilterSubmodule

/-- `zero_at_filter_add_submonoid l` is the additive submonoid of `f : α → β`
which tend to zero along `l`. -/
def zeroAtFilterAddSubmonoid [TopologicalSpace β] [AddZeroClass β] [ContinuousAdd β]
    (l : Filter α) : AddSubmonoid (α → β)
    where
  carrier := ZeroAtFilter l
  add_mem' a b ha hb := ha.add hb
  zero_mem' := zero_zeroAtFilter l
#align filter.zero_at_filter_add_submonoid Filter.zeroAtFilterAddSubmonoid

/-- If `l` is a filter on `α`, then a function `f: α → β` is `bounded_at_filter l`
if `f =O[l] 1`. -/
def BoundedAtFilter [Norm β] (l : Filter α) (f : α → β) : Prop :=
  Asymptotics.IsO l f (1 : α → ℝ)
#align filter.bounded_at_filter Filter.BoundedAtFilter

theorem ZeroAtFilter.boundedAtFilter [NormedAddCommGroup β] {l : Filter α} {f : α → β}
    (hf : ZeroAtFilter l f) : BoundedAtFilter l f :=
  by
  rw [zero_at_filter, ← Asymptotics.isOCat_const_iff (one_ne_zero' ℝ)] at hf
  exact hf.is_O
#align filter.zero_at_filter.bounded_at_filter Filter.ZeroAtFilter.boundedAtFilter

theorem const_boundedAtFilter [NormedField β] (l : Filter α) (c : β) :
    BoundedAtFilter l (Function.const α c : α → β) :=
  Asymptotics.isO_const_const c one_ne_zero l
#align filter.const_bounded_at_filter Filter.const_boundedAtFilter

theorem BoundedAtFilter.add [NormedAddCommGroup β] {l : Filter α} {f g : α → β}
    (hf : BoundedAtFilter l f) (hg : BoundedAtFilter l g) : BoundedAtFilter l (f + g) := by
  simpa using hf.add hg
#align filter.bounded_at_filter.add Filter.BoundedAtFilter.add

theorem BoundedAtFilter.neg [NormedAddCommGroup β] {l : Filter α} {f : α → β}
    (hf : BoundedAtFilter l f) : BoundedAtFilter l (-f) :=
  hf.neg_left
#align filter.bounded_at_filter.neg Filter.BoundedAtFilter.neg

theorem BoundedAtFilter.smul {𝕜 : Type _} [NormedField 𝕜] [NormedAddCommGroup β] [NormedSpace 𝕜 β]
    {l : Filter α} {f : α → β} (c : 𝕜) (hf : BoundedAtFilter l f) : BoundedAtFilter l (c • f) :=
  hf.const_smul_left c
#align filter.bounded_at_filter.smul Filter.BoundedAtFilter.smul

theorem BoundedAtFilter.mul [NormedField β] {l : Filter α} {f g : α → β} (hf : BoundedAtFilter l f)
    (hg : BoundedAtFilter l g) : BoundedAtFilter l (f * g) :=
  by
  refine' (hf.mul hg).trans _
  convert Asymptotics.isO_refl _ l
  ext x
  simp
#align filter.bounded_at_filter.mul Filter.BoundedAtFilter.mul

/-- The submodule of functions that are bounded along a filter `l`. -/
def boundedFilterSubmodule [NormedField β] (l : Filter α) : Submodule β (α → β)
    where
  carrier := BoundedAtFilter l
  zero_mem' := const_boundedAtFilter l 0
  add_mem' f g hf hg := hf.add hg
  smul_mem' c f hf := hf.smul c
#align filter.bounded_filter_submodule Filter.boundedFilterSubmodule

/-- The subalgebra of functions that are bounded along a filter `l`. -/
def boundedFilterSubalgebra [NormedField β] (l : Filter α) : Subalgebra β (α → β) :=
  by
  refine' Submodule.toSubalgebra (bounded_filter_submodule l) _ fun f g hf hg => _
  · exact const_bounded_at_filter l (1 : β)
  · simpa only [Pi.one_apply, mul_one, norm_mul] using hf.mul hg
#align filter.bounded_filter_subalgebra Filter.boundedFilterSubalgebra

end Filter


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.module.pi

/-!
# Bundled hom instances for module and multiplicative actions

This file defines instances for module, mul_action and related structures on bundled `_hom` types.

These are analogous to the instances in `algebra.module.pi`, but for bundled instead of unbundled
functions.
-/

variables {R S A B : Type*}

namespace add_monoid_hom

section
variables [monoid R] [monoid S] [add_monoid A] [add_comm_monoid B]
variables [distrib_mul_action R B] [distrib_mul_action S B]

instance : distrib_mul_action R (A →+ B) :=
{ smul := λ r f,
  { to_fun := r • f,
    map_zero' := by simp,
    map_add' := λ x y, by simp [smul_add] },
  one_smul := λ f, by simp,
  mul_smul := λ r s f, by simp [mul_smul],
  smul_add := λ r f g, ext $ λ x, by simp [smul_add],
  smul_zero := λ r, ext $ λ x, by simp [smul_zero] }

@[simp] lemma coe_smul (r : R) (f : A →+ B) : ⇑(r • f) = r • f := rfl
lemma smul_apply (r : R) (f : A →+ B) (x : A) : (r • f) x = r • f x := rfl

instance [smul_comm_class R S B] : smul_comm_class R S (A →+ B) :=
⟨λ a b f, ext $ λ x, smul_comm _ _ _⟩

instance [has_smul R S] [is_scalar_tower R S B] : is_scalar_tower R S (A →+ B) :=
⟨λ a b f, ext $ λ x, smul_assoc _ _ _⟩

instance [distrib_mul_action Rᵐᵒᵖ B] [is_central_scalar R B] : is_central_scalar R (A →+ B) :=
⟨λ a b, ext $ λ x, op_smul_eq_smul _ _⟩

end

instance [semiring R] [add_monoid A] [add_comm_monoid B] [module R B] :
  module R (A →+ B) :=
{ add_smul := λ r s x, ext $ λ y, by simp [add_smul],
  zero_smul := λ x, ext $ λ y, by simp [zero_smul],
  ..add_monoid_hom.distrib_mul_action }

end add_monoid_hom


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury G. Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.affine_space.midpoint
import Mathlib.algebra.module.ordered
import Mathlib.tactic.field_simp
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Ordered modules as affine spaces

In this file we define the slope of a function `f : k → PE` taking values in an affine space over
`k` and prove some theorems about `slope` and `line_map` in the case when `PE` is an ordered
semimodule over `k`. The `slope` function naturally appears in the Mean Value Theorem, and in the
proof of the fact that a function with nonnegative second derivative on an interval is convex on
this interval. In the third part of this file we prove inequalities that will be used in
`analysis.convex.basic` to link convexity of a function on an interval to monotonicity of the slope,
see section docstring below for details.

## Implementation notes

We do not introduce the notion of ordered affine spaces (yet?). Instead, we prove various theorems
for an ordered semimodule interpreted as an affine space.

## Tags

affine space, ordered semimodule, slope
-/

/-!
### Definition of `slope` and basic properties

In this section we define `slope f a b` and prove some properties that do not require order on the
codomain.  -/

/-- `slope f a b = (b - a)⁻¹ • (f b -ᵥ f a)` is the slope of a function `f` on the interval
`[a, b]`. Note that `slope f a a = 0`, not the derivative of `f` at `a`. -/
def slope {k : Type u_1} {E : Type u_2} {PE : Type u_3} [field k] [add_comm_group E]
    [semimodule k E] [add_torsor E PE] (f : k → PE) (a : k) (b : k) : E :=
  b - a⁻¹ • (f b -ᵥ f a)

theorem slope_def_field {k : Type u_1} [field k] (f : k → k) (a : k) (b : k) :
    slope f a b = (f b - f a) / (b - a) :=
  Eq.symm div_eq_inv_mul

@[simp] theorem slope_same {k : Type u_1} {E : Type u_2} {PE : Type u_3} [field k]
    [add_comm_group E] [semimodule k E] [add_torsor E PE] (f : k → PE) (a : k) : slope f a a = 0 :=
  sorry

theorem eq_of_slope_eq_zero {k : Type u_1} {E : Type u_2} {PE : Type u_3} [field k]
    [add_comm_group E] [semimodule k E] [add_torsor E PE] {f : k → PE} {a : k} {b : k}
    (h : slope f a b = 0) : f a = f b :=
  sorry

theorem slope_comm {k : Type u_1} {E : Type u_2} {PE : Type u_3} [field k] [add_comm_group E]
    [semimodule k E] [add_torsor E PE] (f : k → PE) (a : k) (b : k) : slope f a b = slope f b a :=
  sorry

/-- `slope f a c` is a linear combination of `slope f a b` and `slope f b c`. This version
explicitly provides coefficients. If `a ≠ c`, then the sum of the coefficients is `1`, so it is
actually an affine combination, see `line_map_slope_slope_sub_div_sub`. -/
theorem sub_div_sub_smul_slope_add_sub_div_sub_smul_slope {k : Type u_1} {E : Type u_2}
    {PE : Type u_3} [field k] [add_comm_group E] [semimodule k E] [add_torsor E PE] (f : k → PE)
    (a : k) (b : k) (c : k) :
    ((b - a) / (c - a)) • slope f a b + ((c - b) / (c - a)) • slope f b c = slope f a c :=
  sorry

/-- `slope f a c` is an affine combination of `slope f a b` and `slope f b c`. This version uses
`line_map` to express this property. -/
theorem line_map_slope_slope_sub_div_sub {k : Type u_1} {E : Type u_2} {PE : Type u_3} [field k]
    [add_comm_group E] [semimodule k E] [add_torsor E PE] (f : k → PE) (a : k) (b : k) (c : k)
    (h : a ≠ c) :
    coe_fn (affine_map.line_map (slope f a b) (slope f b c)) ((c - b) / (c - a)) = slope f a c :=
  sorry

/-- `slope f a b` is an affine combination of `slope f a (line_map a b r)` and
`slope f (line_map a b r) b`. We use `line_map` to express this property. -/
theorem line_map_slope_line_map_slope_line_map {k : Type u_1} {E : Type u_2} {PE : Type u_3}
    [field k] [add_comm_group E] [semimodule k E] [add_torsor E PE] (f : k → PE) (a : k) (b : k)
    (r : k) :
    coe_fn
          (affine_map.line_map (slope f (coe_fn (affine_map.line_map a b) r) b)
            (slope f a (coe_fn (affine_map.line_map a b) r)))
          r =
        slope f a b :=
  sorry

/-!
### Monotonicity of `line_map`

In this section we prove that `line_map a b r` is monotone (strictly or not) in its arguments if
other arguments belong to specific domains.
-/

theorem line_map_mono_left {k : Type u_1} {E : Type u_2} [ordered_ring k] [ordered_add_comm_group E]
    [semimodule k E] [ordered_semimodule k E] {a : E} {a' : E} {b : E} {r : k} (ha : a ≤ a')
    (hr : r ≤ 1) : coe_fn (affine_map.line_map a b) r ≤ coe_fn (affine_map.line_map a' b) r :=
  sorry

theorem line_map_strict_mono_left {k : Type u_1} {E : Type u_2} [ordered_ring k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {a' : E} {b : E}
    {r : k} (ha : a < a') (hr : r < 1) :
    coe_fn (affine_map.line_map a b) r < coe_fn (affine_map.line_map a' b) r :=
  sorry

theorem line_map_mono_right {k : Type u_1} {E : Type u_2} [ordered_ring k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {b' : E}
    {r : k} (hb : b ≤ b') (hr : 0 ≤ r) :
    coe_fn (affine_map.line_map a b) r ≤ coe_fn (affine_map.line_map a b') r :=
  sorry

theorem line_map_strict_mono_right {k : Type u_1} {E : Type u_2} [ordered_ring k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {b' : E}
    {r : k} (hb : b < b') (hr : 0 < r) :
    coe_fn (affine_map.line_map a b) r < coe_fn (affine_map.line_map a b') r :=
  sorry

theorem line_map_mono_endpoints {k : Type u_1} {E : Type u_2} [ordered_ring k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {a' : E} {b : E}
    {b' : E} {r : k} (ha : a ≤ a') (hb : b ≤ b') (h₀ : 0 ≤ r) (h₁ : r ≤ 1) :
    coe_fn (affine_map.line_map a b) r ≤ coe_fn (affine_map.line_map a' b') r :=
  has_le.le.trans (line_map_mono_left ha h₁) (line_map_mono_right hb h₀)

theorem line_map_strict_mono_endpoints {k : Type u_1} {E : Type u_2} [ordered_ring k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {a' : E} {b : E}
    {b' : E} {r : k} (ha : a < a') (hb : b < b') (h₀ : 0 ≤ r) (h₁ : r ≤ 1) :
    coe_fn (affine_map.line_map a b) r < coe_fn (affine_map.line_map a' b') r :=
  sorry

theorem line_map_lt_line_map_iff_of_lt {k : Type u_1} {E : Type u_2} [ordered_ring k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {r : k}
    {r' : k} (h : r < r') :
    coe_fn (affine_map.line_map a b) r < coe_fn (affine_map.line_map a b) r' ↔ a < b :=
  sorry

theorem left_lt_line_map_iff_lt {k : Type u_1} {E : Type u_2} [ordered_ring k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {r : k}
    (h : 0 < r) : a < coe_fn (affine_map.line_map a b) r ↔ a < b :=
  sorry

theorem line_map_lt_left_iff_lt {k : Type u_1} {E : Type u_2} [ordered_ring k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {r : k}
    (h : 0 < r) : coe_fn (affine_map.line_map a b) r < a ↔ b < a :=
  left_lt_line_map_iff_lt h

theorem line_map_lt_right_iff_lt {k : Type u_1} {E : Type u_2} [ordered_ring k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {r : k}
    (h : r < 1) : coe_fn (affine_map.line_map a b) r < b ↔ a < b :=
  sorry

theorem right_lt_line_map_iff_lt {k : Type u_1} {E : Type u_2} [ordered_ring k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {r : k}
    (h : r < 1) : b < coe_fn (affine_map.line_map a b) r ↔ b < a :=
  line_map_lt_right_iff_lt h

theorem line_map_le_line_map_iff_of_lt {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {r : k}
    {r' : k} (h : r < r') :
    coe_fn (affine_map.line_map a b) r ≤ coe_fn (affine_map.line_map a b) r' ↔ a ≤ b :=
  sorry

theorem left_le_line_map_iff_le {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {r : k}
    (h : 0 < r) : a ≤ coe_fn (affine_map.line_map a b) r ↔ a ≤ b :=
  sorry

@[simp] theorem left_le_midpoint {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} :
    a ≤ midpoint k a b ↔ a ≤ b :=
  left_le_line_map_iff_le (iff.mpr inv_pos zero_lt_two)

theorem line_map_le_left_iff_le {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {r : k}
    (h : 0 < r) : coe_fn (affine_map.line_map a b) r ≤ a ↔ b ≤ a :=
  left_le_line_map_iff_le h

@[simp] theorem midpoint_le_left {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} :
    midpoint k a b ≤ a ↔ b ≤ a :=
  line_map_le_left_iff_le (iff.mpr inv_pos zero_lt_two)

theorem line_map_le_right_iff_le {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {r : k}
    (h : r < 1) : coe_fn (affine_map.line_map a b) r ≤ b ↔ a ≤ b :=
  sorry

@[simp] theorem midpoint_le_right {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} :
    midpoint k a b ≤ b ↔ a ≤ b :=
  line_map_le_right_iff_le (inv_lt_one one_lt_two)

theorem right_le_line_map_iff_le {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} {r : k}
    (h : r < 1) : b ≤ coe_fn (affine_map.line_map a b) r ↔ b ≤ a :=
  line_map_le_right_iff_le h

@[simp] theorem right_le_midpoint {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {a : E} {b : E} :
    b ≤ midpoint k a b ↔ b ≤ a :=
  right_le_line_map_iff_le (inv_lt_one one_lt_two)

/-!
### Convexity and slope

Given an interval `[a, b]` and a point `c ∈ (a, b)`, `c = line_map a b r`, there are a few ways to
say that the point `(c, f c)` is above/below the segment `[(a, f a), (b, f b)]`:

* compare `f c` to `line_map (f a) (f b) r`;
* compare `slope f a c` to `slope `f a b`;
* compare `slope f c b` to `slope f a b`;
* compare `slope f a c` to `slope f c b`.

In this section we prove equivalence of these four approaches. In order to make the statements more
readable, we introduce local notation `c = line_map a b r`. Then we prove lemmas like

```
lemma map_le_line_map_iff_slope_le_slope_left (h : 0 < r * (b - a)) :
  f c ≤ line_map (f a) (f b) r ↔ slope f a c ≤ slope f a b :=
```

For each inequality between `f c` and `line_map (f a) (f b) r` we provide 3 lemmas:

* `*_left` relates it to an inequality on `slope f a c` and `slope f a b`;
* `*_right` relates it to an inequality on `slope f a b` and `slope f c b`;
* no-suffix version relates it to an inequality on `slope f a c` and `slope f c b`.

Later these inequalities will be used in to restate `convex_on` in terms of monotonicity of the
slope.
-/

/-- Given `c = line_map a b r`, `a < c`, the point `(c, f c)` is non-strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a c ≤ slope f a b`. -/
theorem map_le_line_map_iff_slope_le_slope_left {k : Type u_1} {E : Type u_2}
    [linear_ordered_field k] [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E]
    {f : k → E} {a : k} {b : k} {r : k} (h : 0 < r * (b - a)) :
    f (coe_fn (affine_map.line_map a b) r) ≤ coe_fn (affine_map.line_map (f a) (f b)) r ↔
        slope f a (coe_fn (affine_map.line_map a b) r) ≤ slope f a b :=
  sorry

/-- Given `c = line_map a b r`, `a < c`, the point `(c, f c)` is non-strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f a b ≤ slope f a c`. -/
theorem line_map_le_map_iff_slope_le_slope_left {k : Type u_1} {E : Type u_2}
    [linear_ordered_field k] [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E]
    {f : k → E} {a : k} {b : k} {r : k} (h : 0 < r * (b - a)) :
    coe_fn (affine_map.line_map (f a) (f b)) r ≤ f (coe_fn (affine_map.line_map a b) r) ↔
        slope f a b ≤ slope f a (coe_fn (affine_map.line_map a b) r) :=
  map_le_line_map_iff_slope_le_slope_left h

/-- Given `c = line_map a b r`, `a < c`, the point `(c, f c)` is strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a c < slope f a b`. -/
theorem map_lt_line_map_iff_slope_lt_slope_left {k : Type u_1} {E : Type u_2}
    [linear_ordered_field k] [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E]
    {f : k → E} {a : k} {b : k} {r : k} (h : 0 < r * (b - a)) :
    f (coe_fn (affine_map.line_map a b) r) < coe_fn (affine_map.line_map (f a) (f b)) r ↔
        slope f a (coe_fn (affine_map.line_map a b) r) < slope f a b :=
  lt_iff_lt_of_le_iff_le' (line_map_le_map_iff_slope_le_slope_left h)
    (map_le_line_map_iff_slope_le_slope_left h)

/-- Given `c = line_map a b r`, `a < c`, the point `(c, f c)` is strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f a b < slope f a c`. -/
theorem line_map_lt_map_iff_slope_lt_slope_left {k : Type u_1} {E : Type u_2}
    [linear_ordered_field k] [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E]
    {f : k → E} {a : k} {b : k} {r : k} (h : 0 < r * (b - a)) :
    coe_fn (affine_map.line_map (f a) (f b)) r < f (coe_fn (affine_map.line_map a b) r) ↔
        slope f a b < slope f a (coe_fn (affine_map.line_map a b) r) :=
  map_lt_line_map_iff_slope_lt_slope_left h

/-- Given `c = line_map a b r`, `c < b`, the point `(c, f c)` is non-strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a b ≤ slope f c b`. -/
theorem map_le_line_map_iff_slope_le_slope_right {k : Type u_1} {E : Type u_2}
    [linear_ordered_field k] [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E]
    {f : k → E} {a : k} {b : k} {r : k} (h : 0 < (1 - r) * (b - a)) :
    f (coe_fn (affine_map.line_map a b) r) ≤ coe_fn (affine_map.line_map (f a) (f b)) r ↔
        slope f a b ≤ slope f (coe_fn (affine_map.line_map a b) r) b :=
  sorry

/-- Given `c = line_map a b r`, `c < b`, the point `(c, f c)` is non-strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f c b ≤ slope f a b`. -/
theorem line_map_le_map_iff_slope_le_slope_right {k : Type u_1} {E : Type u_2}
    [linear_ordered_field k] [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E]
    {f : k → E} {a : k} {b : k} {r : k} (h : 0 < (1 - r) * (b - a)) :
    coe_fn (affine_map.line_map (f a) (f b)) r ≤ f (coe_fn (affine_map.line_map a b) r) ↔
        slope f (coe_fn (affine_map.line_map a b) r) b ≤ slope f a b :=
  map_le_line_map_iff_slope_le_slope_right h

/-- Given `c = line_map a b r`, `c < b`, the point `(c, f c)` is strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a b < slope f c b`. -/
theorem map_lt_line_map_iff_slope_lt_slope_right {k : Type u_1} {E : Type u_2}
    [linear_ordered_field k] [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E]
    {f : k → E} {a : k} {b : k} {r : k} (h : 0 < (1 - r) * (b - a)) :
    f (coe_fn (affine_map.line_map a b) r) < coe_fn (affine_map.line_map (f a) (f b)) r ↔
        slope f a b < slope f (coe_fn (affine_map.line_map a b) r) b :=
  lt_iff_lt_of_le_iff_le' (line_map_le_map_iff_slope_le_slope_right h)
    (map_le_line_map_iff_slope_le_slope_right h)

/-- Given `c = line_map a b r`, `c < b`, the point `(c, f c)` is strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f c b < slope f a b`. -/
theorem line_map_lt_map_iff_slope_lt_slope_right {k : Type u_1} {E : Type u_2}
    [linear_ordered_field k] [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E]
    {f : k → E} {a : k} {b : k} {r : k} (h : 0 < (1 - r) * (b - a)) :
    coe_fn (affine_map.line_map (f a) (f b)) r < f (coe_fn (affine_map.line_map a b) r) ↔
        slope f (coe_fn (affine_map.line_map a b) r) b < slope f a b :=
  map_lt_line_map_iff_slope_lt_slope_right h

/-- Given `c = line_map a b r`, `a < c < b`, the point `(c, f c)` is non-strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a c ≤ slope f c b`. -/
theorem map_le_line_map_iff_slope_le_slope {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {f : k → E} {a : k} {b : k}
    {r : k} (hab : a < b) (h₀ : 0 < r) (h₁ : r < 1) :
    f (coe_fn (affine_map.line_map a b) r) ≤ coe_fn (affine_map.line_map (f a) (f b)) r ↔
        slope f a (coe_fn (affine_map.line_map a b) r) ≤
          slope f (coe_fn (affine_map.line_map a b) r) b :=
  sorry

/-- Given `c = line_map a b r`, `a < c < b`, the point `(c, f c)` is non-strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f c b ≤ slope f a c`. -/
theorem line_map_le_map_iff_slope_le_slope {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {f : k → E} {a : k} {b : k}
    {r : k} (hab : a < b) (h₀ : 0 < r) (h₁ : r < 1) :
    coe_fn (affine_map.line_map (f a) (f b)) r ≤ f (coe_fn (affine_map.line_map a b) r) ↔
        slope f (coe_fn (affine_map.line_map a b) r) b ≤
          slope f a (coe_fn (affine_map.line_map a b) r) :=
  map_le_line_map_iff_slope_le_slope hab h₀ h₁

/-- Given `c = line_map a b r`, `a < c < b`, the point `(c, f c)` is strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a c < slope f c b`. -/
theorem map_lt_line_map_iff_slope_lt_slope {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {f : k → E} {a : k} {b : k}
    {r : k} (hab : a < b) (h₀ : 0 < r) (h₁ : r < 1) :
    f (coe_fn (affine_map.line_map a b) r) < coe_fn (affine_map.line_map (f a) (f b)) r ↔
        slope f a (coe_fn (affine_map.line_map a b) r) <
          slope f (coe_fn (affine_map.line_map a b) r) b :=
  lt_iff_lt_of_le_iff_le' (line_map_le_map_iff_slope_le_slope hab h₀ h₁)
    (map_le_line_map_iff_slope_le_slope hab h₀ h₁)

/-- Given `c = line_map a b r`, `a < c < b`, the point `(c, f c)` is strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f c b < slope f a c`. -/
theorem line_map_lt_map_iff_slope_lt_slope {k : Type u_1} {E : Type u_2} [linear_ordered_field k]
    [ordered_add_comm_group E] [semimodule k E] [ordered_semimodule k E] {f : k → E} {a : k} {b : k}
    {r : k} (hab : a < b) (h₀ : 0 < r) (h₁ : r < 1) :
    coe_fn (affine_map.line_map (f a) (f b)) r < f (coe_fn (affine_map.line_map a b) r) ↔
        slope f (coe_fn (affine_map.line_map a b) r) b <
          slope f a (coe_fn (affine_map.line_map a b) r) :=
  map_lt_line_map_iff_slope_lt_slope hab h₀ h₁

end Mathlib


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.category.preorder
import category_theory.eq_to_hom
import topology.category.Top.epi_mono
import topology.sets.opens

/-!
# The category of open sets in a topological space.

We define `to_Top : opens X ⥤ Top` and
`map (f : X ⟶ Y) : opens Y ⥤ opens X`, given by taking preimages of open sets.

Unfortunately `opens` isn't (usefully) a functor `Top ⥤ Cat`.
(One can in fact define such a functor,
but using it results in unresolvable `eq.rec` terms in goals.)

Really it's a 2-functor from (spaces, continuous functions, equalities)
to (categories, functors, natural isomorphisms).
We don't attempt to set up the full theory here, but do provide the natural isomorphisms
`map_id : map (𝟙 X) ≅ 𝟭 (opens X)` and
`map_comp : map (f ≫ g) ≅ map g ⋙ map f`.

Beyond that, there's a collection of simp lemmas for working with these constructions.
-/

open category_theory
open topological_space
open opposite

universe u

namespace topological_space.opens

variables {X Y Z : Top.{u}}

/-!
Since `opens X` has a partial order, it automatically receives a `category` instance.
Unfortunately, because we do not allow morphisms in `Prop`,
the morphisms `U ⟶ V` are not just proofs `U ≤ V`, but rather
`ulift (plift (U ≤ V))`.
-/

instance opens_hom_has_coe_to_fun {U V : opens X} : has_coe_to_fun (U ⟶ V) (λ f, U → V) :=
⟨λ f x, ⟨x, f.le x.2⟩⟩

/-!
We now construct as morphisms various inclusions of open sets.
-/
-- This is tedious, but necessary because we decided not to allow Prop as morphisms in a category...

/--
The inclusion `U ⊓ V ⟶ U` as a morphism in the category of open sets.
-/
def inf_le_left (U V : opens X) : U ⊓ V ⟶ U := inf_le_left.hom

/--
The inclusion `U ⊓ V ⟶ V` as a morphism in the category of open sets.
-/
def inf_le_right (U V : opens X) : U ⊓ V ⟶ V := inf_le_right.hom

/--
The inclusion `U i ⟶ supr U` as a morphism in the category of open sets.
-/
def le_supr {ι : Type*} (U : ι → opens X) (i : ι) : U i ⟶ supr U := (le_supr U i).hom

/--
The inclusion `⊥ ⟶ U` as a morphism in the category of open sets.
-/
def bot_le (U : opens X) : ⊥ ⟶ U := bot_le.hom

/--
The inclusion `U ⟶ ⊤` as a morphism in the category of open sets.
-/
def le_top (U : opens X) : U ⟶ ⊤ := le_top.hom

-- We do not mark this as a simp lemma because it breaks open `x`.
-- Nevertheless, it is useful in `sheaf_of_functions`.
lemma inf_le_left_apply (U V : opens X) (x) :
  (inf_le_left U V) x = ⟨x.1, (@_root_.inf_le_left _ _ U V : _ ≤ _) x.2⟩ :=
rfl

@[simp]
lemma inf_le_left_apply_mk (U V : opens X) (x) (m) :
  (inf_le_left U V) ⟨x, m⟩ = ⟨x, (@_root_.inf_le_left _ _ U V : _ ≤ _) m⟩ :=
rfl

@[simp]
lemma le_supr_apply_mk {ι : Type*} (U : ι → opens X) (i : ι) (x) (m) :
  (le_supr U i) ⟨x, m⟩ = ⟨x, (_root_.le_supr U i : _) m⟩ :=
rfl

/--
The functor from open sets in `X` to `Top`,
realising each open set as a topological space itself.
-/
def to_Top (X : Top.{u}) : opens X ⥤ Top :=
{ obj := λ U, ⟨U, infer_instance⟩,
  map := λ U V i, ⟨λ x, ⟨x.1, i.le x.2⟩,
    (embedding.continuous_iff embedding_subtype_coe).2 continuous_induced_dom⟩ }

@[simp]
lemma to_Top_map (X : Top.{u}) {U V : opens X} {f : U ⟶ V} {x} {h} :
  ((to_Top X).map f) ⟨x, h⟩ = ⟨x, f.le h⟩ :=
rfl

/--
The inclusion map from an open subset to the whole space, as a morphism in `Top`.
-/
@[simps { fully_applied := ff }]
def inclusion {X : Top.{u}} (U : opens X) : (to_Top X).obj U ⟶ X :=
{ to_fun := _,
  continuous_to_fun := continuous_subtype_coe }

lemma open_embedding {X : Top.{u}} (U : opens X) : open_embedding (inclusion U) :=
is_open.open_embedding_subtype_coe U.2

/--
The inclusion of the top open subset (i.e. the whole space) is an isomorphism.
-/
def inclusion_top_iso (X : Top.{u}) : (to_Top X).obj ⊤ ≅ X :=
{ hom := inclusion ⊤,
  inv := ⟨λ x, ⟨x, trivial⟩, continuous_def.2 $ λ U ⟨S, hS, hSU⟩, hSU ▸ hS⟩ }

/-- `opens.map f` gives the functor from open sets in Y to open set in X,
    given by taking preimages under f. -/
def map (f : X ⟶ Y) : opens Y ⥤ opens X :=
{ obj := λ U, ⟨ f ⁻¹' U, U.is_open.preimage f.continuous ⟩,
  map := λ U V i, ⟨ ⟨ λ x h, i.le h ⟩ ⟩ }.

lemma map_coe (f : X ⟶ Y) (U : opens Y) :
  ↑((map f).obj U) = f ⁻¹' U :=
rfl

@[simp] lemma map_obj (f : X ⟶ Y) (U) (p) :
  (map f).obj ⟨U, p⟩ = ⟨f ⁻¹' U, p.preimage f.continuous⟩ := rfl

@[simp] lemma map_id_obj (U : opens X) : (map (𝟙 X)).obj U = U :=
let ⟨_,_⟩ := U in rfl

@[simp] lemma map_id_obj' (U) (p) : (map (𝟙 X)).obj ⟨U, p⟩ = ⟨U, p⟩ :=
rfl

@[simp] lemma map_id_obj_unop (U : (opens X)ᵒᵖ) : (map (𝟙 X)).obj (unop U) = unop U :=
let ⟨_,_⟩ := U.unop in rfl
@[simp]

/--
The inclusion `U ⟶ (map f).obj ⊤` as a morphism in the category of open sets.
-/
def le_map_top (f : X ⟶ Y) (U : opens X) : U ⟶ (map f).obj ⊤ :=
le_top U

@[simp] lemma map_comp_obj (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (map (f ≫ g)).obj U = (map f).obj ((map g).obj U) :=
rfl

@[simp] lemma map_comp_obj' (f : X ⟶ Y) (g : Y ⟶ Z) (U) (p) :
  (map (f ≫ g)).obj ⟨U, p⟩ = (map f).obj ((map g).obj ⟨U, p⟩) :=
rfl

@[simp] lemma map_comp_map (f : X ⟶ Y) (g : Y ⟶ Z) {U V} (i : U ⟶ V) :
  (map (f ≫ g)).map i = (map f).map ((map g).map i) :=
rfl

@[simp] lemma map_comp_obj_unop (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (map (f ≫ g)).obj (unop U) = (map f).obj ((map g).obj (unop U)) :=
rfl

@[simp] lemma op_map_comp_obj (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (map (f ≫ g)).op.obj U = (map f).op.obj ((map g).op.obj U) :=
rfl

lemma map_supr (f : X ⟶ Y) {ι : Type*} (U : ι → opens Y) :
  (map f).obj (supr U) = supr ((map f).obj ∘ U) :=
begin
  ext1, rw [supr_def, supr_def, map_obj],
  dsimp, rw set.preimage_Union, refl,
end

section
variable (X)

/--
The functor `opens X ⥤ opens X` given by taking preimages under the identity function
is naturally isomorphic to the identity functor.
-/
@[simps]
def map_id : map (𝟙 X) ≅ 𝟭 (opens X) :=
{ hom := { app := λ U, eq_to_hom (map_id_obj U) },
  inv := { app := λ U, eq_to_hom (map_id_obj U).symm } }

lemma map_id_eq : map (𝟙 X) = 𝟭 (opens X) :=
by { unfold map, congr, ext, refl, ext }

end

/--
The natural isomorphism between taking preimages under `f ≫ g`, and the composite
of taking preimages under `g`, then preimages under `f`.
-/
@[simps]
def map_comp (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map g ⋙ map f :=
{ hom := { app := λ U, eq_to_hom (map_comp_obj f g U) },
  inv := { app := λ U, eq_to_hom (map_comp_obj f g U).symm } }

lemma map_comp_eq (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) = map g ⋙ map f :=
rfl

/--
If two continuous maps `f g : X ⟶ Y` are equal,
then the functors `opens Y ⥤ opens X` they induce are isomorphic.
-/
-- We could make `f g` implicit here, but it's nice to be able to see when
-- they are the identity (often!)
def map_iso (f g : X ⟶ Y) (h : f = g) : map f ≅ map g :=
nat_iso.of_components (λ U, eq_to_iso (congr_fun (congr_arg functor.obj (congr_arg map h)) U) )
  (by obviously)

lemma map_eq (f g : X ⟶ Y) (h : f = g) : map f = map g :=
by { unfold map, congr, ext, rw h, rw h, assumption' }

@[simp] lemma map_iso_refl (f : X ⟶ Y) (h) : map_iso f f h = iso.refl (map _) := rfl

@[simp] lemma map_iso_hom_app (f g : X ⟶ Y) (h : f = g) (U : opens Y) :
  (map_iso f g h).hom.app U = eq_to_hom (congr_fun (congr_arg functor.obj (congr_arg map h)) U) :=
rfl

@[simp] lemma map_iso_inv_app (f g : X ⟶ Y) (h : f = g) (U : opens Y) :
  (map_iso f g h).inv.app U =
     eq_to_hom (congr_fun (congr_arg functor.obj (congr_arg map h.symm)) U) :=
rfl

/-- A homeomorphism of spaces gives an equivalence of categories of open sets.

TODO: define `order_iso.equivalence`, use it.
-/
@[simps] def map_map_iso {X Y : Top.{u}} (H : X ≅ Y) : opens Y ≌ opens X :=
{ functor := map H.hom,
  inverse := map H.inv,
  unit_iso := nat_iso.of_components (λ U, eq_to_iso (by simp [map, set.preimage_preimage]))
    (by { intros _ _ _, simp }),
  counit_iso := nat_iso.of_components (λ U, eq_to_iso (by simp [map, set.preimage_preimage]))
    (by { intros _ _ _, simp }) }

end topological_space.opens

/--
An open map `f : X ⟶ Y` induces a functor `opens X ⥤ opens Y`.
-/
@[simps]
def is_open_map.functor {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f) :
  opens X ⥤ opens Y :=
{ obj := λ U, ⟨f '' U, hf U U.2⟩,
  map := λ U V h, ⟨⟨set.image_subset _ h.down.down⟩⟩ }

/--
An open map `f : X ⟶ Y` induces an adjunction between `opens X` and `opens Y`.
-/
def is_open_map.adjunction {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f) :
  adjunction hf.functor (topological_space.opens.map f) :=
adjunction.mk_of_unit_counit
{ unit := { app := λ U, hom_of_le $ λ x hxU, ⟨x, hxU, rfl⟩ },
  counit := { app := λ V, hom_of_le $ λ y ⟨x, hfxV, hxy⟩, hxy ▸ hfxV } }

instance is_open_map.functor_full_of_mono {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f)
  [H : mono f] : full hf.functor :=
{ preimage := λ U V i, hom_of_le (λ x hx, by
  { obtain ⟨y, hy, eq⟩ := i.le ⟨x, hx, rfl⟩, exact (Top.mono_iff_injective f).mp H eq ▸ hy }) }

instance is_open_map.functor_faithful {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f) :
  faithful hf.functor := {}

namespace topological_space.opens
open topological_space

@[simp] lemma open_embedding_obj_top {X : Top} (U : opens X) :
  U.open_embedding.is_open_map.functor.obj ⊤ = U :=
by { ext1, exact set.image_univ.trans subtype.range_coe }

@[simp] lemma inclusion_map_eq_top {X : Top} (U : opens X) :
  (opens.map U.inclusion).obj U = ⊤ :=
by { ext1, exact subtype.coe_preimage_self _ }

@[simp]
lemma adjunction_counit_app_self {X : Top} (U : opens X) :
  U.open_embedding.is_open_map.adjunction.counit.app U = eq_to_hom (by simp) :=
by ext

lemma inclusion_top_functor (X : Top) :
  (@opens.open_embedding X ⊤).is_open_map.functor =
  map (inclusion_top_iso X).inv :=
begin
  apply functor.hext, intro, abstract obj_eq { ext,
  exact ⟨ λ ⟨⟨_,_⟩,h,rfl⟩, h, λ h, ⟨⟨x,trivial⟩,h,rfl⟩ ⟩ },
  intros, apply subsingleton.helim, congr' 1,
  iterate 2 {apply inclusion_top_functor.obj_eq},
end

lemma functor_obj_map_obj {X Y : Top} {f : X ⟶ Y} (hf : is_open_map f) (U : opens Y) :
  hf.functor.obj ((opens.map f).obj U) = hf.functor.obj ⊤ ⊓ U :=
begin
  ext, split,
  { rintros ⟨x, hx, rfl⟩, exact ⟨⟨x, trivial, rfl⟩, hx⟩ },
  { rintros ⟨⟨x, -, rfl⟩, hx⟩, exact ⟨x, hx, rfl⟩ }
end

@[simp] lemma functor_map_eq_inf {X : Top} (U V : opens X) :
  U.open_embedding.is_open_map.functor.obj ((opens.map U.inclusion).obj V) = V ⊓ U :=
by { ext1, refine set.image_preimage_eq_inter_range.trans _, simpa }

lemma map_functor_eq' {X U : Top} (f : U ⟶ X) (hf : _root_.open_embedding f) (V) :
  ((opens.map f).obj $ hf.is_open_map.functor.obj V) = V :=
opens.ext $ set.preimage_image_eq _ hf.inj

@[simp] lemma map_functor_eq {X : Top} {U : opens X} (V : opens U) :
  ((opens.map U.inclusion).obj $ U.open_embedding.is_open_map.functor.obj V) = V :=
topological_space.opens.map_functor_eq' _ U.open_embedding V

@[simp] lemma adjunction_counit_map_functor {X : Top} {U : opens X} (V : opens U) :
  U.open_embedding.is_open_map.adjunction.counit.app (U.open_embedding.is_open_map.functor.obj V)
    = eq_to_hom (by { conv_rhs { rw ← V.map_functor_eq }, refl }) :=
by ext

end topological_space.opens


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.eq_to_hom
import category_theory.quotient
import combinatorics.quiver.path

/-!
# The category paths on a quiver.
When `C` is a quiver, `paths C` is the category of paths.

## When the quiver is itself a category
We provide `path_composition : paths C ⥤ C`.

We check that the quotient of the path category of a category by the canonical relation
(paths are related if they compose to the same path) is equivalent to the original category.
-/

universes v₁ v₂ u₁ u₂

namespace category_theory

section

/--
A type synonym for the category of paths in a quiver.
-/
def paths (V : Type u₁) : Type u₁ := V

instance (V : Type u₁) [inhabited V] : inhabited (paths V) := ⟨(default : V)⟩

variables (V : Type u₁) [quiver.{v₁+1} V]

namespace paths

instance category_paths : category.{max u₁ v₁} (paths V) :=
{ hom := λ (X Y : V), quiver.path X Y,
  id := λ X, quiver.path.nil,
  comp := λ X Y Z f g, quiver.path.comp f g, }

variables {V}

/--
The inclusion of a quiver `V` into its path category, as a prefunctor.
-/
@[simps]
def of : prefunctor V (paths V) :=
{ obj := λ X, X,
  map := λ X Y f, f.to_path, }

local attribute [ext] functor.ext

/-- Two functors out of a path category are equal when they agree on singleton paths. -/
@[ext]
lemma ext_functor {C} [category C]
  {F G : paths V ⥤ C}
  (h_obj : F.obj = G.obj)
  (h : ∀ (a b : V) (e : a ⟶ b), F.map e.to_path =
  eq_to_hom (congr_fun h_obj a) ≫ G.map e.to_path ≫ eq_to_hom (congr_fun h_obj.symm b)) :
  F = G :=
begin
  ext X Y f,
  { induction f with Y' Z' g e ih,
    { erw [F.map_id, G.map_id, category.id_comp, eq_to_hom_trans, eq_to_hom_refl], },
    { erw [F.map_comp g e.to_path, G.map_comp g e.to_path, ih, h],
      simp only [category.id_comp, eq_to_hom_refl, eq_to_hom_trans_assoc, category.assoc], }, },
  { intro X, rw h_obj, }
end

end paths

variables (W : Type u₂) [quiver.{v₂+1} W]

-- A restatement of `prefunctor.map_path_comp` using `f ≫ g` instead of `f.comp g`.
@[simp] lemma prefunctor.map_path_comp' (F : prefunctor V W)
  {X Y Z : paths V} (f : X ⟶ Y) (g : Y ⟶ Z) :
  F.map_path (f ≫ g) = (F.map_path f).comp (F.map_path g) :=
prefunctor.map_path_comp _ _ _

end

section

variables {C : Type u₁} [category.{v₁} C]

open quiver

/-- A path in a category can be composed to a single morphism. -/
@[simp]
def compose_path {X : C} : Π {Y : C} (p : path X Y), X ⟶ Y
| _ path.nil := 𝟙 X
| _ (path.cons p e) := compose_path p ≫ e

@[simp]
lemma compose_path_to_path {X Y : C} (f : X ⟶ Y) : compose_path (f.to_path) = f :=
category.id_comp _

@[simp]
lemma compose_path_comp {X Y Z : C} (f : path X Y) (g : path Y Z) :
  compose_path (f.comp g) = compose_path f ≫ compose_path g :=
begin
  induction g with Y' Z' g e ih,
  { simp, },
  { simp [ih], },
end

@[simp]

@[simp]
lemma compose_path_comp' {X Y Z : paths C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  compose_path (f ≫ g) = compose_path f ≫ compose_path g :=
compose_path_comp f g

variables (C)

/-- Composition of paths as functor from the path category of a category to the category. -/
@[simps]
def path_composition : paths C ⥤ C :=
{ obj := λ X, X,
  map := λ X Y f, compose_path f, }

/-- The canonical relation on the path category of a category:
two paths are related if they compose to the same morphism. -/
-- TODO: This, and what follows, should be generalized to
-- the `hom_rel` for the kernel of any functor.
-- Indeed, this should be part of an equivalence between congruence relations on a category `C`
-- and full, essentially surjective functors out of `C`.
@[simp]
def paths_hom_rel : hom_rel (paths C) :=
λ X Y p q, (path_composition C).map p = (path_composition C).map q

/-- The functor from a category to the canonical quotient of its path category. -/
@[simps]
def to_quotient_paths : C ⥤ quotient (paths_hom_rel C) :=
{ obj := λ X, quotient.mk X,
  map := λ X Y f, quot.mk _ f.to_path,
  map_id' := λ X, quot.sound (quotient.comp_closure.of _ _ _ (by simp)),
  map_comp' := λ X Y Z f g, quot.sound (quotient.comp_closure.of _ _ _ (by simp)), }

/-- The functor from the canonical quotient of a path category of a category
to the original category. -/
@[simps]
def quotient_paths_to : quotient (paths_hom_rel C) ⥤ C :=
quotient.lift _ (path_composition C) (λ X Y p q w, w)

/-- The canonical quotient of the path category of a category
is equivalent to the original category. -/
def quotient_paths_equiv : quotient (paths_hom_rel C) ≌ C :=
{ functor := quotient_paths_to C,
  inverse := to_quotient_paths C,
  unit_iso := nat_iso.of_components (λ X, by { cases X, refl, }) begin
    intros,
    cases X, cases Y,
    induction f,
    dsimp,
    simp only [category.comp_id, category.id_comp],
    apply quot.sound,
    apply quotient.comp_closure.of,
    simp [paths_hom_rel],
  end,
  counit_iso := nat_iso.of_components (λ X, iso.refl _) (by tidy),
  functor_unit_iso_comp' := by { intros, cases X, dsimp, simp, refl, }, }

end

end category_theory


theorem append_nil_both
  {t: Type} {xs ys: list t}: xs ++ ys = [] ↔ xs = [] ∧ ys = [] :=
begin
  split,
  intro h,
  induction xs,
  induction ys,
  split,
  refl,
  refl,
  split,
  refl,
  cases h,
  cases h,
  intro h,
  cases h,
  rw h_left,
  rw h_right,
  simp [list.append],
end