import data.real.basic
import tactic
import algebra.ring

/-
# Chapter 1 : Sets

## Level 10

As a final test of your ability in working with sets, prove that the set of rational
numbers is dense in the reals.

This proof will, among other things, rely on several new axioms that appear
in the left side bar.
Note that you may need to change the type of some quantities from rationals to reals.
Lean doesn't necessarily consider the rational $2$ to be the same at the real number $2$.
Some of the axioms on the left make working with the casts from rationals to reals easier.
-/

/-
This is a very difficult proof to think out but with a little bit of assistance it does become possible.
One recommendation is doing the proof in math terms first. We will provide the math proof for you
but you will have to make sense of it yourself. If you don't want to see the proof then you should
skip the following paragraph.

(Spoiler)
The mathematical proof goes as follows.

let r1 and r2 ∈ ℝ s.t. r1 < r2
Then r2 - r1 > 0

By the Archimedean Property ∃ n ∈ ℕ s.t. 1 / n < r2 - r1,
so 1 < nr2 - nr1

Then using has_ceiling we get ∃ m ∈ ℤ s.t.
nr1 < m < nr2

finally we get that r1 < m / n < r2
(End Spoiler)

Hints:
use inv_prod_self, archimedean_R, has_ceiling, as well as norm_num and possibly norm_cast.
-/

/- Axiom : inv_prod_self :
∀ n : ℕ, 0 < n → (1/n : ℝ) * (n : ℝ ) = 1
-/

/- Axiom : inv_prod_other :
∀ (m : ℤ), ∀ (n : ℕ), 0 < n → (1/n : ℝ) * (m : ℝ) = (m/n : ℝ)
-/

/- Axiom : archimedean_R : ∀ x : ℝ, 0 < x → ∃ n : ℕ, 0 < n ∧ (1/n : ℝ) < x
-/

/- Axiom : has_ceiling : ∀ x : ℝ,  ∃ m : ℤ, ((m-1) : ℝ) ≤ x ∧ x < (m:ℝ)
-/

-- one way to prove ℚ dense in ℝ
def dense_in_R (A : set ℝ) := ∀ (x y : ℝ), x < y → ∃ a ∈ A, a ∈ set.Ioo x y
def embedded_rationals : set ℝ := { x | ∃ r : ℚ, x = ↑r }
-- begin hide
axiom archimedean_R : ∀ x : ℝ, 0 < x → ∃ n : ℕ, 0 < n ∧ (1/n : ℝ) < x
-- we might want to prove these below. Made into axioms just for ease.
-- the problem is that the proofs are too hard for this level, IMO (DS)
axiom has_ceiling : ∀ x : ℝ,  ∃ m : ℤ, ((m-1) : ℝ) ≤ x ∧ x < (m:ℝ)
axiom inv_prod_self : ∀ n : ℕ, 0 < n → (1/n : ℝ) * (n : ℝ ) = 1
axiom inv_prod_other : ∀ (m : ℤ), ∀ (n : ℕ), 0 < n → (1/n : ℝ) * (m : ℝ) = (m/n : ℝ)
-- end hide

/- Lemma
Rationals are dense in the reals.
-/
theorem rat_dense_in_R : dense_in_R embedded_rationals :=
begin
  intros h j k,
  have x : 0 < j - h,
  simp,
  exact k,
  have p := archimedean_R (j - h),
  have t := p(x),
  cases t with n hn,
  cases hn with v hv,
  --have V : 1 < ↑n * (j - h),
  have v1 : 0 < (n : ℝ), simp, exact v,
  have g : 0 < (j - h - 1 / (n : ℝ)), linarith,
  have s : 0 < (n : ℝ) * (j - h - 1 / (n : ℝ)),
  revert g,
  revert v1,
  exact mul_pos,

  have F := has_ceiling ((n : ℝ) * (j - h - 1 / (n : ℝ))),
  cases F with m hm,
  cases hm with z hz,
  have J : j - h - 1 / (n : ℝ) = j + (-h) + (-1 / (n : ℝ)),
  ring,
  rw J at s,
  rw add_assoc at s,
  rw left_distrib at s,
  rw left_distrib at s,
  field_simp at s,
  have L : - (n : ℝ) / (n : ℝ) = -1,
  ring,
  rw inv_mul_cancel,
  linarith,
  rw L at s,
  ring at s,
  ring at s,
  simp at s,
  have P : (j - h) = (j + (-h)),
  linarith,
  rw P at s,
  rw right_distrib at s,
  have D := has_ceiling (h * ↑n),
  cases D with r hr,
  cases hr with b hb,
  have U : ↑r ≤ h * ↑n + 1,
  linarith,
  use (↑r / ↑n : ℚ),
  split,
  unfold embedded_rationals,
  use (↑r / ↑n : ℚ),
  unfold set.Ioo,
  split,
  have Y : (h * ↑n) * (1 / ↑n) < ↑r * (1 / ↑n),
  finish,
  rw mul_assoc at Y,
  rw mul_comm ↑n _ at Y,
  rw inv_prod_self at Y,
  swap,
  exact v,
  rw mul_one at Y,
  field_simp at Y,
  norm_num,
  exact Y,
  have HO : ↑r < j * ↑n,
  linarith,
  have O :  ↑r * (1 / ↑n) < (j * ↑n) * (1 / ↑n),
  finish,
  rw mul_assoc at O,
  rw mul_comm ↑n _ at O,
  rw inv_prod_self at O,
  swap,
  exact v,
  rw mul_one at O,
  field_simp at O,
  norm_num,
  exact O,

end

