import geometry.manifold.instances.sphere
import to_mathlib.linear_algebra.finite_dimensional
import to_mathlib.analysis.inner_product_space.rotation
import global.gromov
import global.twist_one_jet_sec
-- import interactive_expr
-- set_option trace.filter_inst_type true

noncomputable theory

open metric finite_dimensional set function linear_map filter
open_locale manifold topology

section general

variables
{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']

{F : Type*} [normed_add_comm_group F] [normed_space ℝ F]
{G : Type*} [topological_space G] (J : model_with_corners ℝ F G)
(N : Type*) [topological_space N] [charted_space G N] [smooth_manifold_with_corners J N]

local notation `TM` := tangent_space I
local notation `TM'` := tangent_space I'
local notation `HJ` := model_prod (model_prod H H') (E →L[ℝ] E')
local notation `ψJ` := chart_at HJ

/-- A map between manifolds is an immersion if it is differentiable and its differential at
any point is injective. Note the formalized definition doesn't require differentiability.
If `f` is not differentiable at `m` then, by definition, `mfderiv I I' f m` is zero, which
is not injective unless the source dimension is zero, which implies differentiability. -/
def immersion (f : M → M') : Prop := ∀ m, injective (mfderiv I I' f m)

variables (M M')

/-- The relation of immersions for maps between two manifolds. -/
def immersion_rel : rel_mfld I M I' M' := {σ | injective σ.2}

variables {M M'}

@[simp] lemma mem_immersion_rel_iff {σ : one_jet_bundle I M I' M'} :
  σ ∈ immersion_rel I M I' M' ↔ injective (σ.2 : tangent_space I _ →L[ℝ] tangent_space I' _) :=
iff.rfl

/-- A characterisation of the immersion relation in terms of a local chart. -/
lemma mem_immersion_rel_iff' {σ σ' : one_jet_bundle I M I' M'} (hσ' : σ' ∈ (ψJ σ).source) :
  σ' ∈ immersion_rel I M I' M' ↔ injective (ψJ σ σ').2 :=
begin
  simp only [fiber_bundle.charted_space_chart_at] with mfld_simps at hσ',
  simp_rw [mem_immersion_rel_iff],
  rw [one_jet_bundle_chart_at_apply', in_coordinates'_eq],
  simp_rw [continuous_linear_map.coe_comp', continuous_linear_equiv.coe_coe,
    equiv_like.comp_injective, equiv_like.injective_comp],
  exacts [hσ'.1.1, hσ'.1.2],
end

lemma chart_at_image_immersion_rel_eq {σ : one_jet_bundle I M I' M'} :
  (ψJ σ) '' ((ψJ σ).source ∩ immersion_rel I M I' M') = (ψJ σ).target ∩ {q : HJ | injective q.2} :=
local_equiv.is_image.image_eq $ λ σ' hσ', (mem_immersion_rel_iff' I I' hσ').symm

variables [finite_dimensional ℝ E] [finite_dimensional ℝ E']

lemma immersion_rel_open :
  is_open (immersion_rel I M I' M') :=
begin
  simp_rw [charted_space.is_open_iff HJ (immersion_rel I M I' M'), chart_at_image_immersion_rel_eq],
  refine λ σ, (ψJ σ).open_target.inter _,
  convert is_open_univ.prod continuous_linear_map.is_open_injective,
  { ext, simp, },
  { apply_instance, },
  { apply_instance, },
end

@[simp] lemma immersion_rel_slice_eq {m : M} {m' : M'} {p : dual_pair $ tangent_space I m}
  {φ : tangent_space I m →L[ℝ] tangent_space I' m'} (hφ : injective φ) :
  (immersion_rel I M I' M').slice ⟨(m, m'), φ⟩ p = ((ker p.π).map φ)ᶜ :=
set.ext_iff.mpr $ λ w, p.injective_update_iff hφ

lemma immersion_rel_ample (h : finrank ℝ E < finrank ℝ E') :
  (immersion_rel I M I' M').ample :=
begin
  rw [rel_mfld.ample_iff],
  rintros ⟨⟨m, m'⟩, φ : tangent_space I m →L[ℝ] tangent_space I' m'⟩
          (p : dual_pair (tangent_space I m)) (hφ : injective φ),
  haveI : finite_dimensional ℝ (tangent_space I m) := (by apply_instance : finite_dimensional ℝ E),
  have hcodim := two_le_rank_of_rank_lt_rank p.ker_pi_ne_top h φ.to_linear_map,
  rw [immersion_rel_slice_eq I I' hφ],
  exact ample_of_two_le_codim hcodim,
end

/-- This is lemma `lem:open_ample_immersion` from the blueprint. -/
lemma immersion_rel_open_ample (h : finrank ℝ E < finrank ℝ E') :
  is_open (immersion_rel I M I' M') ∧ (immersion_rel I M I' M').ample :=
⟨immersion_rel_open I I', immersion_rel_ample I I' h⟩

end general

section generalbis

variables
{E : Type*} [normed_add_comm_group E] [normed_space ℝ E] [finite_dimensional ℝ E]
{H : Type*} [topological_space H] (I : model_with_corners ℝ E H) [model_with_corners.boundaryless I]
{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'] [finite_dimensional ℝ E']
{H' : Type*} [topological_space H'] (I' : model_with_corners ℝ E' H') [model_with_corners.boundaryless I']
{M' : Type*} [metric_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M']

variables [finite_dimensional ℝ E] [finite_dimensional ℝ E']

variables
  {EP : Type*} [normed_add_comm_group EP] [normed_space ℝ EP] [finite_dimensional ℝ EP]
  {HP : Type*} [topological_space HP] {IP : model_with_corners ℝ EP HP} [model_with_corners.boundaryless IP]
  {P : Type*} [topological_space P] [charted_space HP P] [smooth_manifold_with_corners IP P]
  {C : set (P × M)} {ε : M → ℝ}

include I I' M' IP

variables (I M I' M' IP P)

/-- parametric h-principle for immersions. -/
theorem immersion_rel_satisfies_h_principle_with
  [nonempty P] [t2_space P] [sigma_compact_space P] [locally_compact_space P]
  [nonempty M] [t2_space M] [sigma_compact_space M] [locally_compact_space M]
  [nonempty M'] [t2_space M'] [locally_compact_space M'] [sigma_compact_space M']
  (h : finrank ℝ E < finrank ℝ E') (hC : is_closed C)
  (hε_pos : ∀ x, 0 < ε x) (hε_cont : continuous ε) :
  (immersion_rel I M I' M').satisfies_h_principle_with IP C ε :=
by exact (immersion_rel_ample I I' h).satisfies_h_principle_with (immersion_rel_open I I')
     hC hε_pos hε_cont

end generalbis

section sphere_eversion

variables (E : Type*) [normed_add_comm_group E] [inner_product_space ℝ E] [fact (finrank ℝ E = 3)]

local attribute [instance] fact_finite_dimensional_of_finrank_eq_succ

local notation `𝕊²` := sphere (0 : E) 1

/- Maybe the next two lemmas won't be used directly, but they should be done first as
sanity checks. -/

lemma immersion_inclusion_sphere : immersion (𝓡 2) 𝓘(ℝ, E) (λ x : 𝕊², (x : E)) :=
mfderiv_coe_sphere_injective

lemma immersion_antipodal_sphere : immersion (𝓡 2) 𝓘(ℝ, E) (λ x : 𝕊², -(x : E)) :=
begin
  intros x,
  change injective (mfderiv (𝓡 2) 𝓘(ℝ, E) (-(λ x : 𝕊², (x:E))) x),
  rw mfderiv_neg,
  exact neg_injective.comp (mfderiv_coe_sphere_injective x),
end

/- The relation of immersion of a two-sphere into its ambient Euclidean space. -/
local notation `𝓡_imm` := immersion_rel (𝓡 2) 𝕊² 𝓘(ℝ, E) E

variables (ω : orientation ℝ E (fin 3))

lemma smooth_bs :
  smooth (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, E)
    (λ p : ℝ × 𝕊², ((1-p.1) • p.2 + p.1 • (-p.2) : E)) :=
begin
  refine (cont_mdiff.smul _ _).add (cont_mdiff_fst.smul _),
  { exact (cont_diff_const.sub cont_diff_id).cont_mdiff.comp cont_mdiff_fst },
  { exact cont_mdiff_coe_sphere.comp cont_mdiff_snd },
  { exact (cont_diff_neg.cont_mdiff.comp cont_mdiff_coe_sphere).comp cont_mdiff_snd },
end

def formal_eversion_aux : family_one_jet_sec (𝓡 2) 𝕊² 𝓘(ℝ, E) E 𝓘(ℝ, ℝ) ℝ :=
family_join
  (smooth_bs E) $
  family_twist
    (drop (one_jet_ext_sec ⟨(coe : 𝕊² → E), cont_mdiff_coe_sphere⟩))
    (λ p : ℝ × 𝕊², ω.rot (p.1, p.2))
    begin
      intros p,
      have : smooth_at (𝓘(ℝ, ℝ × E)) 𝓘(ℝ, E →L[ℝ] E) ω.rot (p.1, p.2),
      { refine (ω.cont_diff_rot _).cont_mdiff_at,
        exact ne_zero_of_mem_unit_sphere p.2 },
      refine this.comp p (smooth.smooth_at _),
      exact smooth_fst.prod_mk (cont_mdiff_coe_sphere.comp smooth_snd),
    end

/-- A formal eversion of a two-sphere into its ambient Euclidean space. -/
def formal_eversion_aux2 : htpy_formal_sol 𝓡_imm :=
{ is_sol' := λ t x, (ω.isometry_rot t x).injective.comp (mfderiv_coe_sphere_injective x),
  .. formal_eversion_aux E ω }

def formal_eversion : htpy_formal_sol 𝓡_imm :=
(formal_eversion_aux2 E ω).reindex ⟨smooth_step, cont_mdiff_iff_cont_diff.mpr smooth_step.smooth⟩

@[simp]
lemma formal_eversion_bs (t : ℝ) : (formal_eversion E ω t).bs =
  λ x : 𝕊², (1 - smooth_step t : ℝ) • (x : E) + (smooth_step t : ℝ) • (-x : E) :=
rfl

lemma formal_eversion_zero (x : 𝕊²) : (formal_eversion E ω 0).bs x = x :=
by simp

lemma formal_eversion_one (x : 𝕊²) : (formal_eversion E ω 1).bs x = -x :=
by simp

lemma formal_eversion_hol_at_zero {t : ℝ} (ht : t < 1/4) :
  (formal_eversion E ω t).to_one_jet_sec.is_holonomic :=
begin
  intros x,
  change mfderiv (𝓡 2) 𝓘(ℝ, E) (λ y : 𝕊², ((1 : ℝ) - smooth_step t) • (y:E) + smooth_step t • -y) x
    = (ω.rot (smooth_step t, x)).comp (mfderiv (𝓡 2) 𝓘(ℝ, E) (λ y : 𝕊², (y:E)) x),
  simp_rw [smooth_step.of_lt ht, ω.rot_zero, continuous_linear_map.id_comp],
  congr,
  ext y,
  simp [smooth_step.of_lt ht],
end

lemma formal_eversion_hol_at_one {t : ℝ} (ht : 3/4 < t) :
  (formal_eversion E ω t).to_one_jet_sec.is_holonomic :=
begin
  intros x,
  change mfderiv (𝓡 2) 𝓘(ℝ, E) (λ y : 𝕊², ((1:ℝ) - smooth_step t) • (y:E) + smooth_step t • -y) x
    = (ω.rot (smooth_step t, x)).comp (mfderiv (𝓡 2) 𝓘(ℝ, E) (λ y : 𝕊², (y:E)) x),
  transitivity mfderiv (𝓡 2) 𝓘(ℝ, E) (-(λ y : 𝕊², (y:E))) x,
  { congr' 2,
    ext y,
    simp [smooth_step.of_gt ht], },
  ext v,
  simp_rw [mfderiv_neg, continuous_linear_map.coe_comp', comp_app, continuous_linear_map.neg_apply,
    smooth_step.of_gt ht],
  rw [ω.rot_one],
  rw [← range_mfderiv_coe_sphere x],
  exact linear_map.mem_range_self _ _,
end

lemma formal_eversion_hol_near_zero_one : ∀ᶠ (s : ℝ × 𝕊²) near {0, 1} ×ˢ univ,
  (formal_eversion E ω s.1).to_one_jet_sec.is_holonomic_at s.2 :=
begin
  have : (Iio (1/4 : ℝ) ∪ Ioi (3/4)) ×ˢ (univ : set 𝕊²) ∈ 𝓝ˢ (({0, 1} : set ℝ) ×ˢ univ),
  { refine ((is_open_Iio.union is_open_Ioi).prod is_open_univ).mem_nhds_set.mpr _,
    rintro ⟨s, x⟩ ⟨hs, hx⟩,
    refine ⟨_, mem_univ _⟩,
    simp_rw [mem_insert_iff, mem_singleton_iff] at hs,
    rcases hs with rfl|rfl,
    { exact or.inl (show (0 : ℝ) < 1 / 4, by norm_num) },
    { exact or.inr (show (3 / 4 : ℝ) < 1, by norm_num) } },
  refine eventually_of_mem this _,
  rintro ⟨t, x⟩ ⟨ht|ht, hx⟩,
  { exact formal_eversion_hol_at_zero E ω ht x },
  { exact formal_eversion_hol_at_one E ω ht x }
end

theorem sphere_eversion : ∃ f : ℝ → 𝕊² → E,
  (cont_mdiff (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, E) ∞ (uncurry f)) ∧
  (f 0 = λ x, x) ∧
  (f 1 = λ x, -x) ∧
  ∀ t, immersion (𝓡 2) 𝓘(ℝ, E) (f t) :=
begin
  classical,
  let ω : orientation ℝ E (fin 3) :=
    ((std_orthonormal_basis _ _).reindex $ fin_congr (fact.out _ : finrank ℝ E = 3)).to_basis.orientation,
  have rankE := fact.out (finrank ℝ E = 3),
  haveI : finite_dimensional ℝ E :=
    finite_dimensional_of_finrank_eq_succ rankE,
  have ineq_rank : finrank ℝ (euclidean_space ℝ (fin 2)) < finrank ℝ E := by simp [rankE],
  let ε : 𝕊² → ℝ := λ x, 1,
  have hε_pos : ∀ x, 0 < ε x,
    from λ x, zero_lt_one,
  have hε_cont : continuous ε := continuous_const,
  haveI : nontrivial E := nontrivial_of_finrank_eq_succ (fact.out _ : finrank ℝ E = 3),
  haveI : nonempty ↥(sphere 0 1 : set E) :=
    (normed_space.sphere_nonempty.mpr zero_le_one).to_subtype,
  rcases (immersion_rel_satisfies_h_principle_with (𝓡 2) 𝕊² 𝓘(ℝ, E) E 𝓘(ℝ, ℝ) ℝ ineq_rank
    ((finite.is_closed (by simp : ({0, 1} : set ℝ).finite)).prod is_closed_univ) hε_pos hε_cont).bs
    (formal_eversion E ω) (formal_eversion_hol_near_zero_one E ω) with ⟨f, h₁, h₂, -, h₅⟩,
  have := h₂.nhds_set_forall_mem,
  refine ⟨f, h₁, _, _, h₅⟩,
  { ext x,
    rw [this (0, x) (by simp)],
    convert formal_eversion_zero E ω x },
  { ext x,
    rw [this (1, x) (by simp)],
    convert formal_eversion_one E ω x },
end

-- The next instance will be used in the main file
instance (n : ℕ) : fact (finrank ℝ (euclidean_space ℝ $ fin n) = n) :=
⟨finrank_euclidean_space_fin⟩

-- The next notation will be used in the main file
notation `ℝ^`n:max := euclidean_space ℝ (fin n)
end sphere_eversion


import tactic
import logic.basic
import category.serial
import category.liftable
import category.liftable.serial

universes u v

inductive put_m' (α : Type u)
| pure : α → put_m'
| write : unsigned → (unit → put_m') → put_m'

def put_m'.bind {α β} : put_m' α → (α → put_m' β) → put_m' β
| (put_m'.pure x)   f := f x
| (put_m'.write w f) g := put_m'.write w $ λ u, put_m'.bind (f u) g

instance : monad put_m' :=
{ pure := λ α, put_m'.pure
, bind := @put_m'.bind }

instance : is_lawful_monad put_m' :=
by { refine { .. }; intros;
       try { refl };
       induction x;
       try { refl };
     { dsimp [put_m'.bind] at *, congr, simp * } }

@[reducible]
def put_m := put_m' punit

def put_m.eval : put_m → list unsigned
| (put_m'.pure x) := []
| (put_m'.write w f) := w :: put_m.eval (f punit.star)

inductive get_m : Type u → Type (u+1)
| fail {α} : get_m α
| pure {α} : α → get_m α
| read {α} : (unsigned → get_m α) → get_m α
| loop {α β γ : Type u} : (β → unsigned → get_m (α ⊕ β)) → (α → get_m γ) → β → get_m γ

def get_m.bind : Π {α β}, get_m α → (α → get_m β) → get_m β
| _ _ (get_m.fail) _ := get_m.fail
| _ _ (get_m.pure x)   f := f x
| _ _ (get_m.read f) g := get_m.read $ λ w, get_m.bind (f w) g
| _ _ (get_m.loop f g x₀) h := get_m.loop f (λ r, get_m.bind (g r) h) x₀

def get_m.map : Π {α β : Type u}, (α → β) → get_m α → get_m β
| _ _ _ (get_m.fail) := get_m.fail
| _ _ f (get_m.pure x) := get_m.pure $ f x
| _ _ f (get_m.read g) := get_m.read $ λ w, get_m.map f (g w)
| _ _ h (get_m.loop f g x₀) := get_m.loop f (λ r, get_m.map h (g r)) x₀

instance : functor get_m.{u} :=
{ map := @get_m.map }

def get_m.seq {α β : Type u} : Π (f : get_m (α → β)) (x : get_m α), get_m β :=
λ (f : get_m (α → β)) (x : get_m α), get_m.bind f (λ f, f <$> x)

-- instance : applicative get_m :=
-- { to_functor := get_m.functor
-- , pure := λ α, get_m.pure
-- , seq := @get_m.seq }
open function

instance : is_lawful_functor.{u} get_m :=
by { constructor; intros;
     dsimp [(<$>),get_m.seq];
     induction x;
     try { refl };
     simp [get_m.map,*]; ext }

instance : monad get_m :=
{ to_functor := get_m.functor
, pure := @get_m.pure
, bind := @get_m.bind }

instance : is_lawful_monad get_m.{u} :=
{ to_is_lawful_functor := get_m.is_lawful_functor,
  bind_assoc := by { intros, dsimp [(>>=)],
                     induction x; try { refl }; simp [get_m.bind,*], },
  bind_pure_comp_eq_map := by { intros, dsimp [(>>=),(<$>)],
                                induction x; try {refl}; simp [get_m.bind,get_m.map,*], },
  map_pure := by intros; refl,
  pure_seq_eq_map := by { intros, dsimp [(>>=),(<$>)],
                          induction x; try {refl}; simp [get_m.bind,get_m.map,*], },
  pure_bind := by intros; refl }

def get_m.eval {α} : list unsigned → get_m α → option α
| [] (get_m.pure x) := pure x
| [] _  := none
| (w :: ws) (get_m.read f) := get_m.eval ws (f w)
| (w :: ws) (get_m.loop f g x₀) :=
  get_m.eval ws $
  f x₀ w >>= @sum.rec _ _ (λ _, get_m α) g (get_m.loop f g)
| (w :: ws) _ := none

def read_write : Π {α}, get_m.{u} α → put_m.{u} → option α
| ._ (get_m.pure x) (put_m'.pure _) := some x
| _ _ (put_m'.pure _) := none
| ._ (get_m.read f) (put_m'.write w g) := read_write (f w) (g punit.star)
| α (@get_m.loop α' β γ f g x₀) (put_m'.write w h) :=
  read_write
    (f x₀ w >>= @sum.rec α' β (λ _, get_m α) g (get_m.loop f g))
    (h punit.star)
| _ _ (put_m'.write w g) := none

def read_write' : Π {α}, get_m α → put_m → option (α × put_m)
| _ (get_m.read f) (put_m'.write w g) := read_write' (f w) (g punit.star)
| α (@get_m.loop α' β γ f g x₀) (put_m'.write w h) :=
  read_write'
    (f x₀ w >>= @sum.rec α' β (λ _, get_m α) g (get_m.loop f g))
    (h punit.star)
-- | _ (get_m.pure x) m@(put_m'.write w g) := some (x,m)
| _ (get_m.pure x) m := some (x,m)
| _ _ (put_m'.pure _) := none
| _ (get_m.fail) (put_m'.write _ _) := none
-- | _ _ m := none

lemma read_read_write_write {α} (x : get_m α) (m : put_m) (i : α) :
  read_write x m = some i ↔ read_write' x m = some (i,pure punit.star) :=
begin
  induction m generalizing x;
  cases x; casesm* punit; simp [read_write,read_write',prod.ext_iff,pure,*],
end

def pipeline {α} (x : get_m α) (y : α → put_m) (i : α) : option α :=
read_write x (y i)

infix ` -<< `:60  := read_write
infix ` -<<< `:60  := read_write'
infix ` <-< `:60  := pipeline

lemma eq_star (x : punit) : x = punit.star :=
by cases x; refl

-- inductive agree : Π {α} (x : α), get_m α → put_m → put_m → Prop
-- | pure {α} (x : α) (m : put_m) : agree x (get_m.pure x) m m
-- | read_write {α} (x : α) (w : unsigned)
--   (f : unsigned → get_m α) (g : punit → put_m) (m : put_m) :
--   agree x (f w) (g punit.star) m →
--   agree x (get_m.read f) (put_m'.write w g) m
-- | loop_write {α} (x : α) {β γ} (σ₀ σ₁ : β) (w : unsigned)
--   (f : β → unsigned → get_m (γ ⊕ β)) (f' : γ → get_m α)
--   (g : punit → put_m) (m m' : put_m) :
--   agree (sum.inr σ₁) (f σ₀ w) (g punit.star) m' →
--   agree x (get_m.loop σ₁ f f') m' m →
--   agree x (get_m.loop σ₀ f f') (put_m'.write w g) m
-- | loop_exit_write {α} (x : α) {β γ} (σ₀ : β) (r : γ) (w : unsigned)
--   (f : β → unsigned → get_m (γ ⊕ β)) (f' : γ → get_m α)
--   (g : punit → put_m) (m m' : put_m) :
--   agree (sum.inl r) (f σ₀ w) (g punit.star) m' →
--   agree x (f' r) m' m →
--   agree x (get_m.loop σ₀ f f') (put_m'.write w g) m

-- lemma agree_spec {α} (g : get_m α) (m : put_m) (x : α) :
--   agree x g m (put_m'.pure punit.star) ↔ g -<< m = some x :=
-- begin
--   split; intro h,
--   { cases h,
--     refl, simp [read_write], }
-- end

-- lemma loop_bind {α β γ} (i : β)
--       (body : β → unsigned → get_m (α ⊕ β)) (f₀ : α → get_m γ) :
--   get_m.loop i body f₀ = get_m.read (body i) >>= _ := _

lemma read_write_loop_bind {α β γ φ : Type u} (i : α)
      (body : α → unsigned → get_m (φ ⊕ α))
      (f₀ : φ → get_m β) (f₁ : β → get_m γ)
      (m : punit → put_m) (w : unsigned) :
  (get_m.loop body f₀ i >>= f₁) -<<< put_m'.write w m =
  (body i w >>= @sum.rec φ α (λ _, get_m β) f₀ (get_m.loop body f₀) >>= f₁) -<<< m punit.star :=
begin
  rw bind_assoc,
  simp [(>>=),get_m.bind,read_write'],
  congr, ext, cases x; simp; refl,
end

-- lemma read_write_left_overs_bind {α} (i : α)
--       (x₀ : get_m α)
--       (x₁ x₂ : put_m) :
-- x₀ -<<< x₁ = some (i,x₂) →

lemma fail_read_write {α} (x₁ : put_m) :
  get_m.fail -<<< x₁ = @none (α × put_m) :=
by cases x₁; refl

lemma pure_read_write {α} (x₁ : put_m) (i : α) :
  get_m.pure i -<<< x₁ = some (i, x₁) :=
by cases x₁; refl

lemma read_write_left_overs_bind {α} (f : punit → put_m) (i : α)
      (x₀ : get_m α)
      (x₁ x₂ : put_m) :
  x₀ -<<< x₁ = some (i,x₂) → x₀ -<<< (x₁ >>= f) = some (i,x₂ >>= f) :=
begin
  induction x₁ generalizing x₀ x₂,
  cases x₀; simp [(>>=),put_m'.bind,read_write',pure_read_write],
  { intros, subst x₂, tauto },
  cases x₀; simp [(>>=),put_m'.bind,read_write'],
  { intros, substs x₂ i, split; refl },
  { apply x₁_ih, },
  { apply x₁_ih, },
end

lemma option_eq_forall_some {α} (x y : option α) :
  x = y ↔ ∀ z, x = some z ↔ y = some z :=
begin
  split; intro h, { rw h; intro, refl },
  { cases y, cases x, refl,
    symmetry, rw ← h, rw h, },
end

lemma read_write_weakening {α}
  (x₀ x₁ : put_m) (y₀ y₁ : get_m α)
  (h : y₀ -<<< x₀ = y₁ -<<< x₁) :
  y₀ -<< x₀ = y₁ -<< x₁ :=
begin
  rw option_eq_forall_some,
  intro, simp [read_read_write_write,h],
end

lemma read_write_mono' {α β} (i : α)
      (x₀ : get_m α) (f₀ : α → get_m β)
      (x₁ x₂ : put_m)
      (h : x₀ -<<< x₁ = some (i,x₂)) :
  (x₀ >>= f₀) -<<< x₁ = f₀ i -<<< x₂ :=
begin
  -- simp [(>>=)],
  induction x₁ generalizing x₀ f₀;
    try { cases x₀; cases h },
  { simp [(>>=),read_write',get_m.bind] },
  { cases x₀; try { cases h },
    simp [(>>=),read_write',get_m.bind] at h ⊢,
    simp [(>>=),read_write',get_m.bind] at h ⊢,
    { apply x₁_ih, assumption },
    simp [read_write_loop_bind,x₁_ih],
    rw [x₁_ih _ _ _ h], }
end

lemma read_write_mono {α β} {i : α}
      {x₀ : get_m α} {f₀ : α → get_m β}
      {x₁ : put_m} {f₁ : punit → put_m}
      (h : x₀ -<< x₁ = some i) :
  (x₀ >>= f₀) -<< (x₁ >>= f₁) = f₀ i -<< f₁ punit.star :=
begin
  apply read_write_weakening,
  apply read_write_mono',
  rw [read_read_write_write] at h,
  replace h := read_write_left_overs_bind f₁ _ _ _ _ h,
  simp [h],
end

lemma read_write_mono_left {α β} {i : α}
      {x₀ : get_m α} {f₀ : α → get_m β}
      {x₁ : put_m}
      (h : x₀ -<< x₁ = some i) :
  (x₀ >>= f₀) -<< x₁ = f₀ i -<< pure punit.star :=
by rw ← read_write_mono h; simp

lemma read_write_eq_eval_eval {α}
      (x₀ : get_m α) (x₁ : put_m)  :
  x₀ -<< x₁ = x₀.eval x₁.eval :=
begin
  induction x₁ generalizing x₀; cases x₀; try { refl },
  simp! [*,read_write],
  simp! [*,read_write],
end
open ulift

lemma get_m.fold_bind {α β} (x : get_m α) (f : α → get_m β) :
  get_m.bind x f = x >>= f := rfl

lemma map_read_write {α β} (f : α → β) (x : get_m α) (y : put_m) :
  (f <$> x) -<< y = f <$> (x -<< y) :=
begin
  rw [← bind_pure_comp_eq_map,← bind_pure_comp_eq_map],
  symmetry,
  simp [(>>=)],
  induction y generalizing x,
  { cases x; refl },
  { cases x; simp [read_write]; try { refl };
    simp [get_m.bind,read_write,y_ih],
    congr' 1, cases h : x_a x_a_2 y_a, refl,
    cases a; refl,
    dsimp [(>>=),get_m.bind],
    congr, ext, simp [get_m.fold_bind],
    rw bind_assoc, congr, ext z, cases z; refl,
    simp [get_m.fold_bind], rw bind_assoc, congr, ext x,
    cases x; refl, }
end

def sum_ulift (α β : Type u) : (α ⊕ β) ≃ (ulift.{v} α ⊕ ulift.{v} β) :=
(equiv.sum_congr equiv.ulift.symm equiv.ulift.symm)

-- def get_m.up : Π {α : Type u} {β : Type.{max u v}} (Heq : α ≃ β), get_m α → get_m β
-- | _ _ Heq (get_m.pure x) := get_m.pure $ Heq x
-- | _ _ Heq (get_m.fail) := get_m.fail
-- | _ _ Heq (get_m.read f) := get_m.read (λ w, get_m.up Heq (f w))
-- | _ β' Heq (@get_m.loop α β γ f g x) :=
--   get_m.loop
--     (λ a b, get_m.up (sum_ulift α β) (f (down.{v} a) b))
--     (λ w, get_m.up Heq (g $ down w))
--     (up.{v} x)

def get_m.up : Π {α : Type u} {β : Type.{max u v}} (Heq : α → β), get_m α → get_m β :=
λ α β f x, (@get_m.rec_on (λ α _, Π β, (α → β) → get_m β) α x
(λ α β f, get_m.fail)
(λ α x β f, get_m.pure $ f x)
(λ α next get_m_up β f, get_m.read $ λ w, get_m_up w _ f)
(λ α β γ body rest x₀ get_m_up₀ get_m_up₁ β' f,
  get_m.loop
    (λ a b, get_m_up₀ (down a) b (ulift.{v} α ⊕ ulift.{v} β)
                     (sum_ulift α β))
    (λ r, get_m_up₁ (down r) _ f)
    (up x₀)) β f)

section eqns

variables {α β' γ : Type u} {β : Type.{max u v}} (Heq : α → β) (x : get_m α)

variables {i : α} {f : unsigned → get_m α}
variables {f' : β' → unsigned → get_m (γ ⊕ β')}
variables {g' : γ → get_m α} {j : β'}

@[simp] lemma get_m.up.eqn_1 : get_m.up Heq (get_m.pure i) = get_m.pure (Heq i) := rfl
@[simp] lemma get_m.up.eqn_2 : get_m.up Heq (get_m.fail) = get_m.fail := rfl
@[simp] lemma get_m.up.eqn_3 : get_m.up Heq (get_m.read f) = get_m.read (λ w, get_m.up Heq (f w)) := rfl
@[simp] lemma get_m.up.eqn_4 :
  get_m.up Heq (get_m.loop f' g' j) =
  get_m.loop
    (λ a b, get_m.up (sum_ulift γ β') (f' (down.{v} a) b))
    (λ w, get_m.up Heq (g' $ down w))
    (up.{v} j) := rfl

end eqns

def put_m.up {α : Type u} {β : Type v} (Heq : α → β) : put_m' α → put_m' β
| (put_m'.pure x) := put_m'.pure $ Heq x
| (put_m'.write w f) := put_m'.write w $ λ u, put_m.up $ f u

instance : liftable1 put_m'.{u} put_m'.{v} :=
{ up := λ α β (eq : α ≃ β) x, put_m.up eq x
, down := λ α β (eq : α ≃ β) x, put_m.up eq.symm x
, down_up := by intros; induction x; simp [put_m.up,*]
, up_down := by intros; induction x; simp [put_m.up,*]  }

open pliftable (up')

lemma up_bind {α β : Type u} {β' : Type (max u v)} (x : get_m α) (g : α → get_m β) (f : β → β') :
  (x >>= g).up f = x.up up.{v} >>= (λ i : ulift α, (g $ down i).up f) :=
begin
  dsimp [(>>=)],
  induction x generalizing f g; try { refl };
    simp [get_m.bind,*]
end

lemma equiv_bind {m} [monad m] [is_lawful_monad m] {α α' β}
  (Heq : α ≃ α') (x : m α) (f : α → m β) :
  x >>= f = (Heq <$> x) >>= f ∘ Heq.symm :=
by simp [(∘)] with functor_norm

def sum.map {α α' β β'} (f : α → α') (g : β → β') : α ⊕ β → α' ⊕ β'
| (sum.inr x) := sum.inr $ g x
| (sum.inl x) := sum.inl $ f x

def equiv.ulift_sum {α β} : (ulift $ α ⊕ β) ≃ (ulift α ⊕ ulift β) :=
{ to_fun := λ x, sum.map up up (down x),
  inv_fun := λ x, up $ sum.map down down x,
  right_inv := by intro; casesm* [_ ⊕ _,ulift _]; refl,
  left_inv := by intro; casesm* [_ ⊕ _,ulift _]; refl }

lemma map_get_m_up {α : Type u} {β γ} (x : get_m α) (f : α → β) (g : β → γ) :
  g <$> get_m.up f x = get_m.up (g ∘ f) x :=
begin
  dsimp [(<$>)],
  induction x; simp [get_m.map,*]; refl,
end

lemma up_read_write {α : Type u} {α' : Type (max u v)} (x : get_m α) (y : put_m) (f : α ≃ α') :
  x.up f -<< up' y = liftable1.up f (x -<< y) :=
begin
  dsimp [up',liftable1.up],
  induction y generalizing x f,
  cases x; simp; refl,
  cases x; simp [up',liftable.up',liftable1.up,read_write,put_m.up,*], refl, refl, refl,
  rw [read_write,← y_ih,up_bind],
    apply congr,
    { apply congr_arg, rw equiv_bind (@equiv.ulift_sum.{u u v v v} x_α x_β) ,
      congr,
      { rw map_get_m_up, congr, ext, cases x; refl },
      simp [(∘)], ext, cases x;
      dsimp [equiv.ulift_sum,sum.map], refl,
      cases x, refl, apply_instance },
    congr,
end

lemma up_read_write' {α : Type u} {α' : Type (max u v)}
  {x : get_m α} {y : put_m} (f : α → α') (f' : α ≃ α')
  (h : ∀ i, f i = f' i) :
  x.up f -<< up' y = liftable1.up f' (x -<< y) :=
begin
  rw ← up_read_write, congr, ext, apply h
end


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.omega.coeffs
import Mathlib.PostPort

namespace Mathlib

/-
Normalized linear integer arithmetic terms.
-/

namespace omega

/-- Shadow syntax of normalized terms. The first element
    represents the constant term and the list represents
    the coefficients. -/
def term :=
  ℤ × List ℤ

namespace term

/-- Evaluate a term using the valuation v. -/
@[simp] def val (v : ℕ → ℤ) : term → ℤ :=
  sorry

@[simp] def neg : term → term :=
  sorry

@[simp] def add : term → term → term :=
  sorry

@[simp] def sub : term → term → term :=
  sorry

@[simp] def mul (i : ℤ) : term → term :=
  sorry

@[simp] def div (i : ℤ) : term → term :=
  sorry

theorem val_neg {v : ℕ → ℤ} {t : term} : val v (neg t) = -val v t := sorry

@[simp] theorem val_sub {v : ℕ → ℤ} {t1 : term} {t2 : term} : val v (sub t1 t2) = val v t1 - val v t2 := sorry

@[simp] theorem val_add {v : ℕ → ℤ} {t1 : term} {t2 : term} : val v (add t1 t2) = val v t1 + val v t2 := sorry

@[simp] theorem val_mul {v : ℕ → ℤ} {i : ℤ} {t : term} : val v (mul i t) = i * val v t := sorry

theorem val_div {v : ℕ → ℤ} {i : ℤ} {b : ℤ} {as : List ℤ} : i ∣ b → (∀ (x : ℤ), x ∈ as → i ∣ x) → val v (div i (b, as)) = val v (b, as) / i := sorry

/-- Fresh de Brujin index not used by any variable ocurring in the term -/
def fresh_index (t : term) : ℕ :=
  list.length (prod.snd t)

def to_string (t : term) : string :=
  list.foldr (fun (_x : ℕ × ℤ) => sorry) (to_string (prod.fst t)) (list.enum (prod.snd t))

protected instance has_to_string : has_to_string term :=
  has_to_string.mk to_string

end term

/-- Fresh de Brujin index not used by any variable ocurring in the list of terms -/
def terms.fresh_index : List term → ℕ :=
  sorry


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
  -- 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.
  assume h1 : G.colorable 2,
  -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
  have h2 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h1],
  -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
  have h3 : ∀ (v w : V), v ∈ A ∧ w ∈ A → ¬ G.adj v w, from by auto [h2],
  have h4 : ∀ (v w : V), v ∈ B ∧ w ∈ B → ¬ G.adj v w, from by auto [h2],
  -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
  have h5 : ∀ (v w : V), G.adj v w → (v ∈ A ∧ w ∈ B) ∨ (v ∈ B ∧ w ∈ A), from by auto [h2, h3, h4],
  have h6 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h7 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h8 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h9 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h10 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h11 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h12 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h13 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h14 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h15 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h16 : ∃ (A B : set V), (∀ (v : V), v ∈ A ∨ v ∈ B) ∧ (∀ (v : V), v ∈ A → ¬ v ∈ B) ∧ (∀ (v : V), v ∈ B → ¬ v ∈ A) ∧ (∀ (v w : V), v ∈ A ∧ w ∈ B → G.adj v w) ∧ (∀ (v w : V), v ∈ B ∧ w ∈ A → G.adj v w), from by auto [h2],
  have h17 : ∃ (A B : set V), (∀ (v : V), v
end --Needs more than 2000 tokens!

--OUTPUT 2
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
  -- 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.
  have h1 : (G.colorable 2) → (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from
  begin
    assume h2 : (G.colorable 2),
    -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
    have h3 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
    begin
      -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
      have h4 : ∀ (A B : Type*) (h : (A ⊕ B) = V), (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) → (∀ (a b : A), ¬ (G.adj a b)), from
      begin
        assume (A B : Type*) (h : (A ⊕ B) = V) (h5 : (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B))),
        assume (a b : A),
        assume h6 : (G.adj a b),
        have h7 : (cast (congr_arg _ h) (complete_bipartite_graph A B)).adj a b, from by auto [h5, h6],
        have h8 : (complete_bipartite_graph A B).adj a b, from by auto [h7, cast_adj],
        have h9 : (complete_bipartite_graph A B).adj a b = ff, from by auto [complete_bipartite_graph.adj_iff],
        have h10 : ff = ff, from by auto [h9, h8],
        show false, from by auto [h10],
      end,
      have h11 : ∀ (A B : Type*) (h : (A ⊕ B) = V), (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) → (∀ (a b : B), ¬ (G.adj a b)), from
      begin
        assume (A B : Type*) (h : (A ⊕ B) = V) (h12 : (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B))),
        assume (a b : B),
        assume h13 : (G.adj a b),
        have h14 : (cast (congr_arg _ h) (complete_bipartite_graph A B)).adj a b, from by auto [h12, h13],
        have h15 : (complete_bipartite_graph A B).adj a b, from by auto [h14, cast_adj],
        have h16 : (complete_bipartite_graph A B).adj a b = ff, from by auto [complete_bipartite_graph.adj_iff],
        have h17 : ff = ff, from by auto [h16, h15],
        show false, from by auto [h17],
      end,
      -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
      have h18 : ∀ (A B : Type*) (h : (A ⊕ B) = V), (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) → (∀ (a b : V), (G.adj a b) → (∃ (a' b' : A), (a = a') ∧ (b = b')) ∨ (∃ (a' b' : B), (a = a') ∧ (b = b'))), from
      begin
        assume (A B : Type*) (h : (A ⊕ B) = V) (h19 : (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B))),
        assume (a b : V),
        assume h20 : (G.adj a b),
        have h21 : (cast (congr_arg _ h) (complete_bipartite_graph A B)).adj a b, from by auto [h19, h20],
        have h22 : (complete_bipartite_graph A B).adj a b, from by auto [h21, cast_adj],
        have h23 : (complete_bipartite_graph A B).adj a b = tt, from by auto [complete_bipartite_graph.adj_iff],
        have h24 : tt = tt, from by auto [h23, h22],
        have h25 : (∃ (a' b' : A), (a = a') ∧ (b = b')), from by auto [h24, complete_bipartite_graph.adj_iff],
        have h26 : (∃ (a' b' : B), (a = a') ∧ (b = b')), from by auto [h24, complete_bipartite_graph.adj_iff],
        show (∃ (a' b' : A), (a = a') ∧ (b = b')) ∨ (∃ (a' b' : B), (a = a') ∧ (b = b')), from by auto [h25, h26],
      end,
      have h27 : ∀ (A B : Type*) (h : (A ⊕ B) = V), (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) → (∀ (a b : V), (G.adj a b) → (∃ (a' b' : A), (a = a') ∧ (b = b')) ∨ (∃ (a' b' : B), (a = a') ∧ (b = b'))), from
      begin
        assume (A B : Type*) (h : (A ⊕ B) = V) (h28 : (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B))),
        assume (a b : V),
        assume h29 : (G.adj a b),
        have h30 : (cast (congr_arg _ h) (complete_bipartite_graph A B)).adj a b, from by auto [h28, h29],
        have h31 : (complete_bipartite_graph A B).adj a b, from by auto [h30, cast_adj],
        have h32 : (complete_bipartite_graph A B).adj a b = tt, from by auto [complete_bipartite_graph.adj_iff],
        have h33 : tt = tt, from by auto [h32, h31],
        have h34 : (∃ (a' b' : A), (a = a') ∧ (b = b')) ∨ (∃ (a' b' : B), (a = a') ∧ (b = b')), from by auto [h33, complete_bipartite_graph.adj_iff],
        show (∃ (a' b' : A), (a = a') ∧ (b = b')) ∨ (∃ (a' b' : B), (a = a') ∧ (b = b')), from by auto [h34],
      end,
      have h35 : ∀ (A B : Type*) (h : (A ⊕ B) = V), (G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) → (∀ (a b : V), (G.adj a b) → (∃ (a' b' : A), (a = a') ∧ (b = b')) ∨ (∃ (a' b' : B), (a = a') ∧ (b = b'))), from
      begin
        assume (A B : Type*) (h : (A ⊕ B) = V) (h36 : (G ≤ cast (congr_arg _ h
end --Needs more than 2000 tokens!

--OUTPUT 3
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
  -- 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.
  have h1 : (G.colorable 2) → (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from by auto [colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def, simple_graph.colorable_def,
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
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  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
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  -- rearranging the terms using commutativity and adding gives:
  ... = 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
  -- Group has Latin Square Property
  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⁻¹],

  -- Setting $b = a$, this becomes:
  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],

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  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 Mathlib.Algebra.Group.Basic

section UnitOperations

  instance : Add PUnit := ⟨λ x y => PUnit.unit⟩
  instance : Sub PUnit := ⟨λ x y => PUnit.unit⟩
  instance : Mul PUnit := ⟨λ x y => PUnit.unit⟩
  instance : Neg PUnit := ⟨λ x => PUnit.unit⟩

  instance : Zero PUnit := ⟨PUnit.unit⟩

  -- Multiplication on `α` is not necessary but we do not want for example `ℕ*()` to compile
  instance [Mul α] : HMul α PUnit PUnit := ⟨λ a x => PUnit.unit⟩
  instance [Mul α] : SMul α PUnit := ⟨λ a x => PUnit.unit⟩

end UnitOperations


/-
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
Ported by: Scott Morrison
-/

import Mathlib.Tactic.Linarith.Elimination
import Mathlib.Tactic.Linarith.Parsing

/-!
# Deriving a proof of false

`linarith` uses an untrusted oracle to produce a certificate of unsatisfiability.
It needs to do some proof reconstruction work to turn this into a proof term.
This file implements the reconstruction.

## Main declarations

The public facing declaration in this file is `proveFalseByLinarith`.
-/

open Lean Elab Tactic Meta

namespace Qq

/-- Typesafe conversion of `n : ℕ` to `Q($α)`. -/
def ofNatQ (α : Q(Type $u)) (_ : Q(Semiring $α)) (n : ℕ) : Q($α) :=
  match n with
  | 0 => q(0 : $α)
  | 1 => q(1 : $α)
  | k+2 =>
    have lit : Q(ℕ) := mkRawNatLit n
    let k : Q(ℕ) := mkRawNatLit k
    let _x : Q(Nat.AtLeastTwo $lit) :=
      (q(instAtLeastTwoHAddNatInstHAddInstAddNatOfNat (n := $k)) : Expr)
    q(OfNat.ofNat $lit)

/-- Analogue of `inferTypeQ`, but that gets universe levels right for our application. -/
-- See https://leanprover.zulipchat.com/#narrow/stream/287929-mathlib4/topic/Using.20.60QQ.60.20when.20you.20only.20have.20an.20.60Expr.60/near/303349037
def inferTypeQ' (e : Expr) : MetaM ((u : Level) × (α : Q(Type $u)) × Q($α)) := do
  let α ← inferType e
  let .sort (.succ u) ← instantiateMVars (← whnf (← inferType α))
    | throwError "not a type{indentExpr α}"
  pure ⟨u, α, e⟩

end Qq

namespace Linarith

open Ineq
open Qq

/-! ### Auxiliary functions for assembling proofs -/

/-- A typesafe version of `mulExpr`. -/
def mulExpr' (n : ℕ) {α : Q(Type $u)} (inst : Q(Semiring $α)) (e : Q($α)) : Q($α) :=
if n = 1 then e else
  let n := ofNatQ α inst n
  q($n * $e)

/--
`mulExpr n e` creates an `Expr` representing `n*e`.
When elaborated, the coefficient will be a native numeral of the same type as `e`.
-/
def mulExpr (n : ℕ) (e : Expr) : MetaM Expr := do
  let ⟨_, α, e⟩ ← inferTypeQ' e
  let inst : Q(Semiring $α) ← synthInstanceQ q(Semiring $α)
  return mulExpr' n inst e

/-- A type-safe analogue of `addExprs`. -/
def addExprs' {α : Q(Type $u)} (_inst : Q(AddMonoid $α)) : List Q($α) → Q($α)
| []   => q(0)
| h::t => go h t
  where
  /-- Inner loop for `addExprs'`. -/
  go (p : Q($α)) : List Q($α) → Q($α)
  | [] => p
  | [q] => q($p + $q)
  | q::t => go q($p + $q) t

/-- `addExprs L` creates an `Expr` representing the sum of the elements of `L`, associated left. -/
def addExprs : List Expr → MetaM Expr
| [] => return q(0) -- This may not be of the intended type; use with caution.
| L@(h::_) => do
  let ⟨_, α, _⟩ ← inferTypeQ' h
  let inst : Q(AddMonoid $α) ← synthInstanceQ q(AddMonoid $α)
  -- This is not type safe; we just assume all the `Expr`s in the tail have the same type:
  return addExprs' inst L

/--
If our goal is to add together two inequalities `t1 R1 0` and `t2 R2 0`,
`addIneq R1 R2` produces the strength of the inequality in the sum `R`,
along with the name of a lemma to apply in order to conclude `t1 + t2 R 0`.
-/
def addIneq : Ineq → Ineq → (Name × Ineq)
| eq, eq => (``Linarith.eq_of_eq_of_eq, eq)
| eq, le => (``Linarith.le_of_eq_of_le, le)
| eq, lt => (``Linarith.lt_of_eq_of_lt, lt)
| le, eq => (``Linarith.le_of_le_of_eq, le)
| le, le => (``add_nonpos, le)
| le, lt => (``add_lt_of_le_of_neg, lt)
| lt, eq => (``Linarith.lt_of_lt_of_eq, lt)
| lt, le => (``add_lt_of_neg_of_le, lt)
| lt, lt => (``Left.add_neg, lt)

/--
`mkLTZeroProof coeffs pfs` takes a list of proofs of the form `tᵢ Rᵢ 0`,
paired with coefficients `cᵢ`.
It produces a proof that `∑cᵢ * tᵢ R 0`, where `R` is as strong as possible.
-/
def mkLTZeroProof : List (Expr × ℕ) → MetaM Expr
| [] => throwError "no linear hypotheses found"
| [(h, c)] => do
     let (_, t) ← mkSingleCompZeroOf c h
     return t
| ((h, c)::t) => do
     let (iq, h') ← mkSingleCompZeroOf c h
     let (_, t) ← t.foldlM (λ pr ce => step pr.1 pr.2 ce.1 ce.2) (iq, h')
     return t
where
  /--
  `step c pf npf coeff` assumes that `pf` is a proof of `t1 R1 0` and `npf` is a proof
  of `t2 R2 0`. It uses `mkSingleCompZeroOf` to prove `t1 + coeff*t2 R 0`, and returns `R`
  along with this proof.
  -/
  step (c : Ineq) (pf npf : Expr) (coeff : ℕ) : MetaM (Ineq × Expr) := do
    let (iq, h') ← mkSingleCompZeroOf coeff npf
    let (nm, niq) := addIneq c iq
    return (niq, ←mkAppM nm #[pf, h'])

/-- If `prf` is a proof of `t R s`, `leftOfIneqProof prf` returns `t`. -/
def leftOfIneqProof (prf : Expr) : MetaM Expr := do
  let (t, _) ← getRelSides (← inferType prf)
  return t

/-- If `prf` is a proof of `t R s`, `typeOfIneqProof prf` returns the type of `t`. -/
def typeOfIneqProof (prf : Expr) : MetaM Expr := do
  inferType (← leftOfIneqProof prf)

/--
`mkNegOneLtZeroProof tp` returns a proof of `-1 < 0`,
where the numerals are natively of type `tp`.
-/
def mkNegOneLtZeroProof (tp : Expr) : MetaM Expr := do
  let zero_lt_one ← mkAppOptM ``zero_lt_one #[tp, none, none, none, none, none]
  mkAppM `neg_neg_of_pos #[zero_lt_one]

/--
`addNegEqProofs l` inspects the list of proofs `l` for proofs of the form `t = 0`. For each such
proof, it adds a proof of `-t = 0` to the list.
-/
def addNegEqProofs : List Expr → MetaM (List Expr)
| [] => return []
| (h::tl) => do
  let (iq, t) ← parseCompAndExpr (← inferType h)
  match iq with
  | Ineq.eq => do
    let nep := mkAppN (← mkAppM `Iff.mpr #[← mkAppOptM ``neg_eq_zero #[none, none, t]]) #[h]
    let tl ← addNegEqProofs tl
    return h::nep::tl
  | _ => return h :: (← addNegEqProofs tl)

/--
`proveEqZeroUsing tac e` tries to use `tac` to construct a proof of `e = 0`.
-/
def proveEqZeroUsing (tac : TacticM Unit) (e : Expr) : MetaM Expr := do
  let ⟨u, α, e⟩ ← inferTypeQ' e
  let _h : Q(Zero $α) ← synthInstanceQ q(Zero $α)
  synthesizeUsing q($e = 0) tac

/-! #### The main method -/

/--
`proveFalseByLinarith` is the main workhorse of `linarith`.
Given a list `l` of proofs of `tᵢ Rᵢ 0`,
it tries to derive a contradiction from `l` and use this to produce a proof of `False`.

An oracle is used to search for a certificate of unsatisfiability.
In the current implementation, this is the Fourier Motzkin elimination routine in
`Elimination.lean`, but other oracles could easily be swapped in.

The returned certificate is a map `m` from hypothesis indices to natural number coefficients.
If our set of hypotheses has the form  `{tᵢ Rᵢ 0}`,
then the elimination process should have guaranteed that
1.\ `∑ (m i)*tᵢ = 0`,
with at least one `i` such that `m i > 0` and `Rᵢ` is `<`.

We have also that
2.\ `∑ (m i)*tᵢ < 0`,
since for each `i`, `(m i)*tᵢ ≤ 0` and at least one is strictly negative.
So we conclude a contradiction `0 < 0`.

It remains to produce proofs of (1) and (2). (1) is verified by calling the `discharger` tactic
of the `LinarithConfig` object, which is typically `ring`. We prove (2) by folding over the
set of hypotheses.
-/
def proveFalseByLinarith (cfg : LinarithConfig) : MVarId → List Expr → MetaM Expr
| _, [] => throwError "no args to linarith"
| g, l@(h::_) => do
    trace[linarith.detail] "Beginning work in `proveFalseByLinarith`."
    -- for the elimination to work properly, we must add a proof of `-1 < 0` to the list,
    -- along with negated equality proofs.
    let l' ← addNegEqProofs l
    trace[linarith.detail] "... finished `addNegEqProofs`."
    let inputs := (← mkNegOneLtZeroProof (← typeOfIneqProof h))::l'.reverse
    trace[linarith.detail] "... finished `mkNegOneLtZeroProof`."
    let (comps, max_var) ← linearFormsAndMaxVar cfg.transparency inputs
    trace[linarith.detail] "... finished `linearFormsAndMaxVar`."
    trace[linarith.detail] "{comps}"
    let oracle := cfg.oracle.getD FourierMotzkin.produceCertificate
    -- perform the elimination and fail if no contradiction is found.
    let certificate : Std.HashMap Nat Nat ← try
      oracle comps max_var
    catch e =>
      trace[linarith] m!"{e.toMessageData}"
      throwError "linarith failed to find a contradiction"
    trace[linarith] m!"linarith has found a contradiction: {certificate.toList}"
    let enum_inputs := inputs.enum
    -- construct a list pairing nonzero coeffs with the proof of their corresponding comparison
    let zip := enum_inputs.filterMap fun ⟨n, e⟩ => (certificate.find? n).map (e, ·)
    let mls ← zip.mapM fun ⟨e, n⟩ => do mulExpr n (← leftOfIneqProof e)
    -- `sm` is the sum of input terms, scaled to cancel out all variables.
    let sm ← addExprs mls
    -- let sm ← instantiateMVars sm
    trace[linarith] "The expression\n  {sm}\nshould be both 0 and negative"
    -- we prove that `sm = 0`, typically with `ring`.
    let sm_eq_zero ← proveEqZeroUsing cfg.discharger sm
    -- we also prove that `sm < 0`
    let sm_lt_zero ← mkLTZeroProof zip
    -- this is a contradiction.
    let pftp ← inferType sm_lt_zero
    let ⟨_, nep, _⟩ ← g.rewrite pftp sm_eq_zero
    let pf' ← mkAppM ``Eq.mp #[nep, sm_lt_zero]
    mkAppM ``Linarith.lt_irrefl #[pf']

end Linarith


import Lean

def checkWithMkMatcherInput (matcher : Lean.Name) : Lean.MetaM Unit :=
  Lean.Meta.Match.withMkMatcherInput matcher fun input => do
  let res ← Lean.Meta.Match.mkMatcher input
  let origMatcher ← Lean.getConstInfo matcher
  if not <| input.matcherName == matcher then
    throwError "matcher name not reconstructed correctly: {matcher} ≟ {input.matcherName}"

  let lCtx ← Lean.getLCtx
  let fvars ← Lean.collectFVars {} res.matcher
  let closure ← Lean.Meta.Closure.mkLambda (fvars.fvarSet.toList.toArray.map lCtx.get!) res.matcher

  let origTy := origMatcher.value!
  let newTy ← closure
  if not <| ←Lean.Meta.isDefEq origTy newTy then
    throwError "matcher {matcher} does not round-trip correctly:\n{origTy} ≟ {newTy}"

def f (xs : List Nat) : List Bool :=
xs.map fun
  | 0 => true
  | _ => false
#eval checkWithMkMatcherInput ``f.match_1

#eval f [1, 2, 0, 2]

theorem ex1 : f [1, 0, 2] = [false, true, false] :=
rfl

#check f

set_option pp.raw true
set_option pp.raw.maxDepth 10
set_option trace.Elab.step true in
def g (xs : List Nat) : List Bool :=
xs.map <| by {
  intro
    | 0 => exact true
    | _ => exact false
}

theorem ex2 : g [1, 0, 2] = [false, true, false] :=
rfl

theorem ex3 {p q r : Prop} : p ∨ q → r → (q ∧ r) ∨ (p ∧ r) :=
by intro
 | Or.inl hp, h => { apply Or.inr; apply And.intro; assumption; assumption }
 | Or.inr hq, h => { apply Or.inl; exact ⟨hq, h⟩ }
#eval checkWithMkMatcherInput ``ex3.match_1

inductive C
| mk₁ : Nat → C
| mk₂ : Nat → Nat → C

def C.x : C → Nat
| C.mk₁ x   => x
| C.mk₂ x _ => x
#eval checkWithMkMatcherInput ``C.x.match_1

def head : {α : Type} → List α → Option α
| _, a::as => some a
| _, _     => none
#eval checkWithMkMatcherInput ``head.match_1

theorem ex4 : head [1, 2] = some 1 :=
rfl

def head2 : {α : Type} → List α → Option α :=
@fun
  | _, a::as => some a
  | _, _     => none

theorem ex5 : head2 [1, 2] = some 1 :=
rfl

def head3 {α : Type} (xs : List α) : Option α :=
let rec aux : {α : Type} → List α → Option α
  | _, a::as => some a
  | _, _     => none;
aux xs

theorem ex6 : head3 [1, 2] = some 1 :=
rfl

inductive Vec.{u} (α : Type u) : Nat → Type u
| nil : Vec α 0
| cons {n} (head : α) (tail : Vec α n) : Vec α (n+1)

def Vec.mapHead1 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _,   nil,       nil,       f => none
| _, cons a as, cons b bs,   f => some (f a b)
#eval checkWithMkMatcherInput ``Vec.mapHead1.match_1

def Vec.mapHead2 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _, nil,            nil,         f => none
| _, @cons _ n a as, cons b bs,   f => some (f a b)
#eval checkWithMkMatcherInput ``Vec.mapHead2.match_1

def Vec.mapHead3 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _, nil,            nil,         f => none
| _, cons (tail := as) (head := a), cons b bs,   f => some (f a b)

inductive Foo
| mk₁ (x y z w : Nat)
| mk₂ (x y z w : Nat)

def Foo.z : Foo → Nat
| mk₁ (z := z) .. => z
| mk₂ (z := z) .. => z
#eval checkWithMkMatcherInput ``Foo.z.match_1

#eval (Foo.mk₁ 10 20 30 40).z

theorem ex7 : (Foo.mk₁ 10 20 30 40).z = 30 :=
rfl

def Foo.addY? : Foo × Foo → Option Nat
| (mk₁ (y := y₁) .., mk₁ (y := y₂) ..) => some (y₁ + y₂)
| _ => none
#eval checkWithMkMatcherInput ``Foo.addY?.match_1

#eval Foo.addY? (Foo.mk₁ 1 2 3 4, Foo.mk₁ 10 20 30 40)

theorem ex8 : Foo.addY? (Foo.mk₁ 1 2 3 4, Foo.mk₁ 10 20 30 40) = some 22 :=
rfl

instance {α} : Inhabited (Sigma fun m => Vec α m) :=
⟨⟨0, Vec.nil⟩⟩

partial def filter {α} (p : α → Bool) : {n : Nat} → Vec α n → Sigma fun m => Vec α m
| _, Vec.nil        => ⟨0, Vec.nil⟩
| _, Vec.cons x xs  => match p x, filter p xs with
  | true,  ⟨_, ys⟩ => ⟨_, Vec.cons x ys⟩
  | false, ys      => ys
#eval checkWithMkMatcherInput ``filter.match_1

inductive Bla
| ofNat  (x : Nat)
| ofBool (x : Bool)

def Bla.optional? : Bla → Option Nat
| ofNat x  => some x
| ofBool _ => none
#eval checkWithMkMatcherInput ``Bla.optional?.match_1

def Bla.isNat? (b : Bla) : Option { x : Nat // optional? b = some x } :=
match b.optional? with
| some y => some ⟨y, rfl⟩
| none   => none
#eval checkWithMkMatcherInput ``Bla.isNat?.match_1

def foo (b : Bla) : Option Nat := b.optional?
theorem fooEq (b : Bla) : foo b = b.optional? :=
rfl

def Bla.isNat2? (b : Bla) : Option { x : Nat // optional? b = some x } :=
match h:foo b with
| some y => some ⟨y, Eq.trans (fooEq b).symm h⟩
| none   => none
#eval checkWithMkMatcherInput ``Bla.isNat2?.match_1

def foo2 (x : Nat) : Nat :=
match x, rfl : (y : Nat) → x = y → Nat with
| 0,   h => 0
| x+1, h => 1
#eval checkWithMkMatcherInput ``foo2.match_1


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.opposites
import category_theory.limits.lattice
import category_theory.limits.shapes.finite_products
import category_theory.limits.shapes.terminal
import category_theory.full_subcategory
import category_theory.limits.shapes.regular_mono
import category_theory.closed.cartesian
import category_theory.limits.shapes.pullbacks
import category_theory.limits.over
import category_theory.monad.adjunction
import category_theory.currying
import category_theory.adjunction.fully_faithful
import category_theory.skeletal
import over

universes v v₂ u u₂

noncomputable theory
namespace category_theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u} [category.{v} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

/--
The subobject category as a full subcategory of the over category. In particular this isn't
skeletal, so it's not a partial order. The quotient is taken in `subq` instead, it's useful to be
able to work with both.
It's reducible for now to get instances to happen quickly, marked semireducible again later.
-/
@[derive [category, λ t, has_coe t (over X)]]
def sub (X : C) := {f : over X // mono f.hom}
/-- The inclusion arrow from subobjects to the over category. -/
def forget_sub (X : C) : sub X ⥤ over X := full_subcategory_inclusion _
@[simp]
lemma forget_sub_obj_left {f} : ((forget_sub X).obj f).left = f.val.left := rfl
/-- Convenience notation for the underlying arrow of a subobject. -/
abbreviation sub.arrow (f : sub X) : _ ⟶ X := ((forget_sub X).obj f).hom
@[simp]
lemma forget_sub_obj_hom {f} : ((forget_sub X).obj f).hom = f.arrow := rfl

instance : full (forget_sub X) := full_subcategory.full _
instance : faithful (forget_sub X) := full_subcategory.faithful _

instance sub_mono (f : sub X) : mono f.arrow := f.property

/-- The subobject category is a thin category, which makes defining its skeleton easy. -/
instance is_thin {X : C} (f g : sub X) : subsingleton (f ⟶ g) :=
⟨begin
  intros h₁ h₂,
  ext1,
  erw [← cancel_mono g.arrow, over.w h₁, over.w h₂],
end⟩

@[reassoc] lemma sub.w {f g : sub X} (k : f ⟶ g) : k.left ≫ g.arrow = f.arrow := over.w _

/-- Convience constructor for a morphism in the subobject category. -/
abbreviation sub.hom_mk {f g : sub X} (h : f.val.left ⟶ g.val.left) (w : h ≫ g.arrow = f.arrow) : f ⟶ g :=
over.hom_mk h w

def sub.iso_mk {f g : sub X} (h : f.val.left ≅ g.val.left) (w : h.hom ≫ g.arrow = f.arrow) : f ≅ g :=
{ hom := sub.hom_mk h.hom w,
  inv := sub.hom_mk h.inv (by rw [h.inv_comp_eq, w]) }

@[derive [partial_order, category]]
def subq (X : C) := thin_skeleton (sub X)

@[simps]
def sub.mk' {X A : C} (f : A ⟶ X) [hf : mono f] : sub X := { val := over.mk f, property := hf }
@[simp] lemma sub_mk'_arrow {X A : C} (f : A ⟶ X) [hf : mono f] : (sub.mk' f).arrow = f := rfl

abbreviation subq.mk {X A : C} (f : A ⟶ X) [mono f] : subq X := (to_thin_skeleton _).obj (sub.mk' f)

@[simps]
def restrict_to_sub {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : sub Y), mono (F.obj ((forget_sub Y).obj f)).hom) : sub Y ⥤ sub X :=
{ obj := λ f, ⟨_, h f⟩,
  map := λ _ _ k, (forget_sub X).preimage ((forget_sub Y ⋙ F).map k), }

def restrict_to_sub_iso {Y : D} {F₁ F₂ : over Y ⥤ over X} (h₁ h₂) (i : F₁ ≅ F₂) :
  restrict_to_sub F₁ h₁ ≅ restrict_to_sub F₂ h₂ :=
fully_faithful_cancel_right (forget_sub X) (iso_whisker_left (forget_sub Y) i)

def restrict_to_sub_comp {X Z : C} {Y : D} (F : over X ⥤ over Y) (G : over Y ⥤ over Z) (h₁ h₂) :
  restrict_to_sub F h₁ ⋙ restrict_to_sub G h₂ ≅ restrict_to_sub (F ⋙ G) (λ f, h₂ ⟨_, h₁ f⟩) :=
fully_faithful_cancel_right (forget_sub _) (iso.refl _)

def restrict_to_sub_id :
  restrict_to_sub (𝟭 (over X)) (λ f, f.2) ≅ 𝟭 _ :=
fully_faithful_cancel_right (forget_sub _) (iso.refl _)

@[simp]
lemma restrict_comm (F : over Y ⥤ over X)
  (h : ∀ (f : sub Y), mono (F.obj ((forget_sub Y).obj f)).hom) :
  restrict_to_sub F h ⋙ forget_sub X = forget_sub Y ⋙ F :=
rfl

def lower_sub {Y : D} (F : sub Y ⥤ sub X) : subq Y ⥤ subq X := thin_skeleton.map F

lemma lower_sub_iso (F₁ F₂ : sub X ⥤ sub Y) (h : F₁ ≅ F₂) : lower_sub F₁ = lower_sub F₂ :=
thin_skeleton.map_iso_eq h

def lower_sub₂ (F : sub X ⥤ sub Y ⥤ sub Z) : subq X ⥤ subq Y ⥤ subq Z :=
thin_skeleton.map₂ F

@[simp]
lemma lower_comm (F : sub Y ⥤ sub X) :
  to_thin_skeleton _ ⋙ lower_sub F = F ⋙ to_thin_skeleton _ :=
rfl

def sub.pullback [has_pullbacks.{v} C] (f : X ⟶ Y) : sub Y ⥤ sub X :=
restrict_to_sub (real_pullback f)
begin
  intro g,
  apply @pullback.snd_of_mono _ _ _ _ _ _ _ _ _,
  change mono g.arrow,
  apply_instance,
end

def sub.pullback_comp [has_pullbacks.{v} C] (f : X ⟶ Y) (g : Y ⟶ Z) :
  sub.pullback (f ≫ g) ≅ sub.pullback g ⋙ sub.pullback f :=
restrict_to_sub_iso _ _ (pullback_comp _ _) ≪≫ (restrict_to_sub_comp _ _ _ _).symm

def sub.pullback_id [has_pullbacks.{v} C] :
  sub.pullback (𝟙 X) ≅ 𝟭 _ :=
restrict_to_sub_iso _ _ pullback_id ≪≫ restrict_to_sub_id

@[simp] lemma sub.pullback_obj_left [has_pullbacks.{v} C] (f : X ⟶ Y) (g : sub Y) :
(↑((sub.pullback f).obj g) : over X).left = pullback g.arrow f :=
rfl

@[simp] lemma sub.pullback_obj_arrow [has_pullbacks.{v} C] (f : X ⟶ Y) (g : sub Y) :
((sub.pullback f).obj g).arrow = pullback.snd :=
rfl

def subq.pullback [has_pullbacks.{v} C] (f : X ⟶ Y) : subq Y ⥤ subq X :=
lower_sub (sub.pullback f)

lemma subq.pullback_id [has_pullbacks.{v} C] (x : subq X) : (subq.pullback (𝟙 X)).obj x = x :=
begin
  apply quotient.induction_on' x,
  intro f,
  apply quotient.sound,
  exact ⟨sub.pullback_id.app f⟩,
end
lemma subq.pullback_comp [has_pullbacks.{v} C] (f : X ⟶ Y) (g : Y ⟶ Z) (x : subq Z) :
  (subq.pullback (f ≫ g)).obj x = (subq.pullback f).obj ((subq.pullback g).obj x) :=
begin
  apply quotient.induction_on' x,
  intro t,
  apply quotient.sound,
  refine ⟨(sub.pullback_comp _ _).app t⟩,
end

attribute [instance] mono_comp

def sub.post (f : X ⟶ Y) [mono f] : sub X ⥤ sub Y :=
restrict_to_sub (over.map f)
(λ g, by apply mono_comp g.arrow f)

def sub.post_comp (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] :
  sub.post (f ≫ g) ≅ sub.post f ⋙ sub.post g :=
restrict_to_sub_iso _ _ (over_map_comp _ _) ≪≫ (restrict_to_sub_comp _ _ _ _).symm

def sub.post_id : sub.post (𝟙 X) ≅ 𝟭 _ :=
restrict_to_sub_iso _ _ over_map_id ≪≫ restrict_to_sub_id

@[simp] lemma sub.post_obj_left (f : X ⟶ Y) [mono f] (g : sub X) :
(↑((sub.post f).obj g) : over Y).left = g.val.left :=
rfl

@[simp]
lemma sub.post_obj_arrow (f : X ⟶ Y) [mono f] (g : sub X) :
((sub.post f).obj g).arrow = g.arrow ≫ f := rfl

instance sub.full_post (f : X ⟶ Y) [mono f] : full (sub.post f) :=
{ preimage := λ g h e,
  begin
    refine sub.hom_mk e.left _,
    rw [← cancel_mono f, assoc],
    apply sub.w e,
  end }

instance sub.faithful_post (f : X ⟶ Y) [mono f] : faithful (sub.post f) := {}.

def subq.post (f : X ⟶ Y) [mono f] : subq X ⥤ subq Y :=
lower_sub (sub.post f)

lemma subq.post_id (x : subq X) : (subq.post (𝟙 X)).obj x = x :=
begin
  apply quotient.induction_on' x,
  intro f,
  apply quotient.sound,
  exact ⟨sub.post_id.app f⟩,
end
lemma subq.post_comp (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] (x : subq X) :
  (subq.post (f ≫ g)).obj x = (subq.post g).obj ((subq.post f).obj x) :=
begin
  apply quotient.induction_on' x,
  intro t,
  apply quotient.sound,
  refine ⟨(sub.post_comp _ _).app t⟩,
end

@[simps]
def sub.image [has_images C] : over X ⥤ sub X :=
{ obj := λ f, sub.mk' (image.ι f.hom),
  map := λ f g k,
  begin
    apply (forget_sub X).preimage _,
    apply over.hom_mk _ _,
    refine image.lift {I := image _, m := image.ι g.hom, e := k.left ≫ factor_thru_image g.hom},
    apply image.lift_fac,
  end }

def image_forget_adj [has_images C] : sub.image ⊣ forget_sub X :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ f g,
  { to_fun := λ k,
    begin
      apply over.hom_mk (factor_thru_image f.hom ≫ k.left) _,
      change (factor_thru_image f.hom ≫ k.left) ≫ _ = f.hom,
      rw [assoc, over.w k],
      apply image.fac
    end,
    inv_fun := λ k,
    begin
      refine over.hom_mk _ _,
      refine image.lift {I := g.val.left, m := g.arrow, e := k.left, fac' := over.w k},
      apply image.lift_fac,
    end,
    left_inv := λ k, subsingleton.elim _ _,
    right_inv := λ k,
    begin
      ext1,
      change factor_thru_image _ ≫ image.lift _ = _,
      rw [← cancel_mono g.arrow, assoc, image.lift_fac, image.fac f.hom],
      exact (over.w k).symm,
    end } }

instance [has_images C] : is_right_adjoint (forget_sub X) :=
{ left := sub.image, adj := image_forget_adj }

instance sub.reflective [has_images C] : reflective (forget_sub X) := {}.

def forget_image [has_images C] : forget_sub X ⋙ sub.image ≅ 𝟭 (sub X) :=
as_iso (adjunction.counit image_forget_adj)

def sub.exists [has_images C] (f : X ⟶ Y) : sub X ⥤ sub Y :=
forget_sub _ ⋙ over.map f ⋙ sub.image

def subq.exists [has_images C] (f : X ⟶ Y) : subq X ⥤ subq Y :=
lower_sub (sub.exists f)

instance sub.faithful_pullback (f : X ⟶ Y) [has_pullbacks C] : faithful (sub.pullback f) := {}.

instance sub.faithful_exists (f : X ⟶ Y) [has_images C] : faithful (sub.exists f) := {}.

def exists_iso_post [has_images C] (f : X ⟶ Y) [mono f] : sub.exists f ≅ sub.post f :=
nat_iso.of_components
begin
  intro Z,
  suffices : (forget_sub _).obj ((sub.exists f).obj Z) ≅ (forget_sub _).obj ((sub.post f).obj Z),
    apply preimage_iso this,
  apply over_iso _ _,
  apply image_mono_iso_source (Z.arrow ≫ f),
  apply image_mono_iso_source_hom_self,
end
begin
  intros Z₁ Z₂ g,
  ext1,
  change image.lift ⟨_, _, _, _⟩ ≫ (image_mono_iso_source (Z₂.arrow ≫ f)).hom =
         (image_mono_iso_source (Z₁.arrow ≫ f)).hom ≫ g.left,
  rw [← cancel_mono (Z₂.arrow ≫ f), assoc, assoc, sub.w_assoc g, image_mono_iso_source_hom_self,
      image_mono_iso_source_hom_self],
  apply image.lift_fac,
end

/-- post is adjoint to pullback for monos -/
def sub.pull_post_adj (f : X ⟶ Y) [mono f] [has_pullbacks C] : sub.post f ⊣ sub.pullback f :=
adjunction.restrict_fully_faithful (forget_sub X) (forget_sub Y) (radj f) (iso.refl _) (iso.refl _)

def thin_skeleton.lower_adjunction
  [∀ (X Y : C), subsingleton (X ⟶ Y)] [∀ (X Y : D), subsingleton (X ⟶ Y)]
  (R : D ⥤ C) (L : C ⥤ D) (h : L ⊣ R) :
  thin_skeleton.map L ⊣ thin_skeleton.map R :=
adjunction.mk_of_unit_counit
{ unit :=
  { app := λ X,
    begin
      letI := is_isomorphic_setoid C,
      refine quotient.rec_on_subsingleton X (λ x, hom_of_le ⟨h.unit.app x⟩),
      -- TODO: make quotient.rec_on_subsingleton' so the letI isn't needed
    end },
  counit :=
  { app := λ X,
    begin
      letI := is_isomorphic_setoid D,
      refine quotient.rec_on_subsingleton X (λ x, hom_of_le ⟨h.counit.app x⟩),
    end } }

def subq.lower_adjunction {A : C} {B : D} {R : sub B ⥤ sub A} {L : sub A ⥤ sub B} (h : L ⊣ R) :
  lower_sub L ⊣ lower_sub R :=
thin_skeleton.lower_adjunction _ _ h

def subq.pull_post_adj (f : X ⟶ Y) [mono f] [has_pullbacks C] : subq.post f ⊣ subq.pullback f :=
subq.lower_adjunction (sub.pull_post_adj f)

/-- image is adjoint to pullback if images exist -/
-- I really think there should be a high-level proof of this but not sure what it is...
def sub.exists_pull_adj (f : X ⟶ Y) [has_images C] [has_pullbacks C] : sub.exists f ⊣ sub.pullback f :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ g h,
  { to_fun := λ k,
    sub.hom_mk
      (begin
        refine pullback.lift (factor_thru_image _ ≫ k.1) g.arrow _,
        rw [assoc, sub.w k],
        apply image.fac,
       end)
      (pullback.lift_snd _ _ _),
    inv_fun := λ k, sub.hom_mk (image.lift ⟨_, h.arrow, k.left ≫ pullback.fst, by { rw [assoc, pullback.condition], apply sub.w_assoc }⟩) (image.lift_fac _),
    left_inv := λ k, subsingleton.elim _ _,
    right_inv := λ k, subsingleton.elim _ _ } }

def subq.exists_pull_adj (f : X ⟶ Y) [has_pullbacks C] [has_images C] : subq.exists f ⊣ subq.pullback f :=
subq.lower_adjunction (sub.exists_pull_adj f)

-- Is this actually necessary?
def factors_through {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) : Prop := nonempty (over.mk f ⟶ over.mk g)
lemma factors_through_iff_le {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [mono f] [mono g] :
  factors_through f g ↔ subq.mk f ≤ subq.mk g :=
iff.rfl

instance {X : C} : has_top (sub X) :=
{ top := sub.mk' (𝟙 _) }

def to_top (f : sub X) : f ⟶ ⊤ :=
sub.hom_mk f.arrow (comp_id _)

instance subq.order_top {X : C} : order_top (subq X) :=
{ top := quotient.mk' ⊤,
  le_top :=
  begin
    refine quotient.ind' (λ f, _),
    exact ⟨to_top f⟩,
  end,
  ..category_theory.subq.partial_order X}

@[simp] lemma top_left (X : C) : (⊤ : sub X).val.left = X := rfl
@[simp] lemma top_arrow (X : C) : (⊤ : sub X).arrow = 𝟙 X := rfl

def sub.post_top (f : X ⟶ Y) [mono f] : (sub.post f).obj ⊤ ≅ sub.mk' f :=
iso_of_both_ways (sub.hom_mk (𝟙 _) rfl) (sub.hom_mk (𝟙 _) (by simp [id_comp f]))

def subq.post_top (f : X ⟶ Y) [mono f] : (subq.post f).obj ⊤ = quotient.mk' (sub.mk' f) :=
quotient.sound' ⟨sub.post_top f⟩

def sub.pullback_top (f : X ⟶ Y) [has_pullbacks C] : (sub.pullback f).obj ⊤ ≅ ⊤ :=
iso_of_both_ways (to_top _) (sub.hom_mk (pullback.lift f (𝟙 _) (by tidy)) (pullback.lift_snd _ _ _))

def subq.pullback_top (f : X ⟶ Y) [has_pullbacks C] : (subq.pullback f).obj ⊤ = ⊤ :=
quotient.sound' ⟨sub.pullback_top f⟩

variable (C)

@[simps]
def subq.functor [has_pullbacks.{v} C] : Cᵒᵖ ⥤ Type (max u v) :=
{ obj := λ X, subq X.unop,
  map := λ X Y f, (subq.pullback f.unop).obj,
  map_id' := λ X, funext subq.pullback_id,
  map_comp' := λ X Y Z f g, funext (subq.pullback_comp _ _) }

variable {C}

@[simps]
def postcompose_sub_equiv_of_iso (e : X ≅ Y) : subq X ≃ subq Y :=
{ to_fun := (subq.post e.hom).obj,
  inv_fun := (subq.post e.inv).obj,
  left_inv := λ g, by simp_rw [← subq.post_comp, e.hom_inv_id, subq.post_id],
  right_inv := λ g, by simp_rw [← subq.post_comp, e.inv_hom_id, subq.post_id] }

-- lemma postcompose_pullback_comm' [has_pullbacks.{v} C] {X Y Z W : C} {f : X ⟶ Y} {g : X ⟶ Z} {h : Y ⟶ W} {k : Z ⟶ W} [mono h] [mono g]
--   {comm : f ≫ h = g ≫ k} (t : is_limit (pullback_cone.mk f g comm)) (a) :
--   (sub.post g).obj ((sub.pullback f).obj a) ≈ (sub.pullback k).obj ((sub.post h).obj a) :=
-- begin
--   apply equiv_of_both_ways,
--   { refine sub.hom_mk (pullback.lift pullback.fst _ _) (pullback.lift_snd _ _ _),
--     change _ ≫ a.arrow ≫ h = (pullback.snd ≫ g) ≫ _,
--     rw [assoc, ← comm, pullback.condition_assoc] },
--   { refine sub.hom_mk (pullback.lift pullback.fst
--                        (pullback_cone.is_limit.lift' t (pullback.fst ≫ a.arrow) pullback.snd _).1
--                        (pullback_cone.is_limit.lift' _ _ _ _).2.1.symm) _,
--     { rw [← pullback.condition, assoc], refl },
--     { erw [pullback.lift_snd_assoc], apply (pullback_cone.is_limit.lift' _ _ _ _).2.2 } }
-- end

lemma postcompose_pullback_comm [has_pullbacks.{v} C] {X Y Z W : C} {f : X ⟶ Y} {g : X ⟶ Z} {h : Y ⟶ W} {k : Z ⟶ W} [mono h] [mono g]
  (comm : f ≫ h = g ≫ k) (t : is_limit (pullback_cone.mk f g comm)) :
  ∀ p, (subq.post g).obj ((subq.pullback f).obj p) = (subq.pullback k).obj ((subq.post h).obj p) :=
begin
  apply quotient.ind',
  intro a,
  apply quotient.sound,
  apply thin_skeleton.equiv_of_both_ways,
  { refine sub.hom_mk (pullback.lift pullback.fst _ _) (pullback.lift_snd _ _ _),
    change _ ≫ a.arrow ≫ h = (pullback.snd ≫ g) ≫ _,
    rw [assoc, ← comm, pullback.condition_assoc] },
  { refine sub.hom_mk (pullback.lift pullback.fst
                        (pullback_cone.is_limit.lift' t (pullback.fst ≫ a.arrow) pullback.snd _).1
                        (pullback_cone.is_limit.lift' _ _ _ _).2.1.symm) _,
    { rw [← pullback.condition, assoc], refl },
    { dsimp, rw [pullback.lift_snd_assoc],
      apply (pullback_cone.is_limit.lift' _ _ _ _).2.2 } }
end

lemma sub.pull_post_self [has_pullbacks.{v} C] (f : X ⟶ Y) [mono f] (g₁ : sub X) :
  sub.post f ⋙ sub.pullback f ≅ 𝟭 _ :=
(as_iso (sub.pull_post_adj f).unit).symm

lemma subq.pull_post_self [has_pullbacks.{v} C] (f : X ⟶ Y) [mono f] :
  ∀ g₁, (subq.pullback f).obj ((subq.post f).obj g₁) = g₁ :=
begin
  apply quotient.ind,
  intro g,
  apply quotient.sound,
  exact ⟨(sub.pull_post_self f g).app _⟩,
end

instance over_mono {B : C} {f g : over B} (m : f ⟶ g) [mono m] : mono m.left :=
⟨λ A h k e,
begin
  let A' : over B := over.mk (k ≫ f.hom),
  have: h ≫ f.hom = k ≫ f.hom,
    rw ← over.w m, rw reassoc_of e,
  let h' : A' ⟶ f := over.hom_mk h,
  let k' : A' ⟶ f := over.hom_mk k,
  have : h' ≫ m = k' ≫ m := over.over_morphism.ext e,
  rw cancel_mono m at this,
  injection this
end⟩

def over_mono' {B : C} {f g : over B} (m : f ⟶ g) [mono m.left] : mono m :=
{right_cancellation := λ A h k e, over.over_morphism.ext ((cancel_mono m.left).1 (congr_arg comma_morphism.left e))}

@[simps]
def preorder_functor {α β : Type*} [preorder α] [preorder β] (f : α → β) (hf : monotone f) : α ⥤ β :=
{ obj := f,
  map := λ X Y ⟨⟨h⟩⟩, ⟨⟨hf h⟩⟩ }

@[simps]
def preorder_equivalence {α β : Type*} [preorder α] [preorder β] (f : α ≃o β) : α ≌ β :=
{ functor := preorder_functor f (λ x y h, by rwa [← rel_iso.map_rel_iff f]),
  inverse := preorder_functor f.symm (λ x y h, by rwa [← rel_iso.map_rel_iff f.symm]),
  unit_iso := nat_iso.of_components (λ X, eq_to_iso (f.left_inv _).symm) (λ X Y f, rfl),
  counit_iso := nat_iso.of_components (λ X, eq_to_iso (f.right_inv _)) (λ X Y f, rfl) }

instance iso_term (A : C) [has_terminal (over A)] : is_iso (⊤_ over A).hom :=
begin
  let := (⊤_ over A).hom,
  dsimp at this,
  let ident : over A := over.mk (𝟙 A),
  let k : ident ⟶ (⊤_ over A) := default _,
  haveI : split_epi (⊤_ over A).hom := ⟨k.left, over.w k⟩,
  let l : (⊤_ over A) ⟶ ident := over.hom_mk (⊤_ over A).hom (comp_id _),
  haveI : mono l := ⟨λ _ _ _ _, subsingleton.elim _ _⟩,
  haveI : mono (⊤_ over A).hom := category_theory.over_mono l,
  apply is_iso_of_mono_of_split_epi,
end

def sub_iso {A B : C} (e : A ≅ B) : sub A ≌ sub B :=
{ functor := sub.post e.hom,
  inverse := sub.post e.inv,
  unit_iso := ((sub.post_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ sub.post_id).symm,
  counit_iso := ((sub.post_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ sub.post_id) }

def sub_slice {A : C} {f : over A} (h₁ h₂) : sub f ≌ sub f.left :=
{ functor := restrict_to_sub f.iterated_slice_equiv.functor h₁,
  inverse := restrict_to_sub f.iterated_slice_equiv.inverse h₂,
  unit_iso := restrict_to_sub_id.symm ≪≫ restrict_to_sub_iso _ _ f.iterated_slice_equiv.unit_iso ≪≫ (restrict_to_sub_comp _ _ _ _).symm,
  counit_iso := restrict_to_sub_comp _ _ _ _ ≪≫ restrict_to_sub_iso _ _ f.iterated_slice_equiv.counit_iso ≪≫ restrict_to_sub_id }

@[simps]
def subq.equiv {A : C} {B : D} (e : sub A ≌ sub B) : subq A ≌ subq B :=
{ functor := lower_sub e.functor,
  inverse := lower_sub e.inverse,
  unit_iso :=
  begin
    apply eq_to_iso,
    convert thin_skeleton.map_iso_eq e.unit_iso,
    { exact thin_skeleton.map_id_eq.symm },
    { exact (thin_skeleton.map_comp_eq _ _).symm },
  end,
  counit_iso :=
  begin
    apply eq_to_iso,
    convert thin_skeleton.map_iso_eq e.counit_iso,
    { exact (thin_skeleton.map_comp_eq _ _).symm },
    { exact thin_skeleton.map_id_eq.symm },
  end }

def sub_one_over (A : C) [has_terminal (over A)] : subq A ≌ subq (⊤_ (over A)) :=
begin
  refine subq.equiv ((sub_iso (as_iso (⊤_ over A).hom).symm).trans (sub_slice _ _).symm),
  intro f, dsimp, apply_instance,
  intro f,
  apply over_mono' _,
  dsimp,
  apply_instance,
end

@[simps]
def sub.intersection [has_pullbacks.{v} C] {A : C} : sub A ⥤ sub A ⥤ sub A :=
{ obj := λ f, sub.pullback f.arrow ⋙ sub.post f.arrow,
  map := λ f₁ f₂ k,
  { app := λ g,
    begin
      apply sub.hom_mk _ _,
      apply pullback.lift pullback.fst (pullback.snd ≫ k.left) _,
      rw [pullback.condition, assoc, sub.w k],
      dsimp,
      rw [pullback.lift_snd_assoc, assoc, sub.w k],
    end } }.

def sub.inter_le_left [has_pullbacks.{v} C] {A : C} (f g : sub A) :
  (sub.intersection.obj f).obj g ⟶ f :=
sub.hom_mk _ rfl

def sub.inter_le_right [has_pullbacks.{v} C] {A : C} (f g : sub A) :
  (sub.intersection.obj f).obj g ⟶ g :=
sub.hom_mk _ pullback.condition

def sub.le_inter [has_pullbacks.{v} C] {A : C} (f g h : sub A) :
  (h ⟶ f) → (h ⟶ g) → (h ⟶ (sub.intersection.obj f).obj g) :=
begin
  intros k₁ k₂,
  refine sub.hom_mk (pullback.lift k₂.left k₁.left _) _,
  rw [sub.w k₁, sub.w k₂],
  erw [pullback.lift_snd_assoc, sub.w k₁],
end

def subq.intersection [has_pullbacks.{v} C] {A : C} : subq A ⥤ subq A ⥤ subq A :=
thin_skeleton.map₂ sub.intersection

lemma subq.inf_le_left [has_pullbacks.{v} C] {A : C} (f g : subq A) :
  (subq.intersection.obj f).obj g ≤ f :=
quotient.induction_on₂' f g (λ a b, ⟨sub.inter_le_left _ _⟩)

lemma subq.inf_le_right [has_pullbacks.{v} C] {A : C} (f g : subq A) :
  (subq.intersection.obj f).obj g ≤ g :=
quotient.induction_on₂' f g (λ a b, ⟨sub.inter_le_right _ _⟩)

lemma subq.le_inf [has_pullbacks.{v} C] {A : C} (h f g : subq A) :
  h ≤ f → h ≤ g → h ≤ (subq.intersection.obj f).obj g :=
quotient.induction_on₃' h f g
begin
  rintros f g h ⟨k⟩ ⟨l⟩,
  exact ⟨sub.le_inter _ _ _ k l⟩,
end

@[simps]
def over.coprod' [has_finite_coproducts.{v} C] {A : C} : over A → over A ⥤ over A := λ f,
{ obj := λ g, over.mk (coprod.desc f.hom g.hom),
  map := λ g₁ g₂ k, over.hom_mk (coprod.map (𝟙 _) k.left) }

@[simps]
def over.coprod [has_finite_coproducts.{v} C] {A : C} : over A ⥤ over A ⥤ over A :=
{ obj := λ f, over.coprod' f,
  map := λ f₁ f₂ k,
  { app := λ g, over.hom_mk (coprod.map k.left (𝟙 _)) (by { dsimp, rw [coprod.map_desc, id_comp, over.w k] }),
    naturality' := λ f g k, -- tidy can do this but it takes ages
    begin
      ext1,
      dsimp,
      simp,
    end },
  map_id' := λ X,
  begin
    ext; dsimp; simp,
  end,
  map_comp' := λ X Y Z f g,
  begin
    ext; dsimp; simp
  end }.

def sub.union [has_images.{v} C] [has_finite_coproducts.{v} C] {A : C} : sub A ⥤ sub A ⥤ sub A :=
curry_obj ((forget_sub A).prod (forget_sub A) ⋙ uncurry.obj over.coprod ⋙ sub.image)

def sub.le_union_left [has_images.{v} C] [has_finite_coproducts.{v} C] {A : C} (f g : sub A) :
  f ⟶ (sub.union.obj f).obj g :=
begin
  refine sub.hom_mk (coprod.inl ≫ factor_thru_image _) _,
  erw [assoc, image.fac, coprod.inl_desc],
  refl,
end

def sub.le_union_right [has_images.{v} C] [has_finite_coproducts.{v} C] {A : C} (f g : sub A) :
  g ⟶ (sub.union.obj f).obj g :=
begin
  refine sub.hom_mk (coprod.inr ≫ factor_thru_image _) _,
  erw [assoc, image.fac, coprod.inr_desc],
  refl,
end

def sub.union_le [has_images.{v} C] [has_finite_coproducts.{v} C] {A : C} (f g h : sub A) :
  (f ⟶ h) → (g ⟶ h) → ((sub.union.obj f).obj g ⟶ h) :=
begin
  intros k₁ k₂,
  refine sub.hom_mk _ _,
  apply image.lift ⟨_, h.arrow, coprod.desc k₁.left k₂.left, _⟩,
  { dsimp,
    ext1,
    { simp [sub.w k₁] },
    { simp [sub.w k₂] } },
  { apply image.lift_fac }
end

def subq.union [has_images.{v} C] [has_finite_coproducts.{v} C] {A : C} : subq A ⥤ subq A ⥤ subq A :=
thin_skeleton.map₂ sub.union

lemma sub.intersection_eq_post_pull [has_pullbacks.{v} C] {A : C} (f₁ f₂ : sub A) :
  (sub.intersection.obj f₁).obj f₂ = (sub.post f₁.arrow).obj ((sub.pullback f₁.arrow).obj f₂) :=
rfl
lemma subq.intersection_eq_post_pull [has_pullbacks.{v} C] {A : C} (f₁ : sub A) (f₂ : subq A) :
  (subq.intersection.obj (quotient.mk' f₁)).obj f₂ = (subq.post f₁.arrow).obj ((subq.pullback f₁.arrow).obj f₂) :=
begin
  apply quotient.induction_on' f₂,
  intro f₂,
  refl,
end

instance [has_pullbacks.{v} C] {B : C} : semilattice_inf_top (subq B) :=
{ inf := λ m n, (subq.intersection.obj m).obj n,
  inf_le_left := subq.inf_le_left,
  inf_le_right := subq.inf_le_right,
  le_inf := subq.le_inf,
  ..category_theory.subq.order_top }

lemma subq.inf_eq_post_pull [has_pullbacks.{v} C] {A : C} (f₁ : sub A) (f₂ : subq A) :
  (quotient.mk' f₁ ⊓ f₂ : subq A) = (subq.post f₁.arrow).obj ((subq.pullback f₁.arrow).obj f₂) :=
begin
  apply quotient.induction_on' f₂,
  intro f₂,
  refl,
end

instance [has_finite_coproducts.{v} C] [has_images.{v} C] {B : C} : semilattice_sup (subq B) :=
{ sup := λ m n, (subq.union.obj m).obj n,
  le_sup_left := λ m n, quotient.induction_on₂' m n (λ a b, ⟨sub.le_union_left _ _⟩),
  le_sup_right := λ m n, quotient.induction_on₂' m n (λ a b, ⟨sub.le_union_right _ _⟩),
  sup_le := λ m n k, quotient.induction_on₃' m n k (λ a b c ⟨i⟩ ⟨j⟩, ⟨sub.union_le _ _ _ i j⟩),
  ..category_theory.subq.partial_order B }

lemma prod_eq_inter {A : C} [has_pullbacks.{v} C] {f₁ f₂ : subq A} : (f₁ ⨯ f₂) = f₁ ⊓ f₂ :=
le_antisymm
  (le_inf
    (le_of_hom limits.prod.fst)
    (le_of_hom limits.prod.snd))
  (le_of_hom
    (prod.lift
      (hom_of_le inf_le_left)
      (hom_of_le inf_le_right)))

lemma inf_eq_intersection {B : C} (m m' : subq B) [has_pullbacks.{v} C] :
  m ⊓ m' = (subq.intersection.obj m).obj m' := rfl

lemma top_eq_id {B : C} : (⊤ : subq B) = subq.mk (𝟙 B) := rfl

/-- Intersection plays well with pullback. -/
lemma inf_pullback [has_pullbacks.{v} C] {X Y : C} (g : X ⟶ Y) (f₂) :
  ∀ f₁, (subq.pullback g).obj (f₁ ⊓ f₂) = (subq.pullback g).obj f₁ ⊓ (subq.pullback g).obj f₂ :=
quotient.ind' begin
  intro f₁,
  erw [inf_eq_intersection, inf_eq_intersection, subq.intersection_eq_post_pull,
       subq.intersection_eq_post_pull, ← subq.pullback_comp,
       ← postcompose_pullback_comm pullback.condition (cone_is_pullback f₁.arrow g),
       ← subq.pullback_comp, pullback.condition],
  refl,
end

lemma inf_post [has_pullbacks.{v} C] {X Y : C} (g : Y ⟶ X) [mono g] (f₂) :
  ∀ f₁, (subq.post g).obj (f₁ ⊓ f₂) = (subq.post g).obj f₁ ⊓ (subq.post g).obj f₂ :=
quotient.ind' begin
  intro f₁,
  erw [inf_eq_intersection, inf_eq_intersection, subq.intersection_eq_post_pull,
       subq.intersection_eq_post_pull, ← subq.post_comp],
  dsimp,
  rw [subq.pullback_comp, subq.pull_post_self],
end

def sub.top_le_pullback_self {A B : C} (f : A ⟶ B) [mono f] [has_pullbacks.{v} C] :
  (⊤ : sub A) ⟶ (sub.pullback f).obj (sub.mk' f) :=
sub.hom_mk _ (pullback.lift_snd _ _ rfl)

def sub.pullback_self {A B : C} (f : A ⟶ B) [mono f] [has_pullbacks.{v} C] :
  (sub.pullback f).obj (sub.mk' f) ≅ ⊤ :=
iso_of_both_ways (to_top _) (sub.top_le_pullback_self _)

lemma subq.pullback_self {A B : C} (f : A ⟶ B) [mono f] [has_pullbacks.{v} C] :
  (subq.pullback f).obj (subq.mk f) = ⊤ :=
quotient.sound' ⟨sub.pullback_self f⟩

section
variable [has_binary_products.{v} C]

instance mono_prod_lift_of_left {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) [mono f] : mono (limits.prod.lift f g) :=
begin
  split, intros W h k l,
  have := l =≫ limits.prod.fst,
  simp at this,
  rwa cancel_mono at this,
end

instance mono_prod_lift_of_right {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) [mono g] : mono (limits.prod.lift f g) :=
begin
  split, intros W h k l,
  have := l =≫ limits.prod.snd,
  simp at this,
  rwa cancel_mono at this,
end
end

section
variable [has_finite_products.{v} C]
instance subterminal_ideal {A B : C} [exponentiable B] [mono (default (A ⟶ ⊤_ C))] :
  mono (default (A^^B ⟶ ⊤_ C)) :=
⟨λ Z f g eq, begin
  apply uncurry_injective,
  rw ← cancel_mono (default (A ⟶ ⊤_ C)),
  apply subsingleton.elim,
end⟩

/-- Auxiliary def for the exponential in the subobject category `sub 1`. -/
def sub.exp_aux (A : C) [exponentiable A] : sub (⊤_ C) ⥤ sub (⊤_ C) :=
{ obj := λ f,
  { val := over.mk (default (f.val.left^^A ⟶ ⊤_ C)),
    property :=
    ⟨λ Z g h eq, uncurry_injective (by { rw ← cancel_mono f.arrow, apply subsingleton.elim })⟩ },
  map := λ f₁ f₂ h, sub.hom_mk ((exp A).map h.left) (subsingleton.elim _ _) }

@[simps]
def sub.exp_aux_left {A₁ A₂ : C} [exponentiable A₁] [exponentiable A₂] (f : A₁ ⟶ A₂) :
  sub.exp_aux A₂ ⟶ sub.exp_aux A₁ :=
{ app := λ g, sub.hom_mk (pre _ f) (subsingleton.elim _ _) }

lemma sub_exp_aux_left_comp {A₁ A₂ A₃ : C} [cartesian_closed C] (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃) :
  sub.exp_aux_left (f ≫ g) = sub.exp_aux_left g ≫ sub.exp_aux_left f :=
begin
  ext : 3,
  apply pre_map,
end
lemma sub_exp_aux_left_id {A₁ : C} [cartesian_closed C] :
  sub.exp_aux_left (𝟙 A₁) = 𝟙 _ :=
begin
  ext : 3,
  apply pre_id,
end

/-- Candidate for the exponential functor in sub 1. -/
def sub.exp (f : sub (⊤_ C)) [cartesian_closed C] : sub (⊤_ C) ⥤ sub (⊤_ C) :=
sub.exp_aux f.val.left
end

variable [has_finite_limits.{v} C]
local attribute [instance] has_finite_products_of_has_finite_limits

def sub.exp_equiv [cartesian_closed C] (f₁ f₂ f₃ : sub (⊤_ C)) :
  ((sub.intersection.obj f₂).obj f₁ ⟶ f₃) ≃ (f₁ ⟶ (sub.exp f₂).obj f₃) :=
{ to_fun := λ k,
  begin
    refine sub.hom_mk (cartesian_closed.curry _) (subsingleton.elim _ _),
    apply (pullback.lift limits.prod.snd limits.prod.fst _) ≫ k.left,
    dsimp,
    apply subsingleton.elim,
  end,
  inv_fun := λ k, sub.hom_mk (prod.lift pullback.snd pullback.fst ≫ cartesian_closed.uncurry k.left) (subsingleton.elim _ _),
  left_inv := λ x, subsingleton.elim _ _,
  right_inv := λ x, subsingleton.elim _ _ }

def subq.exp_aux [cartesian_closed C] (f : sub (⊤_ C)) : subq (⊤_ C) ⥤ subq (⊤_ C) :=
lower_sub (sub.exp f)

def subq.exp (f : subq (⊤_ C)) [cartesian_closed C] : subq (⊤_ C) ⥤ subq (⊤_ C) :=
begin
  apply quotient.lift_on' f subq.exp_aux _,
  rintros f₁ f₂ ⟨h⟩,
  apply lower_sub_iso,
  have hi : h.hom.left ≫ h.inv.left = 𝟙 _,
    change (h.hom ≫ h.inv).left = _,
    rw h.hom_inv_id, refl,
  have ih : h.inv.left ≫ h.hom.left = 𝟙 _,
    change (h.inv ≫ h.hom).left = _,
    rw h.inv_hom_id, refl,
  refine ⟨sub.exp_aux_left h.inv.left, sub.exp_aux_left h.hom.left, _, _⟩,
  rw [← sub_exp_aux_left_comp, hi, sub_exp_aux_left_id], exact rfl,
  rw [← sub_exp_aux_left_comp, ih, sub_exp_aux_left_id], exact rfl,
end

variable (C)
def top_cc [cartesian_closed C] : cartesian_closed (subq (⊤_ C)) :=
{ closed := λ f₁,
  { is_adj :=
    { right := subq.exp f₁,
      adj := adjunction.mk_of_hom_equiv
      { hom_equiv := λ f₂ f₃,
        begin
          change (_ ⨯ _ ⟶ _) ≃ (_ ⟶ _),
          rw prod_eq_inter,
          apply @@quotient.rec_on_subsingleton₂ (is_isomorphic_setoid _) (is_isomorphic_setoid _) _ _ f₁ f₂,
          intros f₁ f₂,
          apply @@quotient.rec_on_subsingleton (is_isomorphic_setoid _) _ _ f₃,
          intro f₃,
          refine ⟨_, _, _, _⟩,
          { rintro k,
            refine ⟨⟨_⟩⟩,
            rcases k with ⟨⟨⟨k⟩⟩⟩,
            refine ⟨sub.exp_equiv _ _ _ k⟩ },
          { rintro k,
            refine ⟨⟨_⟩⟩,
            rcases k with ⟨⟨⟨k⟩⟩⟩,
            refine ⟨(sub.exp_equiv _ _ _).symm k⟩ },
          { tidy },
          { tidy },
          { tidy },
          { tidy }
        end } } } }

end category_theory


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.adjunction.fully_faithful
import category_theory.epi_mono

/-!
# Reflective functors

Basic properties of reflective functors, especially those relating to their essential image.

Note properties of reflective functors relating to limits and colimits are included in
`category_theory.monad.limits`.
-/

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

noncomputable theory

namespace category_theory

open category adjunction

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

/--
A functor is *reflective*, or *a reflective inclusion*, if it is fully faithful and right adjoint.
-/
class reflective (R : D ⥤ C) extends is_right_adjoint R, full R, faithful R.

variables {i : D ⥤ C}

/--
For a reflective functor `i` (with left adjoint `L`), with unit `η`, we have `η_iL = iL η`.
-/
-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.
lemma unit_obj_eq_map_unit [reflective i] (X : C) :
  (of_right_adjoint i).unit.app (i.obj ((left_adjoint i).obj X))
    = i.map ((left_adjoint i).map ((of_right_adjoint i).unit.app X)) :=
begin
 rw [←cancel_mono (i.map ((of_right_adjoint i).counit.app ((left_adjoint i).obj X))),
     ←i.map_comp],
 simp,
end

/--
When restricted to objects in `D` given by `i : D ⥤ C`, the unit is an isomorphism. In other words,
`η_iX` is an isomorphism for any `X` in `D`.
More generally this applies to objects essentially in the reflective subcategory, see
`functor.ess_image.unit_iso`.
-/
instance is_iso_unit_obj [reflective i] {B : D} :
  is_iso ((of_right_adjoint i).unit.app (i.obj B)) :=
begin
  have : (of_right_adjoint i).unit.app (i.obj B) =
            inv (i.map ((of_right_adjoint i).counit.app B)),
  { rw ← comp_hom_eq_id,
    apply (of_right_adjoint i).right_triangle_components },
  rw this,
  exact is_iso.inv_is_iso,
end

/--
If `A` is essentially in the image of a reflective functor `i`, then `η_A` is an isomorphism.
This gives that the "witness" for `A` being in the essential image can instead be given as the
reflection of `A`, with the isomorphism as `η_A`.

(For any `B` in the reflective subcategory, we automatically have that `ε_B` is an iso.)
-/
lemma functor.ess_image.unit_is_iso [reflective i] {A : C} (h : A ∈ i.ess_image) :
  is_iso ((of_right_adjoint i).unit.app A) :=
begin
  suffices : (of_right_adjoint i).unit.app A =
                h.get_iso.inv ≫ (of_right_adjoint i).unit.app (i.obj h.witness) ≫
                  (left_adjoint i ⋙ i).map h.get_iso.hom,
  { rw this,
    apply_instance },
  rw ← nat_trans.naturality,
  simp,
end

/-- If `η_A` is an isomorphism, then `A` is in the essential image of `i`. -/
lemma mem_ess_image_of_unit_is_iso [is_right_adjoint i] (A : C)
  [is_iso ((of_right_adjoint i).unit.app A)] : A ∈ i.ess_image :=
⟨(left_adjoint i).obj A, ⟨(as_iso ((of_right_adjoint i).unit.app A)).symm⟩⟩

/-- If `η_A` is a split monomorphism, then `A` is in the reflective subcategory. -/
lemma mem_ess_image_of_unit_split_mono [reflective i] {A : C}
  [split_mono ((of_right_adjoint i).unit.app A)] : A ∈ i.ess_image :=
begin
  let η : 𝟭 C ⟶ left_adjoint i ⋙ i := (of_right_adjoint i).unit,
  haveI : is_iso (η.app (i.obj ((left_adjoint i).obj A))) := (i.obj_mem_ess_image _).unit_is_iso,
  have : epi (η.app A),
  { apply epi_of_epi (retraction (η.app A)) _,
    rw (show retraction _ ≫ η.app A = _, from η.naturality (retraction (η.app A))),
    apply epi_comp (η.app (i.obj ((left_adjoint i).obj A))) },
  resetI,
  haveI := is_iso_of_epi_of_split_mono (η.app A),
  exact mem_ess_image_of_unit_is_iso A,
end

/-- Composition of reflective functors. -/
instance reflective.comp (F : C ⥤ D) (G : D ⥤ E) [Fr : reflective F] [Gr : reflective G] :
  reflective (F ⋙ G) := { to_faithful := faithful.comp F G, }

/-- (Implementation) Auxiliary definition for `unit_comp_partial_bijective`. -/
def unit_comp_partial_bijective_aux [reflective i] (A : C) (B : D) :
  (A ⟶ i.obj B) ≃ (i.obj ((left_adjoint i).obj A) ⟶ i.obj B) :=
((adjunction.of_right_adjoint i).hom_equiv _ _).symm.trans (equiv_of_fully_faithful i)

/-- The description of the inverse of the bijection `unit_comp_partial_bijective_aux`. -/
lemma unit_comp_partial_bijective_aux_symm_apply [reflective i] {A : C} {B : D}
  (f : i.obj ((left_adjoint i).obj A) ⟶ i.obj B) :
  (unit_comp_partial_bijective_aux _ _).symm f = (of_right_adjoint i).unit.app A ≫ f :=
by simp [unit_comp_partial_bijective_aux]

/--
If `i` has a reflector `L`, then the function `(i.obj (L.obj A) ⟶ B) → (A ⟶ B)` given by
precomposing with `η.app A` is a bijection provided `B` is in the essential image of `i`.
That is, the function `λ (f : i.obj (L.obj A) ⟶ B), η.app A ≫ f` is bijective, as long as `B` is in
the essential image of `i`.
This definition gives an equivalence: the key property that the inverse can be described
nicely is shown in `unit_comp_partial_bijective_symm_apply`.

This establishes there is a natural bijection `(A ⟶ B) ≃ (i.obj (L.obj A) ⟶ B)`. In other words,
from the point of view of objects in `D`, `A` and `i.obj (L.obj A)` look the same: specifically
that `η.app A` is an isomorphism.
-/
def unit_comp_partial_bijective [reflective i] (A : C) {B : C} (hB : B ∈ i.ess_image) :
  (A ⟶ B) ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) :=
calc (A ⟶ B) ≃ (A ⟶ i.obj hB.witness) : iso.hom_congr (iso.refl _) hB.get_iso.symm
     ...     ≃ (i.obj _ ⟶ i.obj hB.witness) : unit_comp_partial_bijective_aux _ _
     ...     ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) : iso.hom_congr (iso.refl _) hB.get_iso

@[simp]
lemma unit_comp_partial_bijective_symm_apply [reflective i] (A : C) {B : C}
  (hB : B ∈ i.ess_image) (f) :
  (unit_comp_partial_bijective A hB).symm f = (of_right_adjoint i).unit.app A ≫ f :=
by simp [unit_comp_partial_bijective, unit_comp_partial_bijective_aux_symm_apply]

lemma unit_comp_partial_bijective_symm_natural [reflective i] (A : C) {B B' : C} (h : B ⟶ B')
  (hB : B ∈ i.ess_image) (hB' : B' ∈ i.ess_image) (f : i.obj ((left_adjoint i).obj A) ⟶ B) :
  (unit_comp_partial_bijective A hB').symm (f ≫ h) =
    (unit_comp_partial_bijective A hB).symm f ≫ h :=
by simp

lemma unit_comp_partial_bijective_natural [reflective i] (A : C) {B B' : C} (h : B ⟶ B')
  (hB : B ∈ i.ess_image) (hB' : B' ∈ i.ess_image) (f : A ⟶ B) :
  (unit_comp_partial_bijective A hB') (f ≫ h) = unit_comp_partial_bijective A hB f ≫ h :=
by rw [←equiv.eq_symm_apply, unit_comp_partial_bijective_symm_natural A h, equiv.symm_apply_apply]

end category_theory