import for_mathlib.algebra.homology.derived_category
import for_mathlib.algebra.homology.trunc
import category_theory.preadditive.projective

noncomputable theory

open category_theory category_theory.category category_theory.limits
  category_theory.pretriangulated

open_locale zero_object

def int.truncate (n : ℤ) : ℕ :=
if h : 0 ≤ n
  then (int.eq_coe_of_zero_le h).some
  else 0

lemma int.coe_truncate (n : ℤ) (hn : 0 ≤ n) : (n.truncate : ℤ) = n :=
begin
  dsimp [int.truncate],
  rw dif_pos hn,
  exact (int.eq_coe_of_zero_le hn).some_spec.symm,
end

lemma int.truncate_eq_zero (n : ℤ) (hn : n ≤ 0) : n.truncate = 0 :=
begin
  by_cases n = 0,
  { apply int.coe_nat_inj,
    rw [int.coe_truncate n (by linarith), h, int.coe_nat_zero], },
  { dsimp [int.truncate],
    rw dif_neg,
    intro h',
    apply h,
    linarith, },
end

lemma int.self_le_coe_truncate (n : ℤ) : n ≤ (n.truncate : ℤ) :=
begin
  by_cases 0 ≤ n,
  { rw n.coe_truncate h, },
  { simp only [not_le] at h,
    rw n.truncate_eq_zero (by linarith),
    linarith, },
end