/-
intros x y hxy,
    have H := lt_trichotomy x 0,
    cases H with xL xr, swap, cases xr with x0 xR,
    -- case x = 0
    rw x0 at hxy,
    have G :=archimedean_R  y hxy,
    cases G with n hn, cases hn with hnL hnR,
    use (1/n), split, existsi (1/n : ℚ), norm_num,
    split, swap, exact hnR, rw x0, norm_num, exact hnL,
    -- case 0 < x
    have H : 0 < y - x, linarith,
    have G := archimedean_R (y-x) H,
    cases G with n hn, cases hn with hnL hnR,
    have F := has_ceiling (n*x),
    cases F with m hm, cases hm with hmL hmR,
    use (m/n), split, existsi (m/n : ℚ), norm_num,
    have hnL1 : 0 < (n : ℝ), norm_cast, exact hnL,
    have hnL2 : 0 < (1/n : ℝ), exact one_div_pos_of_pos hnL1,
    split, exact (lt_div_iff' hnL1).mpr hmR,
    have h1 : (m : ℝ) ≤ n*x + 1, linarith,
    have h2 : (m/n : ℝ) ≤ x + (1/n : ℝ),
        have h21 := (mul_le_mul_left hnL2).mpr h1,
        rw mul_add (1/n : ℝ) _ _ at h21, rw mul_one at h21,
        rw ← mul_assoc at h21,
        have h22 := inv_prod_self n hnL,    --cheating here
        rw h22 at h21, rw one_mul at h21,
        have h23 := inv_prod_other m n hnL, --and here
        rw h23 at h21, exact h21,
    have h3 : x + (1/n : ℝ) < x + (y-x), linarith,
    have h4 : x + (y-x) = y, norm_num, rw h4 at h3,
    linarith,
    -- case x < 0  -- reduces to the above
     have H : 0 < y - x, linarith,
    have G := archimedean_R (y-x) H,
    cases G with n hn, cases hn with hnL hnR,
    have F := has_ceiling (n*x),
    cases F with m hm, cases hm with hmL hmR,
    use (m/n), split, existsi (m/n : ℚ), norm_num,
    have hnL1 : 0 < (n : ℝ), norm_cast, exact hnL,
    have hnL2 : 0 < (1/n : ℝ), exact one_div_pos_of_pos hnL1,
    split, exact (lt_div_iff' hnL1).mpr hmR,
    have h1 : (m : ℝ) ≤ n*x + 1, linarith,
    have h1 : (m : ℝ) ≤ n*x + 1, linarith,
    have h2 : (m/n : ℝ) ≤ x + (1/n : ℝ),
        have h21 := (mul_le_mul_left hnL2).mpr h1,
        rw mul_add (1/n : ℝ) _ _ at h21, rw mul_one at h21,
        rw ← mul_assoc at h21,
        have h22 := inv_prod_self n hnL,    --cheating here
        rw h22 at h21, rw one_mul at h21,
        have h23 := inv_prod_other m n hnL, --and here
        rw h23 at h21, exact h21,
    have h3 : x + (1/n : ℝ) < x + (y-x), linarith,
    have h4 : x + (y-x) = y, norm_num, rw h4 at h3,
    linarith, done

    intros h j k,
  have x : 0 < j - h,
  simp,
  exact k,
  have p := archimedean_R (j - h),
  have t := p(x),
  cases t with n hn,
  cases hn with v hv,
  have v1 : 0 < ↑n,
  linarith,
  have g : 0 < (j - h - 1 / ↑n),
  linarith,
  have s : 0 < ↑n * (j - h - 1 / ↑n),
  revert v1,
  revert g,
  have b := mul_pos (0 < (j - h - 1 / ↑n)) (0 < ↑n),
-/


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/

import category_theory.limits.shapes.products
import category_theory.functor.epi_mono

/-!

# Adjunctions involving evaluation

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

We show that evaluation of functors have adjoints, given the existence of (co)products.

-/

namespace category_theory

open category_theory.limits

universes v₁ v₂ u₁ u₂
variables {C : Type u₁} [category.{v₁} C] (D : Type u₂) [category.{v₂} D]

noncomputable theory

section

variables [∀ (a b : C), has_coproducts_of_shape (a ⟶ b) D]

/-- The left adjoint of evaluation. -/
@[simps]
def evaluation_left_adjoint (c : C) : D ⥤ C ⥤ D :=
{ obj := λ d,
  { obj := λ t, ∐ (λ i : c ⟶ t, d),
    map := λ u v f, sigma.desc $ λ g, sigma.ι (λ _, d) $ g ≫ f,
    map_id' := begin
      intros, ext ⟨j⟩, simp only [cofan.mk_ι_app, colimit.ι_desc, category.comp_id],
      congr' 1, rw category.comp_id,
    end,
    map_comp' := begin
      intros, ext, simp only [cofan.mk_ι_app, colimit.ι_desc_assoc, colimit.ι_desc],
      congr' 1, rw category.assoc,
    end },
  map := λ d₁ d₂ f,
  { app := λ e, sigma.desc $ λ h, f ≫ sigma.ι (λ _, d₂) h,
    naturality' := by { intros, ext, dsimp, simp } },
  map_id' := by { intros, ext x ⟨j⟩, dsimp, simp },
  map_comp' := by { intros, ext, dsimp, simp } }

/-- The adjunction showing that evaluation is a right adjoint. -/
@[simps unit_app counit_app_app]
def evaluation_adjunction_right (c : C) :
  evaluation_left_adjoint D c ⊣ (evaluation _ _).obj c :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ d F,
  { to_fun := λ f, sigma.ι (λ _, d) (𝟙 _) ≫ f.app c,
    inv_fun := λ f,
    { app := λ e, sigma.desc $ λ h, f ≫ F.map h,
      naturality' := by { intros, ext, dsimp, simp } },
    left_inv := begin
      intros f,
      ext x ⟨g⟩,
      dsimp,
      simp only [colimit.ι_desc, limits.cofan.mk_ι_app, category.assoc, ← f.naturality,
        evaluation_left_adjoint_obj_map, colimit.ι_desc_assoc, cofan.mk_ι_app],
      congr' 2,
      rw category.id_comp
    end,
    right_inv := λ f, by { dsimp, simp } },
  hom_equiv_naturality_left_symm' := by { intros, ext, dsimp, simp },
  hom_equiv_naturality_right' := by { intros, dsimp, simp } }

instance evaluation_is_right_adjoint (c : C) :
  is_right_adjoint ((evaluation _ D).obj c) :=
⟨_, evaluation_adjunction_right _ _⟩

lemma nat_trans.mono_iff_mono_app {F G : C ⥤ D} (η : F ⟶ G) :
  mono η ↔ (∀ c, mono (η.app c)) :=
begin
  split,
  { introsI h c,
    exact (infer_instance : mono (((evaluation _ _).obj c).map η)) },
  { introsI _,
    apply nat_trans.mono_of_mono_app }
end

end

section

variables [∀ (a b : C), has_products_of_shape (a ⟶ b) D]

/-- The right adjoint of evaluation. -/
@[simps]
def evaluation_right_adjoint (c : C) : D ⥤ C ⥤ D :=
{ obj := λ d,
  { obj := λ t, ∏ (λ i : t ⟶ c, d),
    map := λ u v f, pi.lift $ λ g, pi.π _ $ f ≫ g,
    map_id' := begin
      intros, ext ⟨j⟩, dsimp,
      simp only [limit.lift_π, category.id_comp, fan.mk_π_app],
      congr, simp,
    end,
    map_comp' := begin
      intros, ext ⟨j⟩, dsimp,
      simp only [limit.lift_π, fan.mk_π_app, category.assoc],
      congr' 1, simp,
    end },
  map := λ d₁ d₂ f,
  { app := λ t, pi.lift $ λ g, pi.π _ g ≫ f,
    naturality' := by { intros, ext, dsimp, simp } },
  map_id' := by { intros, ext x ⟨j⟩, dsimp, simp },
  map_comp' := by { intros, ext, dsimp, simp } }

/-- The adjunction showing that evaluation is a left adjoint. -/
@[simps unit_app_app counit_app]
def evaluation_adjunction_left (c : C) :
  (evaluation _ _).obj c ⊣ evaluation_right_adjoint D c :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ F d,
  { to_fun := λ f,
    { app := λ t, pi.lift $ λ g, F.map g ≫ f,
      naturality' := by { intros, ext, dsimp, simp } },
    inv_fun := λ f, f.app _ ≫ pi.π _ (𝟙 _),
    left_inv := λ f, by { dsimp, simp },
    right_inv := begin
      intros f,
      ext x ⟨g⟩,
      dsimp,
      simp only [limit.lift_π, evaluation_right_adjoint_obj_map,
        nat_trans.naturality_assoc, fan.mk_π_app],
      congr,
      rw category.comp_id
    end },
  hom_equiv_naturality_left_symm' := by { intros, dsimp, simp },
  hom_equiv_naturality_right' := by { intros, ext, dsimp, simp } }

instance evaluation_is_left_adjoint (c : C) :
  is_left_adjoint ((evaluation _ D).obj c) :=
⟨_, evaluation_adjunction_left _ _⟩

lemma nat_trans.epi_iff_epi_app {F G : C ⥤ D} (η : F ⟶ G) :
  epi η ↔ (∀ c, epi (η.app c)) :=
begin
  split,
  { introsI h c,
    exact (infer_instance : epi (((evaluation _ _).obj c).map η)) },
  { introsI,
    apply nat_trans.epi_of_epi_app }
end

end

end category_theory


def g (x : Nat) (b : Bool) :=
  if b then
    x - 1
  else
    x + 1

theorem g_eq (x : Nat) (h : ¬ x = 0) : g x (x > 0) = x - 1 ∧ g x false = x + 1 := by
  have : x > 0 := by match x with
    | 0 => contradiction
    | x+1 => apply Nat.zero_lt_succ
  simp [g, this]

macro_rules
| `(tactic| decreasing_tactic) =>
 `(tactic|
   (simp [invImage, InvImage, Prod.lex, sizeOfWFRel, measure, Nat.lt_wfRel, WellFoundedRelation.rel, g_eq, *]
    apply Nat.pred_lt; assumption))

def f (x : Nat) : Nat :=
  if h : x = 0 then
    1
  else
    f (g x (x > 0)) + 2
termination_by f x => x


import tactic

inductive Form : Type
| atom : ℕ → Form
| tensor : Form → Form → Form
| par : Form → Form → Form
| neg : Form → Form

infix ` ⊗ `:70 := Form.tensor
infix ` ⅋ `:65 := Form.par
prefix `~` := Form.neg

inductive Link : Type
| ax : ℕ → ℕ → Form → Link
| cut : ℕ → ℕ → Form → Link
| tensor : ℕ → ℕ → ℕ → Form → Form → Link
| par : ℕ → ℕ → ℕ → Form → Form → Link
| con : ℕ → Form → Link

def Form_occ := Form × ℕ

inductive premise : Form_occ → Link → Prop
| cut_pos {A i j}          : premise (A,i) (Link.cut i j A)
| cut_neg {A i j}          : premise (~A,j) (Link.cut i j A)
| tensor_left {A B i j k}  : premise (A,i) (Link.tensor i j k A B)
| tensor_right {A B i j k} : premise (B,j) (Link.tensor i j k A B)
| par_left {A B i j k}     : premise (A,i) (Link.par i j k A B)
| par_right {A B i j k}    : premise (B,j) (Link.par i j k A B)
| con {A i}                : premise (A,i) (Link.con i A)

inductive conclusion : Form_occ → Link → Prop
| ax_pos {A i j}     : conclusion (A,i) (Link.ax i j A)
| ax_neg {A i j}     : conclusion (~A,j) (Link.ax i j A)
| tensor {A B i j k} : conclusion (A ⊗ B,k) (Link.tensor i j k A B)
| par {A B i j k}    : conclusion (A ⅋ B,k) (Link.par i j k A B)

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

instance : has_mem Form_occ Link := ⟨mem_Link⟩

inductive valid_link : Link → Prop
| ax  (i j A) : valid_link (Link.ax i j A)
| cut (i j A) : valid_link (Link.cut i j A)
| con (i A) : valid_link (Link.con i A)
| tensor (i j k A B) : (A,i) ≠ (B,j) → valid_link (Link.tensor i j k A B)
| par (i j k A B) : (A,i) ≠ (B,j) → valid_link (Link.par i j k A B)

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

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

instance : has_mem Form_occ proof_structure := ⟨mem_Form_occ_ps⟩

@[reducible]
def dir := bool

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

@[pattern] def with_down (Ai : Form_occ) := (Ai,down)
@[pattern] def with_up (Ai : Form_occ) := (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 Ci : Form_occ) : Form_occ × dir → Form_occ × dir → Prop
| down : steps_tensor Ai↓ Ci↓
| turn : steps_tensor Bi↓ Ai↑
| up : steps_tensor Ci↑ Bi↑

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

inductive dual (A : Form) (ai ni : ℕ) : Form_occ → Form_occ → Prop
| posneg : dual (A,ai) (~A,ni)
| negpos : dual (~A,ni) (A,ai)

inductive steps (T : switch) : Link → Form_occ × dir → Form_occ × dir → Prop
| ax  {A ai ni Bi Ci} : dual A ai ni Bi Ci → steps (Link.ax ai ni A) Bi↑ Ci↓
| cut {A ai ni Bi Ci} : dual A ai ni Bi Ci → steps (Link.cut ai ni A) Bi↓ Ci↑
| con {A ai}          : steps (Link.con ai A) (A, ai)↓ (A,ai)↑
| tensor {A B ai bi ci X Y} :
  T.flip steps_tensor (A, ai) (B, bi) (A ⊗ B, ci) X Y →
  steps (Link.tensor ai bi ci A B) X Y
| par {A B ai bi ci X Y} :
  T.flip steps_par (A, ai) (B, bi) (A ⅋ B, ci) X Y →
  steps (Link.par ai bi ci A B) X Y

inductive trip (ps : proof_structure) (S : switching) : ℕ → Form_occ × dir → Form_occ × 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 trip2 (ps : proof_structure) (S : switching) : Form_occ × dir → Form_occ × dir → Prop
| single (Ai : Form_occ) (d : dir) : Ai ∈ ps → trip2 (Ai,d) (Ai,d)
| front (Ai Bi Ci : Form_occ) (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 : Form_occ) (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 (Form_occ × dir) → Prop
| emp : list_trip []
| single (Ai : Form_occ) (d : dir) : Ai ∈ ps → list_trip [(Ai,d)]
| cons (Ai Bi : Form_occ) (d₁ d₂ : dir) (Γ : list (Form_occ × dir)) (Δ : Link) :
  Δ ∈ ps.links → steps (S Δ) Δ (Ai,d₁) (Bi,d₂) → list_trip ((Bi,d₂) :: Γ) → list_trip ((Ai,d₁) :: (Bi,d₂) :: Γ)

lemma not_self_dual {A} : (~A) ≠ A :=
begin
  intro e,
  apply_fun Form.sizeof at e,
  refine ne_of_gt _ e,
  rw [Form.sizeof, nat.add_comm], exact nat.lt_succ_self _ ,
end

lemma not_self_double_dual {A} : (~~A) ≠ A :=
begin
  suffices : A ≠ (~~A), by symmetry; assumption,
  intro e,
  apply_fun Form.sizeof at e,
  refine ne_of_lt _ e,
  refine lt_trans _ _, exact (~A).sizeof,
  rw [Form.sizeof, nat.add_comm], exact nat.lt_succ_self _ ,
  rw [Form.sizeof, Form.sizeof], apply add_lt_add_left,
  have : sizeof (~A) = (~A).sizeof, refl, rw this,
  rw [Form.sizeof, nat.add_comm], exact nat.lt_succ_self _ ,
end

lemma not_self_sub_left_tensor {A B} : A ≠ A ⊗ B :=
begin
  intro e,
  apply_fun Form.sizeof at e,
  refine ne_of_lt _ e,
  rw [Form.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 {A B} : B ≠ A ⊗ B :=
begin
  intro e,
  apply_fun Form.sizeof at e,
  refine ne_of_lt _ e,
  rw [Form.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 {A B} : A ≠ A ⅋ B :=
begin
  intro e,
  apply_fun Form.sizeof at e,
  refine ne_of_lt _ e,
  rw [Form.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 {A B} : B ≠ A ⅋ B :=
begin
  intro e,
  apply_fun Form.sizeof at e,
  refine ne_of_lt _ e,
  rw [Form.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 : Form_occ}
  variables {X Y Z : Form_occ × dir}

  lemma dual_unique_prev {A pi ni} :
    dual A pi ni Ai Ci → dual A pi ni Bi Ci → Ai = Bi :=
  begin
    intros d₁ d₂,
    generalize_hyp e : Ci = Ci' at d₂,
    cases d₁; cases d₂; injection e with e1 e2; cases e2;
    try { cases e1 }; [refl, cases not_self_dual e1, cases not_self_dual e1.symm, refl]
  end

  lemma dual_unique_next {A pi ni} :
    dual A pi ni Ai Bi → dual A pi ni Ai Ci → Bi = Ci :=
  begin
    intros d₁ d₂,
    generalize_hyp e : Ai = Ai' at d₂,
    cases d₁; cases d₂; injection e with e1 e2; cases e2;
    try { cases e1 }; [refl, cases not_self_dual e1.symm, cases not_self_dual e1, refl]
  end

  lemma steps_tensor_unique_prev : Ai ≠ Bi → Bi ≠ Ci → Ai ≠ Ci → steps_tensor Ai Bi Ci X Z → steps_tensor Ai Bi Ci Y Z → X = Y :=
  by intros _ _ _ s₁ s₂; cases s₁; cases s₂; try {refl}; try {contradiction}

  lemma steps_tensor_unique_next : Ai ≠ Bi → Bi ≠ Ci → Ai ≠ Ci → steps_tensor Ai Bi Ci X Y → steps_tensor Ai Bi Ci X Z → Y = Z :=
  by intros _ _ _ s₁ s₂; cases s₁; cases s₂; try {refl}; try {contradiction}

  lemma steps_par_unique_prev : Ai ≠ Bi → Bi ≠ Ci → Ai ≠ Ci → steps_par Ai Bi Ci X Z → steps_par Ai Bi Ci Y Z → X = Y :=
  by intros _ _ _ s₁ s₂; cases s₁; cases s₂; try {refl}; try {contradiction}

  lemma steps_par_unique_next : Ai ≠ Bi → Bi ≠ Ci → Ai ≠ Ci → steps_par Ai Bi Ci X Y → steps_par Ai Bi Ci X Z → Y = Z :=
  by intros _ _ _ s₁ s₂; cases s₁; cases s₂; try {refl}; try {contradiction}

  theorem steps_unique_prev : valid_link Δ → steps T Δ X Z → steps T Δ Y Z → X = Y :=
  begin
    intros hΔ s₁ s₂,
    cases s₁,
    case steps.ax : A ai ni Bi Ci d₁ {
      cases s₂ with _ _ _ Di _ d₂,
      rw dual_unique_prev d₁ d₂ },
    case steps.cut : A ai ni Bi Ci d₁ {
      rcases s₂ with _ | ⟨_,_,_,Di,_,d₂⟩,
      rw dual_unique_prev d₂ d₁
    },
    case steps.con : A ai { cases s₂, refl },
    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_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.con : A ai { cases s₂, refl },
    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 },
    case steps.con : { 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 },
    case steps.con : { 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 : Form_occ × 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,
    induction n,
    case nat.zero : {
      rintros X Y Z hΔ ⟨Ai,d,hA⟩ s,
      apply trip.cons hΔ s,
      cases Z with Ci d',
      apply trip.single,
      apply mem_ps_of_steps_next hΔ s,
    },
    case nat.succ : n ih {
      rintros X Y Z hΔ tXY sYZ,
      cases tXY with _ _ _ _ W _ Δ' _ hΔ' sXW tWY,
      apply trip.cons hΔ' sXW,
      apply ih 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 category_theory.category.default

universes v u  -- The order in this declaration matters: v often needs to be explicitly specified while u often can be omitted

namespace category_theory

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

--rewrite this

/-
# Category world

## Level 7: Composition of monomorphisms

Now we show that the composition of two monomorphisms produces another monomorphism.-/

/- Lemma
If $$f : X ⟶ Y$$ and $$g : X ⟶ Y$$ are monomorphisms, then $$f ≫ g : X ⟶ Z$$ is a monomorphism.
-/
lemma epi_of_epi' {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [epi (f ≫ g)] : epi g :=
begin
    split,
    intros W h l hyp,
    rw ← cancel_epi (f ≫ g),
    rw category.assoc,
    rw hyp,
    rw ← category.assoc,
end

end category_theory


import category_theory.category.default

universes v u  -- The order in this declaration matters: v often needs to be explicitly specified while u often can be omitted

namespace category_theory

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

/-
# Category world

## Level 3: The `specialize` tactic
-/

/-So recall that, in the Natural Number Game, we learned a tactic called `simp` that uses the lemmas and theorems to try to simplify the goal. Now we are going to learn `simpa`.

`simpa [rules, ...]` will simplify the goal and the type of a hypothesis this if present in the context, then try to close the goal using the assumption tactic.

-/

/-Try your hand at proving these next few lemmas using `simpa`.-/

/- Lemma
If $$f : X ⟶ Y$$ and $$g : X ⟶ Y$$ are morphisms such that $$f = g$$, then $$f ≫ h = g ≫ h$$.
-/
lemma eq_of_comp_right_eq'' (Y Z : C) {f g : Y ⟶ Z} (w : ∀ {X : C} (h : X ⟶ Y), h ≫ f = h ≫ g) : f = g :=
begin
    specialize w (𝟙 Y),
    rw ← category.id_comp f,
    rw ← category.id_comp g,
    exact w,
end

end category_theory

/- Tactic : specialize
## Summary
fill in summary
## Details
fill in details
-/


macro mods:declModifiers "lemma" n:declId sig:declSig val:declVal : command => `($mods:declModifiers theorem $n $sig $val)

lemma fooSimple (n : Nat) : Prop :=
  if n = 0 then True else False

lemma fooPat : Nat → Prop
  | 0   => True
  | n+1 => False


-- there are several ways of doing this, and probably more compact and/or
-- idiomatic ways than what I have here

example (p q r : Prop) (hp : p) :
    (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) :=
by simp *

example (p q r : Prop) (hp : p) :
    (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) :=
by { constructor, left, assumption, constructor, right, left, assumption, right, right, assumption }

example (p q r : Prop) (hp : p) :
    (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) :=
by { repeat { split; repeat { { left, assumption } <|> right <|> assumption } } }


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebraic_geometry.presheafed_space
import topology.sheaves.stalks

/-!
# Stalks for presheaved spaces

This file lifts constructions of stalks and pushforwards of stalks to work with
the category of presheafed spaces.
-/

noncomputable theory

universes v u v' u'

open category_theory
open category_theory.limits category_theory.category category_theory.functor
open algebraic_geometry
open topological_space

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

local attribute [tidy] tactic.op_induction'

open Top.presheaf

namespace algebraic_geometry.PresheafedSpace

/--
The stalk at `x` of a `PresheafedSpace`.
-/
def stalk (X : PresheafedSpace C) (x : X) : C := X.presheaf.stalk x

/--
A morphism of presheafed spaces induces a morphism of stalks.
-/
def stalk_map {X Y : PresheafedSpace C} (α : X ⟶ Y) (x : X) : Y.stalk (α.base x) ⟶ X.stalk x :=
(stalk_functor C (α.base x)).map (α.c) ≫ X.presheaf.stalk_pushforward C α.base x

section restrict

-- PROJECT: restriction preserves stalks.
-- We'll want to define cofinal functors, show precomposing with a cofinal functor preserves
-- colimits, and (easily) verify that "open neighbourhoods of x within U" is cofinal in "open
-- neighbourhoods of x".
/-
def restrict_stalk_iso {U : Top} (X : PresheafedSpace C)
  (f : U ⟶ (X : Top.{v})) (h : open_embedding f) (x : U) :
  (X.restrict f h).stalk x ≅ X.stalk (f x) :=
begin
  dsimp only [stalk, Top.presheaf.stalk, stalk_functor],
  dsimp [colim],
  sorry
end

-- TODO `restrict_stalk_iso` is compatible with `germ`.
-/

end restrict

namespace stalk_map

@[simp] lemma id (X : PresheafedSpace C) (x : X) : stalk_map (𝟙 X) x = 𝟙 (X.stalk x) :=
begin
  dsimp [stalk_map],
  simp only [stalk_pushforward.id],
  rw [←map_comp],
  convert (stalk_functor C x).map_id X.presheaf,
  tidy,
end

-- TODO understand why this proof is still gross (i.e. requires using `erw`)
@[simp] lemma comp {X Y Z : PresheafedSpace C} (α : X ⟶ Y) (β : Y ⟶ Z) (x : X) :
  stalk_map (α ≫ β) x =
    (stalk_map β (α.base x) : Z.stalk (β.base (α.base x)) ⟶ Y.stalk (α.base x)) ≫
    (stalk_map α x : Y.stalk (α.base x) ⟶ X.stalk x) :=
begin
  dsimp [stalk_map, stalk_functor, stalk_pushforward],
  ext U,
  op_induction U,
  cases U,
  simp only [colimit.ι_map_assoc, colimit.ι_pre_assoc, colimit.ι_pre,
    whisker_left_app, whisker_right_app,
    assoc, id_comp, map_id, map_comp],
  dsimp,
  simp only [map_id, assoc, pushforward.comp_inv_app],
  -- FIXME Why doesn't simp do this:
  erw [category_theory.functor.map_id],
  erw [category_theory.functor.map_id],
  erw [id_comp, id_comp, id_comp],
end
end stalk_map

end algebraic_geometry.PresheafedSpace


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.opens
import Mathlib.ring_theory.ideal.prod
import Mathlib.linear_algebra.finsupp
import Mathlib.algebra.punit_instances
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# Prime spectrum of a commutative ring

The prime spectrum of a commutative ring is the type of all prime ideals.
It is naturally endowed with a topology: the Zariski topology.

(It is also naturally endowed with a sheaf of rings,
which is constructed in `algebraic_geometry.structure_sheaf`.)

## Main definitions

* `prime_spectrum R`: The prime spectrum of a commutative ring `R`,
  i.e., the set of all prime ideals of `R`.
* `zero_locus s`: The zero locus of a subset `s` of `R`
  is the subset of `prime_spectrum R` consisting of all prime ideals that contain `s`.
* `vanishing_ideal t`: The vanishing ideal of a subset `t` of `prime_spectrum R`
  is the intersection of points in `t` (viewed as prime ideals).

## Conventions

We denote subsets of rings with `s`, `s'`, etc...
whereas we denote subsets of prime spectra with `t`, `t'`, etc...

## Inspiration/contributors

The contents of this file draw inspiration from
<https://github.com/ramonfmir/lean-scheme>
which has contributions from Ramon Fernandez Mir, Kevin Buzzard, Kenny Lau,
and Chris Hughes (on an earlier repository).

-/

/-- The prime spectrum of a commutative ring `R`
is the type of all prime ideals of `R`.

It is naturally endowed with a topology (the Zariski topology),
and a sheaf of commutative rings (see `algebraic_geometry.structure_sheaf`).
It is a fundamental building block in algebraic geometry. -/
def prime_spectrum (R : Type u) [comm_ring R] := Subtype fun (I : ideal R) => ideal.is_prime I

namespace prime_spectrum

/-- A method to view a point in the prime spectrum of a commutative ring
as an ideal of that ring. -/
def as_ideal {R : Type u} [comm_ring R] (x : prime_spectrum R) : ideal R := subtype.val x

protected instance is_prime {R : Type u} [comm_ring R] (x : prime_spectrum R) :
    ideal.is_prime (as_ideal x) :=
  subtype.property x

/--
The prime spectrum of the zero ring is empty.
-/
theorem punit (x : prime_spectrum PUnit) : False :=
  iff.mp (ideal.ne_top_iff_one (subtype.val x)) (and.left (subtype.property x))
    (subsingleton.elim 0 1 ▸ ideal.zero_mem (subtype.val x))

/-- The prime spectrum of `R × S` is in bijection with the disjoint unions of the prime spectrum of
    `R` and the prime spectrum of `S`. -/
def prime_spectrum_prod (R : Type u) [comm_ring R] (S : Type v) [comm_ring S] :
    prime_spectrum (R × S) ≃ prime_spectrum R ⊕ prime_spectrum S :=
  ideal.prime_ideals_equiv R S

@[simp] theorem prime_spectrum_prod_symm_inl_as_ideal {R : Type u} [comm_ring R] {S : Type v}
    [comm_ring S] (x : prime_spectrum R) :
    as_ideal (coe_fn (equiv.symm (prime_spectrum_prod R S)) (sum.inl x)) =
        ideal.prod (as_ideal x) ⊤ :=
  sorry

@[simp] theorem prime_spectrum_prod_symm_inr_as_ideal {R : Type u} [comm_ring R] {S : Type v}
    [comm_ring S] (x : prime_spectrum S) :
    as_ideal (coe_fn (equiv.symm (prime_spectrum_prod R S)) (sum.inr x)) =
        ideal.prod ⊤ (as_ideal x) :=
  sorry

theorem ext {R : Type u} [comm_ring R] {x : prime_spectrum R} {y : prime_spectrum R} :
    x = y ↔ as_ideal x = as_ideal y :=
  subtype.ext_iff_val

/-- The zero locus of a set `s` of elements of a commutative ring `R`
is the set of all prime ideals of the ring that contain the set `s`.

An element `f` of `R` can be thought of as a dependent function
on the prime spectrum of `R`.
At a point `x` (a prime ideal)
the function (i.e., element) `f` takes values in the quotient ring `R` modulo the prime ideal `x`.
In this manner, `zero_locus s` is exactly the subset of `prime_spectrum R`
where all "functions" in `s` vanish simultaneously.
-/
def zero_locus {R : Type u} [comm_ring R] (s : set R) : set (prime_spectrum R) :=
  set_of fun (x : prime_spectrum R) => s ⊆ ↑(as_ideal x)

@[simp] theorem mem_zero_locus {R : Type u} [comm_ring R] (x : prime_spectrum R) (s : set R) :
    x ∈ zero_locus s ↔ s ⊆ ↑(as_ideal x) :=
  iff.rfl

@[simp] theorem zero_locus_span {R : Type u} [comm_ring R] (s : set R) :
    zero_locus ↑(ideal.span s) = zero_locus s :=
  set.ext fun (x : prime_spectrum R) => galois_insertion.gc (submodule.gi R R) s (as_ideal x)

/-- The vanishing ideal of a set `t` of points
of the prime spectrum of a commutative ring `R`
is the intersection of all the prime ideals in the set `t`.

An element `f` of `R` can be thought of as a dependent function
on the prime spectrum of `R`.
At a point `x` (a prime ideal)
the function (i.e., element) `f` takes values in the quotient ring `R` modulo the prime ideal `x`.
In this manner, `vanishing_ideal t` is exactly the ideal of `R`
consisting of all "functions" that vanish on all of `t`.
-/
def vanishing_ideal {R : Type u} [comm_ring R] (t : set (prime_spectrum R)) : ideal R :=
  infi fun (x : prime_spectrum R) => infi fun (h : x ∈ t) => as_ideal x

theorem coe_vanishing_ideal {R : Type u} [comm_ring R] (t : set (prime_spectrum R)) :
    ↑(vanishing_ideal t) = set_of fun (f : R) => ∀ (x : prime_spectrum R), x ∈ t → f ∈ as_ideal x :=
  sorry

theorem mem_vanishing_ideal {R : Type u} [comm_ring R] (t : set (prime_spectrum R)) (f : R) :
    f ∈ vanishing_ideal t ↔ ∀ (x : prime_spectrum R), x ∈ t → f ∈ as_ideal x :=
  sorry

theorem subset_zero_locus_iff_le_vanishing_ideal {R : Type u} [comm_ring R]
    (t : set (prime_spectrum R)) (I : ideal R) : t ⊆ zero_locus ↑I ↔ I ≤ vanishing_ideal t :=
  sorry

/-- `zero_locus` and `vanishing_ideal` form a galois connection. -/
theorem gc (R : Type u) [comm_ring R] :
    galois_connection (fun (I : ideal R) => zero_locus ↑I)
        fun (t : order_dual (set (prime_spectrum R))) => vanishing_ideal t :=
  fun (I : ideal R) (t : order_dual (set (prime_spectrum R))) =>
    subset_zero_locus_iff_le_vanishing_ideal t I

/-- `zero_locus` and `vanishing_ideal` form a galois connection. -/
theorem gc_set (R : Type u) [comm_ring R] :
    galois_connection (fun (s : set R) => zero_locus s)
        fun (t : order_dual (set (prime_spectrum R))) => ↑(vanishing_ideal t) :=
  sorry

theorem subset_zero_locus_iff_subset_vanishing_ideal (R : Type u) [comm_ring R]
    (t : set (prime_spectrum R)) (s : set R) : t ⊆ zero_locus s ↔ s ⊆ ↑(vanishing_ideal t) :=
  gc_set R s t

-- TODO: we actually get the radical ideal,

-- but I think that isn't in mathlib yet.

theorem subset_vanishing_ideal_zero_locus {R : Type u} [comm_ring R] (s : set R) :
    s ⊆ ↑(vanishing_ideal (zero_locus s)) :=
  galois_connection.le_u_l (gc_set R) s

theorem le_vanishing_ideal_zero_locus {R : Type u} [comm_ring R] (I : ideal R) :
    I ≤ vanishing_ideal (zero_locus ↑I) :=
  galois_connection.le_u_l (gc R) I

theorem subset_zero_locus_vanishing_ideal {R : Type u} [comm_ring R] (t : set (prime_spectrum R)) :
    t ⊆ zero_locus ↑(vanishing_ideal t) :=
  galois_connection.l_u_le (gc R) t

theorem zero_locus_bot {R : Type u} [comm_ring R] : zero_locus ↑⊥ = set.univ :=
  galois_connection.l_bot (gc R)

@[simp] theorem zero_locus_singleton_zero {R : Type u} [comm_ring R] : zero_locus 0 = set.univ :=
  zero_locus_bot

@[simp] theorem zero_locus_empty {R : Type u} [comm_ring R] : zero_locus ∅ = set.univ :=
  galois_connection.l_bot (gc_set R)

@[simp] theorem vanishing_ideal_univ {R : Type u} [comm_ring R] : vanishing_ideal ∅ = ⊤ :=
  eq.mpr (id (Eq.refl (vanishing_ideal ∅ = ⊤)))
    (eq.mp (Eq.refl (vanishing_ideal ⊤ = ⊤)) (galois_connection.u_top (gc R)))

theorem zero_locus_empty_of_one_mem {R : Type u} [comm_ring R] {s : set R} (h : 1 ∈ s) :
    zero_locus s = ∅ :=
  sorry

theorem zero_locus_empty_iff_eq_top {R : Type u} [comm_ring R] {I : ideal R} :
    zero_locus ↑I = ∅ ↔ I = ⊤ :=
  sorry

@[simp] theorem zero_locus_univ {R : Type u} [comm_ring R] : zero_locus set.univ = ∅ :=
  zero_locus_empty_of_one_mem (set.mem_univ 1)

theorem zero_locus_sup {R : Type u} [comm_ring R] (I : ideal R) (J : ideal R) :
    zero_locus ↑(I ⊔ J) = zero_locus ↑I ∩ zero_locus ↑J :=
  galois_connection.l_sup (gc R)

theorem zero_locus_union {R : Type u} [comm_ring R] (s : set R) (s' : set R) :
    zero_locus (s ∪ s') = zero_locus s ∩ zero_locus s' :=
  galois_connection.l_sup (gc_set R)

theorem vanishing_ideal_union {R : Type u} [comm_ring R] (t : set (prime_spectrum R))
    (t' : set (prime_spectrum R)) :
    vanishing_ideal (t ∪ t') = vanishing_ideal t ⊓ vanishing_ideal t' :=
  galois_connection.u_inf (gc R)

theorem zero_locus_supr {R : Type u} [comm_ring R] {ι : Sort u_1} (I : ι → ideal R) :
    zero_locus ↑(supr fun (i : ι) => I i) = set.Inter fun (i : ι) => zero_locus ↑(I i) :=
  galois_connection.l_supr (gc R)

theorem zero_locus_Union {R : Type u} [comm_ring R] {ι : Sort u_1} (s : ι → set R) :
    zero_locus (set.Union fun (i : ι) => s i) = set.Inter fun (i : ι) => zero_locus (s i) :=
  galois_connection.l_supr (gc_set R)

theorem zero_locus_bUnion {R : Type u} [comm_ring R] (s : set (set R)) :
    zero_locus (set.Union fun (s' : set R) => set.Union fun (H : s' ∈ s) => s') =
        set.Inter fun (s' : set R) => set.Inter fun (H : s' ∈ s) => zero_locus s' :=
  sorry

theorem vanishing_ideal_Union {R : Type u} [comm_ring R] {ι : Sort u_1}
    (t : ι → set (prime_spectrum R)) :
    vanishing_ideal (set.Union fun (i : ι) => t i) = infi fun (i : ι) => vanishing_ideal (t i) :=
  galois_connection.u_infi (gc R)

theorem zero_locus_inf {R : Type u} [comm_ring R] (I : ideal R) (J : ideal R) :
    zero_locus ↑(I ⊓ J) = zero_locus ↑I ∪ zero_locus ↑J :=
  sorry

theorem union_zero_locus {R : Type u} [comm_ring R] (s : set R) (s' : set R) :
    zero_locus s ∪ zero_locus s' = zero_locus ↑(ideal.span s ⊓ ideal.span s') :=
  sorry

theorem sup_vanishing_ideal_le {R : Type u} [comm_ring R] (t : set (prime_spectrum R))
    (t' : set (prime_spectrum R)) :
    vanishing_ideal t ⊔ vanishing_ideal t' ≤ vanishing_ideal (t ∩ t') :=
  sorry

theorem mem_compl_zero_locus_iff_not_mem {R : Type u} [comm_ring R] {f : R} {I : prime_spectrum R} :
    I ∈ (zero_locus (singleton f)ᶜ) ↔ ¬f ∈ as_ideal I :=
  sorry

/-- The Zariski topology on the prime spectrum of a commutative ring
is defined via the closed sets of the topology:
they are exactly those sets that are the zero locus of a subset of the ring. -/
protected instance zariski_topology {R : Type u} [comm_ring R] :
    topological_space (prime_spectrum R) :=
  topological_space.of_closed (set.range zero_locus) sorry sorry sorry

theorem is_open_iff {R : Type u} [comm_ring R] (U : set (prime_spectrum R)) :
    is_open U ↔ ∃ (s : set R), Uᶜ = zero_locus s :=
  sorry

theorem is_closed_iff_zero_locus {R : Type u} [comm_ring R] (Z : set (prime_spectrum R)) :
    is_closed Z ↔ ∃ (s : set R), Z = zero_locus s :=
  sorry

theorem is_closed_zero_locus {R : Type u} [comm_ring R] (s : set R) : is_closed (zero_locus s) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (is_closed (zero_locus s)))
        (propext (is_closed_iff_zero_locus (zero_locus s)))))
    (Exists.intro s rfl)

/-- The function between prime spectra of commutative rings induced by a ring homomorphism.
This function is continuous. -/
def comap {R : Type u} [comm_ring R] {S : Type v} [comm_ring S] (f : R →+* S) :
    prime_spectrum S → prime_spectrum R :=
  fun (y : prime_spectrum S) => { val := ideal.comap f (as_ideal y), property := sorry }

@[simp] theorem comap_as_ideal {R : Type u} [comm_ring R] {S : Type v} [comm_ring S] (f : R →+* S)
    (y : prime_spectrum S) : as_ideal (comap f y) = ideal.comap f (as_ideal y) :=
  rfl

@[simp] theorem comap_id {R : Type u} [comm_ring R] : comap (ring_hom.id R) = id :=
  funext fun (_x : prime_spectrum R) => subtype.ext (ideal.ext fun (_x_1 : R) => iff.rfl)

@[simp] theorem comap_comp {R : Type u} [comm_ring R] {S : Type v} [comm_ring S] {S' : Type u_1}
    [comm_ring S'] (f : R →+* S) (g : S →+* S') : comap (ring_hom.comp g f) = comap f ∘ comap g :=
  funext fun (_x : prime_spectrum S') => subtype.ext (ideal.ext fun (_x_1 : R) => iff.rfl)

@[simp] theorem preimage_comap_zero_locus {R : Type u} [comm_ring R] {S : Type v} [comm_ring S]
    (f : R →+* S) (s : set R) : comap f ⁻¹' zero_locus s = zero_locus (⇑f '' s) :=
  sorry

theorem comap_continuous {R : Type u} [comm_ring R] {S : Type v} [comm_ring S] (f : R →+* S) :
    continuous (comap f) :=
  sorry

theorem zero_locus_vanishing_ideal_eq_closure {R : Type u} [comm_ring R]
    (t : set (prime_spectrum R)) : zero_locus ↑(vanishing_ideal t) = closure t :=
  sorry

/-- The prime spectrum of a commutative ring is a compact topological space. -/
protected instance compact_space {R : Type u} [comm_ring R] : compact_space (prime_spectrum R) :=
  sorry

/-- `basic_open r` is the open subset containing all prime ideals not containing `r`. -/
def basic_open {R : Type u} [comm_ring R] (r : R) : topological_space.opens (prime_spectrum R) :=
  { val := set_of fun (x : prime_spectrum R) => ¬r ∈ as_ideal x, property := sorry }

theorem is_open_basic_open {R : Type u} [comm_ring R] {a : R} : is_open ↑(basic_open a) :=
  subtype.property (basic_open a)

end Mathlib


import Lean
import Init.Classical

import SciLean.Core.DifferentialDep
import SciLean.Core.Adjoint
import SciLean.Core.HasAdjDiffDep

namespace SciLean

variable {α β γ : Type}
variable {X Y Z : Type} [SemiHilbertDiff X] [SemiHilbertDiff Y] [SemiHilbertDiff Z]
variable {Y₁ Y₂ : Type} [SemiHilbertDiff Y₁] [SemiHilbertDiff Y₂]
variable {ι : Type} [Enumtype ι]

noncomputable
def adjointDifferentialDep (f : X → Y) (x : X) (dy' : 𝒯[f x] Y) : 𝒯[x] X := (∂ f x)† dy'

instance (priority:=low) (f : X → Y) : PartialDagger f (adjointDifferentialDep f) := ⟨⟩

-- Question: Should there be `𝒯[y] Y` or `𝒯[f x] Y`?
-- Maybe return `(y:Y)×(𝒯[y] Y → 𝒯[x] X)×(f x = y)` but there is a problem with `Sigma` vs `PSigma`
noncomputable
def reverseDifferentialDep (f : X → Y) (x : X) : (Σ' (y:Y) (_:𝒯[y] Y → 𝒯[x] X), (f x=y)) := ⟨f x, λ dy => ∂† f x dy, rfl⟩

instance (priority:=low) (f : X → Y) : ReverseDifferential f (reverseDifferentialDep f) := ⟨⟩

noncomputable
abbrev gradientDep (f : X → ℝ) (x : X) : 𝒯[x] X := ∂† f x 1

instance (priority:=low) (f : X → ℝ) : Nabla f (gradientDep f) := ⟨⟩

-- -- Notation
-- -- ∇ s, f s         --> ∇ λ s => f s
-- -- ∇ s : ℝ, f s     --> ∇ λ s : ℝ => f s
-- -- ∇ s := t, f s    --> (∇ λ s => f s) t
-- syntax "∇" diffBinder "," term:66 : term
-- syntax "∇" "(" diffBinder ")" "," term:66 : term
-- macro_rules
-- | `(∇ $x:ident, $f) =>
--   `(∇ λ $x => $f)
-- | `(∇ $x:ident : $type:term, $f) =>
--   `(∇ λ $x : $type => $f)
-- | `(∇ $x:ident := $val:term, $f) =>
--   `((∇ λ $x => $f) $val)
-- | `(∇ ($b:diffBinder), $f) =>
--   `(∇ $b, $f)

instance (f : X → Y) [HasAdjDiffDepT f] (x : X) : IsLinT (∂† f x) := sorry

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

@[simp ↓, diff]
theorem id.arg_x.adjDiffDep_simp
  : ∂† (λ x : X => x) = λ x dx => dx := by simp[adjointDifferentialDep]; done

@[simp ↓, diff]
theorem const.arg_x.adjDiffDep_simp
  : ∂† (λ (x : X) (i : ι) => x) = λ x f => ∑ i, f i := by simp[adjointDifferentialDep]; sorry -- done

@[simp ↓, diff]
theorem const.arg_y.adjDiffDep_simp (x : X)
  : ∂† (λ (y : Y) => x) = (λ y dy' => 0) := by simp[adjointDifferentialDep]; done

@[simp ↓ low-4, diff low-4]
theorem swap.arg_y.adjDiffDep_simp
  (f : ι → X → Z) [inst : ∀ i, HasAdjDiffDepT (f i)]
  : ∂† (λ x y => f y x) = (λ x dx' => ∑ i, (∂† (f i) x) (dx' i)) :=
by
  have := λ i => (inst i).proof.1
  have := λ i => (inst i).proof.2

  simp[adjointDifferentialDep]; sorry -- done

@[simp ↓ low-3, diff low-3]
theorem subst.arg_x.adjDiffDep_simp
  (f : X → Y → Z) [instf : HasAdjDiffDepNT 2 f]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : ∂† (λ x => f x (g x))
    =
    λ x dx' =>
      let ⟨y,dg',h⟩ := ℛ g x
      (∂† (hold λ x' => f x' y)) x (h ▸ dx')
      +
      dg' (∂† (f x) y (h ▸ dx'))
    :=
by
  have := instg.proof.1
  have := instg.proof.2
  have := instf.proof.1

  funext x dx';
  simp[adjointDifferentialDep, tangentMapDep]
  admit

@[simp ↓ low-2, diff low-2]
theorem subst.arg_x.parm1.adjDiffDep_simp
  (a : α)
  (f : X → Y → α → Z) [HasAdjDiffDepNT 2 λ x y => f x y a]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : ∂† (λ x => f x (g x) a)
    =
    λ x dx' =>
      let ⟨y,dg',h⟩ := ℛ g x
      (∂† (hold λ x' => f x' y a)) x (h ▸ dx')
      +
      dg' (∂† (hold λ y' => f x y' a) y (h ▸ dx'))
    :=
by
  apply subst.arg_x.adjDiffDep_simp (λ x y => f x y a) g
  done

@[simp ↓ low-2, diff low-2]
theorem subst.arg_x.parm2.adjDiffDep_simp
  (a : α) (b : β)
  (f : X → Y → α → β → Z) [HasAdjDiffDepNT 2 λ x y => f x y a b]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : ∂† (λ x => f x (g x) a b)
    =
    λ x dx' =>
      let ⟨y,dg',h⟩ := ℛ g x
      (∂† (hold λ x' => f x' y a b)) x (h ▸ dx')
      +
      dg' (∂† (hold λ y' => f x y' a b) y (h ▸ dx'))
    :=
by
  apply subst.arg_x.adjDiffDep_simp (λ x y => f x y a b) g
  done

@[simp ↓ low-2, diff low-2]
theorem subst.arg_x.parm3.adjDiffDep_simp
  (a : α) (b : β) (c : γ)
  (f : X → Y → α → β → γ → Z) [HasAdjDiffDepNT 2 λ x y => f x y a b c]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : ∂† (λ x => f x (g x) a b c)
    =
    λ x dx' =>
      let ⟨y,dg',h⟩ := ℛ g x
      (∂† (hold λ x' => f x' y a b c)) x (h ▸ dx')
      +
      dg' (∂† (hold λ y => f x y a b c) y (h ▸ dx'))
    :=
by
  apply subst.arg_x.adjDiffDep_simp (λ x y => f x y a b c) g
  done

@[simp ↓ low-1, diff low-1]
theorem comp.arg_x.adjDiffDep_simp
  (f : Y → Z) [instf : HasAdjDiffDepT f]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : ∂† (λ x => f (g x))
    =
    λ x dx' =>
      let ⟨y,dg',h⟩ := ℛ g x
      dg' ((∂† f y) (h ▸ dx')) :=
by
  simp; unfold hold; simp
  done

@[simp ↓ low-2, diff low-2]
theorem diag.arg_x.adjDiffDep_simp
  (f : Y₁ → Y₂ → Z) [HasAdjDiffDepNT 2 f]
  (g₁ : X → Y₁) [hg : HasAdjDiffDepT g₁]
  (g₂ : X → Y₂) [HasAdjDiffDepT g₂]
  : ∂† (λ x => f (g₁ x) (g₂ x))
    =
    λ x dx' =>
      let ⟨y₁,dg₁',h₁⟩ := ℛ g₁ x
      let ⟨y₂,dg₂',h₂⟩ := ℛ g₂ x
      dg₁' ((∂† λ y₁ => f y₁ y₂) y₁ (h₁ ▸ h₂ ▸ dx'))
      +
      dg₂' ((∂† λ y₂ => f y₁ y₂) y₂ (h₂ ▸ h₁ ▸ dx'))
    :=
by
  simp; unfold hold; simp; unfold hold; simp[reverseDifferentialDep,adjointDifferentialDep]; done

@[simp ↓ low, diff low]
theorem eval.arg_f.adjDiffDep_simp
  (i : ι)
  : ∂† (λ (f : ι → X) => f i)
    =
    (λ f df' j => if h : i = j then h ▸ df' else 0)
  :=
by
  simp[reverseDifferentialDep,adjointDifferentialDep]; sorry -- done

@[simp ↓ low-1, diff low-1]
theorem eval.arg_x.parm1.adjDiffDep_simp
  (f : X → ι → Z) [HasAdjDiffDep f]
  : ∂† (λ x => f x i)
    =
    (λ x dx' => (∂† f x) (λ j => if h : i = j then h ▸ dx' else 0))
  :=
by
  rw [comp.arg_x.adjDiffDep_simp (λ (x : ι → Z) => x i) f]
  simp[reverseDifferentialDep,adjointDifferentialDep]

--------------------------------------------------------
-- These theorems are problematic when used with simp --

@[simp ↓ low-1, diff low-1]
theorem comp.arg_x.parm1.adjDiffDep_simp
  (a : α)
  (f : Y → α → Z) [HasAdjDiffDep λ y => f y a]
  (g : X → Y) [HasAdjDiffDep g]
  :
    ∂† (λ x => f (g x) a)
    =
    λ x dx' =>
      let ⟨y,dg',h⟩ := ℛ g x
      dg' ((∂† (hold λ y => f y a)) y (h ▸ dx'))
:= by
  simp; unfold hold; simp
  done

@[simp ↓ low-1, diff low-1]
theorem comp.arg_x.parm2.adjDiffDep_simp
  (a : α) (b : β)
  (f : Y → α → β → Z) [HasAdjDiffDep λ y => f y a b]
  (g : X → Y) [HasAdjDiffDep g]
  :
    ∂† (λ x => f (g x) a b)
    =
    λ x dx' =>
      let ⟨y,dg',h⟩ := ℛ g x
      dg' ((∂† (hold λ y => f y a b)) y (h ▸ dx'))
:= by
  simp; unfold hold; simp
  done

@[simp ↓ low-1, diff low-1]
theorem comp.arg_x.parm3.adjDiffDep_simp
  (a : α) (b : β) (c : γ)
  (f : Y → α → β → γ → Z) [HasAdjDiffDep λ y => f y a b c]
  (g : X → Y) [HasAdjDiffDep g]
  :
    ∂† (λ x => f (g x) a b c)
    =
    λ x dx' =>
      let ⟨y,dg',h⟩ := ℛ g x
      dg' ((∂† (hold λ y => f y a b c)) y (h ▸ dx'))
:= by
  simp; unfold hold; simp
  done

@[simp ↓ low-1, diff low-1] -- try to avoid using this theorem
theorem diag.arg_x.parm1.adjDiffDep_simp
  (a : α)
  (f : Y₁ → Y₂ → α → Z) [HasAdjDiffDepNT 2 λ y₁ y₂ => f y₁ y₂ a]
  (g₁ : X → Y₁) [HasAdjDiffDepT g₁]
  (g₂ : X → Y₂) [HasAdjDiffDepT g₂]
  : ∂† (λ x => f (g₁ x) (g₂ x) a)
    =
    λ x dx' =>
      let ⟨y₁,dg₁',h₁⟩ := ℛ g₁ x
      let ⟨y₂,dg₂',h₂⟩ := ℛ g₂ x
      dg₁' ((∂† λ y₁ => f y₁ y₂ a) y₁ (h₁ ▸ h₂ ▸ dx'))
      +
      dg₂' ((∂† λ y₂ => f y₁ y₂ a) y₂ (h₂ ▸ h₁ ▸ dx'))
