import topology.metric_space.hausdorff_distance
import topology.uniform_space.separation
import geometry.manifold.cont_mdiff_mfderiv
import indexing
import to_mathlib.topology.paracompact
import to_mathlib.topology.algebra.order.compact
import to_mathlib.topology.nhds_set
import to_mathlib.topology.misc
import to_mathlib.geometry.manifold.charted_space
import to_mathlib.geometry.manifold.smooth_manifold_with_corners
import to_mathlib.analysis.normed_space.misc

import interactive_expr
set_option trace.filter_inst_type true

noncomputable theory

open set equiv
open_locale manifold topology

section general
variables {𝕜 : Type*} [nontrivially_normed_field 𝕜]
  {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
  {H : Type*} [topological_space H]
  (I : model_with_corners 𝕜 E H)
  (M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
  {E' : Type*} [normed_add_comm_group E'] [normed_space 𝕜 E']
  {H' : Type*} [topological_space H']
  (I' : model_with_corners 𝕜 E' H')
  (M' : Type*) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M']

structure open_smooth_embedding  :=
(to_fun : M → M')
(inv_fun : M' → M)
(left_inv' : ∀{x}, inv_fun (to_fun x) = x)
(is_open_range : is_open (range to_fun))
(smooth_to : smooth I I' to_fun)
(smooth_inv : smooth_on I' I inv_fun (range to_fun))

instance : has_coe_to_fun (open_smooth_embedding I M I' M') (λ _, M → M') :=
⟨open_smooth_embedding.to_fun⟩

namespace open_smooth_embedding

variables {I I' M M'} (f : open_smooth_embedding I M I' M')

@[simp] lemma coe_mk (f g h₁ h₂ h₃ h₄) :
  ⇑(⟨f, g, h₁, h₂, h₃, h₄⟩ : open_smooth_embedding I M I' M') = f :=
rfl

@[simp] lemma left_inv (x : M) : f.inv_fun (f x) = x := by apply f.left_inv'

@[simp] lemma inv_fun_comp_coe : f.inv_fun ∘ f = id := funext f.left_inv

@[simp] lemma right_inv {y : M'} (hy : y ∈ range f) : f (f.inv_fun y) = y :=
by { obtain ⟨x, rfl⟩ := hy, rw [f.left_inv] }

lemma smooth_at_inv {y : M'} (hy : y ∈ range f) : smooth_at I' I f.inv_fun y :=
(f.smooth_inv y hy).cont_mdiff_at $ f.is_open_range.mem_nhds hy

lemma smooth_at_inv' {x : M} : smooth_at I' I f.inv_fun (f x) :=
f.smooth_at_inv $ mem_range_self x

lemma left_inverse : function.left_inverse f.inv_fun f :=
left_inv f

lemma injective : function.injective f :=
f.left_inverse.injective

protected lemma continuous : continuous f := f.smooth_to.continuous

lemma open_map : is_open_map f :=
f.left_inverse.is_open_map f.is_open_range f.smooth_inv.continuous_on

lemma coe_comp_inv_fun_eventually_eq (x : M) : f ∘ f.inv_fun =ᶠ[𝓝 (f x)] id :=
filter.eventually_of_mem (f.open_map.range_mem_nhds x) $ λ y hy, f.right_inv hy

/- Note that we are slightly abusing the fact that `tangent_space I x` and
`tangent_space I (f.inv_fun (f x))` are both definitionally `E` below. -/
def fderiv (x : M) : tangent_space I x ≃L[𝕜] tangent_space I' (f x) :=
have h₁ : mdifferentiable_at I' I f.inv_fun (f x) := ((f.smooth_inv (f x) (mem_range_self x)
  ).mdifferentiable_within_at le_top).mdifferentiable_at (f.open_map.range_mem_nhds x),
have h₂ : mdifferentiable_at I I' f x := f.smooth_to.cont_mdiff.mdifferentiable le_top _,
continuous_linear_equiv.equiv_of_inverse
  (mfderiv I I' f x)
  (mfderiv I' I f.inv_fun (f x))
begin
  intros v,
  rw [← continuous_linear_map.comp_apply, ← mfderiv_comp x h₁ h₂, f.inv_fun_comp_coe, mfderiv_id,
    continuous_linear_map.coe_id', id.def],
end
begin
  intros v,
  have hx : x = f.inv_fun (f x), { rw f.left_inv, },
  have hx' : f (f.inv_fun (f x)) = f x, { rw f.left_inv, },
  rw hx at h₂,
  rw [hx, hx', ← continuous_linear_map.comp_apply, ← mfderiv_comp (f x) h₂ h₁, ((has_mfderiv_at_id
    I' (f x)).congr_of_eventually_eq (f.coe_comp_inv_fun_eventually_eq x)).mfderiv,
    continuous_linear_map.coe_id', id.def],
end

@[simp] lemma fderiv_coe (x : M) :
  (f.fderiv x : tangent_space I x →L[𝕜] tangent_space I' (f x)) = mfderiv I I' f x :=
by { ext, refl }

@[simp] lemma fderiv_symm_coe (x : M) :
  ((f.fderiv x).symm : tangent_space I' (f x) →L[𝕜] tangent_space I x) =
  mfderiv I' I f.inv_fun (f x) :=
by { ext, refl }

lemma fderiv_symm_coe' {x : M'} (hx : x ∈ range f) :
  ((f.fderiv (f.inv_fun x)).symm : tangent_space I' (f (f.inv_fun x)) →L[𝕜]
    tangent_space I (f.inv_fun x)) =
  (mfderiv I' I f.inv_fun x : tangent_space I' x →L[𝕜] tangent_space I (f.inv_fun x)) :=
by rw [fderiv_symm_coe, f.right_inv hx]

open filter

lemma open_embedding : open_embedding f :=
open_embedding_of_continuous_injective_open f.continuous f.injective f.open_map

lemma inducing : inducing f := f.open_embedding.to_inducing

-- `∀ᶠ x near s, p x` means property `p` holds at every point in a neighborhood of the set `s`.
notation `∀ᶠ` binders ` near ` s `, ` r:(scoped p, filter.eventually p $ 𝓝ˢ s) := r

lemma forall_near' {P : M → Prop} {A : set M'} (h : ∀ᶠ m near f ⁻¹' A, P m) :
  ∀ᶠ m' near A ∩ range f, ∀ m, m' = f m → P m :=
begin
  rw eventually_nhds_set_iff at h ⊢,
  rintros _ ⟨hfm₀, m₀, rfl⟩,
  have : ∀ U ∈ 𝓝 m₀, ∀ᶠ m' in 𝓝 (f m₀), m' ∈ f '' U,
  { intros U U_in,
    exact f.open_map.image_mem_nhds U_in },
  apply (this _ $ h m₀ hfm₀).mono,
  rintros _ ⟨m₀, hm₀, hm₀'⟩ m₁ rfl,
  rwa ← f.injective hm₀'
end

lemma eventually_nhds_set_mono {α : Type*} [topological_space α] {s t : set α} {P : α → Prop}
  (h : ∀ᶠ x near t, P x) (h' : s ⊆ t) : ∀ᶠ x near s, P x :=
h.filter_mono (nhds_set_mono h')

-- TODO: optimize this proof which is probably more complicated than it needs to be
lemma forall_near [t2_space M'] {P : M → Prop} {P' : M' → Prop} {K : set M} (hK : is_compact K)
  {A : set M'} (hP : ∀ᶠ m near f ⁻¹' A, P m) (hP' : ∀ᶠ m' near A, m' ∉ f '' K → P' m')
  (hPP' : ∀ m, P m → P' (f m)) :
  ∀ᶠ m' near A, P' m' :=
begin
  rw show A = (A ∩ range f) ∪ (A ∩ (range f)ᶜ), by simp,
  apply filter.eventually.union,
  { have : ∀ᶠ m' near A ∩ range f, m' ∈ range f,
      from f.is_open_range.forall_near_mem_of_subset (inter_subset_right _ _),
    apply (this.and $ f.forall_near' hP).mono,
    rintros _ ⟨⟨m, rfl⟩, hm⟩,
    exact hPP' _ (hm _ rfl) },
  { have op : is_open (f '' K)ᶜ,
    { rw is_open_compl_iff,
      exact (hK.image f.continuous).is_closed },
    have : A ∩ (range f)ᶜ ⊆ A ∩ (f '' K)ᶜ,
    { exact inter_subset_inter_right _ (compl_subset_compl.mpr (image_subset_range f K)) },
    apply eventually_nhds_set_mono _ this,
    rw eventually_nhds_set_iff at hP' ⊢,
    rintros x ⟨hx, hx'⟩,
    have hx' : ∀ᶠ y in 𝓝 x, y ∈ (f '' K)ᶜ,
      from is_open_iff_eventually.mp op x hx',
    apply ((hP' x hx).and hx').mono,
    rintros y ⟨hy, hy'⟩,
    exact hy hy' },
end

variables (I M)

/-- The identity map is a smooth open embedding. -/
-- unused
@[simps] def id : open_smooth_embedding I M I M :=
{ to_fun := id,
  inv_fun := id,
  left_inv' := λ x, rfl,
  is_open_range := is_open_map.id.is_open_range,
  smooth_to := smooth_id,
  smooth_inv := smooth_on_id }

variables {I M I' M'}

-- unused
@[simps] def comp
  {E'' : Type*} [normed_add_comm_group E''] [normed_space 𝕜 E'']
  {H'' : Type*} [topological_space H'']
  {I'' : model_with_corners 𝕜 E'' H''}
  {M'' : Type*} [topological_space M''] [charted_space H'' M''] [smooth_manifold_with_corners I'' M'']
  (g : open_smooth_embedding I' M' I'' M'') (f : open_smooth_embedding I M I' M') :
  open_smooth_embedding I M I'' M'' :=
{ to_fun := g ∘ f,
  inv_fun := f.inv_fun ∘ g.inv_fun,
  left_inv' := λ x, by simp only [function.comp_app, left_inv],
  is_open_range := (g.open_map.comp f.open_map).is_open_range,
  smooth_to := g.smooth_to.comp f.smooth_to,
  smooth_inv := (f.smooth_inv.comp' g.smooth_inv).mono
  begin
    change range (g ∘ f) ⊆ range g ∩ g.inv_fun ⁻¹' range f,
    refine subset_inter_iff.mpr ⟨range_comp_subset_range f g, _⟩,
    rintros x' ⟨x, rfl⟩,
    exact ⟨x, by simp only [left_inv]⟩,
  end, }

end open_smooth_embedding

namespace continuous_linear_equiv

variables (e : E ≃L[𝕜] E') [complete_space E] [complete_space E']

@[simp] lemma is_open_map : is_open_map e := (e : E →L[𝕜] E').is_open_map e.surjective

-- unused
@[simps] def to_open_smooth_embedding :
  open_smooth_embedding 𝓘(𝕜, E) E 𝓘(𝕜, E') E' :=
{ to_fun := e,
  inv_fun := e.symm,
  left_inv' := e.symm_apply_apply,
  is_open_range := e.is_open_map.is_open_range,
  smooth_to := (e : E →L[𝕜] E').cont_mdiff,
  smooth_inv := (e.symm : E' →L[𝕜] E).cont_mdiff.cont_mdiff_on }

end continuous_linear_equiv

end general

section without_boundary

open metric (hiding mem_nhds_iff) function

universe u

section general_nonsense

variables {𝕜 E H M : Type*} [nontrivially_normed_field 𝕜]
  [normed_add_comm_group E] [normed_space 𝕜 E]
  [topological_space H] {I : model_with_corners 𝕜 E H}
  [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
  {x : M} {n : ℕ∞}

lemma ext_chart_at_target_eq_image_chart_target :
  (ext_chart_at I x).target = I '' (chart_at H x).target :=
begin
  erw [(chart_at H x).to_local_equiv.trans_target'' I.to_local_equiv, I.source_eq, univ_inter],
  refl,
end

@[simp] lemma model_with_corners_self.ext_chart_at {e : E} :
  ext_chart_at 𝓘(𝕜, E) e = local_equiv.refl E :=
by simp

lemma cont_mdiff_on_ext_chart_symm :
  cont_mdiff_on 𝓘(𝕜, E) I n (ext_chart_at I x).symm (ext_chart_at I x).target :=
begin
  have hs : (ext_chart_at I x).target ⊆ (chart_at E (ext_chart_at I x x)).source,
  { simp only [subset_univ] with mfld_simps },
  have h2s : maps_to (ext_chart_at I x).symm (ext_chart_at I x).target (chart_at H x).source,
  { rw ← ext_chart_at_source I, exact (ext_chart_at I x).symm_maps_to, },
  refine (cont_mdiff_on_iff_of_subset_source hs h2s).mpr ⟨continuous_on_ext_chart_at_symm I x, _⟩,
  simp_rw [model_with_corners_self.ext_chart_at, local_equiv.refl_symm, local_equiv.refl_coe,
    comp.right_id, id.def, image_id'],
  exact (cont_diff_on_congr (λ y hy, (ext_chart_at I x).right_inv hy)).mpr cont_diff_on_id
end

end general_nonsense

variables
  {F H : Type*} (M : Type u)
  [normed_add_comm_group F] [normed_space ℝ F]
  [topological_space H] [topological_space M] [charted_space H M]
  [t2_space M] [locally_compact_space M] [sigma_compact_space M]
  (IF : model_with_corners ℝ F H) [smooth_manifold_with_corners IF M]

/- Clearly should be generalised. Maybe what we really want is a theory of local diffeomorphisms.

Note that the input `f` is morally an `open_smooth_embedding` but stated in terms of `cont_diff`
instead of `cont_mdiff`. This is more convenient for our purposes. -/
def open_smooth_emb_of_diffeo_subset_chart_target (x : M) {f : local_homeomorph F F}
  (hf₁ : f.source = univ)
  (hf₂ : cont_diff ℝ ∞ f)
  (hf₃ : cont_diff_on ℝ ∞ f.symm f.target)
  (hf₄ : range f ⊆ IF '' (chart_at H x).target) :
  open_smooth_embedding 𝓘(ℝ, F) F IF M :=
{ to_fun := (ext_chart_at IF x).symm ∘ f,
  inv_fun := f.inv_fun ∘ (ext_chart_at IF x),
  left_inv' := λ y,
  begin
    obtain ⟨z, hz, hz'⟩ := hf₄ (mem_range_self y),
    have aux : f.symm (IF z) = y, { rw hz', exact f.left_inv (hf₁.symm ▸ mem_univ _), },
    simp only [← hz', (chart_at H x).right_inv hz, aux, ext_chart_at,
      local_homeomorph.extend, local_equiv.coe_trans,
      local_homeomorph.inv_fun_eq_coe, model_with_corners.to_local_equiv_coe,
      local_homeomorph.coe_coe, local_equiv.coe_trans_symm, local_homeomorph.coe_coe_symm,
      model_with_corners.left_inv, model_with_corners.to_local_equiv_coe_symm, comp_app, aux],
  end,
  is_open_range := is_open_map.is_open_range $ λ u hu,
  begin
    have aux : is_open (f '' u) := f.image_open_of_open hu (hf₁.symm ▸ subset_univ u),
    convert is_open_ext_chart_at_preimage' IF x aux,
    rw image_comp,
    refine (ext_chart_at IF x).symm_image_eq_source_inter_preimage
      ((image_subset_range f u).trans _),
    rw ext_chart_at_target_eq_image_chart_target,
    exact hf₄,
  end,
  smooth_to :=
  begin
    refine cont_mdiff_on_ext_chart_symm.comp_cont_mdiff hf₂.cont_mdiff (λ y, _),
    rw ext_chart_at_target_eq_image_chart_target,
    exact hf₄ (mem_range_self y),
  end,
  smooth_inv :=
  begin
    rw ← ext_chart_at_target_eq_image_chart_target at hf₄,
    have hf' : range ((ext_chart_at IF x).symm ∘ f) ⊆ (ext_chart_at IF x) ⁻¹' f.target,
    { rw [range_comp, ← image_subset_iff, ← f.image_source_eq_target, hf₁, image_univ],
      exact (local_equiv.image_symm_image_of_subset_target _ hf₄).subset, },
    have hf'' : range ((ext_chart_at IF x).symm ∘ f) ⊆ (chart_at H x).source,
    { rw [← ext_chart_at_source IF, range_comp, ← local_equiv.symm_image_target_eq_source],
      exact (monotone_image hf₄).trans subset.rfl, },
    exact hf₃.cont_mdiff_on.comp (cont_mdiff_on_ext_chart_at.mono hf'') hf',
  end}

@[simp] lemma coe_open_smooth_emb_of_diffeo_subset_chart_target
  (x : M) {f : local_homeomorph F F}
  (hf₁ : f.source = univ)
  (hf₂ : cont_diff ℝ ∞ f)
  (hf₃ : cont_diff_on ℝ ∞ f.symm f.target)
  (hf₄ : range f ⊆ IF '' (chart_at H x).target) :
  (open_smooth_emb_of_diffeo_subset_chart_target M IF x hf₁ hf₂ hf₃ hf₄ : F → M) =
  (ext_chart_at IF x).symm ∘ f :=
by simp [open_smooth_emb_of_diffeo_subset_chart_target]

lemma range_open_smooth_emb_of_diffeo_subset_chart_target
  (x : M) {f : local_homeomorph F F}
  (hf₁ : f.source = univ)
  (hf₂ : cont_diff ℝ ∞ f)
  (hf₃ : cont_diff_on ℝ ∞ f.symm f.target)
  (hf₄ : range f ⊆ IF '' (chart_at H x).target) :
  range (open_smooth_emb_of_diffeo_subset_chart_target M IF x hf₁ hf₂ hf₃ hf₄) =
  (ext_chart_at IF x).symm '' (range f) :=
by rw [coe_open_smooth_emb_of_diffeo_subset_chart_target, range_comp]

variables {M} (F) [model_with_corners.boundaryless IF] [finite_dimensional ℝ F]

lemma nice_atlas'
  {ι : Type*} {s : ι → set M} (s_op : ∀ j, is_open $ s j) (cov : (⋃ j, s j) = univ)
  (U : set F) (hU₁ : (0 : F) ∈ U) (hU₂ : is_open U) :
  ∃ (ι' : Type u) (t : set ι') (φ : t → open_smooth_embedding 𝓘(ℝ, F) F IF M),
  t.countable ∧
  (∀ i, ∃ j, range (φ i) ⊆ s j) ∧
  locally_finite (λ i, range (φ i)) ∧
  (⋃ i, φ i '' U) = univ :=
begin
  let W : M → ℝ → set M := λ x r,
    (ext_chart_at IF x).symm ∘ diffeomorph_to_nhd (ext_chart_at IF x x) r '' U,
  let B : M → ℝ → set M := charted_space.ball IF,
  let p : M → ℝ → Prop :=
    λ x r, 0 < r ∧ ball (ext_chart_at IF x x) r ⊆ (ext_chart_at IF x).target ∧ ∃ j, B x r ⊆ s j,
  have hW₀ : ∀ x r, p x r → x ∈ W x r := λ x r h, ⟨0, hU₁, by simp [h.1]⟩,
  have hW₁ : ∀ x r, p x r → is_open (W x r),
  { rintros x r ⟨h₁, h₂, -, -⟩,
    simp only [W],
    rw image_comp,
    let V := diffeomorph_to_nhd (ext_chart_at IF x x) r '' U,
    change is_open ((ext_chart_at IF x).symm '' V),
    have hV₁ : is_open V := ((diffeomorph_to_nhd
      (ext_chart_at IF x x) r).is_open_image_iff_of_subset_source (by simp)).mp hU₂,
    have hV₂ : V ⊆ (ext_chart_at IF x).target :=
      subset.trans ((image_subset_range _ _).trans (by simp [h₁])) h₂,
    rw (ext_chart_at IF x).symm_image_eq_source_inter_preimage hV₂,
    exact is_open_ext_chart_at_preimage' IF x hV₁, },
  have hB : ∀ x, (𝓝 x).has_basis (p x) (B x) :=
    λ x, charted_space.nhds_has_basis_balls_of_open_cov IF x s_op cov,
  obtain ⟨t, ht₁, ht₂, ht₃, ht₄⟩ :=
    exists_countable_locally_finite_cover surjective_id hW₀ hW₁ hB,
  let g : M × ℝ → local_homeomorph F F := λ z, diffeomorph_to_nhd (ext_chart_at IF z.1 z.1) z.2,
  have hg₁ : ∀ z, (g z).source = univ, { simp, },
  have hg₂ : ∀ z, cont_diff ℝ ∞ (g z), { simp, },
  have hg₃ : ∀ z, cont_diff_on ℝ ∞ (g z).symm (g z).target, { simp, },
  refine ⟨M × ℝ, t,
    λ z, open_smooth_emb_of_diffeo_subset_chart_target M IF z.1.1 (hg₁ z.1) (hg₂ z.1) (hg₃ z.1) _,
    ht₁, λ z, _, _, _⟩,
  { obtain ⟨⟨x, r⟩, hxr⟩ := z,
    obtain ⟨hr : 0 < r, hr' : ball (ext_chart_at IF x x) r ⊆ _, -⟩ := ht₂ _ hxr,
    rw ← ext_chart_at_target_eq_image_chart_target,
    exact (range_diffeomorph_to_nhd_subset_ball (ext_chart_at IF x x) hr).trans hr', },
  { obtain ⟨⟨x, r⟩, hxr⟩ := z,
    obtain ⟨hr : 0 < r, -, j, hj : B x r ⊆ s j⟩ := ht₂ _ hxr,
    simp_rw range_open_smooth_emb_of_diffeo_subset_chart_target,
    exact ⟨j, (monotone_image (range_diffeomorph_to_nhd_subset_ball _ hr)).trans hj⟩, },
  { simp_rw range_open_smooth_emb_of_diffeo_subset_chart_target,
    refine ht₄.subset _,
    rintros ⟨⟨x, r⟩, hxr⟩,
    obtain ⟨hr : 0 < r, -, -⟩ := ht₂ _ hxr,
    exact monotone_image (range_diffeomorph_to_nhd_subset_ball _ hr), },
  { simpa only [Union_coe_set] using ht₃, },
end

variables [nonempty M]

lemma nice_atlas {ι : Type*} {s : ι → set M} (s_op : ∀ j, is_open $ s j) (cov : (⋃ j, s j) = univ) :
  ∃ n, ∃ φ : index_type n → open_smooth_embedding 𝓘(ℝ, F) F IF M,
  (∀ i, ∃ j, range (φ i) ⊆ s j) ∧
  locally_finite (λ i, range (φ i)) ∧
  (⋃ i, φ i '' ball 0 1) = univ :=
begin
  obtain ⟨ι', t, φ, h₁, h₂, h₃, h₄⟩ := nice_atlas' F IF s_op cov (ball 0 1) (by simp) is_open_ball,
  have htne : t.nonempty,
  { by_contra contra,
    simp only [not_nonempty_iff_eq_empty.mp contra, Union_false, Union_coe_set, Union_empty,
      @eq_comm _ _ univ, univ_eq_empty_iff] at h₄,
    exact not_is_empty_of_nonempty M h₄, },
  obtain ⟨n, ⟨fn⟩⟩ := (set.countable_iff_exists_nonempty_index_type_equiv htne).mp h₁,
  refine ⟨n, φ ∘ fn, λ i, h₂ (fn i), h₃.comp_injective fn.injective, _⟩,
  rwa fn.surjective.Union_comp (λ i, φ i '' ball 0 1),
end

end without_boundary

namespace open_smooth_embedding

section updating

variables {𝕜 EX EM EY EN EM' X M Y N M' : Type*} [nontrivially_normed_field 𝕜]
  [normed_add_comm_group EX] [normed_space 𝕜 EX]
  [normed_add_comm_group EM] [normed_space 𝕜 EM]
  [normed_add_comm_group EM'] [normed_space 𝕜 EM']
  [normed_add_comm_group EY] [normed_space 𝕜 EY]
  [normed_add_comm_group EN] [normed_space 𝕜 EN]
  {HX : Type*} [topological_space HX] {IX : model_with_corners 𝕜 EX HX}
  {HY : Type*} [topological_space HY] {IY : model_with_corners 𝕜 EY HY}
  {HM : Type*} [topological_space HM] {IM : model_with_corners 𝕜 EM HM}
  {HM' : Type*} [topological_space HM'] {IM' : model_with_corners 𝕜 EM' HM'}
  {HN : Type*} [topological_space HN] {IN : model_with_corners 𝕜 EN HN}
  [topological_space X] [charted_space HX X] [smooth_manifold_with_corners IX X]
  [topological_space M] [charted_space HM M] [smooth_manifold_with_corners IM M]
  [topological_space M'] [charted_space HM' M']

section non_metric
variables
  [topological_space Y]      [charted_space HY Y] [smooth_manifold_with_corners IY Y]
  [topological_space N]      [charted_space HN N] [smooth_manifold_with_corners IN N]
  (φ : open_smooth_embedding IX X IM M)
  (ψ : open_smooth_embedding IY Y IN N)
  (f : M → N) (g : X → Y)

section
local attribute [instance] classical.dec
/-- This is definition `def:update` in the blueprint. -/
def update (m : M) : N := if m ∈ range φ then ψ (g (φ.inv_fun m)) else f m
end

@[simp] lemma update_of_nmem_range {m : M} (hm : m ∉ range φ) :
  update φ ψ f g m = f m :=
by simp [update, hm]

@[simp] lemma update_of_mem_range {m : M} (hm : m ∈ range φ) :
  update φ ψ f g m = ψ (g (φ.inv_fun m)) :=
by simp [update, hm]

@[simp] lemma update_apply_embedding (x : X) :
  update φ ψ f g (φ x) = ψ (g x) :=
by simp [update]

/- This small auxiliry result is used in the next two lemmas. -/
lemma nice_update_of_eq_outside_compact_aux {K : set X} (g : X → Y)
  (hg : ∀ (x : X), x ∉ K → f (φ x) = ψ (g x)) {m : M} (hm : m ∉ φ '' K) :
  φ.update ψ f g m = f m :=
begin
  by_cases hm' : m ∈ range φ,
  { obtain ⟨x, rfl⟩ := hm',
    replace hm : x ∉ K, { contrapose! hm, exact mem_image_of_mem φ hm, },
    simp [hg x hm] },
  { simp [hm'] }
end

open function

/-- This is lemma `lem:smooth_updating` in the blueprint. -/
lemma smooth_update
  (f : M' → M → N) (g : M' → X → Y)
  {k : M' → M}
  {K : set X} (hK : is_closed (φ '' K)) (hf : smooth (IM'.prod IM) IN (uncurry f))
  (hg : smooth (IM'.prod IX) IY (uncurry g))
  (hk : smooth IM' IM k)
  (hg' : ∀ y x, x ∉ K → f y (φ x) = ψ (g y x)) :
  smooth IM' IN (λ x, update φ ψ (f x) (g x) (k x)) :=
begin
  have hK' : ∀ x, k x ∉ φ '' K → update φ ψ (f x) (g x) (k x) = f x (k x) :=
    λ x hx, nice_update_of_eq_outside_compact_aux φ ψ (f x) (g x) (hg' x) hx,
  refine cont_mdiff_of_locally_cont_mdiff_on (λ x, _),
  let U := range φ,
  let V := (φ '' K)ᶜ,
  have h₂ : is_open (k ⁻¹' V) := hK.is_open_compl.preimage hk.continuous,
  have h₃ : V ∪ U = univ,
  { rw [← compl_subset_iff_union, compl_compl], exact image_subset_range φ K, },
  have h₄ : ∀ x, k x ∈ U → update φ ψ (f x) (g x) (k x) = (ψ ∘ g x ∘ φ.inv_fun) (k x) :=
    λ m hm, by simp [hm],
  by_cases hx : k x ∈ U,
  { refine ⟨k ⁻¹' U, φ.is_open_range.preimage hk.continuous, hx,
    (cont_mdiff_on_congr h₄).mpr $ ψ.smooth_to.comp_cont_mdiff_on $
      hg.comp_cont_mdiff_on (smooth_on_id.prod_mk $ φ.smooth_inv.comp hk.smooth_on subset_rfl)⟩ },
  { refine ⟨k ⁻¹' V, h₂, _, (cont_mdiff_on_congr hK').mpr
      (hf.comp (smooth_id.prod_mk hk)).cont_mdiff_on⟩,
    simpa [hx] using set.ext_iff.mp h₃ (k x) }
end
end non_metric

section metric
variables
  [metric_space Y]      [charted_space HY Y] [smooth_manifold_with_corners IY Y]
  [metric_space N]      [charted_space HN N] [smooth_manifold_with_corners IN N]
  (φ : open_smooth_embedding IX X IM M)
  (ψ : open_smooth_embedding IY Y IN N)
  (f : M → N) (g : X → Y)

/-- This is `lem:dist_updating` in the blueprint. -/
lemma dist_update [proper_space Y] {K : set X} (hK : is_compact K)
  {P : Type*} [metric_space P] {KP : set P} (hKP : is_compact KP)
  (f : P → M → N) (hf : continuous ↿f)
  (hf' : ∀ p, (f p) '' range φ ⊆ range ψ) {ε : M → ℝ} (hε : ∀ m, 0 < ε m) (hε' : continuous ε) :
  ∃ η > (0 : ℝ), ∀ g : P → X → Y,
    (∀ (p ∈ KP) (p' ∈ KP) (x ∈ K), dist (g p' x) (ψ.inv_fun (f p (φ x))) < η →
      dist (update φ ψ (f p') (g p') $ φ x) (f p $ φ x) < ε (φ x)) :=
begin
  let F : P × X → Y := λ q, (ψ.inv_fun ∘ (f q.1) ∘ φ) q.2,
  let K₁ := metric.cthickening 1 (F '' KP.prod K),
  have hK₁ : is_compact K₁,
  { refine metric.is_compact_of_is_closed_bounded metric.is_closed_cthickening
      (metric.bounded.cthickening $ is_compact.bounded $ _),
    apply (hKP.prod hK).image,
    exact ψ.smooth_inv.continuous_on.comp_continuous
      (hf.comp $ continuous_fst.prod_mk $ φ.continuous.comp continuous_snd)
      (λ q, hf' q.1 ⟨φ q.2, mem_range_self _, rfl⟩) },
  have h₁ : uniform_continuous_on ψ K₁ :=
    hK₁.uniform_continuous_on_of_continuous ψ.continuous.continuous_on,
  have hεφ : ∀ x ∈ K, 0 < (ε ∘ φ) x := λ x hx, hε _,
  obtain ⟨ε₀, hε₀, hε₀'⟩ :=
    hK.exists_forall_le' (hε'.comp φ.continuous).continuous_on hεφ,
  obtain ⟨τ, hτ : 0 < τ, hτ'⟩ := metric.uniform_continuous_on_iff.mp h₁ ε₀ hε₀,
  refine ⟨min τ 1, by simp [hτ], λ g p hp p' hp' x hx hη,  _⟩,
  cases lt_min_iff.mp hη with H H',
  specialize hεφ x hx,
  apply lt_of_lt_of_le _ (hε₀' x hx), clear hε₀',
  simp only [update_apply_embedding],
  have h₁ : g p' x ∈ K₁,
    from metric.mem_cthickening_of_dist_le (g p' x) (F (p, x)) 1 _ ⟨(p, x), ⟨hp, hx⟩, rfl⟩ H'.le,
  have h₂ : f p (φ x) ∈ range ψ,
    from hf' p ⟨φ x, mem_range_self _, rfl⟩,
  rw ← ψ.right_inv h₂,
  exact hτ' _ h₁ _ (metric.self_subset_cthickening _ ⟨(p, x), ⟨hp, hx⟩, rfl⟩) H,
end

end metric

end updating

end open_smooth_embedding


import SciLean.Data.ArrayType.Algebra

namespace SciLean

variable {Cont : Type} {Idx : Type |> outParam} {Elem : Type |> outParam}
variable [ArrayType Cont Idx Elem] [Enumtype Idx]

-- There are some issues working with `getElem : (x : Cont) → (i : Idx) → Dom x i → Elem`
-- bacause it has inherently dependent types plus `Dom x i : Prop` and
-- we do not have `Vec (P → X)` for `P : Prop` and `X : Type`

--------------------------------------------------------------------------------
-- getElem
--------------------------------------------------------------------------------

instance getElem.arg_cont_.isLin [Vec Elem]
  : IsLin (λ (cont : Cont) (idx : Idx) => cont[idx]) := sorry_proof
instance getElem.arg_cont.isLin [Vec Elem] (idx : Idx)
  : IsLin (λ (cont : Cont) => cont[idx]) := sorry_proof

instance getElem.arg_cont_.isSmooth [Vec Elem]
  : IsSmooth (λ (cont : Cont) (idx : Idx) => cont[idx]) := by infer_instance
instance getElem.arg_cont.isSmooth [Vec Elem] (idx : Idx)
  : IsSmooth (λ (cont : Cont) => cont[idx]) := by infer_instance
instance getElem.arg_cont.composition.isSmooth [Vec Elem] [Vec X]
  (f : X → Cont) [IsSmoothT f] (idx : Idx)
  : IsSmoothT (λ (x : X) => (f x)[idx]) := IsSmoothT_comp₃ (λ cont => cont[idx]) f

@[diff] theorem getElem.arg_cont_.diff_simp [Vec Elem]
  : ∂ (λ (cont : Cont) (idx : Idx) => cont[idx]) = λ cont dcont idx => dcont[idx]
  := by symdiff; done
@[diff] theorem getElem.arg_cont_.tangentMap_simp [Vec Elem]
  : 𝒯 (λ (cont : Cont) (idx : Idx) => cont[idx])
    =
    λ cont dcont => (λ idx => cont[idx], λ idx => dcont[idx])
  := by symdiff; done
@[diff] theorem getElem.arg_cont.diff_simp [Vec Elem] (idx : Idx)
  : ∂ (λ (cont : Cont) => cont[idx]) = λ cont dcont => dcont[idx]
  := by symdiff; done
@[diff] theorem getElem.arg_cont.tangentMap_simp [Vec Elem] (idx : Idx)
  : 𝒯 (λ (cont : Cont) => cont[idx])
    =
    λ cont dcont => (cont[idx],dcont[idx])
  := by symdiff; done
@[diff] theorem getElem.arg_cont.composition.diff_simp [Vec Elem] [Vec X]
  (f : X → Cont) [IsSmoothT f] (idx : Idx)
  : ∂ (λ (x : X) => (f x)[idx]) = λ x dx => (∂ f x dx)[idx]
  := by rw[differential.of_comp (λ cont => cont[idx]'sorry_proof) f]; symdiff; done

instance getElem.arg_cont.hasAdjoint [SemiHilbert Elem] (idx : Idx)
  : HasAdjoint (λ (cont : Cont) => cont[idx]) := sorry_proof
@[diff] theorem getElem.arg_cont.adj_simp [SemiHilbert Elem] (idx : Idx)
  : (λ (cont : Cont) => cont[idx])† = λ cont' => setElem 0 idx cont' := sorry_proof
@[diff] theorem getElem.arg_cont_idx.adj_simp [SemiHilbert Elem]
  : (λ (cont : Cont) (idx: Idx) => cont[idx])† = λ cont' => introElem cont' := sorry_proof
@[diff] theorem getElem.arg_cont.composition.adj_simp [SemiHilbert Elem] [SemiHilbert X] (idx : Idx)
  (f : X → Cont) [HasAdjointT f]
  : (λ x => (f x)[idx])† = λ x' => f† (setElem 0 idx x') :=
by
  rw[comp.arg_x.adj_simp (λ cont : Cont => cont[idx]'True.intro) f]; symdiff; done

instance getElem.arg_cont.hasAdjDiff [SemiHilbert Elem] (idx : Idx)
  : HasAdjDiff (λ (cont : Cont) => cont[idx]) := by apply infer_HasAdjDiff'; symdiff; infer_instance; done

@[diff] theorem getElem.arg_cont.adjDiff_simp [SemiHilbert Elem] (idx : Idx)
  : ∂† (λ (cont : Cont) => cont[idx]) = λ _ dcont' => setElem 0 idx dcont' := by unfold adjointDifferential; symdiff; symdiff; done
@[diff] theorem getElem.arg_cont_idx.adjDiff_simp [SemiHilbert Elem]
  : ∂† (λ (cont : Cont) idx => cont[idx]) = λ _ dcont' => introElem dcont' := by unfold adjointDifferential; symdiff; symdiff; done
@[diff] theorem getElem.arg_cont.composition.adjDiff_simp [SemiHilbert Elem] [SemiHilbert X] (idx : Idx)
  (f : X → Cont) [inst : HasAdjDiffT f]
  : ∂† (λ (x : X) => (f x)[idx]) = λ x dx' => ∂† f x (setElem 0 idx dx') :=
by
  have _ := inst.1
  have _ := inst.2

  unfold adjointDifferential
  symdiff; symdiff
  done

--------------------------------------------------------------------------------
-- setElem
--------------------------------------------------------------------------------

function_properties setElem [Vec Elem] (cont : Cont) (idx : Idx) (elem : Elem) : Cont
-- argument (cont,elem)
--   isLin := sorry_proof,
--   isSmooth,
--   abbrev ∂ 𝒯 := setElem dcont idx delem by sorry_proof
argument cont
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := setElem dcont idx 0 by sorry_proof
argument elem
  isSmooth := sorry_proof,
  abbrev ∂ 𝒯 := setElem 0 idx delem by sorry_proof

function_properties setElem [SemiHilbert Elem] (cont : Cont) (idx : Idx) (elem : Elem) : Cont
argument cont
  hasAdjoint [Fact (elem=0)] := sorry_proof,
  -- abbrev † [Fact (elem=0)] := setElem cont' idx 0 by sorry_proof
  hasAdjDiff := sorry_proof,
  abbrev ∂† ℛ := setElem dcont' idx 0 by unfold adjointDifferential; symdiff; sorry_proof
argument elem
  hasAdjoint [Fact (cont=0)] := sorry_proof,
  abbrev † [Fact (cont=0)] := elem'[idx] by sorry_proof,
  hasAdjDiff := sorry_proof,
  abbrev ∂† := delem'[idx] by unfold adjointDifferential; symdiff; symdiff; done

-- @[simp ↓, infer_tc_goals_rl]
-- instance setElem.arg_cont.adj_simp [SemiHilbert Elem] (idx : Idx) (elem : Elem) -- [Fact (elem=0)]
--   : (λ cont : Cont => setElem cont idx elem)†
--     =
--     (λ cont' => setElem cont' idx 0) := by sorry_proof

-- this clashes with `setElem.arg_cont.adj_simp` for some unknown reason
-- TODO: remove this once the clash is resolved!
example :
  (λ (x : ℝ) => x + x)†
  =
  (λ y => y + y) := by sorry --symdiff; done

-- double check it does not happend with ∂†
example :
  ∂† (λ (x : ℝ) => x + x)
  =
  (λ x dy' => dy' + dy') := by sorry --symdiff; done

--------------------------------------------------------------------------------
-- introElem
--------------------------------------------------------------------------------

function_properties introElem [Vec Elem] (f : Idx → Elem) : Cont
argument f
  isLin := sorry_proof,
  isSmooth,
  abbrev ∂ 𝒯 := introElem df by symdiff

function_properties introElem [SemiHilbert Elem] (f : Idx → Elem) : Cont
argument f
  hasAdjoint := sorry_proof,
  abbrev † := λ idx => f'[idx] by sorry_proof,
  hasAdjDiff,
  abbrev ∂† ℛ := λ idx => df'[idx] by unfold adjointDifferential; symdiff; symdiff; done

---

-- TODO: modify, mapIdx, map


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

/-!
# The category paths on a quiver.
-/

universes v₁ v₂ u₁ u₂

namespace category_theory

section

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

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

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

namespace paths

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

variables {V}

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

end paths

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

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

end

section

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

open quiver

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

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

end

end category_theory


import classes.context_sensitive.basics.toolbox
import utilities.list_utils

inductive Te
| a_ : Te
| b_ : Te
| c_ : Te

inductive Nt
| B_ : Nt
| C_ : Nt
| R_ : Nt
| S_ : Nt
| X_ : Nt
| Y_ : Nt
| Z_ : Nt

private def a : symbol Te Nt := symbol.terminal Te.a_
private def b : symbol Te Nt := symbol.terminal Te.b_
private def c : symbol Te Nt := symbol.terminal Te.c_

private def B : symbol Te Nt := symbol.nonterminal Nt.B_
private def C : symbol Te Nt := symbol.nonterminal Nt.C_
private def R : symbol Te Nt := symbol.nonterminal Nt.R_
private def S : symbol Te Nt := symbol.nonterminal Nt.S_
private def X : symbol Te Nt := symbol.nonterminal Nt.X_
private def Y : symbol Te Nt := symbol.nonterminal Nt.Y_
private def Z : symbol Te Nt := symbol.nonterminal Nt.Z_

/-- rule `S → aSBC | aRC` as two context-sensitive rules -/
private def r₁ : csrule Te Nt := csrule.mk [] Nt.S_ [] [a, S, B, C]
private def r₂ : csrule Te Nt := csrule.mk [] Nt.S_ [] [a, R, C]

/-- non-contracting rule `CB → BC` modelled by `CB → XB → XC → BC` which is context-sensitive -/
private def r₃  : csrule Te Nt := csrule.mk [] Nt.C_ [B] [X]
private def r₃' : csrule Te Nt := csrule.mk [X] Nt.B_ [] [C]
private def r₃'': csrule Te Nt := csrule.mk [] Nt.X_ [C] [B]

/-- non-contracting rule `RB → bR` modelled by `RB → YB → YR → bR` which is context-sensitive -/
private def r₄  : csrule Te Nt := csrule.mk [] Nt.R_ [B] [Y]
private def r₄' : csrule Te Nt := csrule.mk [Y] Nt.B_ [] [R]
private def r₄'': csrule Te Nt := csrule.mk [] Nt.Y_ [R] [b]

/-- non-contracting rule `RC → bc` modelled by `RC → ZC → Zc → bc` which is context-sensitive -/
private def r₅  : csrule Te Nt := csrule.mk [] Nt.R_ [C] [Z]
private def r₅' : csrule Te Nt := csrule.mk [Z] Nt.C_ [] [c]
private def r₅'': csrule Te Nt := csrule.mk [] Nt.Z_ [c] [b]

/-- context-sensitive rule `cC → cc` -/
private def r₆ : csrule Te Nt := csrule.mk [c] Nt.C_ [] [c]

private def my_grammar : CS_grammar Te :=
CS_grammar.mk Nt Nt.S_ [r₁, r₂, r₃, r₃', r₃'', r₄, r₄', r₄'', r₅, r₅', r₅'', r₆]

/-- generate `abc` by the grammar above -/
example : [Te.a_, Te.b_, Te.c_] ∈ CS_language my_grammar :=
begin
  unfold my_grammar,

  apply CS_deri_of_tran_deri,
  {
    use r₂,
    split_ile,
    use [[], []],
    split;
    refl,
  },

  apply CS_deri_of_tran_deri,
  {
    use r₅,
    split_ile,
    use [[a], []],
    split;
    refl,
  },

  apply CS_deri_of_tran_deri,
  {
    use r₅',
    split_ile,
    use [[a], []],
    split;
    refl,
  },

  apply CS_deri_of_tran,
  {
    use r₅'',
    split_ile,
    use [[a], []],
    split;
    refl,
  },
end

private meta def CS_step (rule : pexpr) (pref post : pexpr) : tactic unit := `[
  apply CS_deri_of_tran_deri,
  tactic.use [rule],
  split_ile,
  tactic.use [pref, post],
  split;
  refl
]

/-- generate `aabbcc` by the grammar above -/
example : [Te.a_, Te.a_, Te.b_, Te.b_, Te.c_, Te.c_] ∈ CS_language my_grammar :=
begin
  unfold my_grammar,
  -- S

  CS_step ``(r₁) ``([]) ``([]),
  -- aSBC

  CS_step ``(r₂) ``([a]) ``([B, C]),
  -- aaRCBClet

  CS_step ``(r₃)   ``([a, a, R]) ``([C]),
  CS_step ``(r₃')  ``([a, a, R]) ``([C]),
  CS_step ``(r₃'') ``([a, a, R]) ``([C]),
  -- aaRBCC

  CS_step ``(r₄)   ``([a, a]) ``([C, C]),
  CS_step ``(r₄')  ``([a, a]) ``([C, C]),
  CS_step ``(r₄'') ``([a, a]) ``([C, C]),
  -- aabRCC

  CS_step ``(r₅)   ``([a, a, b]) ``([C]),
  CS_step ``(r₅')  ``([a, a, b]) ``([C]),
  CS_step ``(r₅'') ``([a, a, b]) ``([C]),
  -- aabbcC

  CS_step ``(r₆) ``([a, a, b, b]) ``([]),
  -- aabbcc

  apply CS_deri_self,
end

private meta def combined_steps_r₃ (pre pos : pexpr) : tactic unit := `[
  CS_step ``(r₃)   pre pos,
  CS_step ``(r₃')  pre pos,
  CS_step ``(r₃'') pre pos
]

private meta def combined_steps_r₄ (pre pos : pexpr) : tactic unit := `[
  CS_step ``(r₄)   pre pos,
  CS_step ``(r₄')  pre pos,
  CS_step ``(r₄'') pre pos
]

/-- generate `aaabbbccc` by the grammar above -/
example : [Te.a_, Te.a_, Te.a_, Te.b_, Te.b_, Te.b_, Te.c_, Te.c_, Te.c_] ∈ CS_language my_grammar :=
begin
  -- S

  CS_step ``(r₁) ``([]) ``([]),
  -- aSBC

  CS_step ``(r₁) ``([a]) ``([B, C]),
  -- aaSBCBC

  CS_step ``(r₂) ``([a, a]) ``([B, C, B, C]),
  -- aaaRCBCBC

  combined_steps_r₃ ``([a, a, a, R]) ``([C, B, C]),
  -- aaaRBCCBC

  combined_steps_r₃ ``([a, a, a, R, B, C]) ``([C]),
  -- aaaRBCBCC

  combined_steps_r₃ ``([a, a, a, R, B]) ``([C, C]),
  -- aaaRBBCCC

  combined_steps_r₄ ``([a, a, a]) ``([B, C, C, C]),
  -- aaabRBCCC

  combined_steps_r₄ ``([a, a, a, b]) ``([C, C, C]),
  -- aaabbRCCC

  CS_step ``(r₅)   ``([a, a, a, b, b]) ``([C, C]),
  CS_step ``(r₅')  ``([a, a, a, b, b]) ``([C, C]),
  CS_step ``(r₅'') ``([a, a, a, b, b]) ``([C, C]),
  -- aaabbbcCC

  CS_step ``(r₆) ``([a, a, a, b, b, b]) ``([C]),
  -- aaabbbccC

  CS_step ``(r₆) ``([a, a, a, b, b, b, c]) ``([]),
  -- aaabbbccc

  apply CS_deri_self,
end

/-- generate ` a^4 . b^4 . c^4 ` by the grammar above -/
example : [Te.a_, Te.a_, Te.a_, Te.a_,
           Te.b_, Te.b_, Te.b_, Te.b_,
           Te.c_, Te.c_, Te.c_, Te.c_]
    ∈ CS_language my_grammar :=
begin

  -- .S.
  CS_step ``(r₁) ``([]) ``([]),
  -- .aSBC.

  -- a.S.BC
  CS_step ``(r₁) ``([a]) ``([B, C]),
  -- a.aSBC.BC

  -- aa.S.BCBC
  CS_step ``(r₁) ``([a, a]) ``([B, C, B, C]),
  -- aa.aSBC.BCBC

  -- aaa.S.BCBCBC
  CS_step ``(r₂) ``([a, a, a]) ``([B, C, B, C, B, C]),
  -- aaa.aRC.BCBCBC

  -- aaaaR.CB.CBCBC
  combined_steps_r₃ ``([a, a, a, a, R]) ``([C, B, C, B, C]),
  -- aaaaR.BC.CBCBC

  -- aaaaRBC.CB.CBC
  combined_steps_r₃ ``([a, a, a, a, R, B, C]) ``([C, B, C]),
  -- aaaaRBC.BC.CBC

  -- aaaaRB.CB.CCBC
  combined_steps_r₃ ``([a, a, a, a, R, B]) ``([C, C, B, C]),
  -- aaaaRB.BC.CCBC

  -- aaaaRBBCC.CB.C
  combined_steps_r₃ ``([a, a, a, a, R, B, B, C, C]) ``([C]),
  -- aaaaRBBCC.BC.C

  -- aaaaRBBC.CB.CC
  combined_steps_r₃ ``([a, a, a, a, R, B, B, C]) ``([C, C]),
  -- aaaaRBBC.BC.CC

  -- aaaaRBB.CB.CCC
  combined_steps_r₃ ``([a, a, a, a, R, B, B]) ``([C, C, C]),
  -- aaaaRBB.BC.CCC

  -- aaaa.RB.BBCCCC
  combined_steps_r₄ ``([a, a, a, a]) ``([B, B, C, C, C, C]),
  -- aaaa.bR.BBCCCC

  -- aaaab.RB.BCCCC
  combined_steps_r₄ ``([a, a, a, a, b]) ``([B, C, C, C, C]),
  -- aaaab.bR.BCCCC

  -- aaaabb.RB.CCCC
  combined_steps_r₄ ``([a, a, a, a, b, b]) ``([C, C, C, C]),
  -- aaaabb.bR.CCCC

  -- aaaabbb.RC.CCC
  CS_step ``(r₅)   ``([a, a, a, a, b, b, b]) ``([C, C, C]),
  -- aaaabbb.ZC.CCC
  CS_step ``(r₅')  ``([a, a, a, a, b, b, b]) ``([C, C, C]),
  -- aaaabbb.Zc.CCC
  CS_step ``(r₅'') ``([a, a, a, a, b, b, b]) ``([C, C, C]),
  -- aaaabbb.bc.CCC

  -- aaaabbbb.cC.CC
  CS_step ``(r₆) ``([a, a, a, a, b, b, b, b]) ``([C, C]),
  -- aaaabbbb.cc.CC

  -- aaaabbbbc.cC.C
  CS_step ``(r₆) ``([a, a, a, a, b, b, b, b, c]) ``([C]),
  -- aaaabbbbc.cc.C

  -- aaaabbbbcc.cC.
  CS_step ``(r₆) ``([a, a, a, a, b, b, b, b, c, c]) ``([]),
  -- aaaabbbbcc.cc.

  apply CS_deri_self,
end


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume h1 : G.colorable 2,
    have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by auto [h1, simple_graph.colorable_def, simple_graph.le_def, simple_graph.complete_bipartite_graph_def, simple_graph.edge_def, simple_graph.vertex_def, simple_graph.cast_def, simple_graph.congr_arg_def, simple_graph.complete_graph_def, simple_graph.disjoint_union_def, simple_graph.disjoint_def, simple_graph.subset_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem_def, simple_graph.mem
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [ring]
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
FEW SHOT PROMPTS TO CODEX(END)-/


import tactic
import topology.basic topology.path_connected topology.continuous_on
import data.set order.filter.basic

open classical unit_interval path
open_locale classical unit_interval filter topological_space
noncomputable theory

universes u v w

instance : has_one ↥(set.Icc (0 : ℝ) 2) := { one := ⟨1 , and.intro (by simp) (by linarith)⟩ }

@[simp, norm_cast] lemma coe_one : ((1 : set.Icc (0 : ℝ) 2) : ℝ) = 1 := rfl

@[simp] lemma mk_one (h : (1 : ℝ) ∈ set.Icc (0 : ℝ) 2) : (⟨1 , h⟩ : set.Icc (0 : ℝ) 2) = 1 := rfl

def coe_Pi_fun (α : Type u) (β : Type v) (p : α → Prop) (f : Π (a : α), p a → β) : {a : α | p a} → β := λ a, f a a.2

instance (α : Type u) (β : Type v) (p : α → Prop) : has_coe (Π (a : α), p a → β) ({a | p a} → β) := { coe := λ f, coe_Pi_fun α β p f }

@[simp, norm_cast] lemma coe_pi_fun {α : Type u} {β : Type v} {p : α → Prop} {f : Π (a : α), p a → β} : (f : {a | p a} → β) = coe_Pi_fun α β p f := rfl

instance coe_sub (α : Type u) (s : set α) : has_coe {x // x ∈ s} s := { coe := λ ⟨a , h⟩, ⟨a , h⟩ }

instance mem_sub {α : Type u} {s : set α} : has_mem {x // x ∈ s} (set ↥s) := { mem := λ ⟨a , h⟩ U, (⟨a , h⟩ : s) ∈ U }

@[simp] lemma mem_sub_norm (α : Type u) (s : set α) (U : set ↥s) (a : {x // x ∈ s}) (h : a.1 ∈ s) : (a : {x // x ∈ s}) ∈ (U : set s) ↔ (⟨a.1 , h⟩ : s) ∈ (U : set s) := by simp

instance subset_has_mem (α : Type u) (s : set α) : has_mem α (set ↥s) := { mem := λ a U, ∃ (h : a ∈ s), (⟨a , h⟩ : s) ∈ U }

@[simp] lemma subset_has_mem_norm (α : Type u) (s : set α) (U : set ↥s) (a : α) (h : a ∈ s) : a ∈ U ↔ ↑(⟨a , h⟩ : s) ∈ U := iff.rfl

def coe_subset_fun (α : Type u) (s : set α) (U : set s) : set α := {a | a ∈ U}

instance coe_subset (α  : Type u) (s : set α) : has_coe (set s) (set α) := { coe := coe_subset_fun α s }

@[simp, norm_cast] lemma mem_sub_norm_more (α : Type u) (s : set α) (U : set s) : (U : set α) = {a | a ∈ U} := rfl

@[simp, norm_cast] lemma mem_sub_norm_univ (α : Type u) (s : set α) (x : α) : x ∈ ((@set.univ s) : set α) ↔ x ∈ s :=
begin
  split,
  { intro h,
  cases h,
  exact h_w, },
  {
    intro h,
    split,
    swap,
    exact h,
    rw set.univ,
    apply set.mem_def.2,
    tauto,
  },
end

@[simp, norm_cast] lemma mem_sub_norm_univ_eq (α : Type u) (s : set α) : ↑(@set.univ s) = s := set.ext (λ x, mem_sub_norm_univ α s x)

@[simp] lemma mem_sub_norm_sub (α : Type u) (s : set α) (U : set s) : (U : set α) ⊆ s :=
begin
  intros x hx,
  cases hx,
  exact hx_w,
end

@[simp] lemma mem_sub_norm_sub2 (α : Type u) (s : set α) (U V : set s) : U ⊆ V ↔ (U : set α) ⊆ (V : set α) :=
begin
  split,
  intro H,
  intros a ha,
  cases ha with Ha ha,
  split,
  swap,
  exact Ha,
  apply H,
  exact ha,
  intro H,
  intros a ha,
  cases a with a Ha,
  specialize H ⟨_ , ha⟩,
  cases H with Ha' H,
  simp [Ha] at H,
  exact H,
end

@[simp, norm_cast] lemma mem_sub_norm_inter (α : Type u) (s : set α) (x y : set s) : (↑(x ∩ y) : set α) = ↑x ∩ ↑y :=
begin
  apply set.ext,
  intro a,
  split,
  intro ha,
  cases ha,
  cases ha_h,
  split,
  split,
  exact ha_h_left,
  split,
  exact ha_h_right,
  intro ha,
  simp,
  simp at ha,
  cases ha with hax hay,
  cases hax with hasx hax,
  cases hay with hasy hay,
  have haa : hasx = hasy,
  {
    simp,
  },
  rw haa at *,
  existsi hasy,
  split,
  exact hax,
  exact hay,
end

def intersection_filter (α : Type u) (s : set α) (𝓕 : filter α) : filter s :=
{ sets := {U | ∃ (F : set α), F ∈ 𝓕 ∧ (U : set α) = (s : set α) ∩ (F : set α)},
  univ_sets := set.mem_def.2 (exists.intro (@set.univ α)
                                           (and.intro 𝓕.univ_sets
                                           (trans (mem_sub_norm_univ_eq α s) (by simp)))),
  sets_of_superset := λ x y hx hxy,
                     begin
                       cases hx with F hF,
                       existsi (y : set α) ∪ F,
                       split,
                       {
                         apply (𝓕.sets_of_superset hF.1),
                         simp,
                       },
                       {
                         apply set.eq_of_subset_of_subset,
                         intros y₁ hy₁,
                         split,
                         exact mem_sub_norm_sub α s y hy₁,
                         left,
                         exact hy₁,
                         rw set.inter_distrib_left,
                         intros xx hxx,
                         cases hxx,
                         cases hxx,
                         exact hxx_right,
                         rw ← hF.2 at hxx,
                         cases hxx,
                         specialize hxy hxx_h,
                         split,
                         exact hxy,
                       },
                     end,
  inter_sets := λ x y hx hy,
                begin
                  cases hx with Fx hFx,
                  cases hy with Fy hFy,
                  existsi Fx ∩ Fy,
                  split,
                  apply (𝓕.inter_sets hFx.1 hFy.1),
                  apply set.eq_of_subset_of_subset,
                  intros a ha,
                  split,
                  cases ha,
                  exact ha_w,
                  cases hFx,
                  cases hFy,
                  rw mem_sub_norm_inter at ha,
                  rw hFx_right at ha,
                  rw hFy_right at ha,
                  split,
                  cases ha,
                  cases ha_left,
                  exact ha_left_right,
                  cases ha,
                  cases ha_right,
                  exact ha_right_right,
                  intros a ha,
                  rw mem_sub_norm_inter,
                  split,
                  rw hFx.2,
                  cases ha,
                  cases ha_right,
                  split,
                  exact ha_left,
                  exact ha_right_left,
                  rw hFy.2,
                  cases ha,
                  cases ha_right,
                  split,
                  exact ha_left,
                  exact ha_right_right,
                end }

instance (α : Type u) (s : set α) : has_coe (filter α) (filter s) := { coe := intersection_filter α s }

variables (α : Type u) (β : Type v) (p : α → Prop) [topological_space α] [topological_space β]

def interior_set (s : set α) : set s := {e | (e : α) ∈ interior s}

@[simp] lemma interior_set_norm (s : set α) : ↑(interior_set α s) = interior s :=
begin
  apply set.ext,
  intro x,
  split,
  intro hx,
  rcases hx with ⟨a , b , c ,d⟩,
  split,
  use c,
  exact d,
  intro hx,
  rcases hx with ⟨a , b , c⟩,
  split,
  split,
  use b,
  exact c,
  rcases b with ⟨d  , e⟩,
  apply e,
  exact c,
end

lemma continuous_dif (f : Π (a : α), p a → β) (g : Π (a : α), ¬ p a → β)
                     (hf : continuous (f : {a | p a} → β))
                     (hg : continuous (g : {a | ¬ p a} → β))
                     (hfb : ∀ x ∈ (frontier {a | p a}),
                            ∀ H : ¬ p x, (filter.tendsto (f : {a | p a} → β) ↑(𝓝 x) (𝓝 ((g : {a | ¬ p a} → β) ⟨x , H⟩))))
                     (hgb : ∀ x ∈ (frontier {a | p a}),
                            ∀ H : p x, (filter.tendsto (g : {a | ¬ p a} → β) ↑(𝓝 x) (𝓝 ((f : {a | p a} → β) ⟨x , H⟩))))
                     : continuous (λ a, dite (p a) (f a) (g a)) :=
continuous_iff_continuous_at.2 (λ x,
begin
  apply filter.tendsto_def.2,
  intros s hs,
  have H1 := set.compl_union_self (interior ({a | p a})),
  rw ← closure_compl at H1,
  rw closure_eq_interior_union_frontier at H1,
  rw frontier_compl at H1,
  have H2 : x ∈ interior {a : α | p a}ᶜ ∪ frontier {a : α | p a} ∪ interior {a : α | p a},
  {
    have H2a : x ∈ set.univ,
    apply set.mem_def.2,
    tauto,
    rw ← H1 at H2a,
    exact H2a,
  },
  cases H2 with H3 H2,
  swap,
  have Hx : p x,
  {
    apply set.mem_def.1,
    apply interior_subset,
    exact H2,
  },
  simp [Hx] at hs,
  have Hf : ((f : {a | p a} → β) ⁻¹' s) ∈ (𝓝 ⟨x , Hx⟩ : filter {a | p a}),
  {
    have Hfa := continuous_iff_continuous_at.1 hf ⟨x , Hx⟩,
    have Hfaa := filter.tendsto_def.1 Hfa s,
    apply Hfaa,
    exact hs,
  },
  rw nhds_subtype_eq_comap at Hf,
  rcases Hf with ⟨U , HU1 , HU2⟩,
  have HU3 : U ∩ (interior {a | p a}) ∈ 𝓝 x,
  {
    apply filter.inter_mem_sets,
    exact HU1,
    rw interior_eq_nhds' at H2,
    simp at H2,
    apply interior_mem_nhds.2,
    exact H2,
  },
  apply (𝓝 x).sets_of_superset,
  exact HU3,
  intros a ha,
  cases ha with haU haI,
  have Ha2 : p a,
  {
     apply set.mem_def.1,
     apply mem_of_mem_nhds,
     apply mem_interior_iff_mem_nhds.1,
     exact haI,
  },
  have Ha3 : (⟨a , Ha2⟩ : {a |  p a}) ∈ coe ⁻¹' U,
  {
     apply set.mem_def.2,
     apply set.mem_def.2,
     use haU,
  },
  specialize HU2 Ha3,
  simp [Ha2],
  use HU2,
  cases H3,
  have Hx : ¬ p x,
  {
     rw set.compl_set_of p at H3,
     apply (@set.mem_def α x {a | ¬ p a}).1,
     apply @interior_subset α _ {a | ¬ p a},
     exact H3,
  },
  simp [Hx] at hs,
  have Hg : ((g : {a | ¬ p a} → β) ⁻¹' s) ∈ (𝓝 ⟨x , Hx⟩ : filter {a | ¬ p a}),
  {
     have Hga := continuous_iff_continuous_at.1 hg ⟨x , Hx⟩,
     have Hgaa := filter.tendsto_def.1 Hga s,
     apply Hgaa,
     exact hs,
  },
  rw nhds_subtype_eq_comap at Hg,
  rcases Hg with ⟨U , HU1 , HU2⟩,
  have HU3 : U ∩ (interior {a | ¬ p a}) ∈ 𝓝 x,
  {
    apply filter.inter_mem_sets,
    exact HU1,
    rw interior_eq_nhds' at H3,
    rw set.compl_set_of p at H3,
    simp at H3,
    apply interior_mem_nhds.2,
    exact H3,
  },
  apply (𝓝 x).sets_of_superset,
  exact HU3,
  intros a ha,
  cases ha with haU haI,
  have Ha2 : ¬ p a,
  {
    apply (@set.mem_def α a {a | ¬ p a}).1,
    apply @interior_subset α _ {a | ¬ p a},
    exact haI,
  },
  have Ha3 : (⟨a , Ha2⟩ : {a | ¬ p a}) ∈ coe ⁻¹' U,
  {
    apply set.mem_def.2,
    apply set.mem_def.2,
    use haU,
  },
  specialize HU2 Ha3,
  simp [Ha2],
  use HU2,
  by_cases p x,
  specialize hgb x H3 h,
  rw filter.tendsto_def at hgb,
  simp [h] at hs,
  specialize hgb s hs,
  rcases hgb with ⟨V, HV1, HV2⟩,
  have Hf : ((f : {a | p a} → β) ⁻¹' s) ∈ (𝓝 ⟨x , h⟩ : filter {a | p a}),
  {
    have Hfa := continuous_iff_continuous_at.1 hf ⟨x , h⟩,
    have Hfaa := filter.tendsto_def.1 Hfa s,
    apply Hfaa,
    exact hs,
  },
  rw nhds_subtype_eq_comap at Hf,
  rcases Hf with ⟨U , HU1 , HU2⟩,
  have HUV := filter.inter_mem_sets HU1 HV1,
  apply (𝓝 x).sets_of_superset,
  exact HUV,
  intros a ha,
  cases ha with haU haV,
  rename h Hx,
  by_cases p a,
  swap,
  simp [h],
  have Ha2 : a ∈ {a | ¬ p a} ∩ V,
  {
    split,
    use h,
    exact haV,
  },
  rw ← HV2 at Ha2,
  cases Ha2 with Ha Ha2,
  use Ha2,
  have Ha : (⟨a , h⟩ : {a | p a}) ∈ coe ⁻¹' U,
  {
    apply set.mem_def.2,
    apply set.mem_def.2,
    use haU,
  },
  specialize HU2 Ha,
  simp [h],
  use HU2,
  specialize hfb x H3 h,
  rw filter.tendsto_def at hfb,
  simp [h] at hs,
  specialize hfb s hs,
  rcases hfb with ⟨V , HV1 , HV2⟩,
  have Hg : ((g : {a | ¬ p a} → β) ⁻¹' s) ∈ (𝓝 ⟨x , h⟩ : filter {a | ¬ p a}),
  {
    have Hga := continuous_iff_continuous_at.1 hg ⟨x , h⟩,
    have Hgaa := filter.tendsto_def.1 Hga s,
    apply Hgaa,
    exact hs,
  },
  rw nhds_subtype_eq_comap at Hg,
  rcases Hg with ⟨U , HU1 , HU2⟩,
  have HUV := filter.inter_mem_sets HU1 HV1,
  apply (𝓝 x).sets_of_superset,
  exact HUV,
  intros a ha,
  cases ha with haU haV,
  rename h Hx,
  by_cases p a,
  simp [h],
  have Ha2 : a ∈ {a | p a} ∩ V,
  {
    split,
    use h,
    exact haV,
  },
  rw ← HV2 at Ha2,
  cases Ha2 with Ha Ha2,
  use Ha2,
  have Ha : (⟨a , h⟩ : {a | ¬ p a}) ∈ coe ⁻¹' U,
  {
    apply set.mem_def.2,
    apply set.mem_def.2,
    use haU,
  },
  specialize HU2 Ha,
  simp [h],
  use HU2,
end).

lemma front_single (x : ↥I × ↥(set.Icc (0 : ℝ) 2)) : x ∈ frontier {a : ↥I × ↥(set.Icc (0 : ℝ) 2) | a.snd ≤ 1} → x.snd = 1 :=
λ hx,
frontier_le_subset_eq (continuous_snd) (by continuity) hx

lemma coe_pi_fun_eq {α : Type u} {β : Type v} {p : α → Prop} {f : Π (a : α), p a → β} {x : α} {hx : p x} : (f : {a | p a} → β) ⟨x , hx⟩ = f x hx := rfl

instance : has_zero ↥(set.Icc (0 : ℝ) 2) := { zero := ⟨0 , by simp⟩ }

@[simp, norm_cast] lemma coe_zero : ((0 : set.Icc (0 : ℝ) 2) : ℝ) = 0 := rfl

@[simp] lemma mk_zero (h : (0 : ℝ) ∈ set.Icc (0 : ℝ) 2) : (⟨0 , h⟩ : set.Icc (0 : ℝ) 2) = 0 := rfl

def two : ↥(set.Icc (0 : ℝ) 2) := ⟨2 , by simp⟩

@[simp, norm_cast] lemma coe_two : ((two : set.Icc (0 : ℝ) 2) : ℝ) = 2 := rfl

@[simp] lemma mk_two (h : (2 : ℝ) ∈ set.Icc (0 : ℝ) 2) : (⟨2 , h⟩ : set.Icc (0 : ℝ) 2) = two := rfl

lemma real_arith : (2 : ℝ) - 1 = 1 :=
begin
  linarith,
end

lemma two_sub_one (h : (2 : ℝ) - 1 ∈ I ) : (⟨2 - 1 , h⟩ : I) = 1 :=
begin
  ext,
  simp,
  exact real_arith,
end


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Simon Hudon
-/
import category_theory.monoidal.braided
import category_theory.limits.shapes.binary_products
import category_theory.pempty

/-!
# The monoidal structure on a category with chosen finite products.

This is a variant of the development in `category_theory.monoidal.of_has_finite_products`,
which uses specified choices of the terminal object and binary product,
enabling the construction of a cartesian category with specific definitions of the tensor unit
and tensor product.

(Because the construction in `category_theory.monoidal.of_has_finite_products` uses `has_limit`
classes, the actual definitions there are opaque behind `classical.choice`.)

We use this in `category_theory.monoidal.types` to construct the monoidal category of types
so that the tensor product is the usual cartesian product of types.

For now we only do the construction from products, and not from coproducts,
which seems less often useful.
-/

universes v u

noncomputable theory

namespace category_theory

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

namespace limits

section
variables {C}

/-- Swap the two sides of a `binary_fan`. -/
def binary_fan.swap {P Q : C} (t : binary_fan P Q) : binary_fan Q P :=
binary_fan.mk t.snd t.fst

@[simp] lemma binary_fan.swap_fst {P Q : C} (t : binary_fan P Q) : t.swap.fst = t.snd := rfl
@[simp] lemma binary_fan.swap_snd {P Q : C} (t : binary_fan P Q) : t.swap.snd = t.fst := rfl

/--
If a cone `t` over `P Q` is a limit cone, then `t.swap` is a limit cone over `Q P`.
-/
@[simps]
def is_limit.swap_binary_fan {P Q : C} {t : binary_fan P Q} (I : is_limit t) : is_limit t.swap :=
{ lift := λ s, I.lift (binary_fan.swap s),
  fac' := λ s, by { rintro ⟨⟨⟩⟩; simp, },
  uniq' := λ s m w,
  begin
    have h := I.uniq (binary_fan.swap s) m,
    rw h,
    rintro ⟨j⟩,
    specialize w ⟨j.swap⟩,
    cases j; exact w,
  end }

/--
Construct `has_binary_product Q P` from `has_binary_product P Q`.
This can't be an instance, as it would cause a loop in typeclass search.
-/
lemma has_binary_product.swap (P Q : C) [has_binary_product P Q] : has_binary_product Q P :=
has_limit.mk ⟨binary_fan.swap (limit.cone (pair P Q)), (limit.is_limit (pair P Q)).swap_binary_fan⟩

/--
Given a limit cone over `X` and `Y`, and another limit cone over `Y` and `X`, we can construct
an isomorphism between the cone points. Relative to some fixed choice of limits cones for every
pair, these isomorphisms constitute a braiding.
-/
def binary_fan.braiding {X Y : C}
  {s : binary_fan X Y} (P : is_limit s) {t : binary_fan Y X} (Q : is_limit t) :
  s.X ≅ t.X :=
is_limit.cone_point_unique_up_to_iso P Q.swap_binary_fan

/--
Given binary fans `sXY` over `X Y`, and `sYZ` over `Y Z`, and `s` over `sXY.X Z`,
if `sYZ` is a limit cone we can construct a binary fan over `X sYZ.X`.

This is an ingredient of building the associator for a cartesian category.
-/
def binary_fan.assoc {X Y Z : C}
  {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan sXY.X Z) :
  binary_fan X sYZ.X :=
binary_fan.mk (s.fst ≫ sXY.fst) (Q.lift (binary_fan.mk (s.fst ≫ sXY.snd) s.snd))

@[simp] lemma binary_fan.assoc_fst {X Y Z : C}
  {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan sXY.X Z) :
  (s.assoc Q).fst = s.fst ≫ sXY.fst := rfl
@[simp] lemma binary_fan.assoc_snd {X Y Z : C}
  {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan sXY.X Z) :
  (s.assoc Q).snd = Q.lift (binary_fan.mk (s.fst ≫ sXY.snd) s.snd) := rfl

/--
Given binary fans `sXY` over `X Y`, and `sYZ` over `Y Z`, and `s` over `X sYZ.X`,
if `sYZ` is a limit cone we can construct a binary fan over `sXY.X Z`.

This is an ingredient of building the associator for a cartesian category.
-/
def binary_fan.assoc_inv {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X sYZ.X) :
  binary_fan sXY.X Z :=
binary_fan.mk (P.lift (binary_fan.mk s.fst (s.snd ≫ sYZ.fst))) (s.snd ≫ sYZ.snd)

@[simp] lemma binary_fan.assoc_inv_fst {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X sYZ.X) :
  (s.assoc_inv P).fst = P.lift (binary_fan.mk s.fst (s.snd ≫ sYZ.fst)) := rfl
@[simp] lemma binary_fan.assoc_inv_snd {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X sYZ.X) :
  (s.assoc_inv P).snd = s.snd ≫ sYZ.snd := rfl

/--
If all the binary fans involved a limit cones, `binary_fan.assoc` produces another limit cone.
-/
@[simps]
def is_limit.assoc {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (Q : is_limit sYZ)
  {s : binary_fan sXY.X Z} (R : is_limit s) : is_limit (s.assoc Q) :=
{ lift := λ t, R.lift (binary_fan.assoc_inv P t),
  fac' := λ t,
  begin
    rintro ⟨⟨⟩⟩; simp,
    apply Q.hom_ext,
    rintro ⟨⟨⟩⟩; simp,
  end,
  uniq' := λ t m w,
  begin
    have h := R.uniq (binary_fan.assoc_inv P t) m,
    rw h,
    rintro ⟨⟨⟩⟩; simp,
    apply P.hom_ext,
    rintro ⟨⟨⟩⟩; simp,
    { exact w ⟨walking_pair.left⟩, },
    { specialize w ⟨walking_pair.right⟩,
      simp at w,
      rw [←w], simp, },
    { specialize w ⟨walking_pair.right⟩,
      simp at w,
      rw [←w], simp, },
  end, }

/--
Given two pairs of limit cones corresponding to the parenthesisations of `X × Y × Z`,
we obtain an isomorphism between the cone points.
-/
@[reducible]
def binary_fan.associator {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (Q : is_limit sYZ)
  {s : binary_fan sXY.X Z} (R : is_limit s) {t : binary_fan X sYZ.X} (S : is_limit t) :
  s.X ≅ t.X :=
is_limit.cone_point_unique_up_to_iso (is_limit.assoc P Q R) S

/--
Given a fixed family of limit data for every pair `X Y`, we obtain an associator.
-/
@[reducible]
def binary_fan.associator_of_limit_cone
  (L : Π X Y : C, limit_cone (pair X Y)) (X Y Z : C) :
  (L (L X Y).cone.X Z).cone.X ≅ (L X (L Y Z).cone.X).cone.X :=
binary_fan.associator
  (L X Y).is_limit (L Y Z).is_limit
  (L (L X Y).cone.X Z).is_limit (L X (L Y Z).cone.X).is_limit

local attribute [tidy] tactic.discrete_cases

/--
Construct a left unitor from specified limit cones.
-/
@[simps]
def binary_fan.left_unitor {X : C} {s : cone (functor.empty.{v} C)} (P : is_limit s)
  {t : binary_fan s.X X} (Q : is_limit t) : t.X ≅ X :=
{ hom := t.snd,
  inv := Q.lift (binary_fan.mk (P.lift
    { X := X, π := { app := discrete.rec (pempty.rec _) } }) (𝟙 X) ),
  hom_inv_id' :=
  by { apply Q.hom_ext, rintro ⟨⟨⟩⟩, { apply P.hom_ext, rintro ⟨⟨⟩⟩, }, { simp, }, }, }

/--
Construct a right unitor from specified limit cones.
-/
@[simps]
def binary_fan.right_unitor {X : C} {s : cone (functor.empty.{v} C)} (P : is_limit s)
  {t : binary_fan X s.X} (Q : is_limit t) : t.X ≅ X :=
{ hom := t.fst,
  inv := Q.lift (binary_fan.mk (𝟙 X) (P.lift
    { X := X, π := { app := discrete.rec (pempty.rec _) } })),
  hom_inv_id' :=
  by { apply Q.hom_ext, rintro ⟨⟨⟩⟩, { simp, }, { apply P.hom_ext, rintro ⟨⟨⟩⟩, }, }, }

end

end limits

open category_theory.limits

section
local attribute [tidy] tactic.case_bash

variables {C}
variables (𝒯 : limit_cone (functor.empty.{v} C))
variables (ℬ : Π (X Y : C), limit_cone (pair X Y))

namespace monoidal_of_chosen_finite_products

/-- Implementation of the tensor product for `monoidal_of_chosen_finite_products`. -/
@[reducible]
def tensor_obj (X Y : C) : C := (ℬ X Y).cone.X

/-- Implementation of the tensor product of morphisms for `monoidal_of_chosen_finite_products`. -/
@[reducible]
def tensor_hom {W X Y Z : C} (f : W ⟶ X) (g : Y ⟶ Z) : tensor_obj ℬ W Y ⟶ tensor_obj ℬ X Z :=
  (binary_fan.is_limit.lift' (ℬ X Z).is_limit
    ((ℬ W Y).cone.π.app ⟨walking_pair.left⟩ ≫ f)
    (((ℬ W Y).cone.π.app ⟨walking_pair.right⟩ : (ℬ W Y).cone.X ⟶ Y) ≫ g)).val

lemma tensor_id (X₁ X₂ : C) : tensor_hom ℬ (𝟙 X₁) (𝟙 X₂) = 𝟙 (tensor_obj ℬ X₁ X₂) :=
begin
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩;
  { dsimp [tensor_hom], simp, },
end

lemma tensor_comp {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : C}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂) :
  tensor_hom ℬ (f₁ ≫ g₁) (f₂ ≫ g₂) =
    tensor_hom ℬ f₁ f₂ ≫ tensor_hom ℬ g₁ g₂ :=
begin
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩;
  { dsimp [tensor_hom], simp, },
end

lemma pentagon (W X Y Z : C) :
  tensor_hom ℬ (binary_fan.associator_of_limit_cone ℬ W X Y).hom (𝟙 Z) ≫
    (binary_fan.associator_of_limit_cone ℬ W (tensor_obj ℬ X Y) Z).hom ≫
      tensor_hom ℬ (𝟙 W) (binary_fan.associator_of_limit_cone ℬ X Y Z).hom =
  (binary_fan.associator_of_limit_cone ℬ (tensor_obj ℬ W X) Y Z).hom ≫
    (binary_fan.associator_of_limit_cone ℬ W X (tensor_obj ℬ Y Z)).hom :=
begin
  dsimp [tensor_hom],
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩,
  { simp, },
  { apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩,
    { simp, },
    apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩,
    { simp, },
    { simp, }, }
end

lemma triangle (X Y : C) :
  (binary_fan.associator_of_limit_cone ℬ X 𝒯.cone.X Y).hom ≫
    tensor_hom ℬ (𝟙 X) (binary_fan.left_unitor 𝒯.is_limit (ℬ 𝒯.cone.X Y).is_limit).hom =
  tensor_hom ℬ (binary_fan.right_unitor 𝒯.is_limit (ℬ X 𝒯.cone.X).is_limit).hom (𝟙 Y) :=
begin
  dsimp [tensor_hom],
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩; simp,
end

lemma left_unitor_naturality {X₁ X₂ : C} (f : X₁ ⟶ X₂) :
  tensor_hom ℬ (𝟙 𝒯.cone.X) f ≫ (binary_fan.left_unitor 𝒯.is_limit (ℬ 𝒯.cone.X X₂).is_limit).hom =
    (binary_fan.left_unitor 𝒯.is_limit (ℬ 𝒯.cone.X X₁).is_limit).hom ≫ f :=
begin
  dsimp [tensor_hom],
  simp,
end

lemma right_unitor_naturality {X₁ X₂ : C} (f : X₁ ⟶ X₂) :
  tensor_hom ℬ f (𝟙 𝒯.cone.X) ≫
    (binary_fan.right_unitor 𝒯.is_limit (ℬ X₂ 𝒯.cone.X).is_limit).hom =
    (binary_fan.right_unitor 𝒯.is_limit (ℬ X₁ 𝒯.cone.X).is_limit).hom ≫ f :=
begin
  dsimp [tensor_hom],
  simp,
end

lemma associator_naturality {X₁ X₂ X₃ Y₁ Y₂ Y₃ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃) :
  tensor_hom ℬ (tensor_hom ℬ f₁ f₂) f₃ ≫ (binary_fan.associator_of_limit_cone ℬ Y₁ Y₂ Y₃).hom =
    (binary_fan.associator_of_limit_cone ℬ X₁ X₂ X₃).hom ≫
      tensor_hom ℬ f₁ (tensor_hom ℬ f₂ f₃) :=
begin
  dsimp [tensor_hom],
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩,
  { simp, },
  { apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩,
    { simp, },
    { simp, }, },
end

end monoidal_of_chosen_finite_products

open monoidal_of_chosen_finite_products

/-- A category with a terminal object and binary products has a natural monoidal structure. -/
def monoidal_of_chosen_finite_products :
  monoidal_category C :=
{ tensor_unit  := 𝒯.cone.X,
  tensor_obj   := λ X Y, tensor_obj ℬ X Y,
  tensor_hom   := λ _ _ _ _ f g, tensor_hom ℬ f g,
  tensor_id'   := tensor_id ℬ,
  tensor_comp' := λ _ _ _ _ _ _ f₁ f₂ g₁ g₂, tensor_comp ℬ f₁ f₂ g₁ g₂,
  associator   := λ X Y Z, binary_fan.associator_of_limit_cone ℬ X Y Z,
  left_unitor  := λ X, binary_fan.left_unitor (𝒯.is_limit) (ℬ 𝒯.cone.X X).is_limit,
  right_unitor := λ X, binary_fan.right_unitor (𝒯.is_limit) (ℬ X 𝒯.cone.X).is_limit,
  pentagon'    := pentagon ℬ,
  triangle'    := triangle 𝒯 ℬ,
  left_unitor_naturality' := λ _ _ f, left_unitor_naturality 𝒯 ℬ f,
  right_unitor_naturality' := λ _ _ f, right_unitor_naturality 𝒯 ℬ f,
  associator_naturality' := λ _ _ _ _ _ _ f₁ f₂ f₃, associator_naturality ℬ f₁ f₂ f₃, }

namespace monoidal_of_chosen_finite_products

open monoidal_category

/--
A type synonym for `C` carrying a monoidal category structure corresponding to
a fixed choice of limit data for the empty functor, and for `pair X Y` for every `X Y : C`.

This is an implementation detail for `symmetric_of_chosen_finite_products`.
-/
@[derive category, nolint unused_arguments has_nonempty_instance]
def monoidal_of_chosen_finite_products_synonym
  (𝒯 : limit_cone (functor.empty.{v} C)) (ℬ : Π (X Y : C), limit_cone (pair X Y)):= C

instance : monoidal_category (monoidal_of_chosen_finite_products_synonym 𝒯 ℬ) :=
monoidal_of_chosen_finite_products 𝒯 ℬ

lemma braiding_naturality {X X' Y Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y') :
  (tensor_hom ℬ f g) ≫ (limits.binary_fan.braiding (ℬ Y Y').is_limit (ℬ Y' Y).is_limit).hom =
    (limits.binary_fan.braiding (ℬ X X').is_limit (ℬ X' X).is_limit).hom ≫ (tensor_hom ℬ g f) :=
begin
  dsimp [tensor_hom, limits.binary_fan.braiding],
  apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟨⟩⟩;
  { dsimp [limits.is_limit.cone_point_unique_up_to_iso], simp, },
end

lemma hexagon_reverse (X Y Z : C) :
  (binary_fan.associator_of_limit_cone ℬ X Y Z).inv ≫
    (limits.binary_fan.braiding
      (ℬ (tensor_obj ℬ X Y) Z).is_limit
      (ℬ Z (tensor_obj ℬ X Y)).is_limit).hom ≫
    (binary_fan.associator_of_limit_cone ℬ Z X Y).inv =
    (tensor_hom ℬ (𝟙 X) (limits.binary_fan.braiding (ℬ Y Z).is_limit (ℬ Z Y).is_limit).hom) ≫
      (binary_fan.associator_of_limit_cone ℬ X Z Y).inv ≫
        (tensor_hom ℬ (limits.binary_fan.braiding (ℬ X Z).is_limit (ℬ Z X).is_limit).hom (𝟙 Y)) :=
begin
  dsimp [tensor_hom, limits.binary_fan.braiding],
  apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟨⟩⟩,
  { apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟨⟩⟩;
    { dsimp [binary_fan.associator_of_limit_cone, binary_fan.associator,
        limits.is_limit.cone_point_unique_up_to_iso],
      simp, }, },
  { dsimp [binary_fan.associator_of_limit_cone, binary_fan.associator,
      limits.is_limit.cone_point_unique_up_to_iso],
    simp, },
end

lemma symmetry (X Y : C) :
  (limits.binary_fan.braiding (ℬ X Y).is_limit (ℬ Y X).is_limit).hom ≫
      (limits.binary_fan.braiding (ℬ Y X).is_limit (ℬ X Y).is_limit).hom =
    𝟙 (tensor_obj ℬ X Y) :=
begin
  dsimp [tensor_hom, limits.binary_fan.braiding],
  apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟨⟩⟩;
  { dsimp [limits.is_limit.cone_point_unique_up_to_iso], simp, },
end

end monoidal_of_chosen_finite_products

open monoidal_of_chosen_finite_products

/--
The monoidal structure coming from finite products is symmetric.
-/
def symmetric_of_chosen_finite_products :
  symmetric_category (monoidal_of_chosen_finite_products_synonym 𝒯 ℬ) :=
{ braiding := λ X Y, limits.binary_fan.braiding (ℬ _ _).is_limit (ℬ _ _).is_limit,
  braiding_naturality' := λ X X' Y Y' f g, braiding_naturality ℬ f g,
  hexagon_forward' := λ X Y Z, hexagon_forward ℬ X Y Z,
  hexagon_reverse' := λ X Y Z, hexagon_reverse ℬ X Y Z,
  symmetry' := λ X Y, symmetry ℬ X Y, }

end

end category_theory


import Lib.Data.AssocList
import Lib.Data.Sorting
import Lib.Data.These
import Lib.Order.Basic

open Std

namespace Option
open These

def mergeWith (f : These α β → Option γ) :
  Option α → Option β → Option γ
| none, none => none
| some x, none => f <| inl x
| none, some y => f <| inr y
| some x, some y => f <| both x y

end Option

namespace These

@[simp]
def unionWith (f : α → α → α) : These α α → Option α
| inl x => some x
| inr x => some x
| both x y => some <| f x y

@[simp]
def intersectionWith (f : α → β → γ) : These α β → Option γ
| inl x => none
| inr x => none
| both x y => some <| f x y

@[simp]
def differenceWith (f : α → β → Option α) : These α β → Option α
| inl x => some x
| inr x => none
| both x y => f x y

end These

namespace Std.AssocList

section defs

variable [Ord k]
variable (f : k → These α β → Option γ)
-- #check Std.AssocList.m
open Nat
-- @[simp]
-- theorem lt_succ_succ (x : Nat) :
--   x < succ (succ x) :=
-- by trans succ x <;> auto

open These AssocList

@[specialize]
def zipWith : AssocList k α → AssocList k β → AssocList k γ
| AssocList.nil, xs =>
  xs.mapFilter <| (f . ∘ inr)
| xs, AssocList.nil =>
  xs.mapFilter <| (f . ∘ inl)
| AssocList.cons i x xs, AssocList.cons j y ys =>
  match compare i j with
  | Ordering.lt =>
    let zs := zipWith xs (cons j y ys)
    match f i <| inl x with
    | none => zs
    | some x' => cons i x' zs
      -- <|
  | Ordering.eq =>
    let zs := zipWith xs ys
    match f i <| both x y with
    | none => zs
    | some x' => cons i x' zs
  | Ordering.gt =>
    let zs := zipWith (AssocList.cons i x xs) ys
    match f i <| inr y with
    | none => zs
    | some x' => cons j x' zs
termination_by zipWith x y => (x.length, y.length)
-- #find prefix getEqn
-- #eval Lean.Meta.getEqnsFor? ``zipWith

-- -- #check Substring
-- variable (xs ys : AssocList k _)
-- open AssocList
-- @[simp]
-- theorem addAux_nil₀ :
--   zipWith f nil ys =
--   ys.mapVal (f ∘ inr) := by
-- cases ys <;>
-- exact WellFounded.fix_eq _ _ _

-- @[simp]
-- theorem addAux_nil₁ :
--   zipWith f xs nil =
--   xs.mapVal (f ∘ inl) := by
-- cases xs <;>
-- exact WellFounded.fix_eq _ _ _

-- @[simp]
-- theorem addAux_cons i x j y :
--   zipWith f (cons i x xs) (cons j y ys) =
--   match compare i j with
--   | Ordering.lt =>
--     cons i (f <| inl x) <| zipWith f xs (cons j y ys)
--   | Ordering.eq =>
--     cons i (f <| both x y) <| zipWith f xs ys
--   | Ordering.gt =>
--     cons j (f <| inr y) <| zipWith f (cons i x xs) ys
--   := WellFounded.fix_eq _ _ _

end defs

-- def R : Nat × α → Nat × α → Prop := (InvImage (.<.) Prod.fst)
open List

-- @[simp]
-- theorem Sorted_map_map :
--   Sorted2 R (List.map (Prod.map id fy) ys) ↔
--   Sorted2 R ys := sorry

-- @[simp]
-- theorem All_LT_map_map :
--   All (R (i, fy x)) (List.map (Prod.map id fy) ys) ↔
--   All (R (i, x)) ys := sorry

variable [LE k] [DecidableTotalOrder k]
variable (f : k → These α β → Option γ)

open List Std.AssocList
-- #check @zipWith

@[auto]
theorem Sublist_keys_mapFilter {xs : AssocList α β}
        {f : α → β → Option γ}:
  Sublist (xs.mapFilter f |>.keys) xs.keys := by
induction xs <;> simp [mapFilter, keys]
. constructor
split
<;> simp [keys]
<;> constructor <;> assumption

theorem All_LT_zipWith (i : k) :
        -- {xs ys : AssocList k α}
        (xs : AssocList k α) →
        (ys : AssocList k β) →
        (Hxs : All (i < .) xs.keys) →
        (Hys : All (i < .) ys.keys) →
  All (i < .) (zipWith f xs ys).keys
| nil, xs, Hxs, Hys => by
  simp [zipWith]
  apply All_of_All_of_Sublist _ Hys
  auto
| xs, nil, Hxs, Hys => by
  cases xs <;> simp [zipWith]
  <;> apply All_of_All_of_Sublist _ Hxs
  <;> auto
| cons i x xs, cons j y ys, Hxs, Hys => by
  simp [zipWith, keys] at Hxs Hys ⊢
  cases Hxs; cases Hys
  next Hxs Hxs' Hys Hys' =>
  split <;>
  next h =>
    simp at h
    split  <;>
    next h' =>
      repeat
        simp [keys]
        first
        | constructor
        | auto
        | apply All_LT_zipWith
termination_by All_LT_zipWith x y _ _ => (x.length, y.length)

theorem Sorted_zipWith (f : k → These α β → Option γ) :
        {xs ys : AssocList k _} →
        (Hxs : Sorted2 (.<.) xs.keys) →
        (Hys : Sorted2 (.<.) ys.keys) →
  Sorted2 (.<.) (zipWith f xs ys).keys
| nil, xs, Hxs, Hys => by
  simp [keys, zipWith]
  apply Sorted2_of_Sorted2_of_Sublist _ Hys
  apply Sublist_keys_mapFilter
| xs, nil, Hxs, Hys => by
  cases xs
  <;> simp [keys, zipWith]
  <;> apply Sorted2_of_Sorted2_of_Sublist _ Hxs
  . constructor
  . apply Sublist_keys_mapFilter
| cons i x xs, cons j y ys, Hxs, Hys => by
  simp [zipWith, keys] at Hxs Hys ⊢
  cases Hxs; cases Hys
  next Hxs Hxs' Hys Hys' =>
  split <;>
  next h =>
    simp at h
    first
    | have h'' := Preorder.le_of_lt h
    | have h'' := Preorder.le_of_eq h
    | have h'' := True.intro
    split <;>
    next h' =>
      repeat
        try simp [keys]
        first
        | constructor
        | auto
        | apply Sorted_zipWith
        | apply All_LT_zipWith
        | apply All_LT_of_lt_of_All_LT h''
      skip
termination_by Sorted_zipWith x y _ _ => (x.length, y.length)

end Std.AssocList

open List
structure OrdMap (α : Type u) [LT α] (β : Type v) where
  vals : AssocList α β
  sorted : Sorted2 (.<.) vals.keys

namespace OrdMap

section defs

variable {k} [LT k]

def empty : OrdMap k α where
  vals := AssocList.nil
  sorted := by constructor

def singleton (x : k) (v : α) : OrdMap k α where
  vals := AssocList.cons x v AssocList.nil
  sorted := by repeat constructor

end defs

section OpWith

open Std.AssocList These

variable [LE k] [DecidableTotalOrder k]
variable (f : k → α → α → α)
variable (g : k → These α β → Option γ)

@[specialize]
def mergeWith (x : OrdMap k α) (y : OrdMap k β) : OrdMap k γ where
  vals := x.vals.zipWith g y.vals
  sorted := Sorted_zipWith _ x.sorted y.sorted

def unionWith :=
mergeWith (λ a => These.unionWith (f a))

def union : OrdMap k α → OrdMap k α → OrdMap k α :=
unionWith (λ a x _ => x)

variable (f : k → α → β → γ)

def intersectionWith :=
mergeWith (λ a => These.intersectionWith (f a))

def intersection : OrdMap k α → OrdMap k α → OrdMap k α :=
intersectionWith (λ a x _ => x)

variable (f : k → α → β → Option α)

def differenceWith : OrdMap k α → OrdMap k β → OrdMap k α :=
mergeWith (λ a => These.differenceWith (f a))

def difference : OrdMap k α → OrdMap k β → OrdMap k α :=
differenceWith λ a x _ => none

def insert (x : k) (v : α) : OrdMap k α → OrdMap k α :=
union (singleton x v)

def erase (x : k) : OrdMap k α → OrdMap k α :=
λ m => difference m (singleton x ())

end OpWith

section misc
variable [LT k]

def foldl (f : β → k → α → β) (x₀ : β) (m : OrdMap k α) : β :=
m.vals.foldl f x₀

variable [BEq k]

def find? (x : k) (m : OrdMap k α) : Option α :=
m.vals.find? x

end misc

section thms
variable [LE k] [DecidableTotalOrder k]

variable (x y : OrdMap k α)
-- variable

theorem ext
        (h : ∀ i, x.find? i = y.find? i) :
  x = y := sorry

variable (y : OrdMap k β)

@[simp]
theorem find?_merge (f : k → These α β → Option γ) :
  (mergeWith f x y).find? i =
  Option.mergeWith (f i) (x.find? i) (y.find? i) :=
sorry

@[simp]
theorem find?_empty (i : k) : empty.find? i = @none α := sorry

-- @[simp]
-- theorem find?_singleton (i : k) : empty.find? i = @none α := sorry

end thms

end OrdMap


universe variable u
variable {α : Type u}
variable [comm_ring α]
variable [f : α → α]
variable [p : α → Prop]

/- Our first example is solved using congruence closure, and
   theory AC. It gets solved as soon as we introduce the hypothesis -/
lemma smt1 (a b c : α) : a = b → p (a + c) → p (c + b) :=
begin [smt]
  intros
end

/- The tactic performs unit propagation without performing CNF conversion,
   and propagates equivalences between propositions. -/
lemma smt2 (p q r : Prop) : p ∧ (q ∨ r) → (p ∧ q) ∨ (p ∧ r) :=
begin [smt]
  intros
end

#print smt1
#print smt2


import category_theory.limits.concrete_category

universes v u

open category_theory

namespace category_theory.limits

local attribute [instance] concrete_category.has_coe_to_fun concrete_category.has_coe_to_sort

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

section equalizer

lemma concrete.equalizer_ext {X Y : C} (f g : X ⟶ Y) [has_equalizer f g]
  [preserves_limit (parallel_pair f g) (forget C)] (x y : equalizer f g)
  (h : equalizer.ι f g x = equalizer.ι f g y) : x = y :=
begin
  apply concrete.limit_ext,
  rintros (a|a),
  { apply h },
  { rw [← limit.w (parallel_pair f g) walking_parallel_pair_hom.right,
    comp_apply, comp_apply, h] }
end

def concrete.equalizer_equiv_aux {X Y : C} (f g : X ⟶ Y) :
  (parallel_pair f g ⋙ forget C).sections ≃ { x : X // f x = g x } :=
{ to_fun := λ x, ⟨x.1 walking_parallel_pair.zero, begin
    have h1 := x.2 walking_parallel_pair_hom.left,
    have h2 := x.2 walking_parallel_pair_hom.right,
    dsimp at h1 h2,
    erw [h1, h2],
  end⟩,
  inv_fun := λ x,
  { val := λ j,
    match j with
    | walking_parallel_pair.zero := x.1
    | walking_parallel_pair.one := f x.1
    end,
    property := begin
      dsimp [functor.sections],
      rintros (a|a) (b|b) (f|f),
      { simp, },
      { refl },
      { exact x.2.symm },
      { simp },
    end },
  left_inv := begin
    rintros ⟨x,hx⟩,
    ext (a|a),
    { refl },
    { change _ = x _,
      rw ← hx walking_parallel_pair_hom.left,
      refl }
  end,
  right_inv := by { rintros ⟨_,_⟩, ext, refl } }

noncomputable
def concrete.equalizer_equiv {X Y : C} (f g : X ⟶ Y) [has_equalizer f g]
  [preserves_limit (parallel_pair f g) (forget C)] :
  ↥(equalizer f g) ≃ { x // f x = g x } :=
let h1 := limit.is_limit (parallel_pair f g),
    h2 := is_limit_of_preserves (forget C) h1,
    E := h2.cone_point_unique_up_to_iso (types.limit_cone_is_limit.{_ v} _) in
E.to_equiv.trans $ concrete.equalizer_equiv_aux _ _

@[simp]
lemma concrete.equalizer_equiv_apply {X Y : C} (f g : X ⟶ Y) [has_equalizer f g]
  [preserves_limit (parallel_pair f g) (forget C)] (x : equalizer f g):
  (concrete.equalizer_equiv f g x : X) = equalizer.ι f g x := rfl

end equalizer

end category_theory.limits