lemma int.truncate_le_of_le {n n' : ℤ} (hnn' : n ≤ n') : n.truncate ≤ n'.truncate :=
begin
  by_cases n ≤ 0,
  { simp only [n.truncate_eq_zero h, zero_le'], },
  { rw [← int.coe_nat_le, int.coe_truncate n, int.coe_truncate n']; linarith, },
end

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

namespace homological_complex

variables {ι : Type*} {c : complex_shape ι} (K L : homological_complex C c)

def acyclic : Prop :=
  ∀ (i : ι), is_zero (K.homology i)

variables {K L}

lemma acyclic.of_iso {K L : homological_complex C c} (e : K ≅ L) (h : K.acyclic) :
  L.acyclic :=
λ i, is_zero.of_iso (h i) ((homology_functor C _ i).map_iso e.symm)

lemma acyclic.iff_of_iso {K L : homological_complex C c} (e : K ≅ L) :
  K.acyclic ↔ L.acyclic :=
⟨acyclic.of_iso e, acyclic.of_iso e.symm⟩

variables (K)
class is_K_projective : Prop :=
(null_homotopic : ∀ ⦃Y : homological_complex C c⦄ (f : K ⟶ Y)
  (hY : acyclic Y), nonempty (homotopy f 0))

variables {K L}

lemma is_K_projective.of_homotopy_equiv [K.is_K_projective] (e : homotopy_equiv K L) :
  L.is_K_projective :=
⟨λ Y f hY, begin
  obtain ⟨h⟩ := is_K_projective.null_homotopic (e.hom ≫ f) hY,
  exact ⟨(homotopy.of_eq (id_comp f).symm).trans
    ((e.homotopy_inv_hom_id.comp_right f).symm.trans
      ((homotopy.of_eq (assoc _ _ _)).trans
        ((h.comp_left e.inv).trans
        (homotopy.of_eq comp_zero))))⟩,
end⟩

lemma is_K_projective.of_iso [K.is_K_projective] (e : K ≅ L) : L.is_K_projective :=
is_K_projective.of_homotopy_equiv (homotopy_equiv.of_iso e)

lemma is_K_projective.iff_of_iso (e : K ≅ L) :
  K.is_K_projective ↔ L.is_K_projective :=
begin
  split,
  { introI, exact is_K_projective.of_iso e, },
  { introI, exact is_K_projective.of_iso e.symm, },
end

lemma is_K_projective.of_is_zero (h : is_zero K) : K.is_K_projective :=
⟨λ Y f hY, begin
  rw h.eq_of_src f 0,
  exact ⟨homotopy.refl _⟩
end⟩

instance zero_is_K_projective : is_K_projective (0 : homological_complex C c) :=
is_K_projective.of_is_zero (limits.is_zero_zero _)

/- TODO : stability by arbitrary direct sums. -/

end homological_complex

namespace homotopy_category

lemma quotient_obj_mem_acyclic_iff (K : cochain_complex C ℤ) :
  (quotient _ _).obj K ∈ (acyclic C) ↔ K.acyclic :=
begin
  let e := λ (n : ℤ), (homotopy_category.homology_factors C _ n).symm.app _ ≪≫
      (homotopy_category.shift_homology_functor_iso C n 0 n (zero_add n)).symm.app
        ((quotient _ _).obj K),
  split,
  { exact λ h n, is_zero.of_iso (h n) (e n), },
  { exact λ h n, is_zero.of_iso (h n) (e n).symm, },
end

end homotopy_category

namespace cochain_complex

open homological_complex

variables (K : cochain_complex C ℤ)

lemma acyclic.iff_shift (r : ℤ) :
  K.acyclic ↔ K⟦r⟧.acyclic :=
begin
  split,
  { intros h n,
    exact is_zero.of_iso (h _)
      ((shift_homology_functor_iso C r n _ rfl).app K), },
  { intros h n,
    exact is_zero.of_iso (h _)
      ((shift_homology_functor_iso C r (n-r) n (by linarith)).symm.app K), },
end

lemma acyclic.shift {K : cochain_complex C ℤ} (h : K.acyclic) (r : ℤ) :
  K⟦r⟧.acyclic := (acyclic.iff_shift K r).1 h

lemma is_K_projective_iff : is_K_projective K ↔
  (homotopy_category.quotient _ _).obj K
    ∈ triangulated.left_orthogonal (homotopy_category.acyclic C) :=
begin
  split,
  { introI,
    rintros ⟨Y⟩ f hY,
    obtain ⟨f, rfl⟩ := (homotopy_category.quotient _ _).map_surjective f,
    rw ← (homotopy_category.quotient C (complex_shape.up ℤ)).map_zero,
    refine homotopy_category.eq_of_homotopy _ _ (is_K_projective.null_homotopic _ _).some,
    erw homotopy_category.quotient_obj_mem_acyclic_iff at hY,
    exact hY, },
  { intro hK,
    refine ⟨λ Y f hY, ⟨homotopy_category.homotopy_of_eq _ _ _⟩⟩,
    simp only [functor.map_zero],
    apply hK,
    simpa only [homotopy_category.quotient_obj_mem_acyclic_iff] using hY, },
end

lemma shift_is_K_projective_iff (K : cochain_complex C ℤ) (r : ℤ) :
  is_K_projective (K⟦r⟧) ↔ is_K_projective K :=
begin
  simp only [is_K_projective_iff],
  erw [set.respects_iso.mem_iff_of_iso (triangulated.left_orthogonal (homotopy_category.acyclic C))
   (((homotopy_category.quotient C (complex_shape.up ℤ)).comm_shift_iso r).app K),
    ← triangulated.is_triangulated_subcategory.shift_iff],
end

end cochain_complex

namespace derived_category

lemma Qh_map_bijective_of_is_K_projective
  (K L : cochain_complex C ℤ) [K.is_K_projective] :
  function.bijective (λ (f : ((homotopy_category.quotient _ _).obj K ⟶
    (homotopy_category.quotient _ _).obj L)), Qh.map f) :=
(triangulated.subcategory.left_orthogonal_bijective_Q_map
  (homotopy_category.acyclic C) _ _
  ((cochain_complex.is_K_projective_iff K).1 infer_instance))

lemma Q_map_surjective_of_is_K_projective
  (K L : cochain_complex C ℤ) [K.is_K_projective] :
  function.surjective (λ (f : K ⟶ L), Q.map f) :=
λ f, begin
  obtain ⟨g, hg⟩ := (Qh_map_bijective_of_is_K_projective K L).2 f,
  dsimp at hg,
  obtain ⟨g, rfl⟩ := (homotopy_category.quotient _ _).map_surjective g,
  exact ⟨g, hg⟩,
end

def homotopy_of_eq_Qh_map_eq_of_is_K_projective
  {K L : cochain_complex C ℤ} [K.is_K_projective] (f₁ f₂ : K ⟶ L)
  (h : Q.map f₁ = Q.map f₂) : homotopy f₁ f₂ :=
homotopy_category.homotopy_of_eq _ _ ((Qh_map_bijective_of_is_K_projective K L).1 h)

end derived_category

namespace cochain_complex

open homological_complex hom_complex

variables (K L : cochain_complex C ℤ)

lemma is_K_projective_iff_hom_complex_acyclic_in_degree_zero :
  is_K_projective K ↔
    ∀ (L : cochain_complex C ℤ) (hL : L.acyclic) (z : cocycle K L 0),
        ∃ (x : cochain K L (-1)), (z : cochain K L 0) = δ (-1) 0 x :=
begin
  split,
  { introI,
    intros L hL z,
    obtain ⟨hf⟩ := is_K_projective.null_homotopic (cocycle.hom_of z) hL,
    exact ⟨cochain.of_homotopy hf, by simp only [δ_cochain_of_homotopy,
      cocycle.cochain_of_hom_hom_of_eq_coe, cochain.of_hom_zero, sub_zero]⟩, },
  { intro hK,
    refine ⟨λ L f hL, _⟩,
    obtain ⟨x, hx⟩ := hK L hL (cocycle.of_hom f),
    simp only [cocycle.of_hom_coe] at hx,
    refine ⟨_⟩,
    equiv_rw hom_complex.equiv_homotopy _ _,
    exact ⟨x, by simpa only [cochain.of_hom_zero, add_zero]⟩, },
end

lemma is_K_projective_iff_hom_complex_acyclic :
  is_K_projective K ↔
    ∀ (L : cochain_complex C ℤ) (hL : L.acyclic)
      (n₀ n₁ : ℤ) (h₀₁ : n₁ = n₀ + 1) (z : cocycle K L n₁),
        ∃ (x : cochain K L n₀), (z : cochain K L n₁) = δ n₀ n₁ x :=
begin
  rw is_K_projective_iff_hom_complex_acyclic_in_degree_zero,
  split,
  { intros hK L hL n₀ n₁ h z,
    obtain ⟨x, hx⟩ := hK (L⟦n₁⟧) (acyclic.shift hL n₁)
      (cocycle.right_shift (ε (n₁) • z) n₁ 0 (zero_add n₁).symm),
    refine ⟨x.right_unshift n₀ (by linarith), _⟩,
    simp only [hom_complex.cochain.δ_right_unshift _ 0 n₀ n₁
      (show n₀ = -1+n₁, by linarith) (zero_add n₁).symm, ← hx,
      cocycle.right_shift_coe, add_subgroup.coe_zsmul, cochain.right_shift_unshift, smul_smul,
      mul_ε_self, one_smul], },
  { intros hK L hL z,
    exact hK L hL (-1) 0 (neg_add_self 1).symm z, },
end

namespace is_K_projective_of_bounded_above_of_projective

variables {K L} (f : K ⟶ L)

@[ext]
structure lift (N : ℤ) :=
(y : cochain K L (-1))
(hy : ∀ (p : ℤ) (hp : N < p), (δ (-1) 0 y).v p p (add_zero p).symm = f.f p)

variable {f}

def lift.of_le {N : ℤ} (l : lift f N) (N' : ℤ) (h : N ≤ N') : lift f N' :=
{ y := l.y,
  hy := λ p hp, l.hy p (by linarith), }

def lift.induction_step {N₁ : ℤ} (l : lift f N₁) (N₀ : ℤ) (eq : N₁ = N₀+1)
  (hK : projective (K.X N₁)) (hL : is_zero (L.homology N₁)) :
  { l' : lift f N₀ //
    ∀ (p q : ℤ) (hpq : q = p + (-1)) (hp : N₁ < p), l'.y.v p q hpq = l.y.v p q hpq } :=
nonempty.some begin
  /- the exactness below should be part of the API of homological_complex :
      is_zero (K.homology j) ↔ (K.sc i j k).exact -/
  have ex : (L.sc N₀ N₁ (N₁+1)).exact := (short_complex.exact_iff_of_iso
    ((short_complex_functor_nat_iso C (complex_shape.up ℤ) eq.symm rfl).app L)).1
      ((short_complex.exact_iff_is_zero_homology _).2 hL),
  obtain ⟨A, π, hπ, x, hx⟩ :=
    ex.pseudo_exact' (f.f N₁ - (δ (-1) 0 l.y).v N₁ N₁ (add_zero N₁).symm)
    begin
      dsimp,
      simp only [preadditive.sub_comp,
        δ_v (-1) 0 _ _ N₁ N₁ (add_zero N₁).symm N₀ _ (by linarith) rfl,
        neg_add_self, ε_0, one_smul, preadditive.add_comp, assoc, L.d_comp_d, comp_zero,
        zero_add, f.comm, ← l.hy (N₁+1) (lt_add_one N₁), preadditive.comp_add, K.d_comp_d_assoc,
        δ_v (-1) 0 _ _ (N₁+1) _ (add_zero _).symm N₁ _ (by linarith) rfl,
        zero_comp, add_zero, sub_self],
    end,
  haveI := hπ,
  dsimp at x hx,
  let φ : K.X N₁ ⟶ L.X N₀ := projective.factor_thru (𝟙 _) π ≫ x,
  have hφ : φ ≫ L.d N₀ N₁ = f.f N₁ - (δ (-1) 0 l.y).v N₁ N₁ (add_zero N₁).symm,
  { simp only [φ, assoc, ← hx, projective.factor_thru_comp_assoc, id_comp], },
  let w : cochain K L (-1) := cochain.mk (λ p q hpq, begin
    by_cases p=N₁,
    { refine eq_to_hom (by rw h) ≫ φ ≫ eq_to_hom (by { congr', linarith, }), },
    { exact 0, },
  end),
  have hw : w.v N₁ N₀ (by linarith) = φ,
  { dsimp [w], simp only [eq_self_iff_true, comp_id, id_comp, if_true], },
  have hw_zero : ∀ (p q : ℤ) (hpq : q = p + (-1))
    (hp : p ≠ N₁), w.v p q hpq = 0,
  { intros p q hpq hp, dsimp [w], rw dif_neg hp, },
  let l' : lift f N₀ :=
  { y := l.y + w,
    hy := λ p hp, begin
      cases (int.add_one_le_iff.mpr hp).lt_or_eq,
      { rw [δ_add, cochain.add_v, l.hy p (by linarith), add_right_eq_self,
          δ_v (-1) 0 (neg_add_self 1).symm _ p p (add_zero p).symm _ _ rfl rfl,
          hw_zero p _ _ (by linarith), hw_zero (p+1) _ _ (by linarith), zero_comp,
          comp_zero, smul_zero, zero_add], },
      { have h' : N₁ = p := by linarith,
        unfreezingI { subst h', },
        simp only [δ_add, cochain.add_v, δ_add, δ_v (-1) 0 (neg_add_self 1).symm w N₁ N₁
          (add_zero N₁).symm N₀ _ (by linarith) rfl, neg_add_self, ε_0, one_smul, hw,
          hw_zero (N₁+1) _ _ (by linarith), comp_zero, add_zero, hφ,
          add_sub_cancel'_right], },
    end, },
  exact ⟨⟨l', λ p q hpq hp, by rw [cochain.add_v, hw_zero p q hpq (by linarith), add_zero]⟩⟩,
end

variables {N₀ : ℤ} (l₀ : lift f N₀) (hK : ∀ (p : ℤ) (hp : p ≤ N₀), projective (K.X p))
  (hL : ∀ (p : ℤ) (hp : p ≤ N₀), is_zero (L.homology p))

include l₀ hK hL

noncomputable
def lift.sequence : Π (k : ℕ), lift f (N₀-k)
| 0 := l₀.of_le _ (by simp only [algebra_map.coe_zero, tsub_zero])
| (k+1) := begin
  refine (lift.induction_step (lift.sequence k) _ _ (hK _ _) (hL _ _)).1,
  { simp only [nat.cast_add, algebra_map.coe_one], ring, },
  all_goals
  { simp only [sub_le_self_iff, nat.cast_nonneg], },
end

lemma lift.sequence_is_eventually_constant {k₁ k₂ : ℕ} (hk : k₁ ≤ k₂) (p q : ℤ) (hpq : q = p+(-1))
  (hp : N₀ - k₁ < p):
  (lift.sequence l₀ hK hL k₁).y.v p q hpq =
    (lift.sequence l₀ hK hL k₂).y.v p q hpq :=
begin
  have h : ∀ (k₁ k₂ : ℕ) (hk₂ : k₂ = k₁ + 1) (hp : N₀ - k₁ < p),
    (lift.sequence l₀ hK hL k₁).y.v p q hpq = (lift.sequence l₀ hK hL k₂).y.v p q hpq,
  { rintro k₁ _ rfl hp,
    unfold lift.sequence,
    exact (((l₀.sequence hK hL k₁).induction_step _ _ _ _).2 _ _ _ hp).symm, },
  rw le_iff_exists_add at hk,
  obtain ⟨d, rfl⟩ := hk,
  induction d with d hd,
  { rw add_zero, },
  { rw hd,
    apply h,
    { rw [nat.succ_eq_add_one, add_assoc], },
    { simp only [nat.cast_add],
      exact lt_of_le_of_lt
        (by simp only [sub_le_sub_iff_left, le_add_iff_nonneg_right, nat.cast_nonneg]) hp, }, },
end

def lift.limit : cochain K L (-1) :=
cochain.mk (λ p q hpq, begin
  let k : ℕ := int.truncate (N₀+1 -p),
  exact ((lift.sequence l₀ hK hL) k).y.v p q hpq,
end)

lemma lift.δ_limit : δ (-1) 0 (lift.limit l₀ hK hL) = cochain.of_hom f :=
begin
  ext,
  dsimp [lift.limit],
  have ineq₁ := int.self_le_coe_truncate (N₀+1-p),
  have ineq₂ := int.self_le_coe_truncate (N₀+1-(p+1)),
  rw [cochain.of_hom_v, ← (l₀.sequence hK hL (N₀+1-p).truncate).hy p (by linarith)],
  simp only [δ_v (-1) 0 (neg_add_self 1).symm _ p p (add_zero p).symm _ _ rfl rfl,
    cochain.mk_v],
  congr' 3,
  { apply lift.sequence_is_eventually_constant,
    apply int.truncate_le_of_le,
    { linarith, },
    { linarith, }, },
end

def lift.homotopy_zero : homotopy f 0 :=
begin
  equiv_rw equiv_homotopy _ _,
  exact ⟨lift.limit l₀ hK hL,
    by simp only [lift.δ_limit, cochain.of_hom_zero, add_zero]⟩,
end

end is_K_projective_of_bounded_above_of_projective

lemma is_K_projective_of_bounded_above_of_projective
  (K : cochain_complex C ℤ) (n : ℤ) [K.is_strictly_le n]
  [∀ (n : ℤ), projective (K.X n)] : is_K_projective K :=
⟨λ L f hL, begin
  let l : is_K_projective_of_bounded_above_of_projective.lift f n :=
  { y := 0,
    hy := λ p hp, begin
      simp only [δ_zero, cochain.zero_v],
      apply ((is_strictly_le.is_zero K n) p hp).eq_of_src,
    end, },
  exact ⟨is_K_projective_of_bounded_above_of_projective.lift.homotopy_zero l
    (λ p hp, infer_instance) (λ p hp, hL p)⟩,
end⟩

instance (P : C) [projective P] (n n' : ℤ) :
  projective (((single C (complex_shape.up ℤ) n).obj P).X n') :=
begin
  by_cases n' = n,
  { subst h,
    exact projective.of_iso (single_obj_X_self C (complex_shape.up ℤ) _ P).symm
      infer_instance, },
  { dsimp [single],
    rw if_neg h,
    exact projective.zero_projective, },
end

instance (P : C) [projective P] (n : ℤ) :
  is_K_projective ((single C (complex_shape.up ℤ) n).obj P) :=
is_K_projective_of_bounded_above_of_projective _ n

end cochain_complex


-- Insert lean 3 code here.

namespace foo

/-- test -/
@[simp] def foo := 1

theorem foo_eq_one : foo.foo = 1 := rfl

end foo


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.field_theory.adjoin
import Mathlib.field_theory.minpoly
import Mathlib.ring_theory.adjoin
import Mathlib.ring_theory.adjoin_root
import Mathlib.ring_theory.algebraic
import Mathlib.PostPort

universes u_8 u_9 l u_2 u_6 u_1 u_4 u_7

namespace Mathlib

/-!
# Power basis

This file defines a structure `power_basis R S`, giving a basis of the
`R`-algebra `S` as a finite list of powers `1, x, ..., x^n`.
There are also constructors for `power_basis` when adjoining an algebraic
element to a ring/field.

## Definitions

* `power_basis R A`: a structure containing an `x` and an `n` such that
`1, x, ..., x^n` is a basis for the `R`-algebra `A` (viewed as an `R`-module).

* `findim (hf : f ≠ 0) : finite_dimensional.findim K (adjoin_root f) = f.nat_degree`,
  the dimension of `adjoin_root f` equals the degree of `f`

* `power_basis.lift (pb : power_basis R S)`: if `y : S'` satisfies the same
  equations as `pb.gen`, this is the map `S →ₐ[R] S'` sending `pb.gen` to `y`

* `power_basis.equiv`: if two power bases satisfy the same equations, they are
  equivalent as algebras

## Implementation notes

Throughout this file, `R`, `S`, ... are `comm_ring`s, `A`, `B`, ... are
`integral_domain`s and `K`, `L`, ... are `field`s.
`S` is an `R`-algebra, `B` is an `A`-algebra, `L` is a `K`-algebra.

## Tags

power basis, powerbasis

-/

/-- `pb : power_basis R S` states that `1, pb.gen, ..., pb.gen ^ (pb.dim - 1)`
is a basis for the `R`-algebra `S` (viewed as `R`-module).

This is a structure, not a class, since the same algebra can have many power bases.
For the common case where `S` is defined by adjoining an integral element to `R`,
the canonical power basis is given by `{algebra,intermediate_field}.adjoin.power_basis`.
-/
structure power_basis (R : Type u_8) (S : Type u_9) [comm_ring R] [ring S] [algebra R S] where
  gen : S
  dim : ℕ
  is_basis : is_basis R fun (i : fin dim) => gen ^ ↑i

namespace power_basis

/-- Cannot be an instance because `power_basis` cannot be a class. -/
theorem finite_dimensional {S : Type u_2} [comm_ring S] {K : Type u_6} [field K] [algebra K S]
    (pb : power_basis K S) : finite_dimensional K S :=
  finite_dimensional.of_fintype_basis (is_basis pb)

theorem findim {S : Type u_2} [comm_ring S] {K : Type u_6} [field K] [algebra K S]
    (pb : power_basis K S) : finite_dimensional.findim K S = dim pb :=
  sorry

/-- TODO: this mixes `polynomial` and `finsupp`, we should hide this behind a
new function `polynomial.of_finsupp`. -/
theorem polynomial.mem_supported_range {R : Type u_1} [comm_ring R] {f : polynomial R} {d : ℕ} :
    f ∈ finsupp.supported R R ↑(finset.range d) ↔ polynomial.degree f < ↑d :=
  sorry

theorem mem_span_pow' {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] [algebra R S]
    {x : S} {y : S} {d : ℕ} :
    y ∈ submodule.span R (set.range fun (i : fin d) => x ^ ↑i) ↔
        ∃ (f : polynomial R), polynomial.degree f < ↑d ∧ y = coe_fn (polynomial.aeval x) f :=
  sorry

theorem mem_span_pow {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] [algebra R S] {x : S}
    {y : S} {d : ℕ} (hd : d ≠ 0) :
    y ∈ submodule.span R (set.range fun (i : fin d) => x ^ ↑i) ↔
        ∃ (f : polynomial R), polynomial.nat_degree f < d ∧ y = coe_fn (polynomial.aeval x) f :=
  sorry

theorem dim_ne_zero {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] [algebra R S]
    [nontrivial S] (pb : power_basis R S) : dim pb ≠ 0 :=
  sorry

theorem exists_eq_aeval {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] [algebra R S]
    [nontrivial S] (pb : power_basis R S) (y : S) :
    ∃ (f : polynomial R),
        polynomial.nat_degree f < dim pb ∧ y = coe_fn (polynomial.aeval (gen pb)) f :=
  iff.mp (mem_span_pow (dim_ne_zero pb)) (is_basis.mem_span (is_basis pb) y)

/-- `pb.minpoly_gen` is a minimal polynomial for `pb.gen`.

If `A` is not a field, it might not necessarily be *the* minimal polynomial,
however `nat_degree_minpoly` shows its degree is indeed minimal.
-/
def minpoly_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S]
    (pb : power_basis A S) : polynomial A :=
  polynomial.X ^ dim pb -
    finset.sum finset.univ
      fun (i : fin (dim pb)) =>
        coe_fn polynomial.C (coe_fn (coe_fn (is_basis.repr sorry) (gen pb ^ dim pb)) i) *
          polynomial.X ^ ↑i

@[simp] theorem nat_degree_minpoly_gen {S : Type u_2} [comm_ring S] {A : Type u_4}
    [integral_domain A] [algebra A S] (pb : power_basis A S) :
    polynomial.nat_degree (minpoly_gen pb) = dim pb :=
  sorry

theorem minpoly_gen_monic {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] (pb : power_basis A S) : polynomial.monic (minpoly_gen pb) :=
  sorry

@[simp] theorem aeval_minpoly_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] (pb : power_basis A S) :
    coe_fn (polynomial.aeval (gen pb)) (minpoly_gen pb) = 0 :=
  sorry

theorem is_integral_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] (pb : power_basis A S) : is_integral A (gen pb) :=
  Exists.intro (minpoly_gen pb) { left := minpoly_gen_monic pb, right := aeval_minpoly_gen pb }

theorem dim_le_nat_degree_of_root {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] (h : power_basis A S) {p : polynomial A} (ne_zero : p ≠ 0)
    (root : coe_fn (polynomial.aeval (gen h)) p = 0) : dim h ≤ polynomial.nat_degree p :=
  sorry

@[simp] theorem nat_degree_minpoly {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] (pb : power_basis A S) : polynomial.nat_degree (minpoly A (gen pb)) = dim pb :=
  sorry

theorem nat_degree_lt_nat_degree {R : Type u_1} [comm_ring R] {p : polynomial R} {q : polynomial R}
    (hp : p ≠ 0) (hpq : polynomial.degree p < polynomial.degree q) :
    polynomial.nat_degree p < polynomial.nat_degree q :=
  sorry

theorem constr_pow_aeval {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] (pb : power_basis A S) {y : S'}
    (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) (f : polynomial A) :
    coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i)
          (coe_fn (polynomial.aeval (gen pb)) f) =
        coe_fn (polynomial.aeval y) f :=
  sorry

theorem constr_pow_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S]
    {S' : Type u_8} [comm_ring S'] [algebra A S'] (pb : power_basis A S) {y : S'}
    (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) :
    coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i) (gen pb) = y :=
  sorry

theorem constr_pow_algebra_map {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] (pb : power_basis A S) {y : S'}
    (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) (x : A) :
    coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i)
          (coe_fn (algebra_map A S) x) =
        coe_fn (algebra_map A S') x :=
  sorry

theorem constr_pow_mul {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S]
    {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] (pb : power_basis A S) {y : S'}
    (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) (x : S) (x' : S) :
    coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i) (x * x') =
        coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i) x *
          coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i) x' :=
  sorry

/-- `pb.lift y hy` is the algebra map sending `pb.gen` to `y`,
where `hy` states the higher powers of `y` are the same as the higher powers of `pb.gen`. -/
def lift {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S]
    {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] (pb : power_basis A S) (y : S')
    (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) : alg_hom A S S' :=
  alg_hom.mk (linear_map.to_fun (is_basis.constr sorry fun (i : fin (dim pb)) => y ^ ↑i)) sorry
    (constr_pow_mul pb hy) sorry sorry (constr_pow_algebra_map pb hy)

@[simp] theorem lift_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S]
    (pb : power_basis A S) (y : S') (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) :
    coe_fn (lift pb y hy) (gen pb) = y :=
  constr_pow_gen pb hy

@[simp] theorem lift_aeval {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S]
    (pb : power_basis A S) (y : S') (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0)
    (f : polynomial A) :
    coe_fn (lift pb y hy) (coe_fn (polynomial.aeval (gen pb)) f) = coe_fn (polynomial.aeval y) f :=
  constr_pow_aeval pb hy f

/-- `pb.equiv pb' h` is an equivalence of algebras with the same power basis. -/
def equiv {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S]
    {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] [nontrivial S']
    (pb : power_basis A S) (pb' : power_basis A S') (h : minpoly A (gen pb) = minpoly A (gen pb')) :
    alg_equiv A S S' :=
  alg_equiv.of_alg_hom (lift pb (gen pb') sorry) (lift pb' (gen pb) sorry) sorry sorry

@[simp] theorem equiv_aeval {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] [nontrivial S']
    (pb : power_basis A S) (pb' : power_basis A S') (h : minpoly A (gen pb) = minpoly A (gen pb'))
    (f : polynomial A) :
    coe_fn (equiv pb pb' h) (coe_fn (polynomial.aeval (gen pb)) f) =
        coe_fn (polynomial.aeval (gen pb')) f :=
  lift_aeval pb (gen pb') (Eq.symm h ▸ minpoly.aeval A (gen pb')) f

@[simp] theorem equiv_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] [nontrivial S']
    (pb : power_basis A S) (pb' : power_basis A S') (h : minpoly A (gen pb) = minpoly A (gen pb')) :
    coe_fn (equiv pb pb' h) (gen pb) = gen pb' :=
  lift_gen pb (gen pb') (Eq.symm h ▸ minpoly.aeval A (gen pb'))

@[simp] theorem equiv_symm {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A]
    [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] [nontrivial S']
    (pb : power_basis A S) (pb' : power_basis A S') (h : minpoly A (gen pb) = minpoly A (gen pb')) :
    alg_equiv.symm (equiv pb pb' h) = equiv pb' pb (Eq.symm h) :=
  rfl

end power_basis

namespace algebra

theorem mem_span_power_basis {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] [algebra R S]
    [nontrivial R] {x : S} {y : S} (hx : is_integral R x)
    (hy : ∃ (f : polynomial R), y = coe_fn (polynomial.aeval x) f) :
    y ∈
        submodule.span R
          (set.range fun (i : fin (polynomial.nat_degree (minpoly R x))) => x ^ ↑i) :=
  sorry

theorem linear_independent_power_basis {S : Type u_2} [comm_ring S] {K : Type u_6} [field K]
    [algebra K S] {x : S} (hx : is_integral K x) :
    linear_independent K fun (i : fin (polynomial.nat_degree (minpoly K x))) => x ^ ↑i :=
  sorry

theorem power_basis_is_basis {S : Type u_2} [comm_ring S] {K : Type u_6} [field K] [algebra K S]
    {x : S} (hx : is_integral K x) :
    is_basis K
        fun (i : fin (polynomial.nat_degree (minpoly K x))) =>
          { val := x, property := subset_adjoin (set.mem_singleton x) } ^ ↑i :=
  sorry

/-- The power basis `1, x, ..., x ^ (d - 1)` for `K[x]`,
where `d` is the degree of the minimal polynomial of `x`. -/
def adjoin.power_basis {S : Type u_2} [comm_ring S] {K : Type u_6} [field K] [algebra K S] {x : S}
    (hx : is_integral K x) : power_basis K ↥(adjoin K (singleton x)) :=
  power_basis.mk { val := x, property := sorry } (polynomial.nat_degree (minpoly K x))
    (power_basis_is_basis hx)

end algebra

namespace adjoin_root

theorem power_basis_is_basis {K : Type u_6} [field K] {f : polynomial K} (hf : f ≠ 0) :
    is_basis K fun (i : fin (polynomial.nat_degree f)) => root f ^ subtype.val i :=
  sorry

/-- The power basis `1, root f, ..., root f ^ (d - 1)` for `adjoin_root f`,
where `f` is an irreducible polynomial over a field of degree `d`. -/
def power_basis {K : Type u_6} [field K] {f : polynomial K} (hf : f ≠ 0) :
    power_basis K (adjoin_root f) :=
  power_basis.mk (root f) (polynomial.nat_degree f) (power_basis_is_basis hf)

end adjoin_root

namespace intermediate_field

theorem power_basis_is_basis {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] {x : L}
    (hx : is_integral K x) :
    is_basis K fun (i : fin (polynomial.nat_degree (minpoly K x))) => adjoin_simple.gen K x ^ ↑i :=
  sorry

/-- The power basis `1, x, ..., x ^ (d - 1)` for `K⟮x⟯`,
where `d` is the degree of the minimal polynomial of `x`. -/
def adjoin.power_basis {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] {x : L}
    (hx : is_integral K x) : power_basis K ↥(adjoin K (insert.insert ∅ x)) :=
  power_basis.mk (adjoin_simple.gen K x) (polynomial.nat_degree (minpoly K x))
    (power_basis_is_basis hx)

@[simp] theorem adjoin.power_basis.gen_eq {K : Type u_6} {L : Type u_7} [field K] [field L]
    [algebra K L] {x : L} (hx : is_integral K x) :
    power_basis.gen (adjoin.power_basis hx) = adjoin_simple.gen K x :=
  rfl

theorem adjoin.finite_dimensional {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L]
    {x : L} (hx : is_integral K x) : finite_dimensional K ↥(adjoin K (insert.insert ∅ x)) :=
  power_basis.finite_dimensional (adjoin.power_basis hx)

theorem adjoin.findim {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] {x : L}
    (hx : is_integral K x) :
    finite_dimensional.findim K ↥(adjoin K (insert.insert ∅ x)) =
        polynomial.nat_degree (minpoly K x) :=
  sorry

end intermediate_field

namespace power_basis

/-- `pb.equiv_adjoin_simple` is the equivalence between `K⟮pb.gen⟯` and `L` itself. -/
def equiv_adjoin_simple {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L]
    (pb : power_basis K L) :
    alg_equiv K (↥(intermediate_field.adjoin K (intermediate_field.insert.insert ∅ (gen pb)))) L :=
  equiv (intermediate_field.adjoin.power_basis sorry) pb sorry

@[simp] theorem equiv_adjoin_simple_aeval {K : Type u_6} {L : Type u_7} [field K] [field L]
    [algebra K L] (pb : power_basis K L) (f : polynomial K) :
    coe_fn (equiv_adjoin_simple pb)
          (coe_fn (polynomial.aeval (intermediate_field.adjoin_simple.gen K (gen pb))) f) =
        coe_fn (polynomial.aeval (gen pb)) f :=
  equiv_aeval (intermediate_field.adjoin.power_basis (equiv_adjoin_simple._proof_3 pb)) pb
    (equiv_adjoin_simple._proof_4 pb) f

@[simp] theorem equiv_adjoin_simple_gen {K : Type u_6} {L : Type u_7} [field K] [field L]
    [algebra K L] (pb : power_basis K L) :
    coe_fn (equiv_adjoin_simple pb) (intermediate_field.adjoin_simple.gen K (gen pb)) = gen pb :=
  equiv_gen (intermediate_field.adjoin.power_basis (equiv_adjoin_simple._proof_3 pb)) pb
    (equiv_adjoin_simple._proof_4 pb)

@[simp] theorem equiv_adjoin_simple_symm_aeval {K : Type u_6} {L : Type u_7} [field K] [field L]
    [algebra K L] (pb : power_basis K L) (f : polynomial K) :
    coe_fn (alg_equiv.symm (equiv_adjoin_simple pb)) (coe_fn (polynomial.aeval (gen pb)) f) =
        coe_fn (polynomial.aeval (intermediate_field.adjoin_simple.gen K (gen pb))) f :=
  sorry

@[simp] theorem equiv_adjoin_simple_symm_gen {K : Type u_6} {L : Type u_7} [field K] [field L]
    [algebra K L] (pb : power_basis K L) :
    coe_fn (alg_equiv.symm (equiv_adjoin_simple pb)) (gen pb) =
        intermediate_field.adjoin_simple.gen K (gen pb) :=
  sorry

end Mathlib


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.lattice
import Mathlib.PostPort

universes u v l u_1 w x u_2 u_3

namespace Mathlib

/-- A `pequiv` is a partial equivalence, a representation of a bijection between a subset
  of `α` and a subset of `β` -/
structure pequiv (α : Type u) (β : Type v)
where
  to_fun : α → Option β
  inv_fun : β → Option α
  inv : ∀ (a : α) (b : β), a ∈ inv_fun b ↔ b ∈ to_fun a

infixr:25 " ≃. " => Mathlib.pequiv

namespace pequiv

protected instance has_coe_to_fun {α : Type u} {β : Type v} : has_coe_to_fun (α ≃. β) :=
  has_coe_to_fun.mk (fun (x : α ≃. β) => α → Option β) to_fun

@[simp] theorem coe_mk_apply {α : Type u} {β : Type v} (f₁ : α → Option β) (f₂ : β → Option α) (h : ∀ (a : α) (b : β), a ∈ f₂ b ↔ b ∈ f₁ a) (x : α) : coe_fn (mk f₁ f₂ h) x = f₁ x :=
  rfl

theorem ext {α : Type u} {β : Type v} {f : α ≃. β} {g : α ≃. β} (h : ∀ (x : α), coe_fn f x = coe_fn g x) : f = g := sorry

theorem ext_iff {α : Type u} {β : Type v} {f : α ≃. β} {g : α ≃. β} : f = g ↔ ∀ (x : α), coe_fn f x = coe_fn g x :=
  { mp := congr_fun ∘ congr_arg fun {f : α ≃. β} (x : α) => coe_fn f x, mpr := ext }

protected def refl (α : Type u_1) : α ≃. α :=
  mk some some sorry

protected def symm {α : Type u} {β : Type v} (f : α ≃. β) : β ≃. α :=
  mk (inv_fun f) (to_fun f) sorry

theorem mem_iff_mem {α : Type u} {β : Type v} (f : α ≃. β) {a : α} {b : β} : a ∈ coe_fn (pequiv.symm f) b ↔ b ∈ coe_fn f a :=
  inv f

theorem eq_some_iff {α : Type u} {β : Type v} (f : α ≃. β) {a : α} {b : β} : coe_fn (pequiv.symm f) b = some a ↔ coe_fn f a = some b :=
  inv f

protected def trans {α : Type u} {β : Type v} {γ : Type w} (f : α ≃. β) (g : β ≃. γ) : α ≃. γ :=
  mk (fun (a : α) => option.bind (coe_fn f a) ⇑g) (fun (a : γ) => option.bind (coe_fn (pequiv.symm g) a) ⇑(pequiv.symm f))
    sorry

@[simp] theorem refl_apply {α : Type u} (a : α) : coe_fn (pequiv.refl α) a = some a :=
  rfl

@[simp] theorem symm_refl {α : Type u} : pequiv.symm (pequiv.refl α) = pequiv.refl α :=
  rfl

@[simp] theorem symm_symm {α : Type u} {β : Type v} (f : α ≃. β) : pequiv.symm (pequiv.symm f) = f := sorry

theorem symm_injective {α : Type u} {β : Type v} : function.injective pequiv.symm :=
  function.left_inverse.injective symm_symm

theorem trans_assoc {α : Type u} {β : Type v} {γ : Type w} {δ : Type x} (f : α ≃. β) (g : β ≃. γ) (h : γ ≃. δ) : pequiv.trans (pequiv.trans f g) h = pequiv.trans f (pequiv.trans g h) :=
  ext fun (_x : α) => option.bind_assoc (coe_fn f _x) ⇑g ⇑h

theorem mem_trans {α : Type u} {β : Type v} {γ : Type w} (f : α ≃. β) (g : β ≃. γ) (a : α) (c : γ) : c ∈ coe_fn (pequiv.trans f g) a ↔ ∃ (b : β), b ∈ coe_fn f a ∧ c ∈ coe_fn g b :=
  option.bind_eq_some'

theorem trans_eq_some {α : Type u} {β : Type v} {γ : Type w} (f : α ≃. β) (g : β ≃. γ) (a : α) (c : γ) : coe_fn (pequiv.trans f g) a = some c ↔ ∃ (b : β), coe_fn f a = some b ∧ coe_fn g b = some c :=
  option.bind_eq_some'

theorem trans_eq_none {α : Type u} {β : Type v} {γ : Type w} (f : α ≃. β) (g : β ≃. γ) (a : α) : coe_fn (pequiv.trans f g) a = none ↔ ∀ (b : β) (c : γ), ¬b ∈ coe_fn f a ∨ ¬c ∈ coe_fn g b := sorry

@[simp] theorem refl_trans {α : Type u} {β : Type v} (f : α ≃. β) : pequiv.trans (pequiv.refl α) f = f :=
  ext fun (x : α) => option.ext fun (a : β) => id (iff.refl (a ∈ coe_fn f x))

@[simp] theorem trans_refl {α : Type u} {β : Type v} (f : α ≃. β) : pequiv.trans f (pequiv.refl β) = f := sorry

protected theorem inj {α : Type u} {β : Type v} (f : α ≃. β) {a₁ : α} {a₂ : α} {b : β} (h₁ : b ∈ coe_fn f a₁) (h₂ : b ∈ coe_fn f a₂) : a₁ = a₂ := sorry

theorem injective_of_forall_ne_is_some {α : Type u} {β : Type v} (f : α ≃. β) (a₂ : α) (h : ∀ (a₁ : α), a₁ ≠ a₂ → ↥(option.is_some (coe_fn f a₁))) : function.injective ⇑f := sorry

theorem injective_of_forall_is_some {α : Type u} {β : Type v} {f : α ≃. β} (h : ∀ (a : α), ↥(option.is_some (coe_fn f a))) : function.injective ⇑f := sorry

def of_set {α : Type u} (s : set α) [decidable_pred s] : α ≃. α :=
  mk (fun (a : α) => ite (a ∈ s) (some a) none) (fun (a : α) => ite (a ∈ s) (some a) none) sorry

theorem mem_of_set_self_iff {α : Type u} {s : set α} [decidable_pred s] {a : α} : a ∈ coe_fn (of_set s) a ↔ a ∈ s := sorry

theorem mem_of_set_iff {α : Type u} {s : set α} [decidable_pred s] {a : α} {b : α} : a ∈ coe_fn (of_set s) b ↔ a = b ∧ a ∈ s := sorry

@[simp] theorem of_set_eq_some_iff {α : Type u} {s : set α} {h : decidable_pred s} {a : α} {b : α} : coe_fn (of_set s) b = some a ↔ a = b ∧ a ∈ s :=
  mem_of_set_iff

@[simp] theorem of_set_eq_some_self_iff {α : Type u} {s : set α} {h : decidable_pred s} {a : α} : coe_fn (of_set s) a = some a ↔ a ∈ s :=
  mem_of_set_self_iff

@[simp] theorem of_set_symm {α : Type u} (s : set α) [decidable_pred s] : pequiv.symm (of_set s) = of_set s :=
  rfl

@[simp] theorem of_set_univ {α : Type u} : of_set set.univ = pequiv.refl α :=
  rfl

@[simp] theorem of_set_eq_refl {α : Type u} {s : set α} [decidable_pred s] : of_set s = pequiv.refl α ↔ s = set.univ := sorry

theorem symm_trans_rev {α : Type u} {β : Type v} {γ : Type w} (f : α ≃. β) (g : β ≃. γ) : pequiv.symm (pequiv.trans f g) = pequiv.trans (pequiv.symm g) (pequiv.symm f) :=
  rfl

theorem trans_symm {α : Type u} {β : Type v} (f : α ≃. β) : pequiv.trans f (pequiv.symm f) = of_set (set_of fun (a : α) => ↥(option.is_some (coe_fn f a))) := sorry

theorem symm_trans {α : Type u} {β : Type v} (f : α ≃. β) : pequiv.trans (pequiv.symm f) f = of_set (set_of fun (b : β) => ↥(option.is_some (coe_fn (pequiv.symm f) b))) := sorry

theorem trans_symm_eq_iff_forall_is_some {α : Type u} {β : Type v} {f : α ≃. β} : pequiv.trans f (pequiv.symm f) = pequiv.refl α ↔ ∀ (a : α), ↥(option.is_some (coe_fn f a)) := sorry

protected instance has_bot {α : Type u} {β : Type v} : has_bot (α ≃. β) :=
  has_bot.mk (mk (fun (_x : α) => none) (fun (_x : β) => none) sorry)

@[simp] theorem bot_apply {α : Type u} {β : Type v} (a : α) : coe_fn ⊥ a = none :=
  rfl

@[simp] theorem symm_bot {α : Type u} {β : Type v} : pequiv.symm ⊥ = ⊥ :=
  rfl

@[simp] theorem trans_bot {α : Type u} {β : Type v} {γ : Type w} (f : α ≃. β) : pequiv.trans f ⊥ = ⊥ := sorry

@[simp] theorem bot_trans {α : Type u} {β : Type v} {γ : Type w} (f : β ≃. γ) : pequiv.trans ⊥ f = ⊥ := sorry

theorem is_some_symm_get {α : Type u} {β : Type v} (f : α ≃. β) {a : α} (h : ↥(option.is_some (coe_fn f a))) : ↥(option.is_some (coe_fn (pequiv.symm f) (option.get h))) := sorry

def single {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] (a : α) (b : β) : α ≃. β :=
  mk (fun (x : α) => ite (x = a) (some b) none) (fun (x : β) => ite (x = b) (some a) none) sorry

theorem mem_single {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] (a : α) (b : β) : b ∈ coe_fn (single a b) a :=
  if_pos rfl

theorem mem_single_iff {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] (a₁ : α) (a₂ : α) (b₁ : β) (b₂ : β) : b₁ ∈ coe_fn (single a₂ b₂) a₁ ↔ a₁ = a₂ ∧ b₁ = b₂ := sorry

@[simp] theorem symm_single {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] (a : α) (b : β) : pequiv.symm (single a b) = single b a :=
  rfl

@[simp] theorem single_apply {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] (a : α) (b : β) : coe_fn (single a b) a = some b :=
  if_pos rfl

theorem single_apply_of_ne {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] {a₁ : α} {a₂ : α} (h : a₁ ≠ a₂) (b : β) : coe_fn (single a₁ b) a₂ = none :=
  if_neg (ne.symm h)

theorem single_trans_of_mem {α : Type u} {β : Type v} {γ : Type w} [DecidableEq α] [DecidableEq β] [DecidableEq γ] (a : α) {b : β} {c : γ} {f : β ≃. γ} (h : c ∈ coe_fn f b) : pequiv.trans (single a b) f = single a c := sorry

theorem trans_single_of_mem {α : Type u} {β : Type v} {γ : Type w} [DecidableEq α] [DecidableEq β] [DecidableEq γ] {a : α} {b : β} (c : γ) {f : α ≃. β} (h : b ∈ coe_fn f a) : pequiv.trans f (single b c) = single a c :=
  symm_injective (single_trans_of_mem c (iff.mpr (mem_iff_mem f) h))

@[simp] theorem single_trans_single {α : Type u} {β : Type v} {γ : Type w} [DecidableEq α] [DecidableEq β] [DecidableEq γ] (a : α) (b : β) (c : γ) : pequiv.trans (single a b) (single b c) = single a c :=
  single_trans_of_mem a (mem_single b c)

@[simp] theorem single_subsingleton_eq_refl {α : Type u} [DecidableEq α] [subsingleton α] (a : α) (b : α) : single a b = pequiv.refl α := sorry

theorem trans_single_of_eq_none {β : Type v} {γ : Type w} {δ : Type x} [DecidableEq β] [DecidableEq γ] {b : β} (c : γ) {f : δ ≃. β} (h : coe_fn (pequiv.symm f) b = none) : pequiv.trans f (single b c) = ⊥ := sorry

theorem single_trans_of_eq_none {α : Type u} {β : Type v} {δ : Type x} [DecidableEq α] [DecidableEq β] (a : α) {b : β} {f : β ≃. δ} (h : coe_fn f b = none) : pequiv.trans (single a b) f = ⊥ :=
  symm_injective (trans_single_of_eq_none a h)

theorem single_trans_single_of_ne {α : Type u} {β : Type v} {γ : Type w} [DecidableEq α] [DecidableEq β] [DecidableEq γ] {b₁ : β} {b₂ : β} (h : b₁ ≠ b₂) (a : α) (c : γ) : pequiv.trans (single a b₁) (single b₂ c) = ⊥ :=
  single_trans_of_eq_none a (single_apply_of_ne (ne.symm h) c)

protected instance partial_order {α : Type u} {β : Type v} : partial_order (α ≃. β) :=
  partial_order.mk (fun (f g : α ≃. β) => ∀ (a : α) (b : β), b ∈ coe_fn f a → b ∈ coe_fn g a)
    (preorder.lt._default fun (f g : α ≃. β) => ∀ (a : α) (b : β), b ∈ coe_fn f a → b ∈ coe_fn g a) sorry sorry sorry

theorem le_def {α : Type u} {β : Type v} {f : α ≃. β} {g : α ≃. β} : f ≤ g ↔ ∀ (a : α) (b : β), b ∈ coe_fn f a → b ∈ coe_fn g a :=
  iff.rfl

protected instance order_bot {α : Type u} {β : Type v} : order_bot (α ≃. β) :=
  order_bot.mk ⊥ partial_order.le partial_order.lt sorry sorry sorry sorry

protected instance semilattice_inf_bot {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] : semilattice_inf_bot (α ≃. β) :=
  semilattice_inf_bot.mk order_bot.bot order_bot.le order_bot.lt sorry sorry sorry sorry
    (fun (f g : α ≃. β) =>
      mk (fun (a : α) => ite (coe_fn f a = coe_fn g a) (coe_fn f a) none)
        (fun (b : β) => ite (coe_fn (pequiv.symm f) b = coe_fn (pequiv.symm g) b) (coe_fn (pequiv.symm f) b) none) sorry)
    sorry sorry sorry

end pequiv

namespace equiv

def to_pequiv {α : Type u_1} {β : Type u_2} (f : α ≃ β) : α ≃. β :=
  pequiv.mk (some ∘ ⇑f) (some ∘ ⇑(equiv.symm f)) sorry

@[simp] theorem to_pequiv_refl {α : Type u_1} : to_pequiv (equiv.refl α) = pequiv.refl α :=
  rfl

theorem to_pequiv_trans {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α ≃ β) (g : β ≃ γ) : to_pequiv (equiv.trans f g) = pequiv.trans (to_pequiv f) (to_pequiv g) :=
  rfl

theorem to_pequiv_symm {α : Type u_1} {β : Type u_2} (f : α ≃ β) : to_pequiv (equiv.symm f) = pequiv.symm (to_pequiv f) :=
  rfl

theorem to_pequiv_apply {α : Type u_1} {β : Type u_2} (f : α ≃ β) (x : α) : coe_fn (to_pequiv f) x = some (coe_fn f x) :=
  rfl


import .lemmas .dickson
open classical nat function prod set subtype list

noncomputable theory

theorem sub_gt_of_gt_ge {a b c : ℕ} (H1 : a > b) (H2 : b ≥ c) : a - c > b - c :=
have c ≤ a, from le_of_lt (lt_of_le_of_lt H2 H1),
have eq₁ : a - c + c = a, from nat.sub_add_cancel this,
have eq₂ : b - c + c = b, from nat.sub_add_cancel H2,
have b ≤ a, from le_of_lt H1,
have b - c ≤ a - c, from nat.sub_le_sub_right this c,
or.elim (nat.lt_or_eq_of_le this)
(assume Hl, Hl)
(assume Hr, have refl : a > a, by super,
 absurd refl (lt_irrefl a))

namespace kruskal

#check good_pairs

section
parameter {A : Type}
parameter f : ℕ → A
parameter g : ℕ → ℕ
parameter o : A → A → Prop
parameter H : ¬ is_good (f ∘ g) o

definition ran_g : set ℕ := {x : ℕ | ∃ i, g i = x}

theorem ne_empty_ran : ran_g ≠ ∅ := ne_empty_of_mem ⟨0,rfl⟩

private definition min : ℕ := least ran_g ne_empty_ran

definition index_of_min : ℕ :=
have min ∈ ran_g, from least_is_mem ran_g ne_empty_ran,
some this

theorem minimality_of_min (n : ℕ) : g index_of_min ≤ g n :=
have H1 : g index_of_min = min, from some_spec (least_is_mem ran_g ne_empty_ran),
have least ran_g ne_empty_ran ≤ g n, from minimality _ (g n) ⟨n,rfl⟩,
begin simp [H1], exact this end

private definition h (n : ℕ) : ℕ := g (index_of_min + n)

theorem exists_sub_bad : ∃ h : ℕ → ℕ, ¬ is_good (f ∘ h) o ∧ ∀ i : ℕ, h 0 ≤ h i :=
have badness : ¬ is_good (f ∘ h) o, from
   suppose is_good (f ∘ h) o,
   let ⟨i,j,hij⟩ := this in
   have index_of_min + i < index_of_min + j, from add_lt_add_left (and.left hij) _,
   have is_good (f ∘ g) o, from ⟨index_of_min + i,⟨index_of_min + j,⟨this,hij^.right⟩⟩⟩,
   H this,
have ∀ i : ℕ, h 0 ≤ h i, from λ i, minimality_of_min (index_of_min + i),
⟨h,⟨badness,this⟩⟩

end

definition extends_at {A : Type} (n : ℕ) (f : ℕ → A) (g : ℕ → A) : Prop := ∀ m ≤ n, g m = f m

theorem extends_at.refl {A : Type} {n : ℕ} {f : ℕ → A} : extends_at n f f := λ m H, rfl

theorem extends_at.trans {A : Type} {n m : ℕ} {f g h: ℕ → A} (H1 : extends_at n f g) (H2 : extends_at m g h) (H3 : n ≤ m) :
  extends_at n f h := λ k H,
have g k = f k, from H1 k H,
have k ≤ m, from nat.le_trans H H3,
have h k = g k, from H2 k this,
by super

theorem least_seq_at_n {S : set (ℕ → ℕ)} (H : S ≠ ∅) (n : ℕ) :
∃ f : ℕ → ℕ, f ∈ S ∧ ∀ g : ℕ → ℕ, g ∈ S → f n ≤ g n :=
let T : set ℕ := {x | ∃ f :ℕ → ℕ, f ∈ S ∧ f n = x} in
have ∃ f, f ∈ S, from exists_mem_of_ne_empty H,
let ⟨f,h⟩ := this in
have nemp : T ≠ ∅, from ne_empty_of_mem ⟨f,⟨h,rfl⟩⟩,
let a := least T nemp in
have a ∈ T, from least_is_mem T nemp,
let ⟨f',h⟩ := this in
have ∀ g : ℕ → ℕ, g ∈ S → f' n ≤ g n, from λ g Hg,
  have a ≤ g n, from minimality _ _ ⟨g,⟨Hg,rfl⟩⟩,
  by super,
⟨f',⟨h^.left, this⟩⟩

section
parameter {A : Type}
parameter {P : (ℕ → A) → Prop}
parameter g : A → ℕ
parameter H : ∃ f : ℕ → A, P f

definition colle : set (ℕ → A) := {f | P f}

lemma nonempty_colle : colle ≠ ∅ :=  let ⟨a,h⟩ := H in ne_empty_of_mem h

definition S : set (ℕ → ℕ) := image (λ f, g ∘ f) colle

lemma nonempty_S : S ≠ ∅ := image_nonempty nonempty_colle

theorem exists_min_func (n : ℕ) : ∃ f : ℕ → ℕ, f ∈ S ∧ ∀ g : ℕ → ℕ, g ∈ S → f n ≤ g n := least_seq_at_n nonempty_S n

definition min_func (n : ℕ) : ℕ → A :=
let fc := some (exists_min_func n) in
have fc ∈ S ∧ ∀ g : ℕ → ℕ, g ∈ S → fc n ≤ g n, from (some_spec (exists_min_func n)),
some this^.left

theorem min_func_property (n : ℕ) : P (min_func n) :=
let fc := some (exists_min_func n) in
let ⟨l,r⟩ := some_spec (exists_min_func n) in
have min_func n ∈ colle ∧ (λ f, g ∘ f) (min_func n) = fc, from some_spec l ,
this^.left

theorem min_func_minimality (f : ℕ → A) (Hp : P f) (n : ℕ) : g (min_func n n) ≤ g (f n) :=
let fc := some (exists_min_func n) in
let ⟨l,r⟩ := some_spec (exists_min_func n) in
have min_func n ∈ colle ∧ (λ f, g ∘ f) (min_func n) = fc, from some_spec l,
have (λ f, g ∘ f) (min_func n) = fc, from this^.right,
have eq2 : (λ f, g ∘ f) (min_func n) n = fc n, by rw this,
have Hr : ∀ g : ℕ → ℕ, g ∈ S → fc n ≤ g n, from (some_spec (exists_min_func n))^.right,
have le : fc n ≤ (λ f, g ∘ f) f n, from Hr _ ⟨f,⟨Hp,rfl⟩⟩,
have (λ f, g ∘ f) (min_func n) n ≤ (λ f, g ∘ f) f n, by rw -eq2 at le;exact le,
by super

end

section

parameter {A : Type}
parameter {P : (ℕ → A) → Prop} -- some property about f
parameter g : A → ℕ -- a measure of cardinality of A
parameter H : ∃ f, P f

-- construct a sequence of functions with property P such that each one extends its predecessor and is the minimal one at n.
noncomputable definition mbs_helper (n : ℕ) : {f : ℕ → A // P f} :=
nat.rec_on n
(let f₀ := min_func g H 0 in
 have P f₀, from min_func_property g H 0,
 ⟨f₀,this⟩)
(λ pred h',
let f' := h'.1 in
have H1 : extends_at pred f' f', from extends_at.refl,
have H2 : P f', from h'.2,
have HP : ∃ f, extends_at pred f' f ∧ P f, from ⟨f',⟨H1,H2⟩⟩,
let fn := min_func g HP (succ pred) in
have extends_at pred f' fn ∧ P fn, from min_func_property g HP (succ pred),
have P fn, from this^.right,
⟨fn,this⟩)

  section
  parameter n : ℕ
  definition helper_elt := (mbs_helper n).1
  definition helper_succ := (mbs_helper (succ n)).1
  lemma helper_ext_refl : extends_at n helper_elt helper_elt := extends_at.refl
  lemma helper_has_property : P helper_elt := (mbs_helper n).2
  lemma helper_inner_hyp : ∃ g, extends_at n helper_elt g ∧ P g := ⟨helper_elt, ⟨helper_ext_refl, helper_has_property⟩⟩
  theorem succ_ext_of_mbs_helper : extends_at n helper_elt helper_succ := (min_func_property g helper_inner_hyp (succ n))^.left
  end

theorem ext_of_mbs_helper (n : ℕ) : ∀ m, m ≤ n → extends_at m  (mbs_helper m).1 (mbs_helper n).1 :=
nat.rec_on n
(take m, assume H,
have eq : m = 0, from eq_zero_of_le_zero H,
have extends_at 0 (mbs_helper 0).1 (mbs_helper 0).1, from extends_at.refl,
by simp [eq,this])
(λ a IH m H,
by_cases
(suppose m = succ a,
have extends_at m (mbs_helper (succ a)).1 (mbs_helper (succ a)).1, from extends_at.refl, by super)
(suppose m ≠ succ a,
have m < succ a, from lt_of_le_of_ne H this,
have Hle : m ≤ a, from (iff.mp (lt_succ_iff_le m a)) this,
have H1 : extends_at m (mbs_helper m).1 (mbs_helper a).1, from IH m Hle,
have extends_at a (mbs_helper a).1 (mbs_helper (succ a)).1, from succ_ext_of_mbs_helper a,
extends_at.trans H1 this Hle))

theorem congruence_of_mbs_helper {n m : ℕ} (H : m ≤ n) : (mbs_helper n).1 m = (mbs_helper m).1 m :=
have extends_at m (mbs_helper m).1 (mbs_helper n).1, from ext_of_mbs_helper n m H,
this m (nat.le_refl m)

end

section
-- construction and properties of mbs.
parameter {A : Type}
parameter {o : A → A → Prop}
parameter g : A → ℕ
parameter H : ∃ f : ℕ → A, ¬ is_good f o

noncomputable definition seq_of_bad_seq (n : ℕ) : {f : ℕ → A // ¬ is_good f o} := mbs_helper g H n

definition minimal_bad_seq (n : ℕ) : A :=  (seq_of_bad_seq n).1 n

definition ext_of_seq_of_bad_seq := ext_of_mbs_helper g H

definition congruence_of_seq_of_bad_seq {n m : ℕ} (Hnm : m ≤ n) := congruence_of_mbs_helper g H Hnm

definition bad_seq_elt := helper_elt g H

definition bad_seq_inner_hyp := helper_inner_hyp g H

theorem badness_of_mbs : ¬ is_good minimal_bad_seq o :=
suppose is_good minimal_bad_seq o,
let ⟨i,j,h⟩ := this in
have i ≤ j, from le_of_lt_or_eq (or.inl h^.left),
have ext : extends_at i (seq_of_bad_seq i).1 (seq_of_bad_seq j).1, from ext_of_seq_of_bad_seq j i this,
have i ≤ i, from nat.le_refl i,
have (seq_of_bad_seq j).1 i = (minimal_bad_seq i), from ext i this,
have o ((seq_of_bad_seq j).1 i) (minimal_bad_seq j), by rw this; exact h^.right,
have i < j ∧ o ((seq_of_bad_seq j).1 i) ((seq_of_bad_seq j).1 j), from ⟨h^.left, this⟩,
have good : is_good (seq_of_bad_seq j).1 o, from ⟨i,⟨j, this⟩⟩,
have ¬ is_good (seq_of_bad_seq j).1 o, from (seq_of_bad_seq j).2,
this good

theorem minimality_of_mbs_0 (f : ℕ → A) (Hf : ¬ is_good f o) : g (minimal_bad_seq 0) ≤ g (f 0) := min_func_minimality g H f Hf 0

theorem minimality_of_mbs (n : ℕ) (f : ℕ → A) (H1 : extends_at n minimal_bad_seq f ∧ ¬ is_good f o) : g (minimal_bad_seq (succ n)) ≤ g (f (succ n)) :=
have Hl : ∀ m, m ≤ n →  f m = (bad_seq_elt n) m, from
  λ m Hle, have f m = minimal_bad_seq m, from H1^.left m Hle,
  have bad_seq_elt n m = minimal_bad_seq m, from congruence_of_seq_of_bad_seq Hle,
  by super, --by+ simp,
have ins_P : extends_at n (bad_seq_elt n) f ∧ ¬ is_good f o, from ⟨Hl, H1^.right⟩,
have ineq : g (min_func g (bad_seq_inner_hyp n) (succ n) (succ n)) ≤ g (f (succ n)), from min_func_minimality g (bad_seq_inner_hyp n) f ins_P (succ n),
by super

end

section

-- Given two sequences f and g, a function h which modifies indices so that h 0 is the break point, construct a new sequence 'combined_seq' by concatenating f and g at (h 0).

parameter {Q :Type}
parameter {o : Q → Q → Prop}
parameters f g : ℕ → Q
parameter h : ℕ → ℕ
parameter Hh : ∀ i, h 0 ≤ h i
parameter Hf : ¬ is_good f o
parameter Hg : ¬ is_good g o
-- in Higman's lemma in Williams 1963, h is f, g is the bad sequence B ∘ f
parameter H : ∀ i j, o (f i) (g (j - h 0)) → o (f i) (f (h (j - h 0)))

definition comb (n : ℕ) : Q := if n < h 0 then f n else g (n - h 0)

theorem g_part_of_comb (H : (h 0) = 0) : ∀ x, comb x = g x :=
λ n, have ¬ n < h 0, by rw H; apply not_lt_zero ,
have comb n = g (n - (h 0)), from if_neg this,
by simp [this, H]

include Hh

theorem badness_of_comb : ¬ is_good comb o :=
λ good, let ⟨i,j,hw⟩ := good in
by_cases
(assume Hposi : i < h 0,
  have eq1i : comb i = f i, from if_pos Hposi,
  by_cases
  (suppose j < h 0,
    have eq1j : comb j = f j, from if_pos this,
    have o (f i) (f j),by rw [-eq1j,-eq1i]; exact hw^.right,
    have is_good f o, from ⟨i, ⟨j,⟨hw^.left,this⟩⟩⟩,
    show _, from Hf this)
  (suppose ¬ j < h 0,
    have eq2j : comb j = g (j - (h 0)), from if_neg this,
    have o (f i) (g (j - (h 0))), by rw [-eq2j,-eq1i]; exact hw^.right,
    have Hr : o (f i) (f (h (j - (h 0)))), from H _ _ this,
    have i < h (j - (h 0)), from lt_of_lt_of_le Hposi (Hh _),
    have is_good f o, from ⟨i, ⟨h (j - h 0), ⟨this, Hr⟩⟩⟩,
    show _, from Hf this))
(assume Hnegi,
  have eq2i : comb i = g (i - h 0), from if_neg Hnegi,
  by_cases
  (suppose j < h 0,
    have j < i, from lt_of_lt_of_le this (le_of_not_gt Hnegi),
    show _, from (not_lt_of_gt hw^.left) this)
  (suppose ¬ j < h 0,
    have eq2j : comb j = g (j - h 0), from if_neg this,
    have Hr2 : o (g (i - h 0)) (g (j - h 0)), by rw [-eq2i,-eq2j]; exact hw^.right,
    have i - h 0 < j - h 0, from sub_gt_of_gt_ge hw^.left (le_of_not_gt Hnegi),
    have is_good g o, from ⟨(i - h 0), ⟨(j - h 0),⟨this, Hr2⟩⟩⟩,
    show _, from Hg this))

end

section
-- further assume that f is a minimal bad sequence and card (g 0) < card (f (h 0))
-- In other words, this section says, assuming that there is a bad sequence of Q, if g is a bad sequence such that H holds, then there is a contradiction.
parameter {Q :Type}
parameter {o : Q → Q → Prop}
parameters {g : ℕ → Q}
parameter h : ℕ → ℕ
parameter m : Q → ℕ -- a measure of cardinality
parameter Hh : ∀ i, h 0 ≤ h i
parameter Hex : ∃ f, ¬ is_good f o
parameter Hg : ¬ is_good g o
parameter H : ∀ i j, o (minimal_bad_seq m Hex i) (g (j - h 0)) → o (minimal_bad_seq m Hex i) ((minimal_bad_seq m Hex) (h (j - h 0)))
parameter Hbp : m (g 0) < m (minimal_bad_seq m Hex (h 0))

definition comb_seq_with_mbs := comb (minimal_bad_seq m Hex) g h

theorem g_part_of_comb_seq_with_mbs (H1 : (h 0) = 0) : ∀ x, comb_seq_with_mbs x = g x :=
begin apply g_part_of_comb, assumption end

theorem badness_of_comb_seq_with_mbs : ¬ is_good comb_seq_with_mbs o :=
badness_of_comb (minimal_bad_seq m Hex) g h Hh (badness_of_mbs m Hex) Hg H

theorem comb_seq_extends_mbs_at_pred_bp (H : h 0 ≠ 0): extends_at (pred (h 0)) (minimal_bad_seq m Hex) comb_seq_with_mbs :=
λ m Hm, if_pos (or_resolve_left (lt_of_le_pred Hm) H)

lemma comb_seq_h0 : comb_seq_with_mbs (h 0) = g 0 :=
have comb_seq_with_mbs (h 0) = g (h 0 - h 0), begin apply if_neg, rw lt_self_iff_false, trivial end,
by simp [this,nat.sub_self]

include Hbp Hex

theorem local_contra_of_comb_seq_with_mbs : false :=
by_cases
(suppose eq0 : h 0 = 0,
have eq : comb_seq_with_mbs 0 = g 0, begin apply g_part_of_comb_seq_with_mbs, assumption end,
have m (comb_seq_with_mbs 0) < m (minimal_bad_seq m Hex (h 0)), by rw -eq at Hbp;exact Hbp,
have le : m (comb_seq_with_mbs 0) < m (minimal_bad_seq m Hex 0), by super,
have m (minimal_bad_seq m Hex 0) ≤ m (comb_seq_with_mbs 0), from minimality_of_mbs_0 m Hex comb_seq_with_mbs badness_of_comb_seq_with_mbs,
(not_le_of_gt le) this)
(assume Hneg,
have le : m (minimal_bad_seq m Hex (succ (pred (h 0)))) ≤  m (comb_seq_with_mbs (succ (pred (h 0)))), from minimality_of_mbs m _ _ _ ⟨begin apply comb_seq_extends_mbs_at_pred_bp, exact Hneg end,badness_of_comb_seq_with_mbs⟩,
have h 0 > 0, from nat.pos_of_ne_zero Hneg,
have succ (pred (h 0)) = h 0, from succ_pred_of_pos this,
have m (minimal_bad_seq m Hex (h 0)) ≤ m (comb_seq_with_mbs (h 0)), by rw this at le;exact le,
have m (minimal_bad_seq m Hex (h 0)) ≤ m (g 0), by rw comb_seq_h0 at this;exact this,
have ¬ m (g 0) < m (minimal_bad_seq m Hex (h 0)), from not_lt_of_ge this,
this Hbp)

end

section
variable {α : Type}

inductive sublist' [has_le α]: list α → list α → Prop
| slnil : sublist' [] []
| cons (l₁ l₂ a) : sublist' l₁ l₂ → sublist' l₁ (a::l₂)
| cons2 (l₁ l₂ a b) : a ≤ b → sublist' l₁ l₂ → sublist' (a::l₁) (b::l₂)

infix ` <++ `:50 := sublist'

@[simp] lemma nil_sublist' [has_le α] : Π (l : list α), [] <++ l
| []       := sublist'.slnil
| (a :: l) := sublist'.cons _ _ a (nil_sublist' l)

@[simp] lemma sublist'.refl [quasiorder α] : Π (l : list α), l <++ l
| []       := sublist'.slnil
| (a :: l) := sublist'.cons2 _ _ a _ (quasiorder.refl a) (sublist'.refl l)

open sublist'

lemma sublist'.trans [quasiorder α] : Π {l₁ l₂ l₃ : list α}, l₁ <++ l₂ → l₂ <++ l₃ → l₁ <++ l₃
| ._ ._ ._ (slnil) (slnil) := nil_sublist' nil
| ._ ._ ._ (slnil) (cons ._ l₃' a h) := nil_sublist' _
| ._ ._ ._ (cons l₁ l₂' a h) (cons ._ l₃' b h') :=
  have l₁ <++ l₃', from sublist'.trans (cons _ _ _ h) h',
  show _, from cons _ _ _ this
| ._ ._ ._ (cons l₁ l₂' a h) (cons2 ._ l₃' ._ b hab h') :=
  have l₁ <++ l₃', from sublist'.trans h h',
  show _, from cons _ _ _ this
| ._ ._ ._ (cons2 l₁' l₂' a b hab h) (cons ._ l₃' c h') :=
  have a :: l₁' <++ b :: l₂', from cons2 _ _ _ _ hab h,
  have a :: l₁' <++ l₃', from sublist'.trans this h',
  show _, from cons _ _ _ this
| ._ ._ ._ (cons2 l₁' l₂' a b hab h) (cons2 ._ l₃' ._ d hbd h') :=
  show _, from cons2 _ _ _ _ (quasiorder.trans hab hbd) (sublist'.trans h h')

lemma sublist'.trans' [quasiorder α] {l₁ l₂ l₃ : list α} (h₁ : l₁ <++ l₂)  (h₂ : l₂ <++ l₃) : l₁ <++ l₃ :=
sublist'.trans h₁ h₂

@[simp] lemma sublist'_cons [quasiorder α](a : α) (l : list α) : l <++ a::l :=
sublist'.cons _ _ _ (sublist'.refl l)

end

section
parameter {Q : Type}
parameter [o : wqo Q]

parameter H : ∃ f : ℕ → list Q, ¬ is_good f sublist'

definition Higman's_mbs (n : ℕ) : list Q := minimal_bad_seq length H n

theorem badness_of_Higman's_mbs : ¬ is_good Higman's_mbs sublist' := badness_of_mbs length H

theorem nonempty_mem_of_mbs (n : ℕ) : Higman's_mbs n ≠ [] :=
λ h, badness_of_Higman's_mbs ⟨n, ⟨succ n,⟨lt_succ_self n,begin rw h, apply nil_sublist' end⟩⟩⟩

definition B_pairs (n : ℕ) : Q × list Q :=
have ∃ p : Q × list Q, Higman's_mbs n = p.1 :: p.2, from ne_nil_desturct (nonempty_mem_of_mbs n),
some this

private definition B (n : ℕ) : list Q := (B_pairs n).2

definition qn (n : ℕ) : Q := (B_pairs n).1

theorem Higman's_mbs_destruct (n : ℕ) : Higman's_mbs n = qn n :: B n :=
some_spec (ne_nil_desturct (nonempty_mem_of_mbs n))

theorem qn_in_mbs (n : ℕ) : qn n ∈ Higman's_mbs n :=
have Higman's_mbs n = qn n :: B n, from some_spec (ne_nil_desturct (nonempty_mem_of_mbs n)),
begin rw this, apply or.inl, reflexivity end

theorem sub_B_mbs (n : ℕ) : B n <++ Higman's_mbs n :=
have B n <++ qn n :: B n, from sublist'.cons _ _ _ (sublist'.refl _),
have Higman's_mbs n = qn n :: B n, from Higman's_mbs_destruct n,
by simph

theorem trans_of_B (i j : ℕ) (H1 : Higman's_mbs i <++ B j) : Higman's_mbs i <++ Higman's_mbs j :=
sublist'.trans H1 (sub_B_mbs j)

theorem len_B_lt_mbs (n : ℕ) : length (B n) < length (Higman's_mbs n) :=
have length (B n) < length (qn n :: B n), by rw length_cons; apply lt_succ_self,
have Higman's_mbs n = qn n :: B n, from Higman's_mbs_destruct n,
by super

section
parameter Hg : ∃ g : ℕ → ℕ, ¬ is_good (B ∘ g) sublist' ∧ ∀ i : ℕ, g 0 ≤ g i

private definition g : ℕ → ℕ := some Hg

theorem Higman's_Hg : ¬ is_good (B ∘ g) sublist' :=
let ⟨l,r⟩ := some_spec Hg in l

theorem Higman's_Hex : ∃ f : ℕ → list Q, ¬ is_good f sublist' :=
⟨(B ∘ g), Higman's_Hg⟩

theorem Higman's_Hh : ∀ i : ℕ, g 0 ≤ g i := (some_spec Hg)^.right

theorem Higman's_H : ∀ i j, Higman's_mbs i <++ (B ∘ g) (j - g 0) → Higman's_mbs i <++ Higman's_mbs (g (j - g 0)) :=
λ i j, λ H1, trans_of_B i (g (j - g 0)) H1

theorem Higman's_Hbp : length (B (g 0)) < length (Higman's_mbs (g 0)) := len_B_lt_mbs (g 0)

theorem Higman's_local_contradition : false :=
local_contra_of_comb_seq_with_mbs g length Higman's_Hh Higman's_Hex Higman's_Hg Higman's_H Higman's_Hbp

end

definition ClassB : Type := {x : list Q // ∃ i, B i = x}

definition oB (b1 : ClassB) (b2 : ClassB) : Prop := b1.val <++ b2.val

theorem oB_refl (q : ClassB) : oB q q := sublist'.refl q.val

theorem oB_trans (a b c : ClassB) (H1 : oB a b) (H2 : oB b c) : oB a c :=
sublist'.trans H1 H2

    section
    parameter HfB : ∃ f, ¬ is_good f oB

    private definition f' : ℕ → ClassB := some HfB

    private theorem bad_f' : ¬ is_good f' oB := some_spec HfB

    private definition g' (n : ℕ) := (f' n).val

    theorem exists_bad_B_seq : ¬ is_good g' sublist' :=
    suppose is_good g' sublist',
    let ⟨i,j,hg'⟩ := this in
    have is_good f' oB, from ⟨i, ⟨j, ⟨hg'^.left, hg'^.right⟩⟩⟩,
    bad_f' this

    private definition g (n : ℕ) : ℕ :=
    have ∃ i, B i = g' n, from (f' n).2,
    some this

    private theorem comp_eq_g' : B ∘ g = g' :=
    have ∀ x, B (g x) = g' x, from λ x, some_spec (f' x).2,
    funext this

    private theorem bad_comp : ¬ is_good (B ∘ g) sublist' :=
    have ¬ is_good g' sublist', from exists_bad_B_seq,
    by rw -comp_eq_g' at this;exact this

    theorem exists_sub_bad_B_seq : ∃ h : ℕ → ℕ, ¬ is_good (B ∘ h) sublist' ∧ ∀ i : ℕ, h 0 ≤ h i := exists_sub_bad B g sublist' bad_comp

    end

theorem oB_is_good : ∀ f, is_good f oB :=
by_contradiction
(suppose ¬ ∀ f, is_good f oB,
have ∃ f, ¬ is_good f oB, from classical.exists_not_of_not_forall this,
have ∃ h : ℕ → ℕ, ¬ is_good (B ∘ h) sublist' ∧ ∀ i : ℕ, h 0 ≤ h i, from exists_sub_bad_B_seq this,
Higman's_local_contradition this)

instance wqo_ClassB : wqo ClassB := wqo.mk (quasiorder.mk (has_le.mk oB) oB_refl oB_trans) oB_is_good

instance wqo_prod_Q_ClassB : wqo (Q × ClassB) := @wqo_prod _ _ o _

theorem good_prod_Q_ClassB : ∀ f : ℕ → Q × ClassB, is_good f (prod_order o.le oB) := wqo.is_good

lemma B_refl (n : ℕ) : ∃ i, B i = B n := ⟨n, rfl⟩

definition fB (n : ℕ) : ClassB := ⟨B n,B_refl n⟩

private definition p (n : ℕ) : Q × ClassB := (qn n, fB n)

theorem good_p : is_good p (prod_order o.le oB) := good_prod_Q_ClassB p

theorem Hij : ∃ i j, i < j ∧ ((qn i) ≤ (qn j) ∧ oB (fB i) (fB j)) := good_p

theorem exists_embeds : ∃ i j, i < j ∧ Higman's_mbs i <++ Higman's_mbs j :=
let ⟨i,j,⟨hijl,⟨hijrl,hijrr⟩⟩⟩ := good_p in
have qn i :: B i <++ qn j :: B j, from sublist'.cons2 _ _ _ _ hijrl hijrr,
have Higman's_mbs i = qn i :: B i, from Higman's_mbs_destruct i,
have Higman's_mbs j = qn j :: B j, from Higman's_mbs_destruct j,
have Higman's_mbs i <++ Higman's_mbs j, by simph,
⟨i,j,⟨hijl,this⟩⟩

theorem Higman's_contradiction : false := badness_of_Higman's_mbs exists_embeds

end

variable {Q : Type}
variable [wqo Q]

theorem good_sublist : ∀ f : ℕ → list Q , is_good f sublist' :=
by_contradiction
(suppose ¬ ∀ f, is_good f sublist',
have ∃ f, ¬ is_good f sublist', from classical.exists_not_of_not_forall this,
Higman's_contradiction this)

def wqo_list : wqo (list Q) :=
⟨⟨⟨sublist'⟩,sublist'.refl,λ a b c h₁ h₂,sublist'.trans' h₁ h₂⟩,good_sublist⟩

end kruskal


import melting_point.topology
open melting_point.topology

inductive X
| a | b | c | d

namespace X
  def τ : set (set X) :=
  { { a },
    { c },
    { a, c },
    { a, b, c },
    { a, d, c },
    ∅, set.univ }

  example : topology X := begin
    fapply topology.mk, exact τ, enumeration,
    repeat { intros x y u v, sinduction u; sinduction v; findset }
  end
end X


theorem needs_intros (P Q R : Prop) (HR : R) : P → (Q → R) :=
begin
  sorry,
end


class AddIdepotent (α : Type u) [Add α] : Prop where
  add_id (x : α) : x + x = x

export AddIdepotent (add_id)

theorem tst [Add α] [AddIdepotent α] (x : α) : id (x + x + x)  = x := by
  rw [add_id, add_id]
  simp [id]


/-
https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/mutual.20defs.3A.20ill-formed.20match.2Fequation.20expression/near/204543114
https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/apply_instance.20for.20defs/near/205085382
-/
import algebra.category.Module.monoidal
import algebra.category.Ring.basic

import tactic.delta_instance

open category_theory

universes u

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

#check Module.monoidal_category

def dummy (X : C) : C := X

-- example {R : Type u} [comm_ring R] (M : Module R) : Module R := dummy M
-- failed to synthesize type class instance for
-- R : Type u,
-- _inst_3 : comm_ring R,
-- M : Module R
-- ⊢ monoidal_category (Module R)

-- example {R : CommRing} (M : Module R) : Module R := dummy M
-- failed to synthesize type class instance for
-- R : CommRing,
-- M : Module ↥R
-- ⊢ monoidal_category (Module ↥R)

def tensor_power (X : C) : ℕ → C
| 0 := 𝟙_ C
| (n+1) := X ⊗ tensor_power n

-- example {R : CommRing} (M : Module R) : Module R := tensor_power M 17
-- failed to synthesize type class instance for
-- R : CommRing,
-- M : Module ↥R
-- ⊢ monoidal_category (Module ↥R)

-- And if you want to do this with unbundled objects:

variables (R : Type u) [comm_ring R] (M : Type u) [add_comm_group M] [module R M]

-- @[derive [add_comm_group, module R]]
-- def foo : Type u :=
--   (tensor_power (Module.of R M) 17 : Module R)

-- attribute [derive [add_comm_group, module R]] foo

-- WORKS
-- instance : add_comm_group (foo R M) := by { delta foo, apply_instance, }
-- instance : module R (foo R M) := by { delta foo, apply_instance, }

-- WORKS
-- instance : add_comm_group (foo R M) := by delta_instance foo
-- instance : module R (foo R M) :=  by delta_instance foo

-- namespace foo

-- /-
-- tactic.mk_instance failed to generate instance for
--   add_comm_group (foo R M)
-- -/
-- @[derive add_comm_group]
-- def to_add_comm_group := foo R M

-- /-
-- failed to synthesize type class instance for
-- R : Type u,
-- _inst_3 : comm_ring R,
-- M : Type u,
-- _inst_4 : add_comm_group M,
-- _inst_5 : module R M
-- ⊢ add_comm_group (to_module R M)
-- -/
-- @[derive module R]
-- def to_module := foo R M

-- end foo


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.extensive
import category_theory.limits.shapes.kernel_pair

/-!

# Adhesive categories

## Main definitions
- `category_theory.is_pushout.is_van_kampen`: A convenience formulation for a pushout being
  a van Kampen colimit.
- `category_theory.adhesive`: A category is adhesive if it has pushouts and pullbacks along
  monomorphisms, and such pushouts are van Kampen.

## Main Results
- `category_theory.type.adhesive`: The category of `Type` is adhesive.
- `category_theory.adhesive.is_pullback_of_is_pushout_of_mono_left`: In adhesive categories,
  pushouts along monomorphisms are pullbacks.
- `category_theory.adhesive.mono_of_is_pushout_of_mono_left`: In adhesive categories,
  monomorphisms are stable under pushouts.
- `category_theory.adhesive.to_regular_mono_category`: Monomorphisms in adhesive categories are
  regular (this implies that adhesive categories are balanced).

## TODO

Show that the following are adhesive:
- functor categories into adhesive categories
- the categories of sheaves over a site

## References
- https://ncatlab.org/nlab/show/adhesive+category
- [Stephen Lack and Paweł Sobociński, Adhesive Categories][adhesive2004]

-/
namespace category_theory

open limits

universes v' u' v u

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

variables {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}

/-- A convenience formulation for a pushout being a van Kampen colimit.
See `is_pushout.is_van_kampen_iff` below. -/
@[nolint unused_arguments] -- This only makes sense when the original diagram is a pushout.
def is_pushout.is_van_kampen (H : is_pushout f g h i) : Prop :=
∀ ⦃W' X' Y' Z' : C⦄ (f' : W' ⟶ X') (g' : W' ⟶ Y') (h' : X' ⟶ Z') (i' : Y' ⟶ Z')
  (αW : W' ⟶ W) (αX : X' ⟶ X) (αY : Y' ⟶ Y) (αZ : Z' ⟶ Z)
  (hf : is_pullback f' αW αX f) (hg : is_pullback g' αW αY g)
  (hh : comm_sq h' αX αZ h) (hi : comm_sq i' αY αZ i)
  (w : comm_sq f' g' h' i'),
  is_pushout f' g' h' i' ↔ is_pullback h' αX αZ h ∧ is_pullback i' αY αZ i

lemma is_pushout.is_van_kampen.flip {H : is_pushout f g h i} (H' : H.is_van_kampen) :
  H.flip.is_van_kampen :=
begin
  introv W' hf hg hh hi w,
  simpa only [is_pushout.flip_iff, is_pullback.flip_iff, and_comm] using
    H' g' f' i' h' αW αY αX αZ hg hf hi hh w.flip,
end

lemma is_pushout.is_van_kampen_iff (H : is_pushout f g h i) :
  H.is_van_kampen ↔ is_van_kampen_colimit (pushout_cocone.mk h i H.w) :=
begin
  split,
  { intros H F' c' α fα eα hα,
    refine iff.trans _ ((H (F'.map walking_span.hom.fst) (F'.map walking_span.hom.snd)
      (c'.ι.app _) (c'.ι.app _) (α.app _) (α.app _) (α.app _) fα
      (by convert hα walking_span.hom.fst) (by convert hα walking_span.hom.snd)
      _ _ _).trans _),
    { have : F'.map walking_span.hom.fst ≫ c'.ι.app walking_span.left =
        F'.map walking_span.hom.snd ≫ c'.ι.app walking_span.right := by simp only [cocone.w],
      rw (is_colimit.equiv_of_nat_iso_of_iso (diagram_iso_span F') c'
        (pushout_cocone.mk _ _ this) _).nonempty_congr,
      { exact ⟨λ h, ⟨⟨this⟩, h⟩, λ h, h.2⟩ },
      { refine cocones.ext (iso.refl c'.X) _, rintro (_|_|_); dsimp;
          simp only [c'.w, category.assoc, category.id_comp, category.comp_id] } },
    { exact ⟨nat_trans.congr_app eα.symm _⟩ },
    { exact ⟨nat_trans.congr_app eα.symm _⟩ },
    { exact ⟨by simp⟩ },
    split,
    { rintros ⟨h₁, h₂⟩ (_|_|_),
      { rw ← c'.w walking_span.hom.fst, exact (hα walking_span.hom.fst).paste_horiz h₁ },
      exacts [h₁, h₂] },
    { intro h, exact ⟨h _, h _⟩ } },
  { introv H W' hf hg hh hi w,
    refine (iff.trans _
      ((H w.cocone ⟨by { rintros (_|_|_), exacts [αW, αX, αY] }, _⟩ αZ _ _).trans _)),
    rotate,
    { rintros i _ (_|_|_),
      { dsimp, simp only [functor.map_id, category.comp_id, category.id_comp] },
      exacts [hf.w, hg.w] },
    { ext (_|_|_),
      { dsimp, rw pushout_cocone.condition_zero, erw [category.assoc, hh.w, hf.w_assoc] },
      exacts [hh.w.symm, hi.w.symm] },
    { rintros i _ (_|_|_),
      { dsimp, simp_rw functor.map_id,
        exact is_pullback.of_horiz_is_iso ⟨by rw [category.comp_id, category.id_comp]⟩ },
      exacts [hf, hg] },
    { split,
      { intro h, exact ⟨h walking_cospan.left, h walking_cospan.right⟩ },
      { rintro ⟨h₁, h₂⟩ (_|_|_),
        { dsimp, rw pushout_cocone.condition_zero, exact hf.paste_horiz h₁ },
        exacts [h₁, h₂] } },
    { exact ⟨λ h, h.2, λ h, ⟨_, h⟩⟩ } }
end
.

lemma is_coprod_iff_is_pushout {X E Y YE : C} (c : binary_cofan X E)
  (hc : is_colimit c) {f : X ⟶ Y} {iY : Y ⟶ YE} {fE : c.X ⟶ YE}
  (H : comm_sq f c.inl iY fE) :
  nonempty (is_colimit (binary_cofan.mk (c.inr ≫ fE) iY)) ↔ is_pushout f c.inl iY fE :=
begin
  split,
  { rintro ⟨h⟩,
    refine ⟨H, ⟨limits.pushout_cocone.is_colimit_aux' _ _⟩⟩,
    intro s,
    dsimp,
    refine ⟨h.desc (binary_cofan.mk (c.inr ≫ s.inr) s.inl), h.fac _ ⟨walking_pair.right⟩, _, _⟩,
    { apply binary_cofan.is_colimit.hom_ext hc,
      { rw ← H.w_assoc, erw h.fac _ ⟨walking_pair.right⟩, exact s.condition },
      { rw ← category.assoc, exact h.fac _ ⟨walking_pair.left⟩ } },
    { intros m e₁ e₂,
      apply binary_cofan.is_colimit.hom_ext h,
      { dsimp, rw [category.assoc, e₂, eq_comm], exact h.fac _ ⟨walking_pair.left⟩ },
      { refine e₁.trans (eq.symm _), exact h.fac _ _ } } },
  { refine λ H, ⟨_⟩,
    fapply limits.binary_cofan.is_colimit_mk,
    { exact λ s, H.is_colimit.desc (pushout_cocone.mk s.inr _ $
        (hc.fac (binary_cofan.mk (f ≫ s.inr) s.inl) ⟨walking_pair.left⟩).symm) },
    { intro s,
      erw [category.assoc, H.is_colimit.fac _ walking_span.right, hc.fac], refl },
    { intro s, exact H.is_colimit.fac _ walking_span.left },
    { intros s m e₁ e₂,
      apply pushout_cocone.is_colimit.hom_ext H.is_colimit,
      { symmetry, exact (H.is_colimit.fac _ walking_span.left).trans e₂.symm },
      { erw H.is_colimit.fac _ walking_span.right,
        apply binary_cofan.is_colimit.hom_ext hc,
        { dsimp, erw [hc.fac, ← H.w_assoc, e₂], refl },
        { refine ((category.assoc _ _ _).symm.trans e₁).trans _, symmetry, exact hc.fac _ _ } } } }
end

lemma is_pushout.is_van_kampen_inl {W E X Z : C} (c : binary_cofan W E)
  [finitary_extensive C]
  [has_pullbacks C]
  (hc : is_colimit c) (f : W ⟶ X) (h : X ⟶ Z) (i : c.X ⟶ Z)
  (H : is_pushout f c.inl h i) : H.is_van_kampen :=
begin
  obtain ⟨hc₁⟩ := (is_coprod_iff_is_pushout c hc H.1).mpr H,
  introv W' hf hg hh hi w,
  obtain ⟨hc₂⟩ := ((binary_cofan.is_van_kampen_iff _).mp (finitary_extensive.van_kampen c hc)
    (binary_cofan.mk _ pullback.fst) _ _ _ hg.w.symm pullback.condition.symm).mpr
    ⟨hg, is_pullback.of_has_pullback αY c.inr⟩,
  refine (is_coprod_iff_is_pushout _ hc₂ w).symm.trans _,
  refine ((binary_cofan.is_van_kampen_iff _).mp (finitary_extensive.van_kampen _ hc₁)
    (binary_cofan.mk _ _) pullback.snd _ _ _ hh.w.symm).trans _,
  { dsimp, rw [← pullback.condition_assoc, category.assoc, hi.w] },
  split,
  { rintro ⟨hc₃, hc₄⟩,
    refine ⟨hc₄, _⟩,
    let Y'' := pullback αZ i,
    let cmp : Y' ⟶ Y'' := pullback.lift i' αY hi.w,
    have e₁ : (g' ≫ cmp) ≫ pullback.snd = αW ≫ c.inl :=
      by rw [category.assoc, pullback.lift_snd, hg.w],
    have e₂ : (pullback.fst ≫ cmp : pullback αY c.inr ⟶ _) ≫ pullback.snd =
      pullback.snd ≫ c.inr :=
      by rw [category.assoc, pullback.lift_snd, pullback.condition],
    obtain ⟨hc₄⟩ := ((binary_cofan.is_van_kampen_iff _).mp (finitary_extensive.van_kampen c hc)
      (binary_cofan.mk _ _) αW _ _ e₁.symm e₂.symm).mpr ⟨_, _⟩,
    { rw [← category.id_comp αZ, ← show cmp ≫ pullback.snd = αY, from pullback.lift_snd _ _ _],
      apply is_pullback.paste_vert _ (is_pullback.of_has_pullback αZ i),
      have : cmp = (hc₂.cocone_point_unique_up_to_iso hc₄).hom,
      { apply binary_cofan.is_colimit.hom_ext hc₂,
        exacts [(hc₂.comp_cocone_point_unique_up_to_iso_hom hc₄ ⟨walking_pair.left⟩).symm,
          (hc₂.comp_cocone_point_unique_up_to_iso_hom hc₄ ⟨walking_pair.right⟩).symm] },
      rw this,
      exact is_pullback.of_vert_is_iso ⟨by rw [← this, category.comp_id, pullback.lift_fst]⟩ },
    { apply is_pullback.of_right _ e₁ (is_pullback.of_has_pullback _ _),
      rw [category.assoc, pullback.lift_fst, ← H.w, ← w.w], exact hf.paste_horiz hc₄ },
    { apply is_pullback.of_right _ e₂ (is_pullback.of_has_pullback _ _),
      rw [category.assoc, pullback.lift_fst], exact hc₃ } },
  { rintros ⟨hc₃, hc₄⟩,
    exact ⟨(is_pullback.of_has_pullback αY c.inr).paste_horiz hc₄, hc₃⟩ }
end

lemma is_pushout.is_van_kampen.is_pullback_of_mono_left [mono f]
  {H : is_pushout f g h i} (H' : H.is_van_kampen) :
  is_pullback f g h i :=
((H' (𝟙 _) g g (𝟙 Y) (𝟙 _) f (𝟙 _) i
  (is_kernel_pair.id_of_mono f) (is_pullback.of_vert_is_iso ⟨by simp⟩) H.1.flip ⟨rfl⟩
  ⟨by simp⟩).mp (is_pushout.of_horiz_is_iso ⟨by simp⟩)).1.flip

lemma is_pushout.is_van_kampen.is_pullback_of_mono_right [mono g]
  {H : is_pushout f g h i} (H' : H.is_van_kampen) :
  is_pullback f g h i :=
((H' f (𝟙 _) (𝟙 _) f (𝟙 _) (𝟙 _) g h  (is_pullback.of_vert_is_iso ⟨by simp⟩)
  (is_kernel_pair.id_of_mono g) ⟨rfl⟩ H.1
  ⟨by simp⟩).mp (is_pushout.of_vert_is_iso ⟨by simp⟩)).2

lemma is_pushout.is_van_kampen.mono_of_mono_left [mono f]
  {H : is_pushout f g h i} (H' : H.is_van_kampen) :
  mono i :=
is_kernel_pair.mono_of_is_iso_fst
  (((H' (𝟙 _) g g (𝟙 Y) (𝟙 _) f (𝟙 _) i
  (is_kernel_pair.id_of_mono f) (is_pullback.of_vert_is_iso ⟨by simp⟩) H.1.flip ⟨rfl⟩
  ⟨by simp⟩).mp (is_pushout.of_horiz_is_iso ⟨by simp⟩)).2)

lemma is_pushout.is_van_kampen.mono_of_mono_right [mono g]
  {H : is_pushout f g h i} (H' : H.is_van_kampen) :
  mono h :=
is_kernel_pair.mono_of_is_iso_fst
  ((H' f (𝟙 _) (𝟙 _) f (𝟙 _) (𝟙 _) g h  (is_pullback.of_vert_is_iso ⟨by simp⟩)
  (is_kernel_pair.id_of_mono g) ⟨rfl⟩ H.1
  ⟨by simp⟩).mp (is_pushout.of_vert_is_iso ⟨by simp⟩)).1

/-- A category is adhesive if it has pushouts and pullbacks along monomorphisms,
and such pushouts are van Kampen. -/
class adhesive (C : Type u) [category.{v} C] : Prop :=
[has_pullback_of_mono_left : ∀ {X Y S : C} (f : X ⟶ S) (g : Y ⟶ S) [mono f], has_pullback f g]
[has_pushout_of_mono_left : ∀ {X Y S : C} (f : S ⟶ X) (g : S ⟶ Y) [mono f], has_pushout f g]
(van_kampen : ∀ {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z} [mono f]
  (H : is_pushout f g h i), H.is_van_kampen)

attribute [priority 100, instance]
  adhesive.has_pullback_of_mono_left adhesive.has_pushout_of_mono_left

lemma adhesive.van_kampen' [adhesive C] [mono g] (H : is_pushout f g h i) : H.is_van_kampen :=
(adhesive.van_kampen H.flip).flip

lemma adhesive.is_pullback_of_is_pushout_of_mono_left [adhesive C]
  (H : is_pushout f g h i) [mono f] : is_pullback f g h i :=
(adhesive.van_kampen H).is_pullback_of_mono_left

lemma adhesive.is_pullback_of_is_pushout_of_mono_right [adhesive C]
  (H : is_pushout f g h i) [mono g] : is_pullback f g h i :=
(adhesive.van_kampen' H).is_pullback_of_mono_right

lemma adhesive.mono_of_is_pushout_of_mono_left [adhesive C]
  (H : is_pushout f g h i) [mono f] : mono i :=
(adhesive.van_kampen H).mono_of_mono_left

lemma adhesive.mono_of_is_pushout_of_mono_right [adhesive C]
  (H : is_pushout f g h i) [mono g] : mono h :=
(adhesive.van_kampen' H).mono_of_mono_right

instance type.adhesive : adhesive (Type u) :=
begin
  constructor,
  intros,
  exactI (is_pushout.is_van_kampen_inl _ (types.is_coprod_of_mono f) _ _ _ H.flip).flip
end

@[priority 100] noncomputable
instance adhesive.to_regular_mono_category [adhesive C] : regular_mono_category C :=
⟨λ X Y f hf, by exactI
  { Z := pushout f f,
    left := pushout.inl,
    right := pushout.inr,
    w := pushout.condition,
    is_limit := (adhesive.is_pullback_of_is_pushout_of_mono_left
      (is_pushout.of_has_pushout f f)).is_limit_fork }⟩

-- This then implies that adhesive categories are balanced
example [adhesive C] : balanced C := infer_instance

end category_theory


import Mathlib.Tactic.Lift
import Mathlib.Tactic.PermuteGoals
import Mathlib.Tactic.Coe
import Mathlib.Init.Set
import Mathlib.Order.Basic
import Mathlib.Algebra.Group.WithOne.Defs
import Mathlib.Data.Set.Image
import Mathlib.Data.Set.List
import Mathlib.Data.Rat.Defs
import Mathlib.Data.PNat.Defs

/-! Some tests of the `lift` tactic. -/

example (n : ℤ) (hn : 0 ≤ n) : 0 ≤ n + 1 := by
  lift n to ℕ
  guard_target =ₛ 0 ≤ n
  swap; guard_target =ₛ 0 ≤ (n : Int) + 1; swap
  · exact hn
  · exact Int.le_add_one hn

example (n : ℤ) (hn : 0 ≤ n) : 0 ≤ n + 1 := by
  lift n to ℕ using hn
  guard_target =ₛ 0 ≤ (n : Int) + 1
  exact Int.le_add_one (Int.ofNat_zero_le _)

example (n : ℤ) (hn : 0 ≤ n) : 0 ≤ n + 1 := by
  have hn' := hn
  lift n to ℕ using hn with k hk
  guard_target =ₛ 0 ≤ (k : Int) + 1
  guard_hyp hk : (k : Int) = n
  exact Int.le_add_one hn'

example (n : ℤ) (hn : 0 ≤ n) : 0 ≤ n + 1 := by
  have hn' := hn
  lift n to ℕ using hn with k
  guard_target =ₛ 0 ≤ (k : Int) + 1
  exact Int.le_add_one hn'

example (n : ℤ) (hn : 0 ≤ n) : 0 ≤ n + 1 := by
  lift n to ℕ using hn with k hk hn
  guard_target =ₛ 0 ≤ (k : Int) + 1
  guard_hyp hn : 0 ≤ (k : Int)
  guard_hyp hk : k = n
  exact Int.le_add_one hn

example (n : ℤ) (hn : 0 ≤ n) : 0 ≤ n + 1 := by
  lift n to ℕ using hn with k rfl hn
  guard_target =ₛ 0 ≤ (k : Int) + 1
  guard_hyp hn : 0 ≤ (k : Int)
  exact Int.le_add_one hn

example (n : ℤ) (hn : 0 ≤ n) : 0 ≤ n + 1 := by
  have hn' := hn
  lift n to ℕ using hn with k rfl
  guard_target =ₛ 0 ≤ (k : Int) + 1
  exact Int.le_add_one hn'

example (n : ℤ) (hn : 0 ≤ n) : 0 ≤ n + 1 := by
  have hn' := hn
  lift n to ℕ using hn with n
  guard_target =ₛ 0 ≤ (n : Int) + 1
  exact Int.le_add_one hn'

example (n : ℤ) (hn : 0 ≤ n) : 0 ≤ n + 1 := by
  -- Should fail because we didn't provide a variable name when lifting an expression
  fail_if_success lift n + 1 to ℕ using (Int.le_add_one hn)
  -- Now it should succeed
  lift n + 1 to ℕ using (Int.le_add_one hn) with k hk
  exact of_decide_eq_true rfl

-- test lift of functions
example (α : Type _) (f : α → ℤ) (hf : ∀ a, 0 ≤ f a) (hf' : ∀ a, f a < 1) (a : α) :
    0 ≤ 2 * f a := by
  lift f to α → ℕ using hf
  guard_target =ₛ (0 : ℤ) ≤ 2 * (fun i : α ↦ (f i : ℤ)) a
  guard_hyp hf' : ∀ a, ((fun i : α ↦ (f i : ℤ)) a) < 1
  constructor

example (α : Type _) (f : α → ℤ) (hf : ∀ a, 0 ≤ f a) (hf' : ∀ a, f a < 1) (a : α) :
    0 ≤ 2 * f a := by
  lift f to α → ℕ using hf with g hg
  guard_target =ₛ 0 ≤ 2 * (g a : Int)
  guard_hyp hg : (fun i => (g i : Int)) = f
  constructor

example (n m k x : ℤ) (hn : 0 < n) (hk : 0 ≤ k + n) (h : k + n = 2 + x)
    (hans : k + n = m + x) (hans2 : 0 ≤ m) : k + n = m + x := by
  lift n to ℕ using le_of_lt hn
  guard_target =ₛ k + ↑n = m + x; guard_hyp hn : (0 : ℤ) < ↑n
  lift m to ℕ
  guard_target =ₛ 0 ≤ m; swap; guard_target =ₛ k + ↑n = ↑m + x
  lift (k + n) to ℕ using hk with l hl
  exact hans
  exact hans2

-- fail gracefully when the lifted variable is a local definition
example (h : False) : let n : ℤ := 3; n = 3 := by
  intro n
  fail_if_success lift n to ℕ
  exfalso; exact h

instance canLift_unit : CanLift Unit Unit id (fun _ ↦ true) := ⟨fun x _ ↦ ⟨x, rfl⟩⟩

example (n : ℤ) (hn : 0 < n) : True := by
  fail_if_success lift n to ℕ using hn
  fail_if_success lift (n : Option ℤ) to ℕ
  trivial

 example (n : ℤ) : ℕ := by
  fail_if_success lift n to ℕ
  exact 0

instance canLift_subtype (R : Type _) (s : Set R) : CanLift R {x // x ∈ s} ((↑) : {x // x ∈ s} → R) (fun x => x ∈ s) :=
{ prf := fun x hx => ⟨⟨x, hx⟩, rfl⟩ }

example {R : Type _} {P : R → Prop} (x : R) (hx : P x) : P x := by
  lift x to {x // P x} using hx with y hy hx
  guard_target =ₛ P y
  guard_hyp hy : y = x
  guard_hyp hx : P y
  exact hx

 example (n : ℤ) (h_ans : n = 5) (hn : 0 ≤ 1 * n) : n = 5 := by
  lift n to ℕ using by { simpa [Int.one_mul] using hn } with k hk
  guard_target =ₛ (k : Int) = 5
  guard_hyp hk : k = n
  guard_hyp hn : 0 ≤ 1 * (k : Int)
  guard_hyp h_ans : (k : Int) = 5
  exact h_ans

example (n : WithOne Unit) (hn : n ≠ 1) : True := by
  lift n to Unit
  · guard_target =ₛ n ≠ 1
    exact hn

  guard_hyp n : Unit
  guard_hyp hn : (n : WithOne Unit) ≠ 1
  trivial

example (n : WithZero Unit) (hn : n ≠ 0) : True := by
  lift n to Unit
  · guard_target =ₛ n ≠ 0
    exact hn

  guard_hyp n : Unit
  guard_hyp hn : (n : WithZero Unit) ≠ 0
  trivial

example (s : Set ℤ) (h : ∀ x ∈ s, 0 ≤ x) : True := by
  lift s to Set ℕ
  · guard_target =ₛ (∀ x ∈ s, 0 ≤ x)
    exact h

  guard_hyp s : Set ℕ
  guard_hyp h : ∀ (x : ℤ), x ∈ (fun (n : ℕ) => (n : ℤ)) '' s → 0 ≤ x
  trivial

example (l : List ℤ) (h : ∀ x ∈ l, 0 ≤ x) : True := by
  lift l to List ℕ
  · guard_target =ₛ (∀ x ∈ l, 0 ≤ x)
    exact h

  guard_hyp l : List ℕ
  guard_hyp h : ∀ (x : ℤ), x ∈ List.map (fun (n : ℕ) => (n : ℤ)) l → 0 ≤ x
  trivial

example (q : ℚ) (h : q.den = 1) : True := by
  lift q to ℤ
  · guard_target =ₛ q.den = 1
    exact h

  guard_hyp q : ℤ
  guard_hyp h : (q : ℚ).den = 1
  trivial

example (x : WithTop Unit) (h : x ≠ ⊤) : True := by
  lift x to Unit
  · guard_target =ₛ x ≠ ⊤
    exact h

  guard_hyp x : Unit
  guard_hyp h : (x : WithTop Unit) ≠ ⊤
  trivial

example (x : WithBot Unit) (h : x ≠ ⊥) : True := by
  lift x to Unit
  · guard_target =ₛ x ≠ ⊥
    exact h

  guard_hyp x : Unit
  guard_hyp h : (x : WithBot Unit) ≠ ⊥
  trivial

example (n : ℕ) (hn : 0 < n) : True := by
  lift n to ℕ+
  · guard_target =ₛ 0 < n
    exact hn

  guard_hyp n : ℕ+
  guard_hyp hn : 0 < (n : ℕ)
  trivial

example (n : ℤ) (hn : 0 < n) : True := by
  lift n to ℕ+
  · guard_target =ₛ 0 < n
    exact hn

  guard_hyp n : ℕ+
  guard_hyp hn : 0 < (n : ℤ)
  trivial


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}"

set_option smartUnfolding false

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⟩ }

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::_ => 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)

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)
set_option pp.match false in
#print Vec.mapHead2 -- reused Vec.mapHead1.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 (motive := (y : Nat) → x = y → Nat) x, rfl with
| 0,   h => 0
| x+1, h => 1
#eval checkWithMkMatcherInput ``foo2.match_1


/- Meta stuff: attributes, tactics, etc. -/

/-
@[user_attribute]
meta def sop_attr: user_attribute :=
{ name := `sop_form,
  descr := "A simplification lemma that brings expressions to a sum-of-products form." } -/

run_cmd mk_simp_attr `sop_form [`simp]

/-
@[user_attribute]
meta def unfold_attr: user_attribute :=
{ name := `unfold_,
  descr := "Essentially what unfold should do but doesn't so I use simp instead." } -/

run_cmd mk_simp_attr `unfold_ [`simp]

meta def solve_context: tactic unit :=
  `[simp * with unfold_ sop_form, try { simp * with unfold_ sop_form },
    done <|> tactic.fail "Cannot prove contexts equal." ]


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.types
import Mathlib.category_theory.limits.shapes.products
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.category_theory.limits.shapes.terminal
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# Special shapes for limits in `Type`.

The general shape (co)limits defined in `category_theory.limits.types`
are intended for use through the limits API,
and the actual implementation should mostly be considered "sealed".

In this file, we provide definitions of the "standard" special shapes of limits in `Type`,
giving the expected definitional implementation:
* the terminal object is `punit`
* the binary product of `X` and `Y` is `X × Y`
* the product of a family `f : J → Type` is `Π j, f j`.

Because these are not intended for use with the `has_limit` API,
we instead construct terms of `limit_data`.

As an example, when setting up the monoidal category structure on `Type`
we use the `types_has_terminal` and `types_has_binary_products` instances.
-/

namespace category_theory.limits.types

/-- A restatement of `types.lift_π_apply` that uses `pi.π` and `pi.lift`. -/
@[simp] theorem pi_lift_π_apply {β : Type u} (f : β → Type u) {P : Type u} (s : (b : β) → P ⟶ f b)
    (b : β) (x : P) : pi.π f b (pi.lift s x) = s b x :=
  congr_fun (limit.lift_π (fan.mk P s) b) x

/-- A restatement of `types.map_π_apply` that uses `pi.π` and `pi.map`. -/
@[simp] theorem pi_map_π_apply {β : Type u} {f : β → Type u} {g : β → Type u}
    (α : (j : β) → f j ⟶ g j) (b : β) (x : ∏ fun (j : β) => f j) :
    pi.π g b (pi.map α x) = α b (pi.π f b x) :=
  limit.map_π_apply (discrete.nat_trans α) b x

/-- The category of types has `punit` as a terminal object. -/
def terminal_limit_cone : limit_cone (functor.empty (Type u)) :=
  limit_cone.mk (cone.mk PUnit (nat_trans.mk sorry)) (id (is_limit.mk sorry))

/-- The category of types has `pempty` as an initial object. -/
def initial_limit_cone : colimit_cocone (functor.empty (Type u)) :=
  colimit_cocone.mk (cocone.mk pempty (nat_trans.mk sorry)) (id (is_colimit.mk sorry))

/-- The product type `X × Y` forms a cone for the binary product of `X` and `Y`. -/
-- We manually generate the other projection lemmas since the simp-normal form for the legs is

-- otherwise not created correctly.

@[simp] theorem binary_product_cone_X (X : Type u) (Y : Type u) :
    cone.X (binary_product_cone X Y) = (X × Y) :=
  Eq.refl (X × Y)

@[simp] theorem binary_product_cone_fst (X : Type u) (Y : Type u) :
    binary_fan.fst (binary_product_cone X Y) = prod.fst :=
  rfl

@[simp] theorem binary_product_cone_snd (X : Type u) (Y : Type u) :
    binary_fan.snd (binary_product_cone X Y) = prod.snd :=
  rfl

/-- The product type `X × Y` is a binary product for `X` and `Y`. -/
@[simp] theorem binary_product_limit_lift (X : Type u) (Y : Type u) (s : binary_fan X Y)
    (x : cone.X s) :
    is_limit.lift (binary_product_limit X Y) s x = (binary_fan.fst s x, binary_fan.snd s x) :=
  Eq.refl (is_limit.lift (binary_product_limit X Y) s x)

/--
The category of types has `X × Y`, the usual cartesian product,
as the binary product of `X` and `Y`.
-/
@[simp] theorem binary_product_limit_cone_is_limit (X : Type u) (Y : Type u) :
    limit_cone.is_limit (binary_product_limit_cone X Y) = binary_product_limit X Y :=
  Eq.refl (limit_cone.is_limit (binary_product_limit_cone X Y))

/-- The functor which sends `X, Y` to the product type `X × Y`. -/
-- We add the option `type_md` to tell `@[simps]` to not treat homomorphisms `X ⟶ Y` in `Type*` as

-- a function type

@[simp] theorem binary_product_functor_obj_map (X : Type u) (Y₁ : Type u) (Y₂ : Type u)
    (f : Y₁ ⟶ Y₂) :
    functor.map (functor.obj binary_product_functor X) f =
        is_limit.lift (binary_product_limit X Y₂) (binary_fan.mk prod.fst (prod.snd ≫ f)) :=
  Eq.refl (functor.map (functor.obj binary_product_functor X) f)

/--
The product functor given by the instance `has_binary_products (Type u)` is isomorphic to the
explicit binary product functor given by the product type.
-/
def binary_product_iso_prod : binary_product_functor ≅ prod.functor :=
  nat_iso.of_components
    (fun (X : Type u) =>
      nat_iso.of_components
        (fun (Y : Type u) =>
          iso.symm
            (is_limit.cone_point_unique_up_to_iso (limit.is_limit (pair X Y))
              (binary_product_limit X Y)))
        sorry)
    sorry

/-- The sum type `X ⊕ Y` forms a cocone for the binary coproduct of `X` and `Y`. -/
@[simp] theorem binary_coproduct_cocone_ι_app (X : Type u) (Y : Type u)
    (j : discrete walking_pair) :
    ∀ (ᾰ : functor.obj (pair X Y) j),
        nat_trans.app (cocone.ι (binary_coproduct_cocone X Y)) j ᾰ =
          walking_pair.rec sum.inl sum.inr j ᾰ :=
  fun (ᾰ : functor.obj (pair X Y) j) => Eq.refl (walking_pair.rec sum.inl sum.inr j ᾰ)

/-- The sum type `X ⊕ Y` is a binary coproduct for `X` and `Y`. -/
def binary_coproduct_colimit (X : Type u) (Y : Type u) : is_colimit (binary_coproduct_cocone X Y) :=
  is_colimit.mk fun (s : binary_cofan X Y) => sum.elim (binary_cofan.inl s) (binary_cofan.inr s)

/--
The category of types has `X ⊕ Y`,
as the binary coproduct of `X` and `Y`.
-/
def binary_coproduct_colimit_cocone (X : Type u) (Y : Type u) : colimit_cocone (pair X Y) :=
  colimit_cocone.mk (binary_coproduct_cocone X Y) (binary_coproduct_colimit X Y)

/--
The category of types has `Π j, f j` as the product of a type family `f : J → Type`.
-/
def product_limit_cone {J : Type u} (F : J → Type u) : limit_cone (discrete.functor F) :=
  limit_cone.mk
    (cone.mk ((j : J) → F j)
      (nat_trans.mk
        fun (j : discrete J)
          (f : functor.obj (functor.obj (functor.const (discrete J)) ((j : J) → F j)) j) => f j))
    (is_limit.mk
      fun (s : cone (discrete.functor F)) (x : cone.X s) (j : J) => nat_trans.app (cone.π s) j x)

/--
The category of types has `Σ j, f j` as the coproduct of a type family `f : J → Type`.
-/
def coproduct_colimit_cocone {J : Type u} (F : J → Type u) : colimit_cocone (discrete.functor F) :=
  colimit_cocone.mk
    (cocone.mk (sigma fun (j : J) => F j)
      (nat_trans.mk fun (j : discrete J) (x : functor.obj (discrete.functor F) j) => sigma.mk j x))
    (is_colimit.mk
      fun (s : cocone (discrete.functor F))
        (x :
        cocone.X
          (cocone.mk (sigma fun (j : J) => F j)
            (nat_trans.mk
              fun (j : discrete J) (x : functor.obj (discrete.functor F) j) => sigma.mk j x))) =>
        nat_trans.app (cocone.ι s) (sigma.fst x) (sigma.snd x))

/--
Show the given fork in `Type u` is an equalizer given that any element in the "difference kernel"
comes from `X`.
The converse of `unique_of_type_equalizer`.
-/
def type_equalizer_of_unique {X : Type u} {Y : Type u} {Z : Type u} (f : X ⟶ Y) {g : Y ⟶ Z}
    {h : Y ⟶ Z} (w : f ≫ g = f ≫ h)
    (t : ∀ (y : Y), g y = h y → exists_unique fun (x : X) => f x = y) : is_limit (fork.of_ι f w) :=
  fork.is_limit.mk' (fork.of_ι f w)
    fun (s : fork g h) =>
      { val :=
          fun
            (i :
            functor.obj (functor.obj (functor.const walking_parallel_pair) (cone.X s))
              walking_parallel_pair.zero) =>
            classical.some sorry,
        property := sorry }

/-- The converse of `type_equalizer_of_unique`. -/
theorem unique_of_type_equalizer {X : Type u} {Y : Type u} {Z : Type u} (f : X ⟶ Y) {g : Y ⟶ Z}
    {h : Y ⟶ Z} (w : f ≫ g = f ≫ h) (t : is_limit (fork.of_ι f w)) (y : Y) (hy : g y = h y) :
    exists_unique fun (x : X) => f x = y :=
  sorry

theorem type_equalizer_iff_unique {X : Type u} {Y : Type u} {Z : Type u} (f : X ⟶ Y) {g : Y ⟶ Z}
    {h : Y ⟶ Z} (w : f ≫ g = f ≫ h) :
    Nonempty (is_limit (fork.of_ι f w)) ↔
        ∀ (y : Y), g y = h y → exists_unique fun (x : X) => f x = y :=
  sorry

/-- Show that the subtype `{x : Y // g x = h x}` is an equalizer for the pair `(g,h)`. -/
def equalizer_limit {Y : Type u} {Z : Type u} {g : Y ⟶ Z} {h : Y ⟶ Z} :
    limit_cone (parallel_pair g h) :=
  limit_cone.mk (fork.of_ι subtype.val sorry)
    (fork.is_limit.mk' (fork.of_ι subtype.val sorry)
      fun (s : fork g h) =>
        { val :=
            fun
              (i :
              functor.obj (functor.obj (functor.const walking_parallel_pair) (cone.X s))
                walking_parallel_pair.zero) =>
              { val := fork.ι s i, property := sorry },
          property := sorry })

end Mathlib


import category_theory.abelian.exact
import category_theory.limits.constructions.epi_mono

noncomputable theory

namespace category_theory

open limits

universes u v

variables {𝓐 𝓑 : Type u} [category.{v} 𝓐] [category.{v} 𝓑]
variables [abelian 𝓐] [abelian 𝓑]
variables (L : 𝓐 ⥤ 𝓑) [preserves_finite_limits L] [preserves_finite_colimits L]

lemma preserve_image {X Y : 𝓐} (f : X ⟶ Y) : image (L.map f) ≅ L.obj (image f) :=
have aux1 : strong_epi_mono_factorisation (L.map f) :=
{ I := L.obj (image f),
  m := L.map $ image.ι _,
  m_mono := by apply_instance,
  e := L.map $ factor_thru_image _,
  e_strong_epi := strong_epi_of_epi _,
  fac' := by rw [←L.map_comp, image.fac] },
is_image.iso_ext (image.is_image (L.map f)) aux1.to_mono_is_image

lemma preserve_image.precomp_factor_thru_image {X Y : 𝓐} (f : X ⟶ Y) :
  factor_thru_image  (L.map f) ≫ (preserve_image L f).hom =
  L.map (factor_thru_image f) :=
begin
  dunfold preserve_image,
  simp only [is_image.iso_ext_hom],
  erw image.fac_lift,
end

def apply_image_subobject_iso_image_subobject_apply {X Y : 𝓐} (f : X ⟶ Y) :
   L.obj (image_subobject f) ≅ (image_subobject (L.map f)) :=
{ hom := L.map (image_subobject_iso _).hom ≫ (preserve_image L f).inv,
  inv := (preserve_image L f).hom ≫ L.map (image_subobject_iso _).inv,
  hom_inv_id' := by rw [category.assoc, ←category.assoc _ _ (L.map _), iso.inv_hom_id, category.id_comp,
    ←L.map_comp, iso.hom_inv_id, L.map_id],
  inv_hom_id' := by rw [category.assoc, ←category.assoc _ _ (preserve_image L f).inv,
    ←L.map_comp, iso.inv_hom_id, L.map_id, category.id_comp, iso.hom_inv_id] }
≪≫ (image_subobject_iso _).symm

def apply_kernel_subobject_iso_kernel_subobject_apply {X Y : 𝓐} (f : X ⟶ Y) :
  L.obj (kernel_subobject f) ≅ (kernel_subobject (L.map f)) :=
{ hom := L.map (kernel_subobject_iso _).hom ≫ (preserves_kernel.iso L f).hom,
  inv := (preserves_kernel.iso L f).inv ≫ L.map (kernel_subobject_iso _).inv,
  hom_inv_id' := by rw [category.assoc, ←category.assoc _ _ (L.map _), iso.hom_inv_id, category.id_comp, ←L.map_comp, iso.hom_inv_id, L.map_id],
  inv_hom_id' := by rw [category.assoc, ←category.assoc _ _ (preserves_kernel.iso _ _).hom, ←L.map_comp, iso.inv_hom_id, L.map_id, category.id_comp, iso.inv_hom_id] }
≪≫ (kernel_subobject_iso _).symm

lemma exact_of_exact_functor {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z)
  (e1 : exact f g) :
  exact (L.map f) (L.map g) :=
have H : is_iso (image_to_kernel f g e1.w) := is_iso_of_mono_of_epi _,
begin
  rw abelian.exact_iff_image_eq_kernel,
  ext,
  work_on_goal 2
  { refine (preserve_image L f) ≪≫ _ ≪≫ (preserves_kernel.iso _ _),
    exact
    { hom := L.map $ (image_subobject_iso _).inv ≫ image_to_kernel f g e1.w ≫ (kernel_subobject_iso _).hom,
      inv := L.map $ (kernel_subobject_iso _).inv ≫ (@as_iso _ _ _ _ (image_to_kernel _ _ e1.w) H).inv ≫ (image_subobject_iso _).hom,
      hom_inv_id' := begin
        simp only [←L.map_comp, category.assoc],
        have h1 := (kernel_subobject_iso g).hom_inv_id,
        reassoc h1,
        rw [h1, ←category.assoc _ _ (image_subobject_iso _).hom, as_iso_inv,
          is_iso.hom_inv_id, category.id_comp, iso.inv_hom_id, L.map_id],
      end,
      inv_hom_id' := begin
        simp only [←L.map_comp, category.assoc],
        have h1 := (image_subobject_iso f).hom_inv_id,
        reassoc h1,
        rw [h1, ←category.assoc _ _ (kernel_subobject_iso _).hom, as_iso_inv,
          is_iso.inv_hom_id, category.id_comp, iso.inv_hom_id, L.map_id],
      end } },
  { simp only [functor.map_comp, category.assoc, iso.trans_hom, preserves_kernel.iso_hom, kernel_comparison_comp_ι, image.fac],
    simp only [←L.map_comp, kernel_subobject_arrow, image_to_kernel_arrow, image_subobject_arrow'],
    rw [←category.assoc, preserve_image.precomp_factor_thru_image, ←L.map_comp, image.fac] }
end

end category_theory