:= by
  (apply diag.arg_x.adjDiffDep_simp (λ y₁ y₂ => f y₁ y₂ a) g₁ g₂)

@[simp ↓ low-1, diff low-1] -- try to avoid using this theorem
theorem diag.arg_x.parm2.adjDiffDep_simp
  (a : α) (b : β)
  (f : Y₁ → Y₂ → α → β → Z) [HasAdjDiffDepNT 2 λ y₁ y₂ => f y₁ y₂ a b]
  (g₁ : X → Y₁) [HasAdjDiffDepT g₁]
  (g₂ : X → Y₂) [HasAdjDiffDepT g₂]
  : ∂† (λ x => f (g₁ x) (g₂ x) a b)
    =
    λ x dx' =>
      let ⟨y₁,dg₁',h₁⟩ := ℛ g₁ x
      let ⟨y₂,dg₂',h₂⟩ := ℛ g₂ x
      dg₁' ((∂† λ y₁ => f y₁ y₂ a b) y₁ (h₁ ▸ h₂ ▸ dx'))
      +
      dg₂' ((∂† λ y₂ => f y₁ y₂ a b) y₂ (h₂ ▸ h₁ ▸ dx'))
:= by
  (apply diag.arg_x.adjDiffDep_simp (λ y₁ y₂ => f y₁ y₂ a b) g₁ g₂)
  done

