/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .set_theory order.complete_boolean_algebra

local attribute [instance] classical.prop_decidable

open set

meta def not_as_big_bertha : tactic string := `[cc] >> pure "cc"

meta def not_as_big_bertha' : tactic string := `[{[smt] close}] >> pure "{[smt] close}"

meta def with_cc : list (tactic string) := tactic.tidy.default_tactics ++ [not_as_big_bertha]

meta def with_cc' : list (tactic string) := tactic.tidy.default_tactics ++ [not_as_big_bertha']

namespace topological_space
section topology_lemmas
variables {α : Type*} [τ : topological_space α]
local notation `cl`:65 := closure

local notation `int`:65 := interior

attribute [simp] interior_eq_of_open

include τ

def dense (S : set α) : Prop := ∀ U : set α, @is_open α τ U → U ≠ ∅ → U ∩ S ≠ ∅

-- S is dense in S₀ if S ∩ S₀ is dense in the subspace S₀
def rel_dense (S₀ S : set α) : Prop := ∀ U : set α, @is_open α τ U → U ∩ S₀ ≠ ∅ → U ∩ S₀ ∩ S ≠ ∅

lemma closure_univ_of_dense {S : set α} (H_dense : dense S) : closure S = univ :=
dense_iff_inter_open.mpr H_dense

lemma closure_rel_dense_of_open {S₀ S : set α} (H_open : is_open τ S₀)  (H_rel_dense : rel_dense S₀ S) : cl S ∩ S₀ = S₀ :=
begin
  ext, split; intro H_mem,
    { cases H_mem with H₁ H₂, from ‹_› },
    { refine ⟨_,‹_›⟩, rw mem_closure_iff,
      intros o Ho H_mem_o, specialize H_rel_dense (o ∩ S₀) (by {apply is_open_inter, from ‹_›, from ‹_›}) _,
       rw set.ne_empty_iff_exists_mem at H_rel_dense ⊢, cases H_rel_dense with x Hx, repeat {auto_cases},
       use x, finish, rw set.ne_empty_iff_exists_mem, use x, finish}
end

/--
S is dense in the basis 𝓑 if S meets every B ∈ 𝓑.
-/
def dense_in_basis (S : set α) {𝓑 : set $ set α} (H_basis : is_topological_basis 𝓑) : Prop :=
∀ B ∈ 𝓑, B ≠ ∅ → B ∩ S ≠ ∅

lemma dense_of_dense_in_basis (S : set α) {𝓑} (H_basis : is_topological_basis 𝓑) (H : dense_in_basis S H_basis) : dense S :=
begin
  intros U HU HU_ne,
  cases (exists_mem_of_ne_empty ‹_›) with a Ha,
  rcases mem_basis_subset_of_mem_open ‹_› Ha ‹_› with ⟨B, ⟨HB₁, ⟨HB₂, HB₃⟩⟩⟩,
  suffices this : ∃ a', a' ∈ U ∧ a' ∈ S,
    from ne_empty_of_exists_mem this,
  have := exists_mem_of_ne_empty (H _ HB₁ (ne_empty_of_exists_mem (by finish))),
  rcases this with ⟨x,⟨Hx₁,Hx₂⟩⟩, use x, tidy
end

def rel_dense_in_basis (S₀ : set α) (S : set α) {𝓑 : set $ set α} (H_basis : is_topological_basis 𝓑) : Prop :=
∀ B ∈ 𝓑, B ∩ S₀ ≠ ∅ → B ∩ S₀ ∩ S ≠ ∅

lemma rel_dense_of_dense_in_basis (S₀ : set α) (S : set α) {𝓑} (H_basis : is_topological_basis 𝓑) (H : rel_dense_in_basis S₀ S H_basis) : rel_dense S₀ S :=
begin
  intros U HU HU_ne,
  rcases (exists_mem_of_ne_empty ‹_›) with ⟨a,Ha,Ha₀⟩,
  rcases mem_basis_subset_of_mem_open ‹_› Ha ‹_› with ⟨B, ⟨HB₁, ⟨HB₂, HB₃⟩⟩⟩,
  suffices this : ∃ a', a' ∈ U ∧ a' ∈ S₀ ∧ a' ∈ S,
    from ne_empty_of_exists_mem (by finish),
  have := exists_mem_of_ne_empty (H _ HB₁ (ne_empty_of_exists_mem (by finish))),
  rcases this with ⟨x,⟨Hx₁,Hx₂⟩⟩, use x, tidy
end

def nowhere_dense (S : set α) : Prop := int (cl S) = ∅

lemma frontier_closed_of_open {S : set α} (H : @is_open _ τ S) : is_closed (frontier S) :=
begin
  unfold frontier, rw[diff_eq], apply is_closed_inter, tidy
end

lemma frontier_nowhere_dense_of_open {S : set α} (H : @is_open _ τ S) : nowhere_dense (frontier S) :=
begin
  unfold nowhere_dense frontier,
  ext, split; intros, swap, cases a,
  rw[diff_eq] at a,
  rw[show cl(cl S ∩ -int S) = cl(S) ∩ -int S,
    by {apply closure_eq_of_is_closed, from frontier_closed_of_open H}] at a,
  rw[show int S = S, by {apply interior_eq_of_open, from ‹_›}] at a,
  rw[interior_inter] at a, simp at a, tidy
end

lemma is_clopen_interior {S : set α} (H : (: is_clopen S :)) : interior S = S :=
interior_eq_of_open H.left

local attribute [ematch] is_clopen_interior

lemma is_clopen_closure {S : set α} (H : (: is_clopen S :)) : closure S = S :=
closure_eq_of_is_closed H.right

local attribute [ematch] is_clopen_closure

@[simp]lemma closure_mono' {s t : set α} (H : (: s ⊆ t :)) : closure s ⊆ closure t ↔ true := by finish[closure_mono]

local attribute [ematch] closure_mono'

lemma closure_eq_compl_interior_compl' {s : set α} :
  closure s = - interior (- s) := closure_eq_compl_interior_compl

local attribute [ematch] closure_eq_compl_interior_compl'

lemma interior_compl' {s : set α} : interior (- s) = - closure s :=
by apply interior_compl

@[ematch]lemma interior_eq_compl_closure_compl {s : set α} :
  interior s = - closure (- s) :=
by ext; simp

lemma subset_anti {s t : set α} : -s ⊆ -t ↔ t ⊆ s :=
compl_subset_compl

lemma subset_anti' {s t : set α} (H : t ⊆ s) :  - (closure s) ⊆ - (closure t) :=
by finish[subset_anti]

local attribute [ematch] subset_anti'

lemma subset_anti_right {s t : set α} (H : s ⊆ -t) : s ⊆ -t ↔ t ⊆ -s :=
by {split, clear H, intro, rw[<-subset_anti], convert a, simp, finish}

local attribute [ematch] subset_anti_right

lemma compl_mono {s t : set α} (H : s ⊆ t) : - t ⊆ - s := by simp[*,subset_anti]

end topology_lemmas
end topological_space

open lattice
section regular
variables {α : Type*} [τ : topological_space α]

include τ
@[reducible]def topological_space.is_regular (S : set α) : Prop :=
 S = interior (closure S)

open topological_space

local attribute [ematch] is_clopen_interior is_clopen_closure closure_mono'
 is_regular subset_anti_right subset_anti' closure_eq_compl_interior_compl'

-- @[reducible,simp,ematch]def int_of_cl (S : set α) := interior (closure S)

def perp (S : set α) : set α := - (closure S)
local attribute [reducible] perp

local postfix `ᵖ`:80 := perp

local notation `cl`:65 := closure

local notation `int`:65 := interior

@[ematch]lemma perp_unfold (S : set α) : Sᵖ = - (cl S) := rfl

lemma perp_eq_int_neg {S : set α} : Sᵖ = int (- S) :=
by simp [perp]

lemma mem_perp_iff {S : set α} {x : α} :
  x ∈ Sᵖ ↔ ∃T, T ∩ S = ∅ ∧ _root_.is_open T ∧ x ∈ T :=
by simp [perp_eq_int_neg, subset_compl_iff_disjoint, mem_interior, -interior_compl]

@[simp]lemma is_open_perp {S : set α} : is_open (Sᵖ) :=
by {unfold perp, apply is_open_compl_iff.mpr, simp}

@[simp]lemma perp_univ : univᵖ = (∅ : set α) :=
by simp[perp_unfold]

@[simp]lemma perp_empty : (∅ : set α)ᵖ = univ :=
by simp[perp_unfold]

@[simp]lemma is_open_of_is_regular {S : set α} (H : (: is_regular S :)) : is_open S :=
by {unfold is_regular at H, rw[H], simp}

local attribute [ematch] is_open_of_is_regular

@[simp]lemma is_regular_of_clopen {S : set α} (H : is_clopen S) : is_regular S :=
by {[smt] eblast}

lemma regular_iff_p_p {S : set α} : is_regular S ↔ (Sᵖᵖ) = S :=
begin
  split; intro H, unfold is_regular at H,
  {[smt] eblast},
  {[smt] eblast}
end

lemma p_p_eq_int_cl {S : set α} : Sᵖᵖ = interior (closure S) :=
by {have := @regular_iff_p_p α _ S; {[smt] eblast}}

lemma int_cl_eq_p_p {S : set α} : int (cl S) = Sᵖᵖ := p_p_eq_int_cl.symm

@[ematch]lemma mem_int_cl_iff_mem_eq_p_p {S : set α} {a : α} : a ∈ int (cl S) ↔ a ∈ (Sᵖᵖ) := by rw[int_cl_eq_p_p]

lemma is_open_of_p_p {S : set α} (H : Sᵖᵖ = S) : is_open S :=
by {rw[p_p_eq_int_cl] at H, from is_open_of_is_regular (by {unfold is_regular, from H.symm})}

@[simp]lemma is_regular_empty : is_regular (∅ : set α) :=
by simp

@[simp]lemma is_regular_univ : is_regular (univ : set α) :=
by simp