@[simp ↓ low-1, diff low-1] -- try to avoid using this theorem
theorem diag.arg_x.parm3.adjDiffDep_simp
  (a : α) (b : β) (c : γ)
  (f : Y₁ → Y₂ → α → β → γ → Z) [HasAdjDiffDepNT 2 λ y₁ y₂ => f y₁ y₂ a b c]
  (g₁ : X → Y₁) [HasAdjDiffDepT g₁]
  (g₂ : X → Y₂) [HasAdjDiffDepT g₂]
  : ∂† (λ x => f (g₁ x) (g₂ x) a b c)
    =
    λ x dx' =>
      let ⟨y₁,dg₁',h₁⟩ := ℛ g₁ x
      let ⟨y₂,dg₂',h₂⟩ := ℛ g₂ x
      dg₁' ((∂† λ y₁ => f y₁ y₂ a b c) y₁ (h₁ ▸ h₂ ▸ dx'))
      +
      dg₂' ((∂† λ y₂ => f y₁ y₂ a b c) y₂ (h₂ ▸ h₁ ▸ dx'))
:= by
  (apply diag.arg_x.adjDiffDep_simp (λ y₁ y₂ => f y₁ y₂ a b c) g₁ g₂)
  done

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

@[simp ↓, diff]
theorem id.arg_x.revDiffDep_simp
  : ℛ (λ x : X => x) = λ x => ⟨x, λ x => x, rfl⟩ := by simp[reverseDifferentialDep]; done

@[simp ↓, diff]
theorem const.arg_x.revDiffDep_simp
  : ℛ (λ (x : X) (i : ι) => x)
    =
    λ x =>
      ⟨(λ i => x), (λ f => ∑ i, f i), rfl⟩
  := by simp[reverseDifferentialDep]; done

@[simp ↓, diff]
theorem const.arg_y.revDiffDep_simp (x : X)
  : ℛ (λ (y : Y) => x)
    =
    λ y =>
      ⟨x, (λ dy' => 0), rfl⟩
  := by simp[reverseDifferentialDep]; done

@[simp ↓ low-4, diff low-4]
theorem swap.arg_y.revDiffDep_simp
  (f : ι → X → Z) [inst : ∀ i, HasAdjDiffDepT (f i)]
  : ∂† (λ x y => f y x) = (λ x dx' => ∑ i, (∂† (f i) x) (dx' i)) :=
by
  have := λ i => (inst i).proof.1
  have := λ i => (inst i).proof.2

  simp[adjointDifferentialDep]; done

@[simp ↓ low-3, diff low-3]
theorem subst.arg_x.revDiffDep_simp
  (f : X → Y → Z) [instf : HasAdjDiffDepNT 2 f]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : ℛ (λ x => f x (g x))
    =
    λ x =>
      let ⟨y,dg',hg⟩ := ℛ g x
      let ⟨z,df',hf⟩ := ℛ (uncurryN 2 f) (x,y)
      ⟨z, λ dz' =>
           let (dx₁,dy) := df' dz'
           dx₁ + dg' dy
      , by
          rw[hg]
          rw[(rfl : uncurryN 2 f (x,y) = f x y)] at hf
          apply hf
          done⟩
    :=