lemma p_anti {P Q : set α} (H : P ⊆ Q) : Qᵖ ⊆ Pᵖ :=
by {have := subset_anti' H, from this}

lemma p_p_mono {P Q : set α} (H : P ⊆ Q) : Pᵖᵖ ⊆ Qᵖᵖ :=
p_anti $ p_anti H

lemma in_p_p_of_open {S : set α} (H : is_open S) : S ⊆ Sᵖᵖ :=
begin
  have : S ⊆ cl S := subset_closure,
  rw[<-subset_anti] at this,
  replace this := closure_mono this,
  rw[<-subset_anti] at this,
  convert this, simp*
end

lemma p_eq_p_p_p {S : set α} (H : is_open S) : Sᵖ = Sᵖᵖᵖ :=
begin
  have := p_anti (in_p_p_of_open ‹_›),
  have := in_p_p_of_open (show is_open (Sᵖ), by simp),
  ext; split; intros; solve_by_elim
end

@[simp]lemma p_p_p_p_eq_p_p {S : set α} : Sᵖᵖᵖᵖ = Sᵖᵖ :=
by {rw[<-p_eq_p_p_p], simp}

lemma is_regular_stable_subset {S₁ S₂ : set α} (H : is_regular S₂) (H₂ : S₁ ⊆ S₂) : S₁ᵖᵖ ⊆ S₂ :=
by {rw[regular_iff_p_p] at H,
   replace H₂ := p_anti (p_anti H₂), convert H₂, cc}

@[simp]lemma is_regular_eq_p_p {S : set α} (H : is_regular S) : Sᵖᵖ = S :=
begin
  refine le_antisymm _ _,
    apply is_regular_stable_subset ‹_›, intros _ _, from ‹_›,
  from in_p_p_of_open (is_open_of_is_regular ‹_›)
end

lemma subset_p_p_of_open {S : set α} (H : (: is_open S :)) : S ⊆ Sᵖᵖ :=
in_p_p_of_open ‹_›

lemma subset_int_cl_of_open {S : set α} (H : is_open S) : S ⊆ int (cl S) :=
by {rw[<-p_p_eq_int_cl], from subset_p_p_of_open ‹_›}

lemma is_regular_sup {S₁ S₂ : set α} : is_regular ((S₁ ∪ S₂)ᵖᵖ) :=
by rw[regular_iff_p_p]; simp

@[simp]lemma is_open_of_p_p' {S : set α} : is_open (Sᵖᵖ) :=
by {simp}

@[simp]lemma is_regular_p_p {S : set α} : is_regular (Sᵖᵖ) :=
begin
  refine le_antisymm _ _,
    rw[<-p_p_eq_int_cl], apply subset_p_p_of_open,
    apply is_open_of_p_p',
    rw[<-p_p_eq_int_cl], simp, intros _ _, from ‹_›
end

lemma inter_eq_inter_aux (S₁ S₂ : set α) (H : is_open S₁) : S₁ ∩ (cl S₂) ⊆ cl (S₁ ∩ S₂) :=
closure_inter_open ‹_›

@[simp]lemma cl_compl_of_is_open (S : set α) (H : is_open S) : cl(-S) = -S :=
by have : is_closed (-S); by simp*; simp[this]

lemma inter_eq_inter_aux₂ (S₁ S₂ : set α) {H₁ : is_open S₁} {H₂ : is_open S₂} : S₁ ∩ (S₂ᵖᵖ) ⊆ (S₁ ∩ S₂)ᵖᵖ :=
begin
    have this₃ := inter_eq_inter_aux S₁ S₂ H₁,
    have this₄ := compl_mono (this₃),
    rw[compl_inter] at this₄,
    have this₅ := p_anti this₄,
    unfold perp at this₅, rw[closure_union] at this₅,
    rw[cl_compl_of_is_open] at this₅, rw[compl_union] at this₅,
    convert this₅, simp, from ‹_›
end

lemma p_p_inter_eq_inter_p_p {S₁ S₂ : set α} (H₁ : is_open S₁) (H₂ : is_open S₂): (S₁ ∩ S₂)ᵖᵖ = S₁ᵖᵖ ∩ S₂ᵖᵖ :=
begin
  have this₀_left : S₁ ∩ S₂ ⊆ S₁, by simp,
  have this₀_right : S₁ ∩ S₂ ⊆ S₂, by simp,
  have this₁_left : (S₁ ∩ S₂)ᵖᵖ ⊆ S₁ᵖᵖ, from p_anti (p_anti this₀_left),
  have this₁_right : (S₁ ∩ S₂)ᵖᵖ ⊆ S₂ᵖᵖ, from p_anti (p_anti this₀_right),
  have this₂ : (S₁ ∩ S₂)ᵖᵖ ⊆ S₁ᵖᵖ ∩ S₂ᵖᵖ,
    by {intros x Hx, split, from this₁_left ‹_›, from this₁_right ‹_›},
  apply subset.antisymm, exact λ _ _, this₂ ‹_›,
  show S₁ᵖᵖ ∩ S₂ᵖᵖ ⊆ (S₁ ∩ S₂)ᵖᵖ,
  have this₃ := inter_eq_inter_aux S₁ S₂ H₁,
  have this₄ := compl_mono (this₃),
  have this₅ := p_anti this₄,
  change _ ᵖ ⊆ _ ᵖᵖ at this₅,
  have this₆ : S₁ ∩ (S₂ᵖᵖ) ⊆ (S₁ ∩ S₂)ᵖᵖ,
    by {apply inter_eq_inter_aux₂; from ‹_›},
  have this₇ : (S₁ᵖᵖ) ∩ (S₂ᵖᵖ) ⊆ ((S₁ᵖᵖ) ∩ S₂)ᵖᵖ,
    by {apply inter_eq_inter_aux₂ (S₁ᵖᵖ), simpa},
  have this₈ : (S₂ ∩ S₁ᵖᵖ) ⊆ (S₂ ∩ S₁)ᵖᵖ,
    by {apply inter_eq_inter_aux₂ S₂ S₁; from ‹_›},
  have this₉ : (S₁ᵖᵖ ∩ S₂)ᵖᵖ ⊆ (S₁ ∩ S₂)ᵖᵖᵖᵖ,
    by {replace this₈ := p_anti this₈, replace this₈ := p_anti this₈,
        conv {congr, rw[inter_comm], skip, rw[inter_comm]}, from this₈},
  rw[<-p_eq_p_p_p] at this₉,
  from subset.trans this₇ this₉, from is_open_perp
end

@[simp]lemma is_regular_inter {S₁ S₂ : set α} (H₁ : is_regular S₁) (H₂ : is_regular S₂) : is_regular (S₁ ∩ S₂) :=
by {rw[regular_iff_p_p] at *, rw[p_p_inter_eq_inter_p_p (is_open_of_p_p H₁) (is_open_of_p_p H₂)], cc}

lemma Union_perp_subset (C : set (set α)) : ⋃₀ (perp '' C) ⊆ (⋂₀ C)ᵖ :=
begin
  intros x hx, simp [-mem_compl_eq, mem_perp_iff] at hx ⊢, rcases hx with ⟨s, hs, t, hts, ht⟩,
  refine ⟨t, _, ht⟩, rw [← subset_empty_iff, ← hts], apply inter_subset_inter_right,
  apply sInter_subset_of_mem hs
end

lemma perp_sUnion_perp {C : set (set α)} (h : ∀(s ∈ C), is_regular s) :
  (⋃₀ (perp '' C))ᵖ = (⋂₀ C)ᵖᵖ :=
begin
  refine subset.antisymm _ (p_anti $ Union_perp_subset C),
  intros x hx, simp [-mem_compl_eq, mem_perp_iff] at hx ⊢,
  rcases hx with ⟨t, h1t, h2t, h3t⟩,
  rw [← subset_compl_iff_disjoint, compl_bUnion, ← subset_interior_iff_subset_of_open h2t] at h1t,
  simp only [compl_compl] at h1t,
  simp only [subset_compl_iff_disjoint.symm, compl_compl],
  refine ⟨t, _, h2t, h3t⟩,
  have := subset.trans h1t (interior_bInter_subset _),
  rw [subset_bInter_iff] at this,
  refine subset.trans _ subset_closure,
  rw [subset_sInter_iff], intros s hs,
  convert this s hs, exact h s hs
end

end regular

open topological_space

section regular_algebra

local postfix `ᵖ`:80 := perp

local notation `cl`:65 := closure

local notation `int`:65 := interior

variables {α : Type*} [τ : topological_space α]

include τ

variable (α)
def regular_opens := {S : set α // is_regular S}

local attribute [reducible] regular_opens

local attribute [reducible] perp

variable{α}
def regular_open_poset : partial_order (regular_opens α) :=
{le := λ S₁ S₂, S₁.val ⊆ S₂.val,
  lt := λ S₁ S₂, S₁.val ⊆ S₂.val ∧ S₁.val ≠ S₂.val,
  le_refl := by {intro a, simp only},
  le_trans := by {intros a b c H₁ H₂, apply subset.trans H₁ H₂},
  lt_iff_le_not_le := by {intros a b, split; intro H, tidy,
                      suffices : a_val = b_val,
                      by contradiction, ext; intros; split; intros,
                         from H_left ‹_›, from a ‹_›},
  le_antisymm :=
    begin
      intros a b H₁ H₂, apply subtype.eq,
      ext; intros; split; intros, from H₁ ‹_›, from H₂ ‹_›
    end}
local attribute [instance] regular_open_poset

lemma le_iff_subset {S₁ S₂ : regular_opens α} : S₁ ≤ S₂ ↔ S₁.val ⊆ S₂ := by refl

def regular_open_lattice : lattice (regular_opens α) :=
{ sup := λ S₁ S₂, ⟨(S₁.val ∪ S₂.val)ᵖᵖ, by {apply is_regular_sup}⟩,
    le_sup_left :=
    begin
      intros a b, refine subset.trans (show a.val ⊆ a.val ∪ b.val, by simp) (show a.val ∪ b.val ⊆ (a.val ∪ b.val)ᵖᵖ, from _),
      apply subset_p_p_of_open (is_open_union (is_open_of_is_regular a.property) (is_open_of_is_regular b.property)),
    end,
  le_sup_right :=
    begin
      intros a b, refine subset.trans (show b.val ⊆ a.val ∪ b.val, by simp) (show a.val ∪ b.val ⊆ (a.val ∪ b.val)ᵖᵖ, from _),
      apply subset_p_p_of_open (is_open_union (is_open_of_is_regular a.property) (is_open_of_is_regular b.property)),
    end,
  sup_le := by {intros a b c H₁ H₂, apply is_regular_stable_subset, from c.property, intros x Hx, cases Hx; solve_by_elim},
  inf := λ S₁ S₂, ⟨S₁.val ∩ S₂.val, by {apply is_regular_inter, from S₁.property, from S₂.property}⟩,
  inf_le_left :=
    begin
      intros a b, intros x Hx, from Hx.left
    end,
  inf_le_right :=
    begin
      intros a b, intros x Hx, from Hx.right
    end,
  le_inf :=
    begin
      intros a b c H₁ H₂, intros x Hx, split; solve_by_elim
    end,
  ..regular_open_poset}
local attribute [instance] regular_open_lattice

def regular_open_bounded_lattice : bounded_lattice (regular_opens α) :=
{  top := ⟨set.univ, is_regular_univ⟩,
  le_top := by tidy,
  bot := ⟨∅, is_regular_empty⟩,
  bot_le := by tidy,
 .. regular_open_lattice}

local attribute [instance] regular_open_bounded_lattice

lemma coe_bot : ((⊥ : regular_opens α) : set α) = ∅ := by refl

def regular_open.neg : (regular_opens α) → (regular_opens α) := λ x, ⟨xᵖ, by {rw[regular_iff_p_p], symmetry, apply p_eq_p_p_p,
                       from is_open_of_is_regular x.property}⟩

def regular_open_has_neg : has_neg (regular_opens α) :=
⟨regular_open.neg⟩
local attribute [instance] regular_open_has_neg

def regular_open.Sup : set (regular_opens α) → (regular_opens α) :=
λ 𝒮, ⟨⋃₀(subtype.val '' 𝒮)ᵖᵖ, is_regular_p_p⟩

def regular_open_has_Sup : has_Sup (regular_opens α) :=
⟨regular_open.Sup⟩
local attribute [instance] regular_open_has_Sup

lemma Sup_unfold {𝒜 : set (regular_opens α)} : Sup 𝒜 = regular_open.Sup 𝒜 := rfl

lemma regular_open_le_Sup :
  ∀ (s : set (regular_opens α)) (a : {S // is_regular S}), a ∈ s → a ≤ has_Sup.Sup s :=
begin
  intros s a Ha, intros x Hx, unfold has_Sup.Sup regular_open.Sup,
  simp, suffices : x ∈ (⋃ (x : {S // is_regular S}) (H : x ∈ s), x.val),
  apply subset_int_cl_of_open, {apply is_open_Union, intros, apply is_open_Union,
  intros, from is_open_of_is_regular i.property},
  simp, use a, tidy, recover
end

lemma regular_open_Sup_le :
∀ (s : set (regular_opens α)) (a : {S // is_regular S}),
    (∀ (b : {S // is_regular S}), b ∈ s → b ≤ a) → has_Sup.Sup s ≤ a :=
begin
  intros 𝒜 A H,
    unfold has_Sup.Sup regular_open_has_Sup regular_open.Sup, simp,
    suffices : (⋃ (x : {S // is_regular S}) (H : x ∈ 𝒜), x.val)ᵖᵖ ⊆ A.val,
      by tidy,
    apply is_regular_stable_subset, from A.property, tidy
end

lemma perp_self_empty {S : set α} : S ∩ (Sᵖ) = ∅ :=
by tidy

lemma inf_unfold {x₁ x₂ : (regular_opens α)} : (x₁ ⊓ x₂) = ⟨x₁.val ∩ x₂.val, is_regular_inter x₁.property x₂.property⟩ :=
by refl
local attribute [simp, priority 0] inf_unfold

lemma neg_unfold {x : (regular_opens α)} : (- x) = ⟨xᵖ, by {rw[regular_iff_p_p], symmetry, apply p_eq_p_p_p,
                       from is_open_of_is_regular x.property}⟩ := by refl

local attribute [simp, priority 0] neg_unfold

@[simp]lemma neg_neg_eq_self {x : (regular_opens α)} : - - x = x :=
begin
  simp, apply subtype.eq, simp, apply is_regular_eq_p_p, from x.property
end
local attribute [simp] neg_neg_eq_self

lemma sup_unfold {x₁ x₂ : (regular_opens α)} :
  (x₁ ⊔ x₂) = ⟨(x₁.val ∪ x₂.val)ᵖᵖ, by {apply is_regular_sup}⟩ := by refl
local attribute [simp, priority 0] sup_unfold

lemma top_unfold : (⊤ : (regular_opens α)).val = set.univ := rfl
local attribute [simp, priority 0] top_unfold

lemma regular_open_inf_neg_eq_bot : ∀ (x : (regular_opens α)), x ⊓ -x = ⊥ :=
by {tidy, suffices : x_val ∩ (x_valᵖ) = (⊥ : (regular_opens α)).val, apply subtype.eq,
   from this, from perp_self_empty}

lemma regular_open_sup_neg_eq_top : ∀ (x : (regular_opens α)), x ⊔ -x = ⊤ :=
begin
  intro x, apply subtype.eq, simp, ext, split; intros, trivial,
    tidy, unfold is_regular at x_property, rw[<-x_property] at a_1,
    suffices : cl x_val ∪ - x_val = univ,
      {rw[this] at a_1, apply a_1, simp},
    tidy, by_cases x ∈ x_val,
      left, from subset_closure h,
      right, from ‹_›
end

def regular_open_boolean_algebra : boolean_algebra (regular_opens α) :=
{le_sup_inf :=
    begin
      intros x y z,
        intros a Ha, simp only [inf_unfold, sup_unfold] at Ha ⊢,
        rw[<-p_p_inter_eq_inter_p_p] at Ha,
        suffices : (x.val ∪ y.val) ∩ (x.val ∪ z.val) ⊆ x.val ∪ y.val ∩ z.val,
          by {apply p_p_mono; from ‹_›},
        simp only [inter_distrib_left, inter_distrib_right],
        tactic.rotate 1,
        from is_open_union (is_open_of_is_regular x.property) (is_open_of_is_regular y.property),
        from is_open_union (is_open_of_is_regular x.property) (is_open_of_is_regular z.property),
        /- `tidy` says -/ intros a_1 a_2, cases a_2, cases z, cases y, cases x,
        work_on_goal 0 { cases a_2, work_on_goal 0 { cases a_2, dsimp at *, simp at *,
        cases Ha, cases Ha_h, cases Ha_h_w, cc },
          cases a_2, dsimp at *, simp at *, cases Ha, cases Ha_h, cases Ha_h_w, cc },
        cases a_2, cases z, cases y, cases x,
        work_on_goal 0 { cases a_2, dsimp at *, simp at *, cases Ha, cases Ha_h, cases Ha_h_w, cc },
        cases a_2, cases z, cases y, cases x, dsimp at *, simp at *,
        cases Ha, cases Ha_h, cases Ha_h_w, cc
    end,
  sub := λ A B, A ⊓ (-B),
  inf_neg_eq_bot := regular_open_inf_neg_eq_bot,
  sup_neg_eq_top := regular_open_sup_neg_eq_top,
  sub_eq := by {intros x y, refl},
  .. regular_open_has_neg,
  .. regular_open_bounded_lattice
}

local attribute [instance] regular_open_boolean_algebra

def regular_open_has_Inf : has_Inf (regular_opens α) :=
{ Inf := λ 𝒮, ⟨regular_open.neg ((Sup) ((λ x : (regular_opens α), -x) '' 𝒮)),
begin
  rw[regular_iff_p_p], change (_)ᵖᵖᵖ = (_)ᵖ, symmetry,
      apply p_eq_p_p_p, rw[Sup_unfold], simp[regular_open.Sup]
end⟩ }
local attribute [instance] regular_open_has_Inf

include α
@[simp]lemma Inf_unfold : ∀ s : set (regular_opens α), Inf s = - Sup ((λ x, - x) '' s) :=
by tidy

lemma regular_open_Inf_le : ∀s : set (regular_opens α), ∀a ∈ s, Inf s ≤ a :=
begin
  intros 𝒜 A H_mem,
  rw[show A = - - A, from (lattice.neg_neg).symm],
  have := lattice.neg_le_neg _,
  convert this, apply regular_open_le_Sup, use A, tidy
end

lemma regular_open_le_Inf : ∀(s : set (regular_opens α)) a, (∀b∈s, a ≤ b) → a ≤ Inf s :=
begin
  intros 𝒜 A H_mme, rw[show A = - - A, from (lattice.neg_neg).symm],
  rw[Inf_unfold], apply lattice.neg_le_neg _,
  have := regular_open_Sup_le _ _ _,
  convert this, intros, specialize H_mme (-b),
  simp[-neg_unfold] at a,
  rcases a with ⟨w,⟨h₁,⟨h₂,h₃⟩⟩⟩,
    suffices : A ≤ -b,
      replace this := lattice.neg_le_neg this,
      convert this, symmetry, apply neg_neg_eq_self,
      replace h₃ := (congr_arg (λ x, - x) h₃).symm,
      dsimp at h₃, simp only [h₃] at *,
      apply H_mme, simp*
end

def regular_open_complete_lattice : complete_lattice (regular_opens α) :=
{le_Sup := regular_open_le_Sup,
  Sup_le := regular_open_Sup_le,
  Inf_le := regular_open_Inf_le,
  le_Inf := regular_open_le_Inf,
  .. regular_open_boolean_algebra,
  .. regular_open_has_Inf,
  .. regular_open_has_Sup,
  .. regular_open_has_neg,
  .. regular_open_bounded_lattice}

local attribute [instance] regular_open_complete_lattice

lemma regular_open_inf_Sup_le_supr_inf : ∀(a : (regular_opens α)) s, a ⊓ Sup s ≤ (⨆ b ∈ s, a ⊓ b) :=
begin
  letI : complete_lattice (regular_opens α) := by apply_instance,
  intros A 𝒜, rw[inf_comm], rw[deduction], let X := _, change _ ≤ X, have := Sup_le, show Type u_1, from (regular_opens α),
  show complete_lattice _, dsimp, apply_instance, dsimp at this,
  tactic.rotate 2, from X, apply this, dsimp[X], intros B H_B, rw[<-deduction],
  rw[inf_comm], have := le_supr_of_le, tactic.rotate 1, from (regular_opens α), tactic.rotate 1,
  apply_instance, from λ (b : subtype is_regular), ⨆(H : b ∈ 𝒜), A ⊓ b, from A ⊓ B,
  specialize this B, apply this, have := @le_supr_of_le (regular_opens α) (B ∈ 𝒜) _,
  apply this, from ‹_›, apply regular_open_poset.le_refl
end

lemma shift_neg_right {a b : (regular_opens α)} (h : a = -b) : -a = b :=
by {rw[h], from lattice.neg_neg}

lemma regular_open_infi_sup_le_sup_Inf : ∀(a : (regular_opens α)) s, (⨅ b ∈ s, a ⊔ b) ≤ a ⊔ Inf s :=
begin
  intros A 𝒜,
  have : A ⊔ Inf 𝒜 = -(-A ⊓ -(Inf 𝒜)),
    by {symmetry, apply shift_neg_right, rw[neg_sup]},
  rw[this], apply' neg_le_neg',
  unfold infi,
  simp only[Inf_unfold], have this₁ := @lattice.neg_neg (regular_opens α) _ _,
  rw[this₁], have this₂ := @lattice.neg_neg (regular_opens α) _ _, rw[this₂],
  have this' := @le_trans (regular_opens α) _,
  have := @regular_open_inf_Sup_le_supr_inf α _ (-A) (has_neg.neg '' 𝒜),
  have this_le := @le_trans (regular_opens α) _, specialize this_le this,
  swap, from Sup
      (has_neg.neg '' range (λ (b : {S // is_regular S}), -Sup (has_neg.neg '' range (λ (H : b ∈ 𝒜), A ⊔ b)))),
  rw[inf_comm], rw[deduction], have := @Sup_le (regular_opens α) _ (has_neg.neg '' 𝒜),
  let X := _, change _ ≤ X, specialize @this X, apply this, intros b Hb, dsimp[X], rw[<-deduction, inf_comm],
  clear this_le, simp only [mem_image] at Hb, cases Hb with b' Hb', rcases Hb' with ⟨H'', ⟨Hb''₁, Hb''₂⟩⟩,
  change -A ⊓ -(b') ≤ _,
  have : -A ⊓ (-b') = -(A ⊔ b'), by {rw[<-neg_sup]}, rw[this],
  have := @le_Sup (regular_opens α) _ (has_neg.neg '' range (λ (b : subtype is_regular), -Sup (has_neg.neg '' range (λ (H : b ∈ 𝒜), A ⊔ b)))),
  apply this, simp only [mem_image],
  use (A ⊔ b'), split, apply mem_range.mpr,
  use b', apply shift_neg_right, clear this,
  refine le_antisymm _ _, apply' Sup_le,
  intros b'' Hb'',
  simp at Hb'', rcases Hb'' with ⟨w, ⟨⟨Hw₁, Hw₂⟩, ⟨Hw₃, Hw₄⟩⟩⟩,
    rw[<-Hw₄], replace Hw₂ := (congr_arg perp Hw₂).symm,
    simp only [Hw₂], apply le_of_eq _, refl,

  apply' le_Sup, simp only [mem_range, mem_image], use (A ⊔ b'), use H'',
  refl, refl
end

def regular_open_algebra [H_nonempty : nonempty α] :
  nontrivial_complete_boolean_algebra (regular_opens α) :=
{infi_sup_le_sup_Inf := regular_open_infi_sup_le_sup_Inf,
  inf_Sup_le_supr_inf := regular_open_inf_Sup_le_supr_inf,
  bot_lt_top :=
    by {apply lt_iff_le_and_ne.mpr, split,
       have := regular_open_bounded_lattice.bot_le, specialize this ⊤,
       from this, intro H, simp[subtype.ext] at H,
       change (∅ : set α) = univ at H, tactic.unfreeze_local_instances,
       cases H_nonempty, suffices : H_nonempty ∈ (∅ : set α), by {cases this}, simp[H]},
  .. regular_open_boolean_algebra,
  ..regular_open_complete_lattice
  }

lemma p_p_eq_univ_of_dense {S : set α} (H_dense : dense S) : Sᵖᵖ = univ :=
by simp only [perp_unfold, closure_univ_of_dense H_dense,
               set.compl_univ, closure_empty, set.compl_empty]

lemma p_p_eq_univ_of_rel_dense_of_open {S₀ : set α} {S : set α} (H_open : is_open S₀) (H_rel_dense : rel_dense S₀ S) : S₀ ∩ Sᵖᵖ = S₀ :=
begin
  simp [perp_unfold], have := closure_rel_dense_of_open H_open H_rel_dense,
  have : S₀ = int S₀, by simp*, {[smt] eblast_using [interior_inter]}
end

lemma Sup_eq_top_of_dense_Union {ι} {rO : ι → regular_opens α}
  (H_dense : dense $ ⋃₀(subtype.val '' range (λ (i : ι), rO i)))
  : (⨆i, rO i : regular_opens α) = ⊤ :=
by {change Sup _ = _, rw[Sup_unfold], exact subtype.ext.mpr (p_p_eq_univ_of_dense ‹_›)}

lemma Sup_eq_top_of_dense_Union_rel {ι} {rO : ι → regular_opens α} (S : regular_opens α)
  (H_dense : rel_dense S.1 $ ⋃₀(subtype.val '' range (λ (i : ι), rO i)))
  : ((⨆i, rO i : regular_opens α) ⊓ S = S) :=
begin
  {change (Sup _) ⊓ _ = _, rw Sup_unfold, have := (p_p_eq_univ_of_rel_dense_of_open (is_open_of_is_regular S.property) ‹_›), rw inter_comm at this, exact subtype.ext.mpr this}
end

open cardinal function
local attribute [instance, priority 0] subtype.preorder

lemma CCC_regular_opens (h : countable_chain_condition α) : CCC (regular_opens α) :=
begin
  intros β O hO h2O,
  have O_inj : injective (subtype.val ∘ O),
  { apply injective_comp subtype.val_injective, intros x y hxy,
    by_contra, apply not_le_of_gt (hO y),
    have := h2O _ _ a, rwa [hxy, inf_self] at this },
  have := h (range (subtype.val ∘ O)) _ _,
  rw [countable_iff] at this, convert this using 1,
  { rw [mk_range_eq], exact O_inj },
  { rintro _ ⟨x, rfl⟩, exact is_open_of_is_regular (O x).2 },
  { rintro _ ⟨x, rfl⟩ _ ⟨y, rfl⟩ hxy,
    have : x ≠ y, { intro h, apply hxy, exact congr_arg (subtype.val ∘ O) h },
    rw [disjoint_iff_eq_empty], refine subset.antisymm _ (empty_subset _), exact h2O _ _ this }
end

local attribute [instance, priority 10] regular_open_algebra
lemma regular_open.bot_lt [nonempty α] {o : regular_opens α} : ⊥ < o ↔ ∃x, x ∈ (o : set α) :=
by { refine bot_lt_iff_ne_bot.trans _,
    rw [← set.ne_empty_iff_exists_mem], rw [← subtype.val_injective.ne_iff], refl }

lemma fst_Sup [nonempty α] {f : set (regular_opens α)} : ↑(Sup f) = (Sup (subtype.val '' f))ᵖᵖ :=
by refl

lemma fst_supr [nonempty α] {ι} {f : ι → regular_opens α} : ↑(⨆ i, f i) = (⨆ i, (f i).1)ᵖᵖ :=
by { rw [supr, fst_Sup], congr' 3, rw [range_comp] }

lemma fst_Inf [nonempty α] {f : set (regular_opens α)} : ↑(Inf f) = (Inf (subtype.val '' f))ᵖᵖ :=
begin
  rw [Inf_unfold, neg_unfold], dsimp,
  rw [fst_Sup, ← p_eq_p_p_p, image_image],
  { refine eq.trans _ (perp_sUnion_perp _),
    { rw [image_image], refl },
    intros s hs, rw [mem_image] at hs, rcases hs with ⟨t, ht, rfl⟩, exact t.2 },
  apply _root_.is_open_sUnion,
  intros t ht, rw [mem_image] at ht, rcases ht with ⟨t, ht, rfl⟩, exact is_open_of_is_regular t.2
end

lemma fst_infi [nonempty α] {ι} {f : ι → regular_opens α} : ↑(⨅ i, f i) = (⨅ i, (f i).1)ᵖᵖ :=
by { rw [infi, fst_Inf], congr' 3, rw [range_comp] }

lemma fst_infi' [nonempty α] {ι} {f : ι → regular_opens α} : (⨅ i, f i).1 = (⨅ i, (f i).1)ᵖᵖ :=
by { convert fst_infi, from ‹_› }

-- lemma fst_infi' [nonempty α] {ι} {f : ι → regular_opens α} : ↑(⨅ i, f i) = int (⨅ i, (f i).1) :=
-- sorry

end regular_algebra


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Scott Morrison

@[simp]
lemma add_left_cancel_iff' (a b : ℕ) : a + b = a ↔ b = 0 :=
@add_left_cancel_iff _ _ a b 0

@[simp]
lemma add_right_cancel_iff' (a b : ℕ) : a + b = b ↔ a = 0 :=
begin
  note h := @add_right_cancel_iff _ _ b a 0,
  simp at h,
  exact h
end

@[simp] lemma f ( α : Type ) [ i : inhabited α ] ( p : Prop ) : (α → p) ↔ p := sorry

definition e : { n : ℕ // (∀ f : ℕ, n + f = f) ∧ (∀ f : ℕ, f + n = f) } :=
begin
  simp,
  exact ⟨ 0, rfl ⟩
end


import GMLInit.Data.BEq
import GMLInit.Data.Array.Basic

structure KeyedArray {α : Type _} [BEq α] (β : Type _) (p : β → α) extends Array β where
  uniq (i j : Fin toArray.size) : (p (toArray.get i) == p (toArray.get j)) = (i.val == j.val)

namespace KeyedArray
variable {α} [BEq α] {β} {p : β → α} (a : KeyedArray β p)

theorem uniq' {i j} (hi : i < a.size) (hj : j < a.size) : (p a.toArray[i] == p a.toArray[j]) = (i == j) := by
  rw [←a.toArray.get_eq_getElem ⟨i, hi⟩]
  rw [←a.toArray.get_eq_getElem ⟨j, hj⟩]
  rw [a.uniq]

def empty : KeyedArray β p where
  toArray := #[]
  uniq := (nomatch .)

def locate? (key : α) : Option (Fin a.size) :=
  Fin.find? fun i => p (a.get i) == key

theorem locate?_some (key : α) (i : Fin a.size) : a.locate? key = some i → p (a.get i) == key := by
  intro h; rw [Fin.find?_some i h]

theorem locate?_none (key : α) (i : Fin a.size) : a.locate? key = none → p (a.get i) != key := by
  intro h; rw [bne, Fin.find?_none i h]; rfl

theorem locate?_some_iff [EquivBEq α] (key : α) (i : Fin a.size) : a.locate? key = some i ↔ p (a.get i) == key := by
  constr
  · exact locate?_some a key i
  · intro h
    match hloc : a.locate? key with
    | some j =>
      have := a.locate?_some key j hloc
      rw [BEq.subst_right (BEq.symm h)] at this
      rw [a.uniq] at this
      congr
      apply Fin.eq_of_val_eq
      exact eq_of_beq this
    | none =>
      have := a.locate?_none key i hloc
      rw [bne, h] at this
      contradiction

def find? (key : α) : Option β :=
  match a.locate? key with
  | none => none
  | some i => some (a.get i)

theorem find?_some (key : α) (value : β) : a.find? key = some value → p value == key := by
  intro h
  simp only [find?] at h
  split at h
  next => contradiction
  next heq =>
    injection h with h
    cases h
    apply locate?_some
    exact heq

def replace [EquivBEq α] (value : β) : KeyedArray β p where
  toArray :=
    match a.locate? (p value) with
    | some k => a.set k value
    | none => a.toArray
  uniq :=
    match hk : a.locate? (p value) with
    | some k => fun
      | ⟨i, (hi : i < (a.set k value).size)⟩,
        ⟨j, (hj : j < (a.set k value).size)⟩ => by
        have seq : (a.set k value).size = a.size := Array.size_set ..
        let hi' : i < a.size := seq ▸ hi
        let hj' : j < a.size := seq ▸ hj
        simp only [Array.get_eq_getElem]
        have heqi : p ((a.set k value)[i]) == p a.toArray[i] := by
          by_cases k.val = i with
          | isTrue h =>
            rw [Array.get_set a.toArray k i hi', if_pos h]
            symmetry using (.==.)
            apply locate?_some
            rw [hk]
            congr
            apply Fin.eq_of_val_eq
            exact h
          | isFalse h =>
            rw [Array.get_set a.toArray k i hi', if_neg h]
            exact BEq.refl ..
        have heqj : p ((a.set k value)[j]) == p a.toArray[j] := by
          by_cases k.val = j with
          | isTrue h =>
            rw [Array.get_set a.toArray k j hj', if_pos h]
            symmetry using (.==.)
            apply locate?_some
            rw [hk]
            congr
            apply Fin.eq_of_val_eq
            exact h
          | isFalse h =>
            rw [Array.get_set a.toArray k j hj', if_neg h]
            exact BEq.refl ..
        rw [BEq.subst_left heqi, BEq.subst_right heqj]
        rw [←a.get_eq_getElem ⟨i,hi'⟩, ←a.get_eq_getElem ⟨j,hj'⟩]
        exact a.uniq ..
    | none => a.uniq

def insert [EquivBEq α] (value : β) : KeyedArray β p where
  toArray :=
    match a.locate? (p value) with
    | some k => a.set k value
    | none => a.toArray.push value
  uniq :=
    match hk : a.locate? (p value) with
    | some k => fun
      | ⟨i, (hi : i < (a.set k value).size)⟩,
        ⟨j, (hj : j < (a.set k value).size)⟩ => by
        have seq : (a.set k value).size = a.size := Array.size_set ..
        have hi' : i < a.size := seq ▸ hi
        have hj' : j < a.size := seq ▸ hj
        simp only [Array.get_eq_getElem]
        have heqi : p ((a.set k value)[i]) == p a.toArray[i] := by
          by_cases k.val = i with
          | isTrue h =>
            rw [a.toArray.get_set k i hi', if_pos h]
            symmetry using (.==.)
            apply locate?_some
            rw [hk]
            congr
            apply Fin.eq_of_val_eq
            exact h
          | isFalse h =>
            rw [a.toArray.get_set k i hi', if_neg h]
            exact BEq.refl ..
        have heqj : p ((a.set k value)[j]) == p a.toArray[j] := by
          by_cases k.val = j with
          | isTrue h =>
            rw [a.toArray.get_set k j hj', if_pos h]
            symmetry using (.==.)
            apply locate?_some
            rw [hk]
            congr
            apply Fin.eq_of_val_eq
            exact h
          | isFalse h =>
            rw [Array.get_set a.toArray k j hj', if_neg h]
            exact BEq.refl ..
        rw [BEq.subst_left heqi, BEq.subst_right heqj]
        rw [←a.get_eq_getElem ⟨i,hi'⟩, ←a.get_eq_getElem ⟨j,hj'⟩]
        exact a.uniq ..
    | none => fun
      | ⟨i, (hi : i < (a.push value).size)⟩,
        ⟨j, (hj : j < (a.push value).size)⟩ => by
        simp only [Array.get_eq_getElem]
        have hsz : (a.push value).size = a.size + 1 := Array.size_push ..
        by_cases i = a.size, j = a.size with
        | isTrue heqi, isTrue heqj => simp only [heqi, heqj, BEq.refl]
        | isTrue heqi, isFalse hnej =>
          simp [heqi]
          rw [Bool.eq_iff_iff]
          constr
          · intro h
            have h := BEq.symm h
            have hj' : j < a.size := by
              rw [hsz] at hj
              apply Nat.lt_of_le_of_ne
              · exact Nat.le_of_lt_succ hj
              · exact hnej
            rw [a.toArray.get_push_lt _ j hj'] at h
            rw [←a.toArray.get_eq_getElem ⟨j,hj'⟩] at h
            have h' := locate?_none a (p value) ⟨j, hj'⟩ hk
            rw [bne, h] at h'
            contradiction
          · intro h
            rw [BEq.eq_of_beq h] at hnej
            contradiction
        | isFalse hnei, isTrue heqj =>
          simp [heqj]
          rw [Bool.eq_iff_iff]
          constr
          · intro h
            have hi' : i < a.size := by
              rw [hsz] at hi
              apply Nat.lt_of_le_of_ne
              · exact Nat.le_of_lt_succ hi
              · exact hnei
            rw [a.toArray.get_push_lt _ i hi'] at h
            rw [←a.toArray.get_eq_getElem ⟨i,hi'⟩] at h
            have h' := locate?_none a (p value) ⟨i,hi'⟩ hk
            rw [bne, h] at h'
            contradiction
          · intro h
            rw [BEq.eq_of_beq h] at hnei
            contradiction
        | isFalse hnei, isFalse hnej =>
          have hi' : i < a.size := by
            rw [hsz] at hi
            apply Nat.lt_of_le_of_ne
            · exact Nat.le_of_lt_succ hi
            · exact hnei
          have hj' : j < a.size := by
            rw [hsz] at hj
            apply Nat.lt_of_le_of_ne
            · exact Nat.le_of_lt_succ hj
            · exact hnej
          rw [a.toArray.get_push_lt _ i hi']
          rw [a.toArray.get_push_lt _ j hj']
          exact a.uniq ..

theorem find?_insert [EquivBEq α] (value : β) : (a.insert value).find? (p value) = some value := sorry

theorem find?_insert_bne [EquivBEq α] {key : α} {value : β} : key != p value → (a.insert value).find? key = a.find? key := sorry

def erase [EquivBEq α] (key : α) : KeyedArray β p where
  toArray :=
    match a.locate? key with
    | none => a.toArray
    | some k => a.del k
  uniq :=
    match a.locate? key with
    | none => a.uniq
    | some k => fun
      | ⟨i, (hi : i < (a.del k).size)⟩,
        ⟨j, (hj : j < (a.del k).size)⟩ => by
        by_cases k.val = i, k.val = j with
        | isTrue hik, isTrue hjk =>
          simp [←hik, ←hjk]
          exact BEq.refl ..
        | isTrue hik, isFalse hjk =>
          simp [←hik]
          rw [a.toArray.get_del, if_pos rfl]
          rw [a.toArray.get_del, if_neg hjk]
          rw [a.uniq']
          match hj': a.size-1 == j, hjk': k.val == j with
          | true, true => rfl
          | true, false => absurd hj; rw [Array.size_del, BEq.eq_of_beq hj']; irreflexivity
          | false, true => absurd hjk; exact BEq.eq_of_beq hjk'
          | false, false => rfl
        | isFalse hik, isTrue hjk =>
          simp [←hjk]
          rw [a.toArray.get_del, if_neg hik]
          rw [a.toArray.get_del, if_pos rfl]
          rw [a.uniq']
          match hi': i == a.size-1, hik': i == k.val with
          | true, true => rfl
          | true, false => absurd hi; rw [Array.size_del, BEq.eq_of_beq hi']; irreflexivity
          | false, true => absurd hik; symmetry; exact BEq.eq_of_beq hik'
          | false, false => rfl
        | isFalse hik, isFalse hjk =>
          simp
          rw [a.toArray.get_del, if_neg hik]
          rw [a.toArray.get_del, if_neg hjk]
          rw [a.uniq']

theorem find?_erase [EquivBEq α] (key : α) : (a.erase key).find? key = none := sorry

theorem find?_erase_bne [EquivBEq α] {key k : α} : k != key → (a.erase key).find? k = a.find? k := sorry

end KeyedArray


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.calculus.inverse
import Mathlib.analysis.normed_space.complemented
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 l

namespace Mathlib

/-!
# Implicit function theorem

We prove three versions of the implicit function theorem. First we define a structure
`implicit_function_data` that holds arguments for the most general version of the implicit function
theorem, see `implicit_function_data.implicit_function`
and `implicit_function_data.to_implicit_function`. This version allows a user to choose
a specific implicit function but provides only a little convenience over the inverse function
theorem.

Then we define `implicit_function_of_complemented`: implicit function defined by `f (g z y) = z`,
where `f : E → F` is a function strictly differentiable at `a` such that its derivative `f'`
is surjective and has a `complemented` kernel.

Finally, if the codomain of `f` is a finite dimensional space, then we can automatically prove
that the kernel of `f'` is complemented, hence the only assumptions are `has_strict_fderiv_at`
and `f'.range = ⊤`. This version is named `implicit_function`.

## TODO

* Add a version for a function `f : E × F → G` such that $$\frac{\partial f}{\partial y}$$ is
  invertible.
* Add a version for `f : 𝕜 × 𝕜 → 𝕜` proving `has_strict_deriv_at` and `deriv φ = ...`.
* Prove that in a real vector space the implicit function has the same smoothness as the original
  one.
* If the original function is differentiable in a neighborhood, then the implicit function is
  differentiable in a neighborhood as well. Current setup only proves differentiability at one
  point for the implicit function constructed in this file (as opposed to an unspecified implicit
  function). One of the ways to overcome this difficulty is to use uniqueness of the implicit
  function in the general version of the theorem. Another way is to prove that *any* implicit
  function satisfying some predicate is strictly differentiable.

## Tags

implicit function, inverse function
-/

/-!
### General version

Consider two functions `f : E → F` and `g : E → G` and a point `a` such that

* both functions are strictly differentiable at `a`;
* the derivatives are surjective;
* the kernels of the derivatives are complementary subspaces of `E`.

Note that the map `x ↦ (f x, g x)` has a bijective derivative, hence it is a local homeomorphism
between `E` and `F × G`. We use this fact to define a function `φ : F → G → E`
(see `implicit_function_data.implicit_function`) such that for `(y, z)` close enough to `(f a, g a)`
we have `f (φ y z) = y` and `g (φ y z) = z`.

We also prove a formula for $$\frac{\partial\varphi}{\partial z}.$$

Though this statement is almost symmetric with respect to `F`, `G`, we interpret it in the following
way. Consider a family of surfaces `{x | f x = y}`, `y ∈ 𝓝 (f a)`. Each of these surfaces is
parametrized by `φ y`.

There are many ways to choose a (differentiable) function `φ` such that `f (φ y z) = y` but the
extra condition `g (φ y z) = z` allows a user to select one of these functions. If we imagine
that the level surfaces `f = const` form a local horizontal foliation, then the choice of
`g` fixes a transverse foliation `g = const`, and `φ` is the inverse function of the projection
of `{x | f x = y}` along this transverse foliation.

This version of the theorem is used to prove the other versions and can be used if a user
needs to have a complete control over the choice of the implicit function.
-/

/-- Data for the general version of the implicit function theorem. It holds two functions
`f : E → F` and `g : E → G` (named `left_fun` and `right_fun`) and a point `a` (named `pt`)
such that

* both functions are strictly differentiable at `a`;
* the derivatives are surjective;
* the kernels of the derivatives are complementary subspaces of `E`. -/
structure implicit_function_data (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2)
    [normed_group E] [normed_space 𝕜 E] [complete_space E] (F : Type u_3) [normed_group F]
    [normed_space 𝕜 F] [complete_space F] (G : Type u_4) [normed_group G] [normed_space 𝕜 G]
    [complete_space G]
    where
  left_fun : E → F
  left_deriv : continuous_linear_map 𝕜 E F
  right_fun : E → G
  right_deriv : continuous_linear_map 𝕜 E G
  pt : E
  left_has_deriv : has_strict_fderiv_at left_fun left_deriv pt
  right_has_deriv : has_strict_fderiv_at right_fun right_deriv pt
  left_range : continuous_linear_map.range left_deriv = ⊤
  right_range : continuous_linear_map.range right_deriv = ⊤
  is_compl_ker :
    is_compl (continuous_linear_map.ker left_deriv) (continuous_linear_map.ker right_deriv)

namespace implicit_function_data

/-- The function given by `x ↦ (left_fun x, right_fun x)`. -/
def prod_fun {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E]
    [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F]
    [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G] [complete_space G]
    (φ : implicit_function_data 𝕜 E F G) (x : E) : F × G :=
  (left_fun φ x, right_fun φ x)

@[simp] theorem prod_fun_apply {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space G] (φ : implicit_function_data 𝕜 E F G) (x : E) :
    prod_fun φ x = (left_fun φ x, right_fun φ x) :=
  rfl

protected theorem has_strict_fderiv_at {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space G] (φ : implicit_function_data 𝕜 E F G) :
    has_strict_fderiv_at (prod_fun φ)
        (↑(continuous_linear_map.equiv_prod_of_surjective_of_is_compl (left_deriv φ) (right_deriv φ)
            (left_range φ) (right_range φ) (is_compl_ker φ)))
        (pt φ) :=
  has_strict_fderiv_at.prod (left_has_deriv φ) (right_has_deriv φ)

/-- Implicit function theorem. If `f : E → F` and `g : E → G` are two maps strictly differentiable
at `a`, their derivatives `f'`, `g'` are surjective, and the kernels of these derivatives are
complementary subspaces of `E`, then `x ↦ (f x, g x)` defines a local homeomorphism between
`E` and `F × G`. In particular, `{x | f x = f a}` is locally homeomorphic to `G`. -/
def to_local_homeomorph {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E]
    [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F]
    [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G] [complete_space G]
    (φ : implicit_function_data 𝕜 E F G) : local_homeomorph E (F × G) :=
  has_strict_fderiv_at.to_local_homeomorph (prod_fun φ)
    (implicit_function_data.has_strict_fderiv_at φ)

/-- Implicit function theorem. If `f : E → F` and `g : E → G` are two maps strictly differentiable
at `a`, their derivatives `f'`, `g'` are surjective, and the kernels of these derivatives are
complementary subspaces of `E`, then `implicit_function_of_is_compl_ker` is the unique (germ of a)
map `φ : F → G → E` such that `f (φ y z) = y` and `g (φ y z) = z`. -/
def implicit_function {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E]
    [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F]
    [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G] [complete_space G]
    (φ : implicit_function_data 𝕜 E F G) : F → G → E :=
  function.curry ⇑(local_homeomorph.symm (to_local_homeomorph φ))

@[simp] theorem to_local_homeomorph_coe {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space G] (φ : implicit_function_data 𝕜 E F G) :
    ⇑(to_local_homeomorph φ) = prod_fun φ :=
  rfl

theorem to_local_homeomorph_apply {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space G] (φ : implicit_function_data 𝕜 E F G) (x : E) :
    coe_fn (to_local_homeomorph φ) x = (left_fun φ x, right_fun φ x) :=
  rfl

theorem pt_mem_to_local_homeomorph_source {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space G] (φ : implicit_function_data 𝕜 E F G) :
    pt φ ∈ local_equiv.source (local_homeomorph.to_local_equiv (to_local_homeomorph φ)) :=
  has_strict_fderiv_at.mem_to_local_homeomorph_source
    (implicit_function_data.has_strict_fderiv_at φ)

theorem map_pt_mem_to_local_homeomorph_target {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G]
    [normed_space 𝕜 G] [complete_space G] (φ : implicit_function_data 𝕜 E F G) :
    (left_fun φ (pt φ), right_fun φ (pt φ)) ∈
        local_equiv.target (local_homeomorph.to_local_equiv (to_local_homeomorph φ)) :=
  local_homeomorph.map_source (to_local_homeomorph φ) (pt_mem_to_local_homeomorph_source φ)

theorem prod_map_implicit_function {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space G] (φ : implicit_function_data 𝕜 E F G) :
    filter.eventually
        (fun (p : F × G) => prod_fun φ (implicit_function φ (prod.fst p) (prod.snd p)) = p)
        (nhds (prod_fun φ (pt φ))) :=
  sorry

theorem left_map_implicit_function {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space G] (φ : implicit_function_data 𝕜 E F G) :
    filter.eventually
        (fun (p : F × G) => left_fun φ (implicit_function φ (prod.fst p) (prod.snd p)) = prod.fst p)
        (nhds (prod_fun φ (pt φ))) :=
  filter.eventually.mono (prod_map_implicit_function φ) fun (z : F × G) => congr_arg prod.fst

theorem right_map_implicit_function {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space G] (φ : implicit_function_data 𝕜 E F G) :
    filter.eventually
        (fun (p : F × G) =>
          right_fun φ (implicit_function φ (prod.fst p) (prod.snd p)) = prod.snd p)
        (nhds (prod_fun φ (pt φ))) :=
  filter.eventually.mono (prod_map_implicit_function φ) fun (z : F × G) => congr_arg prod.snd

theorem implicit_function_apply_image {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space G] (φ : implicit_function_data 𝕜 E F G) :
    filter.eventually (fun (x : E) => implicit_function φ (left_fun φ x) (right_fun φ x) = x)
        (nhds (pt φ)) :=
  has_strict_fderiv_at.eventually_left_inverse (implicit_function_data.has_strict_fderiv_at φ)

theorem implicit_function_has_strict_fderiv_at {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [complete_space F] {G : Type u_4} [normed_group G]
    [normed_space 𝕜 G] [complete_space G] (φ : implicit_function_data 𝕜 E F G)
    (g'inv : continuous_linear_map 𝕜 G E)
    (hg'inv : continuous_linear_map.comp (right_deriv φ) g'inv = continuous_linear_map.id 𝕜 G)
    (hg'invf : continuous_linear_map.comp (left_deriv φ) g'inv = 0) :
    has_strict_fderiv_at (implicit_function φ (left_fun φ (pt φ))) g'inv (right_fun φ (pt φ)) :=
  sorry

end implicit_function_data

namespace has_strict_fderiv_at

/-!
### Case of a complemented kernel

In this section we prove the following version of the implicit function theorem. Consider a map
`f : E → F` and a point `a : E` such that `f` is strictly differentiable at `a`, its derivative `f'`
is surjective and the kernel of `f'` is a complemented subspace of `E` (i.e., it has a closed
complementary subspace). Then there exists a function `φ : F → ker f' → E` such that for `(y, z)`
close to `(f a, 0)` we have `f (φ y z) = y` and the derivative of `φ (f a)` at zero is the
embedding `ker f' → E`.

Note that a map with these properties is not unique. E.g., different choices of a subspace
complementary to `ker f'` lead to different maps `φ`.
-/

/-- Data used to apply the generic implicit function theorem to the case of a strictly
differentiable map such that its derivative is surjective and has a complemented kernel. -/
@[simp] def implicit_function_data_of_complemented {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [complete_space F] (f : E → F)
    (f' : continuous_linear_map 𝕜 E F) {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) :
    implicit_function_data 𝕜 E F ↥(continuous_linear_map.ker f') :=
  implicit_function_data.mk f f' (fun (x : E) => coe_fn (classical.some hker) (x - a))
    (classical.some hker) a hf sorry hf' sorry sorry

/-- A local homeomorphism between `E` and `F × f'.ker` sending level surfaces of `f`
to vertical subspaces. -/
def implicit_to_local_homeomorph_of_complemented {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [complete_space F] (f : E → F)
    (f' : continuous_linear_map 𝕜 E F) {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) :
    local_homeomorph E (F × ↥(continuous_linear_map.ker f')) :=
  implicit_function_data.to_local_homeomorph
    (implicit_function_data_of_complemented f f' hf hf' hker)

/-- Implicit function `g` defined by `f (g z y) = z`. -/
def implicit_function_of_complemented {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [complete_space F] (f : E → F) (f' : continuous_linear_map 𝕜 E F) {a : E}
    (hf : has_strict_fderiv_at f f' a) (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) :
    F → ↥(continuous_linear_map.ker f') → E :=
  implicit_function_data.implicit_function (implicit_function_data_of_complemented f f' hf hf' hker)

@[simp] theorem implicit_to_local_homeomorph_of_complemented_fst {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [complete_space F]
    {f : E → F} {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) (x : E) :
    prod.fst (coe_fn (implicit_to_local_homeomorph_of_complemented f f' hf hf' hker) x) = f x :=
  rfl

theorem implicit_to_local_homeomorph_of_complemented_apply {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [complete_space F]
    {f : E → F} {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) (y : E) :
    coe_fn (implicit_to_local_homeomorph_of_complemented f f' hf hf' hker) y =
        (f y, coe_fn (classical.some hker) (y - a)) :=
  rfl

@[simp] theorem implicit_to_local_homeomorph_of_complemented_apply_ker {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [complete_space F]
    {f : E → F} {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f'))
    (y : ↥(continuous_linear_map.ker f')) :
    coe_fn (implicit_to_local_homeomorph_of_complemented f f' hf hf' hker) (↑y + a) =
        (f (↑y + a), y) :=
  sorry

@[simp] theorem implicit_to_local_homeomorph_of_complemented_self {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [complete_space F]
    {f : E → F} {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) :
    coe_fn (implicit_to_local_homeomorph_of_complemented f f' hf hf' hker) a = (f a, 0) :=
  sorry

theorem mem_implicit_to_local_homeomorph_of_complemented_source {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [complete_space F]
    {f : E → F} {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) :
    a ∈
        local_equiv.source
          (local_homeomorph.to_local_equiv
            (implicit_to_local_homeomorph_of_complemented f f' hf hf' hker)) :=
  mem_to_local_homeomorph_source
    (implicit_function_data.has_strict_fderiv_at
      (implicit_function_data_of_complemented f f' hf hf' hker))

theorem mem_implicit_to_local_homeomorph_of_complemented_target {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [complete_space F]
    {f : E → F} {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) :
    (f a, 0) ∈
        local_equiv.target
          (local_homeomorph.to_local_equiv
            (implicit_to_local_homeomorph_of_complemented f f' hf hf' hker)) :=
  sorry

/-- `implicit_function_of_complemented` sends `(z, y)` to a point in `f ⁻¹' z`. -/
theorem map_implicit_function_of_complemented_eq {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [complete_space F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) :
    filter.eventually
        (fun (p : F × ↥(continuous_linear_map.ker f')) =>
          f (implicit_function_of_complemented f f' hf hf' hker (prod.fst p) (prod.snd p)) =
            prod.fst p)
        (nhds (f a, 0)) :=
  sorry

/-- Any point in some neighborhood of `a` can be represented as `implicit_function`
of some point. -/
theorem eq_implicit_function_of_complemented {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [complete_space F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) :
    filter.eventually
        (fun (x : E) =>
          implicit_function_of_complemented f f' hf hf' hker (f x)
              (prod.snd
                (coe_fn (implicit_to_local_homeomorph_of_complemented f f' hf hf' hker) x)) =
            x)
        (nhds a) :=
  implicit_function_data.implicit_function_apply_image
    (implicit_function_data_of_complemented f f' hf hf' hker)

theorem to_implicit_function_of_complemented {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [complete_space F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤)
    (hker : submodule.closed_complemented (continuous_linear_map.ker f')) :
    has_strict_fderiv_at (implicit_function_of_complemented f f' hf hf' hker (f a))
        (continuous_linear_map.subtype_val (continuous_linear_map.ker f')) 0 :=
  sorry

/-!
### Finite dimensional case

In this section we prove the following version of the implicit function theorem. Consider a map
`f : E → F` from a Banach normed space to a finite dimensional space.
Take a point `a : E` such that `f` is strictly differentiable at `a` and its derivative `f'`
is surjective. Then there exists a function `φ : F → ker f' → E` such that for `(y, z)`
close to `(f a, 0)` we have `f (φ y z) = y` and the derivative of `φ (f a)` at zero is the
embedding `ker f' → E`.

This version deduces that `ker f'` is a complemented subspace from the fact that `F` is a finite
dimensional space, then applies the previous version.

Note that a map with these properties is not unique. E.g., different choices of a subspace
complementary to `ker f'` lead to different maps `φ`.
-/

/-- Given a map `f : E → F` to a finite dimensional space with a surjective derivative `f'`,
returns a local homeomorphism between `E` and `F × ker f'`. -/
def implicit_to_local_homeomorph {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] [complete_space 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [finite_dimensional 𝕜 F] (f : E → F)
    (f' : continuous_linear_map 𝕜 E F) {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤) :
    local_homeomorph E (F × ↥(continuous_linear_map.ker f')) :=
  implicit_to_local_homeomorph_of_complemented f f' hf hf' sorry

/-- Implicit function `g` defined by `f (g z y) = z`. -/
def implicit_function {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] [complete_space 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] [finite_dimensional 𝕜 F] (f : E → F) (f' : continuous_linear_map 𝕜 E F)
    {a : E} (hf : has_strict_fderiv_at f f' a) (hf' : continuous_linear_map.range f' = ⊤) :
    F → ↥(continuous_linear_map.ker f') → E :=
  function.curry ⇑(local_homeomorph.symm (implicit_to_local_homeomorph f f' hf hf'))

@[simp] theorem implicit_to_local_homeomorph_fst {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    [complete_space 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E]
    {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [finite_dimensional 𝕜 F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤) (x : E) :
    prod.fst (coe_fn (implicit_to_local_homeomorph f f' hf hf') x) = f x :=
  rfl

@[simp] theorem implicit_to_local_homeomorph_apply_ker {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    [complete_space 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E]
    {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [finite_dimensional 𝕜 F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤) (y : ↥(continuous_linear_map.ker f')) :
    coe_fn (implicit_to_local_homeomorph f f' hf hf') (↑y + a) = (f (↑y + a), y) :=
  implicit_to_local_homeomorph_of_complemented_apply_ker hf hf'
    (implicit_to_local_homeomorph._proof_1 f') y

@[simp] theorem implicit_to_local_homeomorph_self {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    [complete_space 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E]
    {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [finite_dimensional 𝕜 F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤) :
    coe_fn (implicit_to_local_homeomorph f f' hf hf') a = (f a, 0) :=
  implicit_to_local_homeomorph_of_complemented_self hf hf'
    (implicit_to_local_homeomorph._proof_1 f')

theorem mem_implicit_to_local_homeomorph_source {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    [complete_space 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E]
    {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [finite_dimensional 𝕜 F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤) :
    a ∈
        local_equiv.source
          (local_homeomorph.to_local_equiv (implicit_to_local_homeomorph f f' hf hf')) :=
  mem_to_local_homeomorph_source
    (implicit_function_data.has_strict_fderiv_at
      (implicit_function_data_of_complemented f f' hf hf'
        (implicit_to_local_homeomorph._proof_1 f')))

theorem mem_implicit_to_local_homeomorph_target {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    [complete_space 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E]
    {F : Type u_3} [normed_group F] [normed_space 𝕜 F] [finite_dimensional 𝕜 F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤) :
    (f a, 0) ∈
        local_equiv.target
          (local_homeomorph.to_local_equiv (implicit_to_local_homeomorph f f' hf hf')) :=
  mem_implicit_to_local_homeomorph_of_complemented_target hf hf'
    (implicit_to_local_homeomorph._proof_1 f')

/-- `implicit_function` sends `(z, y)` to a point in `f ⁻¹' z`. -/
theorem map_implicit_function_eq {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] [complete_space 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [finite_dimensional 𝕜 F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤) :
    filter.eventually
        (fun (p : F × ↥(continuous_linear_map.ker f')) =>
          f (implicit_function f f' hf hf' (prod.fst p) (prod.snd p)) = prod.fst p)
        (nhds (f a, 0)) :=
  map_implicit_function_of_complemented_eq hf hf' (implicit_to_local_homeomorph._proof_1 f')

/-- Any point in some neighborhood of `a` can be represented as `implicit_function`
of some point. -/
theorem eq_implicit_function {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] [complete_space 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [finite_dimensional 𝕜 F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤) :
    filter.eventually
        (fun (x : E) =>
          implicit_function f f' hf hf' (f x)
              (prod.snd (coe_fn (implicit_to_local_homeomorph f f' hf hf') x)) =
            x)
        (nhds a) :=
  eq_implicit_function_of_complemented hf hf' (implicit_to_local_homeomorph._proof_1 f')

theorem to_implicit_function {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] [complete_space 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [finite_dimensional 𝕜 F] {f : E → F}
    {f' : continuous_linear_map 𝕜 E F} {a : E} (hf : has_strict_fderiv_at f f' a)
    (hf' : continuous_linear_map.range f' = ⊤) :
    has_strict_fderiv_at (implicit_function f f' hf hf' (f a))
        (continuous_linear_map.subtype_val (continuous_linear_map.ker f')) 0 :=
  to_implicit_function_of_complemented hf hf' (implicit_to_local_homeomorph._proof_1 f')

end Mathlib


import SciLean.Core.HilbertDiff
import SciLean.Core.DifferentialDep
import SciLean.Core.Adjoint

namespace SciLean

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

/-- Transitive closure of `HasAdjDiffDepN`
-/
class HasAdjDiffDepNT {X Y : Type} {Xs Y' : Type} [SemiHilbertDiff Xs] [SemiHilbertDiff Y']
  (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] : Prop where
  proof : IsSmoothDepNT n f ∧ ∀ x, HasAdjointT (∂ (uncurryN n f) x)

class HasAdjDiffDepN {X Y : Type} {Xs Y' : Type} [SemiHilbertDiff Xs] [SemiHilbertDiff Y']
  (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] extends HasAdjDiffDepNT n f : Prop

abbrev HasAdjDiffDepT {X Y : Type} [SemiHilbertDiff X] [SemiHilbertDiff Y] (f : X → Y) := HasAdjDiffDepNT 1 f
abbrev HasAdjDiffDep {X Y : Type} [SemiHilbertDiff X] [SemiHilbertDiff Y] (f : X → Y) := HasAdjDiffDepN 1 f

-- class HasAdjDiffDep (f : X → Y) : Prop where
--   isSmooth : IsSmooth f
--   hasAdjDiffDep : ∀ x, HasAdjoint $ ∂ f x
instance (priority:=low-10) {X Y : Type} {Xs Y' : Type} [SemiHilbertDiff Xs] [SemiHilbertDiff Y']
  (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y']
  [IsSmoothDepN n f] [∀ x, HasAdjoint (∂ (uncurryN n f) x)]
  : HasAdjDiffDepN n f
  := HasAdjDiffDepN.mk (toHasAdjDiffDepNT:= by constructor; constructor; infer_instance; infer_instance)

theorem infer_HasAdjDiffDep {X Y : Type} {Xs Y' : Type} [SemiHilbertDiff Xs] [SemiHilbertDiff Y']
  {n : Nat} {f : X → Y} [Prod.Uncurry n (X → Y) Xs Y'] [IsSmoothDepNT n f]
  : (∀ x, HasAdjointT $ ∂ (uncurryN n f) x) → HasAdjDiffDepNT n f
  := λ h => by constructor; constructor; infer_instance; apply h

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

--- Removing arguments - generalized this

instance HasAdjDiffDep2_apply_2 (f : X → Y → Z) [HasAdjDiffDepNT 2 f] (y : Y)
  : HasAdjDiffDepT (λ x => f x y) := sorry_proof

instance HasAdjDiffDep2_apply_1 (f : X → Y → Z) [inst : HasAdjDiffDepNT 2 f] (x : X)
  : HasAdjDiffDepT (λ y => f x y) :=
by
  have is := inst.proof.1
  have ia := inst.proof.2

  apply infer_HasAdjDiffDep; intro x; simp; admit

instance (f : X → Y → Z → W) [HasAdjDiffDepNT 3 f] (y z)
  : HasAdjDiffDepT (λ x => f x y z) := sorry_proof

instance (f : X → Y → Z → W) [HasAdjDiffDepNT 3 f] (x z)
  : HasAdjDiffDepT (λ y => f x y z) := sorry_proof

instance (f : X → Y → Z → W) [HasAdjDiffDepNT 3 f] (x y)
  : HasAdjDiffDepT (λ z => f x y z) := sorry_proof

--- Adding arguments - generalized this

instance HasAdjDiffDep_add_extra_2_1 (f : X → Y) [hf : HasAdjDiffDepT f]
  : HasAdjDiffDepNT 2 (λ (z : Z) x => f x) := sorry_proof

instance HasAdjDiffDep_add_extra_2_2 (f : X → Y) [HasAdjDiffDepT f]
  : HasAdjDiffDepNT 2 (λ x (z : Z) => f x) := sorry_proof

instance HasAdjDiffDep_add_extra_3_1 (f : Y → Z → W) [HasAdjDiffDepNT 2 f]
  : HasAdjDiffDepNT 3 (λ (x : X) y z => f y z) := sorry_proof

instance HasAdjDiffDep_add_extra_3_2 (f : X → Z → W) [HasAdjDiffDepNT 2 f]
  : HasAdjDiffDepNT 3 (λ x (y : Y) z => f x z) := sorry_proof

instance HasAdjDiffDep_add_extra_3_3 (f : X → Y → W) [HasAdjDiffDepNT 2 f]
  : HasAdjDiffDepNT 3 (λ x y (z : Z) => f x y) := sorry_proof

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

instance id.arg_x.hasAdjDiffDep
  : HasAdjDiffDepT (λ x : X => x) := by apply infer_HasAdjDiffDep; intro; simp[uncurryN, Prod.Uncurry.uncurry]; sorry -- infer_instance

-- TODO: move somewhere else
instance const.arg_x.hasAdjoint_no_index {X} [SemiHilbert X]
  : HasAdjointT (Y:= no_index _) λ (x : X) (i : ι) => x := sorry_proof
--

instance const.arg_x.hasAdjDiffDep
  : HasAdjDiffDepT (λ (x : X) (i : ι) => x) := by sorry --apply infer_HasAdjDiffDep; intro; unfold uncurryN; unfold Prod.Uncurry.uncurry; unfold instUncurryOfNatNatInstOfNatNatForAll; simp[uncurryN, Prod.Uncurry.uncurry]; sorry -infer_instance; done

instance const.arg_y.hasAdjDiffDep (x : X)
  : HasAdjDiffDepT (λ (y : Y) => x) :=
by
  apply infer_HasAdjDiffDep; intro;
  simp; sorry --infer_instance

instance (priority := low) swap.arg_y.hasAdjDiffDep
  (f : ι → Y → Z) [inst : ∀ i, HasAdjDiffDepT (f i)]
  : HasAdjDiffDepT (λ y x => f x y) :=
by
  have is := λ x => (inst x).proof.1
  have ia := λ x => (inst x).proof.2
  apply infer_HasAdjDiffDep; intro y;
  unfold uncurryN; unfold Prod.Uncurry.uncurry; unfold instUncurryOfNatNatInstOfNatNatForAll;
  simp; sorry -- infer_instance; done

instance (priority := mid-1) subst.arg_x.hasAdjDiffDep
  (f : X → Y → Z) [instf : HasAdjDiffDepNT 2 f]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : HasAdjDiffDepT (λ x => f x (g x)) :=
by
  have isf := instf.proof.1
  have iaf := instf.proof.2
  have isg := instg.proof.1
  have iag := instg.proof.2

  apply infer_HasAdjDiffDep; intro;
  simp[uncurryN, Prod.Uncurry.uncurry, tangentMap]; admit

instance (priority := mid-1) subst2.arg_x.hasAdjDiffDep
  (f : X → Y → Y₁ → Z) [HasAdjDiffDepNT 3 f]
  (g : X → Y → Y₁) [HasAdjDiffDepNT 2 g] :
  HasAdjDiffDepNT 2 (λ x y => f x y (g x y)) := sorry_proof

instance (priority := mid-1) subst3.arg_x.hasAdjDiffDep
  (f : X → Y → Z → Y₁ → W) [HasAdjDiffDepNT 4 f]
  (g : X → Y → Z → Y₁) [HasAdjDiffDepNT 3 g] :
  HasAdjDiffDepNT 3 (λ x y z => f x y z (g x y z)) := sorry_proof

instance comp.arg_x.hasAdjDiffDep
  (f : Y → Z) [instf : HasAdjDiffDepT f]
  (g : X → Y) [instg : HasAdjDiffDepT g]
  : HasAdjDiffDepT (λ x => f (g x)) := by infer_instance

instance {Ws W' : Type} [SemiHilbertDiff Ws] [SemiHilbertDiff W']
  (f : Z → W) [Prod.Uncurry n W Ws W'] [HasAdjDiffDepNT (n+1) f]
  (g : X → Y → Z) [HasAdjDiffDepNT 2 g]
  : HasAdjDiffDepNT (n+2) fun x y => f (g x y) := sorry_proof

instance {Ws W' : Type} [SemiHilbertDiff Ws] [SemiHilbertDiff W']
  (f : Y₁ → Y₂→ W) [Prod.Uncurry n W Ws W'] [HasAdjDiffDepNT (n+2) f]
  (g₁ : X → Y → Z → Y₁) [HasAdjDiffDepNT 3 g₁]
  (g₂ : X → Y → Z → Y₂) [HasAdjDiffDepNT 3 g₂]
  : HasAdjDiffDepNT (n+3) fun x y z => f (g₁ x y z) (g₂ x y z) := sorry_proof

instance comp2.arg_x.HasAdjDiffDep
  (f : Y₁ → Y₂ → Z) [HasAdjDiffDepNT 2 f]
  (g₁ : X → Y → Y₁) [HasAdjDiffDepNT 2 g₁]
  (g₂ : X → Y → Y₂) [HasAdjDiffDepNT 2 g₂]
  : HasAdjDiffDepNT 2 (λ x y => f (g₁ x y) (g₂ x y)) :=
by
  have : HasAdjDiffDepNT 3 fun x y => f (g₁ x y) := by infer_instance
  infer_instance

instance comp3.arg_x.HasAdjDiffDep
  (f : Y₁ → Y₂ → Y₃ → W) [HasAdjDiffDepNT 3 f]
  (g₁ : X → Y → Z → Y₁) [HasAdjDiffDepNT 3 g₁]
  (g₂ : X → Y → Z → Y₂) [HasAdjDiffDepNT 3 g₂]
  (g₃ : X → Y → Z → Y₃) [HasAdjDiffDepNT 3 g₃]
  : HasAdjDiffDepNT 3 (λ x y z => f (g₁ x y z) (g₂ x y z) (g₃ x y z)) :=
by
  -- have : HasAdjDiffDepNT 4 fun x y z => f (g₁ x y z) (g₂ x y z) := by apply hoho
  infer_instance

instance diag.arg_x.hasAdjDiffDep
  (f : Y₁ → Y₂ → Z) [instf : HasAdjDiffDepNT 2 f]
  (g₁ : X → Y₁) [instg1 : HasAdjDiffDepT g₁]
  (g₂ : X → Y₂) [instg2 : HasAdjDiffDepT g₂]
  : HasAdjDiffDepT (λ x => f (g₁ x) (g₂ x)) := by infer_instance

instance eval.arg_x.parm1.hasAdjDiffDep
  (f : X → ι → Z) [inst : HasAdjDiffDepT f] (i : ι)
  : HasAdjDiffDepT (λ x => f x i) :=
  by
    have := inst.proof.1
    have := inst.proof.2

    apply infer_HasAdjDiffDep; intro x; simp; sorry -- infer_instance

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

instance comp.arg_x.parm1.hasAdjDiffDep
  (a : α)
  (f : Y → α → Z) [HasAdjDiffDepT λ y => f y a]
  (g : X → Y) [HasAdjDiffDepT g]
  : HasAdjDiffDepT λ x => f (g x) a :=
  by
    apply comp.arg_x.hasAdjDiffDep (λ y => f y a) g
    done

instance diag.arg_x.parm1.hasAdjDiffDep
  (a : α)
  (f : Y₁ → Y₂ → α → Z) [HasAdjDiffDepNT 2 λ y₁ y₂ => f y₁ y₂ a]
  (g₁ : X → Y₁) [HasAdjDiffDepT g₁]
  (g₂ : X → Y₂) [HasAdjDiffDepT g₂]
  : HasAdjDiffDepT λ x => f (g₁ x) (g₂ x) a :=
  by
    apply diag.arg_x.hasAdjDiffDep (λ y₁ y₂ => f y₁ y₂ a) g₁ g₂
    done


/-
Copyright (c) 2020 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/

import algebra.order.ring
import data.int.basic
import tactic.norm_num

/-!
# Lemmas for `linarith`

This file contains auxiliary lemmas that `linarith` uses to construct proofs.
If you find yourself looking for a theorem here, you might be in the wrong place.
-/

namespace linarith

lemma int.coe_nat_bit0 (n : ℕ) : (↑(bit0 n : ℕ) : ℤ) = bit0 (↑n : ℤ) := by simp [bit0]
lemma int.coe_nat_bit1 (n : ℕ) : (↑(bit1 n : ℕ) : ℤ) = bit1 (↑n : ℤ) := by simp [bit1, bit0]
lemma int.coe_nat_bit0_mul (n : ℕ) (x : ℕ) : (↑(bit0 n * x) : ℤ) = (↑(bit0 n) : ℤ) * (↑x : ℤ) :=
by simp
lemma int.coe_nat_bit1_mul (n : ℕ) (x : ℕ) : (↑(bit1 n * x) : ℤ) = (↑(bit1 n) : ℤ) * (↑x : ℤ) :=
by simp
lemma int.coe_nat_one_mul (x : ℕ) : (↑(1 * x) : ℤ) = 1 * (↑x : ℤ) := by simp
lemma int.coe_nat_zero_mul (x : ℕ) : (↑(0 * x) : ℤ) = 0 * (↑x : ℤ) := by simp
lemma int.coe_nat_mul_bit0 (n : ℕ) (x : ℕ) : (↑(x * bit0 n) : ℤ) = (↑x : ℤ) * (↑(bit0 n) : ℤ) :=
by simp
lemma int.coe_nat_mul_bit1 (n : ℕ) (x : ℕ) : (↑(x * bit1 n) : ℤ) = (↑x : ℤ) * (↑(bit1 n) : ℤ) :=
by simp
lemma int.coe_nat_mul_one (x : ℕ) : (↑(x * 1) : ℤ) = (↑x : ℤ) * 1 := by simp
lemma int.coe_nat_mul_zero (x : ℕ) : (↑(x * 0) : ℤ) = (↑x : ℤ) * 0 := by simp

lemma nat_eq_subst {n1 n2 : ℕ} {z1 z2 : ℤ} (hn : n1 = n2) (h1 : ↑n1 = z1) (h2 : ↑n2 = z2) :
  z1 = z2 :=
by simpa [eq.symm h1, eq.symm h2, int.coe_nat_eq_coe_nat_iff]

lemma nat_le_subst {n1 n2 : ℕ} {z1 z2 : ℤ} (hn : n1 ≤ n2) (h1 : ↑n1 = z1) (h2 : ↑n2 = z2) :
  z1 ≤ z2 :=
by simpa [eq.symm h1, eq.symm h2, int.coe_nat_le]

lemma nat_lt_subst {n1 n2 : ℕ} {z1 z2 : ℤ} (hn : n1 < n2) (h1 : ↑n1 = z1) (h2 : ↑n2 = z2) :
  z1 < z2 :=
by simpa [eq.symm h1, eq.symm h2, int.coe_nat_lt]

lemma eq_of_eq_of_eq {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b = 0) : a + b = 0 :=
by simp *

lemma le_of_eq_of_le {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b ≤ 0) : a + b ≤ 0 :=
by simp *

lemma lt_of_eq_of_lt {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b < 0) : a + b < 0 :=
by simp *

lemma le_of_le_of_eq {α} [ordered_semiring α] {a b : α} (ha : a ≤ 0) (hb : b = 0) : a + b ≤ 0 :=
by simp *

lemma lt_of_lt_of_eq {α} [ordered_semiring α] {a b : α} (ha : a < 0) (hb : b = 0) : a + b < 0 :=
by simp *

lemma mul_neg {α} [ordered_ring α] {a b : α} (ha : a < 0) (hb : 0 < b) : b * a < 0 :=
have (-b)*a > 0, from mul_pos_of_neg_of_neg (neg_neg_of_pos hb) ha,
neg_of_neg_pos (by simpa)

lemma mul_nonpos {α} [ordered_ring α] {a b : α} (ha : a ≤ 0) (hb : 0 < b) : b * a ≤ 0 :=
have (-b)*a ≥ 0, from mul_nonneg_of_nonpos_of_nonpos (le_of_lt (neg_neg_of_pos hb)) ha,
by simpa

-- used alongside `mul_neg` and `mul_nonpos`, so has the same argument pattern for uniformity
@[nolint unused_arguments]
lemma mul_eq {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : 0 < b) : b * a = 0 :=
by simp *

lemma eq_of_not_lt_of_not_gt {α} [linear_order α] (a b : α) (h1 : ¬ a < b) (h2 : ¬ b < a) : a = b :=
le_antisymm (le_of_not_gt h2) (le_of_not_gt h1)

-- used in the `nlinarith` normalization steps. The `_` argument is for uniformity.
@[nolint unused_arguments]
lemma mul_zero_eq {α} {R : α → α → Prop} [semiring α] {a b : α} (_ : R a 0) (h : b = 0) :
  a * b = 0 :=
by simp [h]

-- used in the `nlinarith` normalization steps. The `_` argument is for uniformity.
@[nolint unused_arguments]
lemma zero_mul_eq {α} {R : α → α → Prop} [semiring α] {a b : α} (h : a = 0) (_ : R b 0) :
  a * b = 0 :=
by simp [h]

end linarith


import category_theory.equivalence

open category_theory

variables {C : Type*} [category C]
variables {D : Type*} [category D]

lemma equiv_preserves_mono {X Y : C} (f : X ⟶ Y) [mono f] (e : C ≌ D) :
  mono (e.functor.map f) :=
begin
  tidy,
  replace w := congr_arg (λ k, e.inverse.map k) w,
  simp at w,
  rw [←category.assoc, ←category.assoc, cancel_mono f] at w,
  -- Should be easy from here? See if `simp` can help.
  sorry
end


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

-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.dfinsupp
import Mathlib.PostPort

universes v w u₁ u_1

namespace Mathlib

/-!
# Direct sum

This file defines the direct sum of abelian groups, indexed by a discrete type.

## Notation

`⨁ i, β i` is the n-ary direct sum `direct_sum`.
This notation is in the `direct_sum` locale, accessible after `open_locale direct_sum`.

## References

* https://en.wikipedia.org/wiki/Direct_sum
-/

/-- `direct_sum β` is the direct sum of a family of additive commutative monoids `β i`.

Note: `open_locale direct_sum` will enable the notation `⨁ i, β i` for `direct_sum β`. -/
def direct_sum (ι : Type v) (β : ι → Type w) [(i : ι) → add_comm_monoid (β i)] :=
  dfinsupp fun (i : ι) => β i

namespace direct_sum

protected instance add_comm_group {ι : Type v} (β : ι → Type w) [(i : ι) → add_comm_group (β i)] : add_comm_group (direct_sum ι β) :=
  dfinsupp.add_comm_group

@[simp] theorem sub_apply {ι : Type v} {β : ι → Type w} [(i : ι) → add_comm_group (β i)] (g₁ : direct_sum ι fun (i : ι) => β i) (g₂ : direct_sum ι fun (i : ι) => β i) (i : ι) : coe_fn (g₁ - g₂) i = coe_fn g₁ i - coe_fn g₂ i :=
  dfinsupp.sub_apply g₁ g₂ i

@[simp] theorem zero_apply {ι : Type v} (β : ι → Type w) [(i : ι) → add_comm_monoid (β i)] (i : ι) : coe_fn 0 i = 0 :=
  rfl

@[simp] theorem add_apply {ι : Type v} {β : ι → Type w} [(i : ι) → add_comm_monoid (β i)] (g₁ : direct_sum ι fun (i : ι) => β i) (g₂ : direct_sum ι fun (i : ι) => β i) (i : ι) : coe_fn (g₁ + g₂) i = coe_fn g₁ i + coe_fn g₂ i :=
  dfinsupp.add_apply g₁ g₂ i

/-- `mk β s x` is the element of `⨁ i, β i` that is zero outside `s`
and has coefficient `x i` for `i` in `s`. -/
def mk {ι : Type v} [dec_ι : DecidableEq ι] (β : ι → Type w) [(i : ι) → add_comm_monoid (β i)] (s : finset ι) : ((i : ↥↑s) → β (subtype.val i)) →+ direct_sum ι fun (i : ι) => β i :=
  add_monoid_hom.mk (dfinsupp.mk s) sorry sorry

/-- `of i` is the natural inclusion map from `β i` to `⨁ i, β i`. -/
def of {ι : Type v} [dec_ι : DecidableEq ι] (β : ι → Type w) [(i : ι) → add_comm_monoid (β i)] (i : ι) : β i →+ direct_sum ι fun (i : ι) => β i :=
  dfinsupp.single_add_hom β i

theorem mk_injective {ι : Type v} [dec_ι : DecidableEq ι] {β : ι → Type w} [(i : ι) → add_comm_monoid (β i)] (s : finset ι) : function.injective ⇑(mk β s) :=
  dfinsupp.mk_injective s

theorem of_injective {ι : Type v} [dec_ι : DecidableEq ι] {β : ι → Type w} [(i : ι) → add_comm_monoid (β i)] (i : ι) : function.injective ⇑(of β i) :=
  dfinsupp.single_injective

protected theorem induction_on {ι : Type v} [dec_ι : DecidableEq ι] {β : ι → Type w} [(i : ι) → add_comm_monoid (β i)] {C : (direct_sum ι fun (i : ι) => β i) → Prop} (x : direct_sum ι fun (i : ι) => β i) (H_zero : C 0) (H_basic : ∀ (i : ι) (x : β i), C (coe_fn (of β i) x)) (H_plus : ∀ (x y : direct_sum ι fun (i : ι) => β i), C x → C y → C (x + y)) : C x :=
  dfinsupp.induction x H_zero
    fun (i : ι) (b : β i) (f : dfinsupp fun (i : ι) => (fun (i : ι) => (fun (i : ι) => β i) i) i) (h1 : coe_fn f i = 0)
      (h2 : b ≠ 0) (ih : C f) => H_plus (dfinsupp.single i b) f (H_basic i b) ih

/-- `to_add_monoid φ` is the natural homomorphism from `⨁ i, β i` to `γ`
induced by a family `φ` of homomorphisms `β i → γ`. -/
def to_add_monoid {ι : Type v} [dec_ι : DecidableEq ι] {β : ι → Type w} [(i : ι) → add_comm_monoid (β i)] {γ : Type u₁} [add_comm_monoid γ] (φ : (i : ι) → β i →+ γ) : (direct_sum ι fun (i : ι) => β i) →+ γ :=
  coe_fn dfinsupp.lift_add_hom φ

@[simp] theorem to_add_monoid_of {ι : Type v} [dec_ι : DecidableEq ι] {β : ι → Type w} [(i : ι) → add_comm_monoid (β i)] {γ : Type u₁} [add_comm_monoid γ] (φ : (i : ι) → β i →+ γ) (i : ι) (x : β i) : coe_fn (to_add_monoid φ) (coe_fn (of β i) x) = coe_fn (φ i) x :=
  dfinsupp.lift_add_hom_apply_single φ i x

theorem to_add_monoid.unique {ι : Type v} [dec_ι : DecidableEq ι] {β : ι → Type w} [(i : ι) → add_comm_monoid (β i)] {γ : Type u₁} [add_comm_monoid γ] (ψ : (direct_sum ι fun (i : ι) => β i) →+ γ) (f : direct_sum ι fun (i : ι) => β i) : coe_fn ψ f = coe_fn (to_add_monoid fun (i : ι) => add_monoid_hom.comp ψ (of β i)) f := sorry

/-- `from_add_monoid φ` is the natural homomorphism from `γ` to `⨁ i, β i`
induced by a family `φ` of homomorphisms `γ → β i`.

Note that this is not an isomorphism. Not every homomorphism `γ →+ ⨁ i, β i` arises in this way. -/
def from_add_monoid {ι : Type v} [dec_ι : DecidableEq ι] {β : ι → Type w} [(i : ι) → add_comm_monoid (β i)] {γ : Type u₁} [add_comm_monoid γ] : (direct_sum ι fun (i : ι) => γ →+ β i) →+ γ →+ direct_sum ι fun (i : ι) => β i :=
  to_add_monoid fun (i : ι) => coe_fn add_monoid_hom.comp_hom (of β i)

@[simp] theorem from_add_monoid_of {ι : Type v} [dec_ι : DecidableEq ι] {β : ι → Type w} [(i : ι) → add_comm_monoid (β i)] {γ : Type u₁} [add_comm_monoid γ] (i : ι) (f : γ →+ β i) : coe_fn from_add_monoid (coe_fn (of (fun (i : ι) => γ →+ β i) i) f) = add_monoid_hom.comp (of (fun (i : ι) => β i) i) f := sorry

theorem from_add_monoid_of_apply {ι : Type v} [dec_ι : DecidableEq ι] {β : ι → Type w} [(i : ι) → add_comm_monoid (β i)] {γ : Type u₁} [add_comm_monoid γ] (i : ι) (f : γ →+ β i) (x : γ) : coe_fn (coe_fn from_add_monoid (coe_fn (of (fun (i : ι) => γ →+ β i) i) f)) x =
  coe_fn (of (fun (i : ι) => β i) i) (coe_fn f x) := sorry

/-- `set_to_set β S T h` is the natural homomorphism `⨁ (i : S), β i → ⨁ (i : T), β i`,
where `h : S ⊆ T`. -/
-- TODO: generalize this to remove the assumption `S ⊆ T`.

def set_to_set {ι : Type v} [dec_ι : DecidableEq ι] (β : ι → Type w) [(i : ι) → add_comm_monoid (β i)] (S : set ι) (T : set ι) (H : S ⊆ T) : (direct_sum ↥S fun (i : ↥S) => β ↑i) →+ direct_sum ↥T fun (i : ↥T) => β ↑i :=
  to_add_monoid fun (i : ↥S) => of (fun (i : Subtype T) => β ↑i) { val := ↑i, property := sorry }

/-- The natural equivalence between `⨁ _ : ι, M` and `M` when `unique ι`. -/
protected def id (M : Type v) (ι : optParam (Type u_1) PUnit) [add_comm_monoid M] [unique ι] : (direct_sum ι fun (_x : ι) => M) ≃+ M :=
  add_equiv.mk ⇑(to_add_monoid fun (_x : ι) => add_monoid_hom.id M) ⇑(of (fun (_x : ι) => M) Inhabited.default) sorry
    sorry sorry


/-
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 category_theory.category.Bipointed
import order.category.PartOrd
import order.hom.bounded

/-!
# The category of bounded orders

This defines `BddOrd`, the category of bounded orders.
-/

universes u v

open category_theory

/-- The category of bounded orders with monotone functions. -/
structure BddOrd :=
(to_PartOrd : PartOrd)
[is_bounded_order : bounded_order to_PartOrd]

namespace BddOrd

instance : has_coe_to_sort BddOrd Type* := induced_category.has_coe_to_sort to_PartOrd
instance (X : BddOrd) : partial_order X := X.to_PartOrd.str

attribute [instance]  BddOrd.is_bounded_order

/-- Construct a bundled `BddOrd` from a `fintype` `partial_order`. -/
def of (α : Type*) [partial_order α] [bounded_order α] : BddOrd := ⟨⟨α⟩⟩

@[simp] lemma coe_of (α : Type*) [partial_order α] [bounded_order α] : ↥(of α) = α := rfl

instance : inhabited BddOrd := ⟨of punit⟩

instance large_category : large_category.{u} BddOrd :=
{ hom := λ X Y, bounded_order_hom X Y,
  id := λ X, bounded_order_hom.id X,
  comp := λ X Y Z f g, g.comp f,
  id_comp' := λ X Y, bounded_order_hom.comp_id,
  comp_id' := λ X Y, bounded_order_hom.id_comp,
  assoc' := λ W X Y Z _ _ _, bounded_order_hom.comp_assoc _ _ _ }

instance concrete_category : concrete_category BddOrd :=
{ forget := ⟨coe_sort, λ X Y, coe_fn, λ X, rfl, λ X Y Z f g, rfl⟩,
  forget_faithful := ⟨λ X Y, by convert fun_like.coe_injective⟩ }

instance has_forget_to_PartOrd : has_forget₂ BddOrd PartOrd :=
{ forget₂ := { obj := λ X, X.to_PartOrd, map := λ X Y, bounded_order_hom.to_order_hom } }

instance has_forget_to_Bipointed : has_forget₂ BddOrd Bipointed :=
{ forget₂ := { obj := λ X, ⟨X, ⊥, ⊤⟩, map := λ X Y f, ⟨f, map_bot f, map_top f⟩ },
  forget_comp := rfl }

/-- `order_dual` as a functor. -/
@[simps] def dual : BddOrd ⥤ BddOrd :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, bounded_order_hom.dual }

/-- Constructs an equivalence between bounded orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : BddOrd.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- The equivalence between `BddOrd` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : BddOrd ≌ BddOrd :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end BddOrd

lemma BddOrd_dual_comp_forget_to_PartOrd :
  BddOrd.dual ⋙ forget₂ BddOrd PartOrd =
    forget₂ BddOrd PartOrd ⋙ PartOrd.dual := rfl

lemma BddOrd_dual_comp_forget_to_Bipointed :
  BddOrd.dual ⋙ forget₂ BddOrd Bipointed =
    forget₂ BddOrd Bipointed ⋙ Bipointed.swap := rfl


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.rel_iso
import Mathlib.order.lattice_intervals
import Mathlib.order.order_dual
import Mathlib.PostPort

universes u_2 l u_1

namespace Mathlib

/-!
# Modular Lattices
This file defines Modular Lattices, a kind of lattice useful in algebra.
For examples, look to the subobject lattices of abelian groups, submodules, and ideals, or consider
any distributive lattice.

## Main Definitions
- `is_modular_lattice` defines a modular lattice to be one such that
  `x ≤ z → (x ⊔ y) ⊓ z ≤ x ⊔ (y ⊓ z)`
- `inf_Icc_order_iso_Icc_sup` gives an order isomorphism between the intervals
  `[a ⊓ b, a]` and `[b, a ⊔ b]`.
  This corresponds to the diamond (or second) isomorphism theorems of algebra.

## Main Results
- `is_modular_lattice_iff_sup_inf_sup_assoc`:
  Modularity is equivalent to the `sup_inf_sup_assoc`: `(x ⊓ z) ⊔ (y ⊓ z) = ((x ⊓ z) ⊔ y) ⊓ z`
- `distrib_lattice.is_modular_lattice`: Distributive lattices are modular.

## To do
- Relate atoms and coatoms in modular lattices

-/

/-- A modular lattice is one with a limited associativity between `⊓` and `⊔`. -/
class is_modular_lattice (α : Type u_2) [lattice α]
where
  sup_inf_le_assoc_of_le : ∀ {x : α} (y : α) {z : α}, x ≤ z → (x ⊔ y) ⊓ z ≤ x ⊔ y ⊓ z

theorem sup_inf_assoc_of_le {α : Type u_1} [lattice α] [is_modular_lattice α] {x : α} (y : α) {z : α} (h : x ≤ z) : (x ⊔ y) ⊓ z = x ⊔ y ⊓ z :=
  le_antisymm (is_modular_lattice.sup_inf_le_assoc_of_le y h)
    (le_inf (sup_le_sup_left inf_le_left x) (sup_le h inf_le_right))

theorem is_modular_lattice.sup_inf_sup_assoc {α : Type u_1} [lattice α] [is_modular_lattice α] {x : α} {y : α} {z : α} : x ⊓ z ⊔ y ⊓ z = (x ⊓ z ⊔ y) ⊓ z :=
  Eq.symm (sup_inf_assoc_of_le y inf_le_right)

theorem inf_sup_assoc_of_le {α : Type u_1} [lattice α] [is_modular_lattice α] {x : α} (y : α) {z : α} (h : z ≤ x) : x ⊓ y ⊔ z = x ⊓ (y ⊔ z) := sorry

protected instance order_dual.is_modular_lattice {α : Type u_1} [lattice α] [is_modular_lattice α] : is_modular_lattice (order_dual α) :=
  is_modular_lattice.mk
    fun (x y z : order_dual α) (xz : x ≤ z) =>
      le_of_eq
        (eq.mpr (id (Eq._oldrec (Eq.refl ((x ⊔ y) ⊓ z = x ⊔ y ⊓ z)) inf_comm))
          (eq.mpr (id (Eq._oldrec (Eq.refl (z ⊓ (x ⊔ y) = x ⊔ y ⊓ z)) sup_comm))
            (eq.mpr (id (Eq._oldrec (Eq.refl (z ⊓ (y ⊔ x) = x ⊔ y ⊓ z)) (propext eq_comm)))
              (eq.mpr (id (Eq._oldrec (Eq.refl (x ⊔ y ⊓ z = z ⊓ (y ⊔ x))) inf_comm))
                (eq.mpr (id (Eq._oldrec (Eq.refl (x ⊔ z ⊓ y = z ⊓ (y ⊔ x))) sup_comm))
                  (eq.mpr
                    ((fun (a a_1 : order_dual α) (e_1 : a = a_1) (ᾰ ᾰ_1 : order_dual α) (e_2 : ᾰ = ᾰ_1) =>
                        congr (congr_arg Eq e_1) e_2)
                      (z ⊓ y ⊔ x) ((z ⊔ coe_fn order_dual.of_dual y) ⊓ x) (Eq.refl (z ⊓ y ⊔ x)) (z ⊓ (y ⊔ x))
                      (z ⊔ coe_fn order_dual.of_dual y ⊓ x) (Eq.refl (z ⊓ (y ⊔ x))))
                    (sup_inf_assoc_of_le (coe_fn order_dual.of_dual y) (iff.mpr order_dual.dual_le xz))))))))

/-- The diamond isomorphism between the intervals `[a ⊓ b, a]` and `[b, a ⊔ b]` -/
def inf_Icc_order_iso_Icc_sup {α : Type u_1} [lattice α] [is_modular_lattice α] (a : α) (b : α) : ↥(set.Icc (a ⊓ b) a) ≃o ↥(set.Icc b (a ⊔ b)) :=
  rel_iso.mk
    (equiv.mk (fun (x : ↥(set.Icc (a ⊓ b) a)) => { val := ↑x ⊔ b, property := sorry })
      (fun (x : ↥(set.Icc b (a ⊔ b))) => { val := a ⊓ ↑x, property := sorry }) sorry sorry)
    sorry

namespace is_compl

/-- The diamond isomorphism between the intervals `set.Iic a` and `set.Ici b`. -/
def Iic_order_iso_Ici {α : Type u_1} [bounded_lattice α] [is_modular_lattice α] {a : α} {b : α} (h : is_compl a b) : ↥(set.Iic a) ≃o ↥(set.Ici b) :=
  order_iso.trans (order_iso.set_congr (set.Iic a) (set.Icc (a ⊓ b) a) sorry)
    (order_iso.trans (inf_Icc_order_iso_Icc_sup a b) (order_iso.set_congr (set.Icc b (a ⊔ b)) (set.Ici b) sorry))

end is_compl

theorem is_modular_lattice_iff_sup_inf_sup_assoc {α : Type u_1} [lattice α] : is_modular_lattice α ↔ ∀ (x y z : α), x ⊓ z ⊔ y ⊓ z = (x ⊓ z ⊔ y) ⊓ z := sorry

namespace distrib_lattice

protected instance is_modular_lattice {α : Type u_1} [distrib_lattice α] : is_modular_lattice α :=
  is_modular_lattice.mk
    fun (x y z : α) (xz : x ≤ z) =>
      eq.mpr (id (Eq._oldrec (Eq.refl ((x ⊔ y) ⊓ z ≤ x ⊔ y ⊓ z)) inf_sup_right))
        (eq.mpr (id (Eq._oldrec (Eq.refl (x ⊓ z ⊔ y ⊓ z ≤ x ⊔ y ⊓ z)) (iff.mpr inf_eq_left xz))) (le_refl (x ⊔ y ⊓ z)))

end distrib_lattice

namespace is_modular_lattice

protected instance is_modular_lattice_Iic {α : Type u_1} [bounded_lattice α] [is_modular_lattice α] {a : α} : is_modular_lattice ↥(set.Iic a) :=
  mk fun (x y z : ↥(set.Iic a)) (xz : x ≤ z) => sup_inf_le_assoc_of_le (↑y) xz

protected instance is_modular_lattice_Ici {α : Type u_1} [bounded_lattice α] [is_modular_lattice α] {a : α} : is_modular_lattice ↥(set.Ici a) :=
  mk fun (x y z : ↥(set.Ici a)) (xz : x ≤ z) => sup_inf_le_assoc_of_le (↑y) xz


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.natural_isomorphism

namespace category_theory

universes u₁ v₁ u₂ v₂ u₃ v₃ u₄ v₄

section
variables {C : Type u₁} [category.{v₁} C]
          {D : Type u₂} [category.{v₂} D]
          {E : Type u₃} [category.{v₃} E]

/--
If `α : G ⟶ H` then
`whisker_left F α : (F ⋙ G) ⟶ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
@[simps] def whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟶ H) : (F ⋙ G) ⟶ (F ⋙ H) :=
{ app := λ X, α.app (F.obj X),
  naturality' := λ X Y f, by rw [functor.comp_map, functor.comp_map, α.naturality] }

/--
If `α : G ⟶ H` then
`whisker_right α F : (G ⋙ F) ⟶ (G ⋙ F)` has components `F.map (α.app X)`.
-/
@[simps] def whisker_right {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) : (G ⋙ F) ⟶ (H ⋙ F) :=
{ app := λ X, F.map (α.app X),
  naturality' := λ X Y f,
    by rw [functor.comp_map, functor.comp_map, ←F.map_comp, ←F.map_comp, α.naturality] }

variables (C D E)

/--
Left-composition gives a functor `(C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E))`.

`(whiskering_lift.obj F).obj G` is `F ⋙ G`, and
`(whiskering_lift.obj F).map α` is `whisker_left F α`.
-/
@[simps] def whiskering_left : (C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E)) :=
{ obj := λ F,
  { obj := λ G, F ⋙ G,
    map := λ G H α, whisker_left F α },
  map := λ F G τ,
  { app := λ H,
    { app := λ c, H.map (τ.app c),
      naturality' := λ X Y f, begin dsimp, rw [←H.map_comp, ←H.map_comp, ←τ.naturality] end },
    naturality' := λ X Y f, begin ext, dsimp, rw [f.naturality] end } }

/--
Right-composition gives a functor `(D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E))`.

`(whiskering_right.obj H).obj F` is `F ⋙ H`, and
`(whiskering_right.obj H).map α` is `whisker_right α H`.
-/
@[simps] def whiskering_right : (D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E)) :=
{ obj := λ H,
  { obj := λ F, F ⋙ H,
    map := λ _ _ α, whisker_right α H },
  map := λ G H τ,
  { app := λ F,
    { app := λ c, τ.app (F.obj c),
      naturality' := λ X Y f, begin dsimp, rw [τ.naturality] end },
    naturality' := λ X Y f, begin ext, dsimp, rw [←nat_trans.naturality] end } }

variables {C} {D} {E}

@[simp] lemma whisker_left_id (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (nat_trans.id G) = nat_trans.id (F.comp G) :=
rfl
@[simp] lemma whisker_left_id' (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (𝟙 G) = 𝟙 (F.comp G) :=
rfl

@[simp] lemma whisker_right_id {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (nat_trans.id G) F = nat_trans.id (G.comp F) :=
((whiskering_right C D E).obj F).map_id _
@[simp] lemma whisker_right_id' {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (𝟙 G) F = 𝟙 (G.comp F) :=
((whiskering_right C D E).obj F).map_id _

@[simp] lemma whisker_left_comp (F : C ⥤ D) {G H K : D ⥤ E} (α : G ⟶ H) (β : H ⟶ K) :
  whisker_left F (α ≫ β) = (whisker_left F α) ≫ (whisker_left F β) :=
rfl

@[simp] lemma whisker_right_comp {G H K : C ⥤ D} (α : G ⟶ H) (β : H ⟶ K) (F : D ⥤ E)  :
  whisker_right (α ≫ β) F = (whisker_right α F) ≫ (whisker_right β F) :=
((whiskering_right C D E).obj F).map_comp α β

/--
If `α : G ≅ H` is a natural isomorphism then
`iso_whisker_left F α : (F ⋙ G) ≅ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
def iso_whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) : (F ⋙ G) ≅ (F ⋙ H) :=
((whiskering_left C D E).obj F).map_iso α
@[simp] lemma iso_whisker_left_hom (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) :
  (iso_whisker_left F α).hom = whisker_left F α.hom :=
rfl
@[simp] lemma iso_whisker_left_inv (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) :
  (iso_whisker_left F α).inv = whisker_left F α.inv :=
rfl

/--
If `α : G ≅ H` then
`iso_whisker_right α F : (G ⋙ F) ≅ (G ⋙ F)` has components `F.map_iso (α.app X)`.
-/
def iso_whisker_right {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) : (G ⋙ F) ≅ (H ⋙ F) :=
((whiskering_right C D E).obj F).map_iso α
@[simp] lemma iso_whisker_right_hom {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
  (iso_whisker_right α F).hom = whisker_right α.hom F :=
rfl
@[simp] lemma iso_whisker_right_inv {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
  (iso_whisker_right α F).inv = whisker_right α.inv F :=
rfl

instance is_iso_whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟶ H) [is_iso α] :
  is_iso (whisker_left F α) :=
is_iso.of_iso (iso_whisker_left F (as_iso α))
instance is_iso_whisker_right {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) [is_iso α] :
  is_iso (whisker_right α F) :=
is_iso.of_iso (iso_whisker_right (as_iso α) F)

variables {B : Type u₄} [category.{v₄} B]

local attribute [elab_simple] whisker_left whisker_right

@[simp] lemma whisker_left_twice (F : B ⥤ C) (G : C ⥤ D) {H K : D ⥤ E} (α : H ⟶ K) :
  whisker_left F (whisker_left G α) = whisker_left (F ⋙ G) α :=
rfl

@[simp] lemma whisker_right_twice {H K : B ⥤ C} (F : C ⥤ D) (G : D ⥤ E) (α : H ⟶ K) :
  whisker_right (whisker_right α F) G = whisker_right α (F ⋙ G) :=
rfl

lemma whisker_right_left (F : B ⥤ C) {G H : C ⥤ D} (α : G ⟶ H) (K : D ⥤ E) :
  whisker_right (whisker_left F α) K = whisker_left F (whisker_right α K) :=
rfl
end

namespace functor

universes u₅ v₅

variables {A : Type u₁} [category.{v₁} A]
variables {B : Type u₂} [category.{v₂} B]

/--
The left unitor, a natural isomorphism `((𝟭 _) ⋙ F) ≅ F`.
-/
@[simps] def left_unitor (F : A ⥤ B) : ((𝟭 A) ⋙ F) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

/--
The right unitor, a natural isomorphism `(F ⋙ (𝟭 B)) ≅ F`.
-/
@[simps] def right_unitor (F : A ⥤ B) : (F ⋙ (𝟭 B)) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

variables {C : Type u₃} [category.{v₃} C]
variables {D : Type u₄} [category.{v₄} D]

/--
The associator for functors, a natural isomorphism `((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H))`.

(In fact, `iso.refl _` will work here, but it tends to make Lean slow later,
and it's usually best to insert explicit associators.)
-/
@[simps] def associator (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) : ((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H)) :=
{ hom := { app := λ _, 𝟙 _ },
  inv := { app := λ _, 𝟙 _ } }

lemma triangle (F : A ⥤ B) (G : B ⥤ C) :
  (associator F (𝟭 B) G).hom ≫ (whisker_left F (left_unitor G).hom) =
    (whisker_right (right_unitor F).hom G) :=
by { ext, dsimp, simp }  -- See note [dsimp, simp].

variables {E : Type u₅} [category.{v₅} E]

variables (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) (K : D ⥤ E)

lemma pentagon :
  (whisker_right (associator F G H).hom K) ≫
    (associator F (G ⋙ H) K).hom ≫
    (whisker_left F (associator G H K).hom) =
  ((associator (F ⋙ G) H K).hom ≫ (associator F G (H ⋙ K)).hom) :=
by { ext, dsimp, simp }

end functor

end category_theory