by
  have := instg.proof.1
  have := instg.proof.2
  have := instf.proof.1

  funext x;
  simp[adjointDifferentialDep, tangentMapDep, reverseDifferentialDep,uncurryN, Prod.Uncurry.uncurry,instUncurryHAddNatInstHAddInstAddNatOfNatForAllProd]
  admit

@[simp ↓ low-2, diff low-2]
theorem subst.arg_x.parm1.revDiffDep_simp
  (a : α)
  (f : X → Y → α → Z) [HasAdjDiffDepNT 2 λ x y => f x y a]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : ℛ (λ x => f x (g x) a)
    =
    λ x =>
      let ⟨y,dg',hg⟩ := ℛ g x
      let ⟨z,df',hf⟩ := ℛ (uncurryN 2 (λ x y => f x y a)) (x,y)
      ⟨z, λ dz' =>
           let (dx₁,dy) := df' dz'
           dx₁ + dg' dy
      , by
          rw[hg]
          rw[(rfl : (uncurryN 2 (λ x y => f x y a)) (x,y) = f x y a)] at hf
          apply hf
          done⟩
    :=
by
  apply subst.arg_x.revDiffDep_simp (λ x y => f x y a) g
  done

@[simp ↓ low-2, diff low-2]
theorem subst.arg_x.parm2.revDiffDep_simp
  (a : α) (b : β)
  (f : X → Y → α → β → Z) [HasAdjDiffDepNT 2 λ x y => f x y a b]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : ℛ (λ x => f x (g x) a b)
    =
    λ x =>
      let ⟨y,dg',hg⟩ := ℛ g x
      let ⟨z,df',hf⟩ := ℛ (uncurryN 2 (λ x y => f x y a b)) (x,y)
      ⟨z, λ dz' =>
           let (dx₁,dy) := df' dz'
           dx₁ + dg' dy
      , by
          rw[hg]
          rw[(rfl : (uncurryN 2 (λ x y => f x y a b)) (x,y) = f x y a b)] at hf
          apply hf
          done⟩
    :=
by
  apply subst.arg_x.revDiffDep_simp (λ x y => f x y a b) g
  done

@[simp ↓ low-2, diff low-2]
theorem subst.arg_x.parm3.revDiffDep_simp
  (a : α) (b : β) (c : γ)
  (f : X → Y → α → β → γ → Z) [HasAdjDiffDepNT 2 λ x y => f x y a b c]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : ℛ (λ x => f x (g x) a b c)
    =
    λ x =>
      let ⟨y,dg',hg⟩ := ℛ g x
      let ⟨z,df',hf⟩ := ℛ (uncurryN 2 (λ x y => f x y a b c)) (x,y)
      ⟨z, λ dz' => let (dx₁,dy) := df' dz'; dx₁ + dg' dy,
       by rw[hg]; rw[← hf]; done⟩
    :=
by
  apply subst.arg_x.revDiffDep_simp (λ x y => f x y a b c) g
  done

-- @[simp ↓ low-10, diff low-10]
theorem uncurryN2.arg_x.diffDep_simp
  (f : X → Y → Z) [HasAdjDiffDepNT 2 f]
  : ∂† (uncurryN 2 f)
    =
    λ (x,y) dz =>
      (∂† (λ x' => f x' y) x dz, ∂† (λ y' => f x y') y dz)
  := sorry_proof

@[simp ↓ low-1, diff low-1]
theorem comp.arg_x.revDiffDep_simp
  (f : Y → Z) [instf : HasAdjDiffDepT f]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : ℛ (λ x => f (g x))
    =
    λ x =>
      let ⟨y,dg',hg⟩ := ℛ g x
      let ⟨z,df',hf⟩ := ℛ f y
      ⟨z, λ dz => dg' (df' dz), by rw[hg]; rw[hf]; done⟩ :=
by
  simp[reverseDifferentialDep, uncurryN2.arg_x.diffDep_simp]
  done

@[simp ↓ low-2, diff low-2]
theorem diag.arg_x.revDiffDep_simp
  (f : Y₁ → Y₂ → Z) [HasAdjDiffDepNT 2 f]
  (g₁ : X → Y₁) [hg : HasAdjDiffDepT g₁]
  (g₂ : X → Y₂) [HasAdjDiffDepT g₂]
  : ℛ (λ x => f (g₁ x) (g₂ x))
    =
    λ x =>
      let ⟨y₁,dg₁',h₁⟩ := ℛ g₁ x
      let ⟨y₂,dg₂',h₂⟩ := ℛ g₂ x
      let ⟨z, df', hf⟩ := ℛ (uncurryN 2 f) (y₁,y₂)
      ⟨z, λ dz => let (dy₁,dy₂) := df' dz; dg₁' dy₁ + dg₂' dy₂,
       by rw[h₁,h₂]; rw[← hf]; done⟩
      -- dg₁' ((∂† λ y₁ => f y₁ y₂) y₁ (h₁ ▸ h₂ ▸ dx'))
      -- +
      -- dg₂' ((∂† λ y₂ => f y₁ y₂) y₂ (h₂ ▸ h₁ ▸ dx'))
    :=
by
  simp[reverseDifferentialDep, uncurryN2.arg_x.diffDep_simp]; unfold hold;simp
  done

@[simp ↓ low, diff low]
theorem eval.arg_f.revDiffDep_simp
  (i : ι)
  : ℛ (λ (f : ι → X) => f i)
    =
    λ f =>
      ⟨f i,
       λ dx j => if h : i = j then h ▸ dx else 0,
       rfl⟩
  :=
by
  simp[reverseDifferentialDep,adjointDifferentialDep]; done

@[simp ↓ low-1, diff low-1]
theorem eval.arg_x.parm1.revDiffDep_simp
  (f : X → ι → Z) [HasAdjDiffDep f] (i : ι)
  : ℛ (λ x => f x i)
    =
    λ x =>
      let ⟨fx, df', hf⟩ := ℛ f x
      ⟨fx i,
      λ dx' => df' (λ j => if h : i = j then h ▸ dx' else 0),
      by rw[hf]; done⟩
  :=
by
  rw [comp.arg_x.revDiffDep_simp (λ (x : ι → Z) => x i) f]
  simp[reverseDifferentialDep,adjointDifferentialDep]
  sorry

-- @[simp ↓]
-- theorem subst.aprg_x.revDiffDep_simp'''
--   (f : X → Y → Z) [IsSmooth f]
--   [instfx : ∀ y, HasAdjDiffDep λ x => f x y]
--   [instfy : ∀ x, HasAdjDiffDep (f x)]
--   (g : Y → X) [instg : HasAdjDiffDep g]
--   : ∂† (λ y => f (g y) y)
--     =
--     λ y dy' =>
--       (∂† (λ y' => f (g y) y')) y dy'
--       +
--       (∂† g y) (∂† (λ x => f x y) (g y) dy')
--     :=
-- by
--   sorry


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl
-/
import topology.algebra.uniform_group
import topology.algebra.uniform_mul_action
import topology.uniform_space.completion

/-!
# Completion of topological groups:

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

This files endows the completion of a topological abelian group with a group structure.
More precisely the instance `uniform_space.completion.add_group` builds an abelian group structure
on the completion of an abelian group endowed with a compatible uniform structure.
Then the instance `uniform_space.completion.uniform_add_group` proves this group structure is
compatible with the completed uniform structure. The compatibility condition is `uniform_add_group`.

## Main declarations:

Beyond the instances explained above (that don't have to be explicitly invoked),
the main constructions deal with continuous group morphisms.

* `add_monoid_hom.extension`: extends a continuous group morphism from `G`
  to a complete separated group `H` to `completion G`.
* `add_monoid_hom.completion`: promotes a continuous group morphism
  from `G` to `H` into a continuous group morphism
  from `completion G` to `completion H`.
-/

noncomputable theory

variables {M R α β : Type*}

section group
open uniform_space Cauchy filter set
variables [uniform_space α]

instance [has_zero α] : has_zero (completion α) := ⟨(0 : α)⟩
instance [has_neg α] : has_neg (completion α) := ⟨completion.map (λa, -a : α → α)⟩
instance [has_add α] : has_add (completion α) := ⟨completion.map₂ (+)⟩
instance [has_sub α] : has_sub (completion α) := ⟨completion.map₂ has_sub.sub⟩

@[norm_cast]
lemma uniform_space.completion.coe_zero [has_zero α] : ((0 : α) : completion α) = 0 := rfl
end group

namespace uniform_space.completion
open uniform_space

section has_zero

instance [uniform_space α] [monoid_with_zero M] [has_zero α] [mul_action_with_zero M α]
  [has_uniform_continuous_const_smul M α] :
  mul_action_with_zero M (completion α) :=
{ smul := (•),
  smul_zero := λ r, by rw [← coe_zero, ← coe_smul, mul_action_with_zero.smul_zero r],
  zero_smul := ext' (continuous_const_smul _) continuous_const $ λ a,
    by rw [← coe_smul, zero_smul, coe_zero],
  .. completion.mul_action M α }

end has_zero

section uniform_add_group
variables [uniform_space α] [add_group α] [uniform_add_group α]

@[norm_cast]
lemma coe_neg (a : α) : ((- a : α) : completion α) = - a :=
(map_coe uniform_continuous_neg a).symm

@[norm_cast]
lemma coe_sub (a b : α) : ((a - b : α) : completion α) = a - b :=
(map₂_coe_coe a b has_sub.sub uniform_continuous_sub).symm

@[norm_cast]
lemma coe_add (a b : α) : ((a + b : α) : completion α) = a + b :=
(map₂_coe_coe a b (+) uniform_continuous_add).symm

instance : add_monoid (completion α) :=
{ zero_add     := assume a, completion.induction_on a
   (is_closed_eq (continuous_map₂ continuous_const continuous_id) continuous_id)
    (assume a, show 0 + (a : completion α) = a, by rw_mod_cast zero_add),
  add_zero     := assume a, completion.induction_on a
    (is_closed_eq (continuous_map₂ continuous_id continuous_const) continuous_id)
    (assume a, show (a : completion α) + 0 = a, by rw_mod_cast add_zero),
  add_assoc    := assume a b c, completion.induction_on₃ a b c
    (is_closed_eq
      (continuous_map₂
        (continuous_map₂ continuous_fst (continuous_fst.comp continuous_snd))
        (continuous_snd.comp continuous_snd))
      (continuous_map₂ continuous_fst
        (continuous_map₂
          (continuous_fst.comp continuous_snd)
          (continuous_snd.comp continuous_snd))))
    (assume a b c, show (a : completion α) + b + c = a + (b + c),
      by repeat { rw_mod_cast add_assoc }),
  nsmul := (•),
  nsmul_zero' := λ a, completion.induction_on a (is_closed_eq continuous_map continuous_const)
    (λ a, by rw [←coe_smul, ←coe_zero, zero_smul]),
  nsmul_succ' := λ n a, completion.induction_on a
    (is_closed_eq continuous_map $ continuous_map₂ continuous_id continuous_map)
    (λ a, by rw_mod_cast succ_nsmul ),
  .. completion.has_zero, ..completion.has_add, }

instance : sub_neg_monoid (completion α) :=
{ sub_eq_add_neg := λ a b, completion.induction_on₂ a b
    (is_closed_eq (continuous_map₂ continuous_fst continuous_snd)
      (continuous_map₂ continuous_fst (completion.continuous_map.comp continuous_snd)))
   (λ a b, by exact_mod_cast congr_arg coe (sub_eq_add_neg a b)),
  zsmul := (•),
  zsmul_zero' := λ a, completion.induction_on a (is_closed_eq continuous_map continuous_const)
    (λ a, by { rw_mod_cast zero_smul, refl} ),
  zsmul_succ' := λ n a, completion.induction_on a
    (is_closed_eq continuous_map $ continuous_map₂ continuous_id continuous_map)
    (λ a, by rw_mod_cast (show int.of_nat n.succ • a = a + int.of_nat n • a,
                          from sub_neg_monoid.zsmul_succ' n a) ),
  zsmul_neg' := λ n a, completion.induction_on a
    (is_closed_eq continuous_map $ completion.continuous_map.comp continuous_map)
    (λ a, by rw [←coe_smul, ←coe_smul, ←coe_neg, show -[1+ n] • a = -((n.succ : ℤ) • a),
                                                 from sub_neg_monoid.zsmul_neg' n a]),
  .. completion.add_monoid, .. completion.has_neg, .. completion.has_sub }

instance : add_group (completion α) :=
{ add_left_neg := assume a, completion.induction_on a
    (is_closed_eq (continuous_map₂ completion.continuous_map continuous_id) continuous_const)
    (assume a, show - (a : completion α) + a = 0, by { rw_mod_cast add_left_neg, refl }),
  .. completion.sub_neg_monoid }

instance : uniform_add_group (completion α) :=
⟨uniform_continuous_map₂ has_sub.sub⟩

instance {M} [monoid M] [distrib_mul_action M α] [has_uniform_continuous_const_smul M α] :
  distrib_mul_action M (completion α) :=
{ smul := (•),
  smul_add := λ r x y, induction_on₂ x y
    (is_closed_eq ((continuous_fst.add continuous_snd).const_smul _)
      ((continuous_fst.const_smul _).add (continuous_snd.const_smul _)))
    (λ a b, by simp only [← coe_add, ← coe_smul, smul_add]),
  smul_zero := λ r, by rw [← coe_zero, ← coe_smul, smul_zero r],
  .. completion.mul_action M α }

/-- The map from a group to its completion as a group hom. -/
@[simps] def to_compl : α →+ completion α :=
{ to_fun := coe,
  map_add' := coe_add,
  map_zero' := coe_zero }

lemma continuous_to_compl : continuous (to_compl : α → completion α) :=
continuous_coe α

variable (α)

lemma dense_inducing_to_compl : dense_inducing (to_compl : α → completion α) :=
dense_inducing_coe

variable {α}

end uniform_add_group

section uniform_add_comm_group
variables [uniform_space α] [add_comm_group α] [uniform_add_group α]

instance : add_comm_group (completion α) :=
{ add_comm  := assume a b, completion.induction_on₂ a b
    (is_closed_eq (continuous_map₂ continuous_fst continuous_snd)
      (continuous_map₂ continuous_snd continuous_fst))
    (assume x y, by { change ↑x + ↑y = ↑y + ↑x, rw [← coe_add, ← coe_add, add_comm]}),
  .. completion.add_group }

instance [semiring R] [module R α] [has_uniform_continuous_const_smul R α] :
  module R (completion α) :=
{ smul := (•),
  add_smul := λ a b, ext' (continuous_const_smul _)
    ((continuous_const_smul _).add (continuous_const_smul _)) $ λ x, by { norm_cast, rw add_smul },
  .. completion.distrib_mul_action, .. completion.mul_action_with_zero }

end uniform_add_comm_group

end uniform_space.completion

section add_monoid_hom
variables [uniform_space α] [add_group α] [uniform_add_group α]
          [uniform_space β] [add_group β] [uniform_add_group β]

open uniform_space uniform_space.completion

/-- Extension to the completion of a continuous group hom. -/
def add_monoid_hom.extension [complete_space β] [separated_space β] (f : α →+ β)
  (hf : continuous f) : completion α →+ β :=
have hf : uniform_continuous f, from uniform_continuous_add_monoid_hom_of_continuous hf,
{ to_fun := completion.extension f,
  map_zero' := by rw [← coe_zero, extension_coe hf, f.map_zero],
  map_add' := assume a b, completion.induction_on₂ a b
  (is_closed_eq
    (continuous_extension.comp continuous_add)
    ((continuous_extension.comp continuous_fst).add (continuous_extension.comp continuous_snd)))
  (λ a b, by rw_mod_cast [extension_coe hf, extension_coe hf, extension_coe hf,
    f.map_add]) }

lemma add_monoid_hom.extension_coe [complete_space β] [separated_space β] (f : α →+ β)
  (hf : continuous f) (a : α) : f.extension hf a = f a :=
extension_coe (uniform_continuous_add_monoid_hom_of_continuous hf) a

@[continuity]
lemma add_monoid_hom.continuous_extension [complete_space β] [separated_space β] (f : α →+ β)
  (hf : continuous f) : continuous (f.extension hf) :=
continuous_extension

/-- Completion of a continuous group hom, as a group hom. -/
def add_monoid_hom.completion (f : α →+ β) (hf : continuous f) : completion α →+ completion β :=
(to_compl.comp f).extension (continuous_to_compl.comp hf)

@[continuity]
lemma add_monoid_hom.continuous_completion (f : α →+ β)
  (hf : continuous f) : continuous (f.completion hf : completion α → completion β) :=
continuous_map

lemma add_monoid_hom.completion_coe (f : α →+ β)
  (hf : continuous f) (a : α) : f.completion hf a = f a :=
map_coe (uniform_continuous_add_monoid_hom_of_continuous hf) a

lemma add_monoid_hom.completion_zero : (0 : α →+ β).completion continuous_const = 0 :=
begin
  ext x,
  apply completion.induction_on x,
  { apply is_closed_eq ((0 : α →+ β).continuous_completion continuous_const),
    simp [continuous_const] },
  { intro a,
    simp [(0 : α →+ β).completion_coe continuous_const, coe_zero] }
end

lemma add_monoid_hom.completion_add {γ : Type*} [add_comm_group γ] [uniform_space γ]
  [uniform_add_group γ] (f g : α →+ γ) (hf : continuous f) (hg : continuous g) :
  (f + g).completion (hf.add hg) = f.completion hf + g.completion hg :=
begin
  have hfg := hf.add hg,
  ext x,
  apply completion.induction_on x,
  { exact is_closed_eq ((f+g).continuous_completion hfg)
    ((f.continuous_completion hf).add (g.continuous_completion hg)) },
  { intro a,
    simp [(f+g).completion_coe hfg, coe_add, f.completion_coe hf, g.completion_coe hg] }
end

end add_monoid_hom


def Set α := α → Prop

class HasMem (α : outParam $ Type u) (β : Type v) where
    mem : α → β → Prop

infix:50 " ∈ " => HasMem.mem

instance : HasMem α (Set α) := ⟨λ a s => s a⟩

instance : LE (Set α) := ⟨λ s t => ∀ {x : α}, x ∈ s → x ∈ t⟩

class HasInf (P : Type u) where
  inf : P → P → P

infix:70 " ⊓ " => HasInf.inf

instance : HasInf (Set α) := ⟨λ s t x => x ∈ s ∧ x ∈ t⟩

theorem infLeLeft {s t : Set α} : s ⊓ t ≤ s := And.left
theorem infLeRight {s t : Set α} : s ⊓ t ≤ t := And.right

theorem inter_mem_sets_iff (f : Set (Set α)) (hf : ∀ {s t}, s ∈ f → s ≤ t → t ∈ f) :
  x ⊓ y ∈ f → x ∈ f ∧ y ∈ f := by
  intro h
  refine ⟨hf h infLeLeft, hf h ?_⟩
  apply infLeRight