import for_mathlib.derived.les2

noncomputable theory

universes v u

open category_theory category_theory.limits

variables {A : Type u} [category.{v} A] [abelian A]

local notation `𝒦` := homotopy_category A (complex_shape.up ℤ)

namespace bounded_homotopy_category
variables {X Y Z : cochain_complex A ℤ} (f : X ⟶ Y) (g : Y ⟶ Z)

section
open homotopy_category

-- move me
@[reassoc]
lemma Ext_map_Ext_iso [enough_projectives A]
  (i : ℤ) (P₁ P₂ X₁ X₂ Y : bounded_homotopy_category A)
  [is_K_projective P₁.val] [is_K_projective P₂.val]
  (f₁ : P₁ ⟶ X₁) [is_quasi_iso f₁] (f₂ : P₂ ⟶ X₂) [is_quasi_iso f₂]
  (φ : X₁ ⟶ X₂) (φ' : P₁ ⟶ P₂) (h : φ' ≫ f₂ = f₁ ≫ φ) :
  ((Ext i).flip.obj Y).map φ.op ≫ (Ext_iso i P₁ X₁ Y f₁).hom =
    (Ext_iso i P₂ X₂ Y f₂).hom ≫ (preadditive_yoneda.obj (Y⟦i⟧)).map φ'.op :=
begin
  dsimp only [Ext_iso, functor.map_iso_hom, iso.op_hom, Ext, Ext0,
    functor.flip_obj_map, functor.comp_map, whiskering_left_obj_map, whisker_left_app,
    functor.flip_map_app],
  rw [← category_theory.functor.map_comp, ← op_comp,
      ← category_theory.functor.map_comp, ← op_comp],
  congr' 2,
  dsimp only [replacement_iso_hom, opposite.unop_op],
  refine lift_ext X₂.π _ _ _,
  simp only [category.assoc, lift_lifts, lift_lifts_assoc, quiver.hom.unop_op, h],
end

-- move me
@[reassoc]
lemma Ext_map_Ext_iso' [enough_projectives A]
  (i : ℤ) (X₁ X₂ Y : bounded_homotopy_category A) (φ : X₁ ⟶ X₂) :
  ((Ext i).flip.obj Y).map φ.op ≫ (Ext_iso i _ X₁ Y X₁.π).hom =
    (Ext_iso i _ X₂ Y X₂.π).hom ≫ (preadditive_yoneda.obj (Y⟦i⟧)).map (lift (X₁.π ≫ φ) X₂.π).op :=
Ext_map_Ext_iso _ _ _ _ _ _ _ _ _ _ $ by rw [lift_lifts]

lemma Ext_iso_naturality_snd_component
  [enough_projectives A]
  (i : ℤ) (P X Y₁ Y₂ : bounded_homotopy_category A)
  [is_K_projective P.val]
  (f : P ⟶ X) [is_quasi_iso f] (g : Y₁ ⟶ Y₂) :
  ((Ext i).obj _).map g ≫ (Ext_iso i P X _ f).hom =
  (Ext_iso i P X _ f).hom ≫ (preadditive_yoneda.flip.obj (opposite.op P)).map (g⟦i⟧') :=
begin
  dsimp only [Ext_iso, Ext, Ext0], ext t,
  dsimp, simp only [comp_apply], dsimp, simp,
end

end

def shift_iso [enough_projectives A]
  (n : ℤ) (X : cochain_complex A ℤ) (Y : bounded_homotopy_category A)
  [((homotopy_category.quotient A (complex_shape.up ℤ)).obj X).is_bounded_above] :
  (((Ext (n+1)).flip.obj Y)).obj (opposite.op $ (of' X)⟦(1:ℤ)⟧) ≅
  (((Ext n).flip.obj Y)).obj (opposite.op $ (of' X)) :=
begin
  let e := Ext_iso n (of' X).replace (of' X) Y (of' X).π,
  let e' := Ext_iso (n+1) ((of' X).replace⟦1⟧) ((of' X)⟦1⟧) Y ((of' X).π⟦(1:ℤ)⟧'),
  refine (e' ≪≫ _ ≪≫ e.symm),
  clear e e',
  refine add_equiv.to_AddCommGroup_iso _,
  refine shift_iso_aux 1 n _ _,
end

open category_theory.preadditive

lemma shift_iso_conj
  (n : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)] :
  (shift_iso _ _ _).inv ≫ (((Ext (n+1)).flip.obj W).right_op.map ((of_hom f)⟦(1 : ℤ)⟧')).unop
    ≫ (shift_iso _ _ _).hom =
  ((Ext n).flip.obj W).map (of_hom f).op :=
begin
  dsimp only [shift_iso, iso.trans_hom, iso.trans_inv, iso.symm_inv, iso.symm_hom,
    functor.right_op_map, quiver.hom.unop_op],
  simp only [category.assoc],
  rw [Ext_map_Ext_iso_assoc (n+1)
    ((shift_functor (bounded_homotopy_category A) (1:ℤ)).obj (of' X).replace)
    ((shift_functor (bounded_homotopy_category A) (1:ℤ)).obj (of' Y).replace)
    _ _ _
    ((shift_functor (bounded_homotopy_category A) 1).map (of' X).π)
    ((shift_functor (bounded_homotopy_category A) 1).map (of' Y).π)
    _ ((lift ((of' X).π ≫ of_hom f) (of' Y).π)⟦1⟧'),
    iso.inv_hom_id_assoc],
  swap,
  { simp only [comp_neg, neg_comp, neg_inj, ← category_theory.functor.map_comp, lift_lifts], },
  simp only [← category.assoc, iso.comp_inv_eq],
  rw [Ext_map_Ext_iso', category.assoc, category.assoc], congr' 1,
  rw [← category.assoc, ← iso.eq_comp_inv],
  apply AddCommGroup.ext, intros φ,
  dsimp only [shift_iso_aux, add_equiv.to_AddCommGroup_iso],
  rw [comp_apply, comp_apply],
  dsimp only [add_equiv.coe_to_add_monoid_hom, add_equiv.symm, equiv.symm, add_equiv.to_equiv_mk,
    add_equiv.coe_mk],
  erw [preadditive_yoneda_obj_map_apply, preadditive_yoneda_obj_map_apply],
  simp only [← category.assoc, quiver.hom.unop_op, ← category_theory.functor.map_comp],
end

--attribute [simps] shift_iso_aux
lemma shift_iso_conj'
  (n : ℤ)
  [enough_projectives A]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  (W₁ W₂ : bounded_homotopy_category A) (f : W₁ ⟶ W₂) :
  (shift_iso n X W₁).inv ≫ ((Ext (n+1)).obj _).map f ≫ (shift_iso n X _).hom =
  ((Ext n).obj _).map f :=
begin
  dsimp only [shift_iso, iso.trans_hom, iso.trans_inv, iso.symm_hom, iso.symm_inv],
  simp only [category.assoc],
  slice_lhs 4 5 { rw Ext_iso_naturality_snd_component },
  simp only [category.assoc, iso.inv_hom_id_assoc, category.id_comp],
  rw ← iso.eq_inv_comp,
  simp_rw ← category.assoc,
  rw iso.comp_inv_eq,
  simp_rw category.assoc,
  rw Ext_iso_naturality_snd_component,
  rw iso.inv_hom_id_assoc,
  ext t,
  dsimp,
  simp only [comp_apply],
  dsimp,
  simp only [add_zero, unit_of_tensor_iso_unit_inv_app,
    discrete.functor_map_id, nat_trans.id_app, category.id_comp, category.assoc,
    nat_trans.naturality, functor.comp_map, μ_hom_inv_app_assoc, functor.map_comp,
    ε_inv_app_obj, discrete.right_unitor_def, eq_to_iso.hom, eq_to_hom_map,
    eq_to_hom_app, μ_naturality_assoc, μ_inv_hom_app_assoc],
  erw ← nat_trans.naturality_assoc,
  erw ← nat_trans.naturality_assoc,
  dsimp, let s := _, change _ ≫ _ ≫ s = _, rw ← category.assoc, convert category.comp_id _,
  dsimp [s],
  simp only [eq_to_hom_map, eq_to_hom_app, eq_to_iso.inv, ε_app_obj, discrete.right_unitor_def,
    category.assoc, μ_inv_hom_app_assoc, eq_to_hom_trans, eq_to_hom_refl],
end

@[reassoc] lemma shift_iso_Ext_map
  (n : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)] :
  (((Ext (n+1)).flip.obj W).right_op.map ((of_hom f)⟦(1 : ℤ)⟧')).unop ≫ (shift_iso _ _ _).hom =
  (shift_iso _ _ _).hom ≫ ((Ext n).flip.obj W).map (of_hom f).op :=
by rw [← iso.inv_comp_eq, shift_iso_conj]

@[reassoc] lemma Ext_map_shift_iso_inv
  (n : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)] :
  (shift_iso _ _ _).inv ≫ (((Ext (n+1)).flip.obj W).right_op.map ((of_hom f)⟦(1 : ℤ)⟧')).unop =
  ((Ext n).flip.obj W).map (of_hom f).op ≫ (shift_iso _ _ _).inv :=
by rw [iso.eq_comp_inv, category.assoc, shift_iso_conj]

def Ext_δ
  (n : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Z)]
  (w : ∀ i, short_exact (f.f i) (g.f i)) :
  ((Ext n).flip.obj W).obj (opposite.op $ of' X) ⟶
  ((Ext (n+1)).flip.obj W).obj (opposite.op $ of' Z) :=
(shift_iso n X W).inv ≫ (connecting_hom' f g (n+1) W w).unop

.

def map_cone {A₁ A₂ B₁ B₂ : cochain_complex A ℤ}
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj A₁)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj B₁)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj A₂)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj B₂)]
  (f₁ : A₁ ⟶ B₁) (f₂ : A₂ ⟶ B₂) (a : A₁ ⟶ A₂) (b : B₁ ⟶ B₂) (sq : f₁ ≫ b = a ≫ f₂) :
  cone f₁ ⟶ cone f₂ :=
(homotopy_category.quotient _ _).map $
{ f := λ i, biprod.lift (biprod.fst ≫ a.f _) (biprod.snd ≫ b.f _),
  comm' := begin
    rintros i j ⟨⟨rfl⟩⟩,
    ext,
    { dsimp [homological_complex.cone.d], simp },
    { dsimp [homological_complex.cone.d], simp,
      simp only [← homological_complex.comp_f, sq] },
    { dsimp [homological_complex.cone.d], simp },
    { dsimp [homological_complex.cone.d], simp },
  end }

.

lemma Ext_δ_natural
  (i : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  {X₁ Y₁ Z₁ : cochain_complex A ℤ} (f₁ : X₁ ⟶ Y₁) (f₂ : Y₁ ⟶ Z₁)
  {X₂ Y₂ Z₂ : cochain_complex A ℤ} (g₁ : X₂ ⟶ Y₂) (g₂ : Y₂ ⟶ Z₂)
  (α₁ : X₁ ⟶ X₂) (α₂ : Y₁ ⟶ Y₂) (α₃ : Z₁ ⟶ Z₂)
  (sq₁ : f₁ ≫ α₂ = α₁ ≫ g₁) (sq₂ : f₂ ≫ α₃ = α₂ ≫ g₂)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X₁)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y₁)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Z₁)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X₂)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y₂)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Z₂)]
  (w₁ : ∀ i, short_exact (f₁.f i) (f₂.f i))
  (w₂ : ∀ i, short_exact (g₁.f i) (g₂.f i)) :
  ((Ext i).flip.obj W).map (of_hom α₁).op ≫ Ext_δ f₁ f₂ i W w₁ =
    Ext_δ g₁ g₂ i W w₂ ≫ ((Ext (i + 1)).flip.obj W).map (of_hom α₃).op :=
begin
  -- TODO: This proof is SLOW.
  delta Ext_δ,
  let F := homotopy_category.quotient A (complex_shape.up ℤ),
  simp only [category.assoc],
  dsimp only [connecting_hom', unop_comp],
  simp only [unop_inv, category.assoc],
  simp only [← category.assoc, is_iso.comp_inv_eq],
  simp only [category.assoc],
  dsimp only [functor.right_op, quiver.hom.unop_op, functor.flip, opposite.unop_op],
  let t := _, change _ = _ ≫ _ ≫ t,
  have ht : t = ((Ext (i+1)).map (quiver.hom.op _)).app W,
  rotate 2,
  { apply map_cone,
    exact sq₁ },
  { -- Move the inv, and this should be doable.
    dsimp [t], rw is_iso.inv_comp_eq,
    ext f,
    dsimp [Ext, shift_iso, Ext_iso, preadditive_yoneda_obj, linear_map.to_add_monoid_hom],
    simp only [comp_apply], dsimp,
    simp only [← category.assoc],
    congr' 1,
    apply lift_ext (of' Z₂).π, swap, apply_instance,
    simp only [category.assoc, lift_lifts, lift_lifts_assoc],
    congr' 1, dsimp [map_cone, cone.π, homotopy_category.cone.π],
    erw [← F.map_comp, ← F.map_comp], congr' 1,
    dsimp [homological_complex.cone.π],
    ext,
    { simp },
    { simp,
      simp only [← homological_complex.comp_f, sq₂] } },
  rw ht, clear ht, clear t,
  ext f,
  dsimp [Ext, shift_iso, Ext_iso, preadditive_yoneda_obj, linear_map.to_add_monoid_hom],
  dsimp only [shift_iso_aux, add_equiv.symm],
  simp only [comp_apply],
  dsimp,
  simp only [← category.assoc], congr' 1,
  simp only [functor.map_comp, ← category.assoc], congr' 1,
  simp only [category.assoc],
  apply lift_ext (((of' X₂).π)⟦(1 : ℤ)⟧'),
  swap, apply_instance,
  simp only [category.assoc, ← functor.map_comp, lift_lifts],
  simp only [functor.map_comp, lift_lifts_assoc, lift_lifts, category.assoc],
  congr' 1,
  dsimp [cone_triangle, map_cone],
  simp only [comp_neg, neg_comp], congr' 1,
  erw [← F.map_comp, ← F.map_comp], congr' 1,
  dsimp [homological_complex.cone.out],
  ext,
  { simp, },
  { simp, }
end

.

lemma Ext_δ_natural'
  (i : ℤ)
  [enough_projectives A]
  (W₁ W₂ : bounded_homotopy_category A)
  (e : W₁ ⟶ W₂)
  {X Y Z : cochain_complex A ℤ} (f : X ⟶ Y) (g : Y ⟶ Z)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Z)]
  (w : ∀ i, short_exact (f.f i) (g.f i)) :
  ((Ext i).obj _).map e ≫ Ext_δ f g i W₂ w =
  Ext_δ f g i W₁ w ≫ ((Ext (i+1)).obj _).map e :=
begin
  delta Ext_δ,
  dsimp [connecting_hom'],
  simp only [quiver.hom.unop_op, unop_inv],
  simp_rw ← category.assoc,
  rw is_iso.comp_inv_eq,
  simp_rw category.assoc,
  let t := _, change _ = _ ≫ _ ≫ t,
  have ht : t = ((Ext (i + 1)).obj _).map e,
  { dsimp only [t],
    rw [is_iso.inv_comp_eq, nat_trans.naturality] },
  rw ht, clear ht t,
  rw iso.eq_inv_comp,
  rw ← nat_trans.naturality,
  simp only [← category.assoc],
  congr' 1,
  rw [iso.comp_inv_eq, ← shift_iso_conj', iso.hom_inv_id_assoc],
end

lemma Ext_five_term_exact_seq'
  (n : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Z)]
  (w : ∀ i, short_exact (f.f i) (g.f i)) :
  let E := λ n, ((Ext n).flip.obj W) in
  exact_seq Ab.{v} $
    [ (E n).map (of_hom g).op
    , (E n).map (of_hom f).op
    , Ext_δ f g n W w
    , (E (n+1)).map (of_hom g).op ] :=
begin
  refine (Ext_five_term_exact_seq f g n W w).pair.unop.cons _,
  refine exact.cons _ (exact.exact_seq _),
  { rw [Ext_δ, functor.right_op_map, quiver.hom.unop_op, ← shift_iso_conj f n W,
      exact_iso_comp, exact_comp_hom_inv_comp_iff],
    have := (Ext_five_term_exact_seq f g (n+1) W w).unop.pair,
    erw [functor.map_neg, category_theory.unop_neg, abelian.exact_neg_left_iff] at this,
    exact this },
  { rw [Ext_δ, exact_iso_comp],
    exact ((Ext_five_term_exact_seq f g (n+1) W w).drop 1).pair.unop, }
end

end bounded_homotopy_category

namespace bounded_derived_category

variables [enough_projectives A]
variables {X Y Z : bounded_derived_category A} (f : X ⟶ Y) (g : Y ⟶ Z)
open homological_complex

def cone (f : X ⟶ Y) : bounded_derived_category A :=
(localization_functor _).obj $
{ val := homotopy_category.cone f.val.out,
  bdd := begin
    obtain ⟨a,ha⟩ := homotopy_category.is_bounded_above.cond X.val.val,
    obtain ⟨b,hb⟩ := homotopy_category.is_bounded_above.cond Y.val.val,
    constructor, use (max a b + 1),
    intros t ht,
    apply is_zero_biprod,
    { apply ha, refine le_trans (le_trans _ ht) _,
      refine le_trans (le_max_left a b) _,
      all_goals { linarith } },
    { apply hb,
      refine le_trans _ ht, refine le_trans (le_max_right a b) _,
      linarith }
  end }

-- UGH
end bounded_derived_category

-- move me
instance single_is_bounded_above (X : A) :
  homotopy_category.is_bounded_above {as := (homological_complex.single A (complex_shape.up ℤ) 0).obj X} :=
begin
  refine ⟨⟨1, _⟩⟩,
  intros i hi,
  dsimp,
  rw if_neg,
  { exact is_zero_zero _ },
  { rintro rfl, exact zero_lt_one.not_le hi }
end

-- move me
instance quotient_single_is_bounded_above (X : A) :
  ((homotopy_category.quotient A (complex_shape.up ℤ)).obj
    ((homological_complex.single A (complex_shape.up ℤ) 0).obj X)).is_bounded_above :=
single_is_bounded_above X

def Ext'_δ [enough_projectives A]
  {X Y Z : A} (W : A) {f : X ⟶ Y} {g : Y ⟶ Z}
  (h : short_exact f g) (n : ℤ) :
  ((Ext' n).flip.obj W).obj (opposite.op $ X) ⟶
  ((Ext' (n+1)).flip.obj W).obj (opposite.op $ Z) :=
begin
  refine @bounded_homotopy_category.Ext_δ _ _ _ _ _ _
    ((homological_complex.single _ _ _).map f)
    ((homological_complex.single _ _ _).map g)
    n _ _
    (quotient_single_is_bounded_above _)
    (quotient_single_is_bounded_above _)
    (quotient_single_is_bounded_above _) _,
  intro i, dsimp, by_cases hi : i = 0,
  { subst i, dsimp, simp only [eq_self_iff_true, category.comp_id, category.id_comp, if_true, h] },
  { rw [dif_neg hi, dif_neg hi, if_neg hi, if_neg hi, if_neg hi],
    refine ⟨exact_of_zero _ _⟩, }
end

lemma Ext'_δ_natural [enough_projectives A]
  {X₁ X₂ X₃ Y₁ Y₂ Y₃ : A}
  (f₁ : X₁ ⟶ X₂) (f₂ : X₂ ⟶ X₃)
  (g₁ : Y₁ ⟶ Y₂) (g₂ : Y₂ ⟶ Y₃)
  (α₁ : X₁ ⟶ Y₁) (α₂ : X₂ ⟶ Y₂) (α₃ : X₃ ⟶ Y₃)
  (sq₁ : f₁ ≫ α₂ = α₁ ≫ g₁) (sq₂ : f₂ ≫ α₃ = α₂ ≫ g₂)
  (Z : A) (hf : short_exact f₁ f₂) (hg : short_exact g₁ g₂) (i : ℤ) :
  ((Ext' i).flip.obj Z).map α₁.op ≫ Ext'_δ Z hf i =
    Ext'_δ Z hg i ≫ ((Ext' (i+1)).flip.obj Z).map α₃.op :=
begin
  delta Ext' Ext'_δ,
  apply bounded_homotopy_category.Ext_δ_natural _ _ _ _ _ _ _
    ((homological_complex.single A (complex_shape.up ℤ) 0).map α₂),
  all_goals { simp only [← category_theory.functor.map_comp, sq₁, sq₂, quiver.hom.unop_op] },
end

namespace category_theory
namespace short_exact

lemma Ext'_five_term_exact_seq [enough_projectives A]
  {X Y Z : A} (W : A) {f : X ⟶ Y} {g : Y ⟶ Z}
  (h : short_exact f g) (n : ℤ) :
  let E := λ n, ((Ext' n).flip.obj W) in
  exact_seq Ab.{v} $
    [ (E n).map g.op
    , (E n).map f.op
    , Ext'_δ W h n
    , (E (n+1)).map g.op ] :=
begin
  let f' := (homological_complex.single _ (complex_shape.up ℤ) (0:ℤ)).map f,
  let g' := (homological_complex.single _ (complex_shape.up ℤ) (0:ℤ)).map g,
  let W' := (bounded_homotopy_category.single _ 0).obj W,
  have Hfg : ∀ (i : ℤ), short_exact (f'.f i) (g'.f i),
  { intro i, dsimp, by_cases hi : i = 0,
    { subst i, dsimp, simp only [eq_self_iff_true, category.comp_id, category.id_comp, if_true, h] },
    { rw [dif_neg hi, dif_neg hi, if_neg hi, if_neg hi, if_neg hi],
      refine ⟨exact_of_zero _ _⟩, } },
  convert bounded_homotopy_category.Ext_five_term_exact_seq' f' g' n W' Hfg,
end

end short_exact
end category_theory


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color.
  have h1 : (G.colorable 2) → (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from assume h2 : (G.colorable 2),
  begin
    -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
    have h3 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
    begin
      -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
      have h4 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
      begin
        -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
        have h5 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
        begin
          -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
          have h6 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
          begin
            -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
            have h7 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
            begin
              -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
              have h8 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
              begin
                -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
                have h9 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                begin
                  -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
                  have h10 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                  begin
                    -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
                    have h11 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                    begin
                      -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
                      have h12 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                      begin
                        -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
                        have h13 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                        begin
                          -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
                          have h14 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                          begin
                            -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
                            have h15 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                            begin
                              -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
                              have h16 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                              begin
                                -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
                                have h17 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                begin
                                  -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
                                  have h18 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                  begin
                                    -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
                                    have h19 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                    begin
                                      -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
                                      have h20 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                      begin
                                        -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
                                        have h21 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                        begin
                                          -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
                                          have h22 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                          begin
                                            -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
                                            have h23 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                            begin
                                              -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
                                              have h24 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B),
end --Needs more than 2000 tokens!

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

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

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

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

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

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

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

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

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

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

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

Setting $b = a$, this becomes:

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

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

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

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

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

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

QED

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


import .sqe .qfree .wf --..equiv ..num .sqe

open list

def atom.unified (a : atom) : Prop :=
  head_coeff a = -1 ∨ head_coeff a = 0 ∨ head_coeff a = 1

def unified (p : formula) : Prop := ∀ a ∈ p.atoms, (atom.unified a)

lemma eval_subst_iff {i ks xs} :
  ∀ {p}, nqfree p →
    ((subst i ks p).eval xs ↔ p.eval ((i + znum.dot_prod ks xs)::xs))
| ⊤' _ := by refl
| ⊥' _ := by refl
| (A' (atom.le i ks')) _ :=
  begin
    simp [subst, formula.map], cases ks' with k' ks';
    simp [asubst, eval_le],
    simp [znum.comp_add_dot_prod, znum.dot_prod, mul_add,
    znum.map_mul_dot_prod],
  end
| (A' (atom.ndvd d i ks')) _ :=
  begin
    simp [subst, formula.map], cases ks' with k' ks';
    simp [asubst, eval_ndvd],
    simp [znum.comp_add_dot_prod, znum.dot_prod, mul_add,
    znum.map_mul_dot_prod],
  end
| (A' (atom.dvd d i ks')) _ :=
  begin
    simp [subst, formula.map], cases ks' with k' ks';
    simp [asubst, eval_dvd],
    simp [znum.comp_add_dot_prod, znum.dot_prod, mul_add,
    znum.map_mul_dot_prod]
  end
| (p ∧' q) hf :=
  begin
    cases hf with hfp hfq,
    unfold subst, unfold formula.map,
    repeat {rewrite eval_and},
    let ihp := @eval_subst_iff p hfp,
    unfold subst at ihp, rewrite ihp,
    let ihq := @eval_subst_iff q hfq,
    unfold subst at ihq, rewrite ihq
  end
| (p ∨' q) hf :=
  begin
    cases hf with hfp hfq,
    unfold subst, unfold formula.map,
    repeat {rewrite eval_or},
    let ihp := @eval_subst_iff p hfp,
    unfold subst at ihp, rewrite ihp,
    let ihq := @eval_subst_iff q hfq,
    unfold subst at ihq, rewrite ihq
  end
| (¬' p) hf := by cases hf
| (∃' p) hf := by cases hf

lemma inf_minus_prsv (zs) : ∀ (p : formula),
  ∃ (y : znum), ∀ z, z < y →
    ((inf_minus p).eval (z::zs) ↔ p.eval (z::zs))
| ⊤' := begin existsi (0 : znum), intros z hz, constructor; intro hc; trivial end
| ⊥' := begin existsi (0 : znum), intros z hz, constructor; intro hc; cases hc end
| (A' (atom.le i ks)) :=
  begin
    cases ks with k ks,
    { existsi (0 : znum), intros z hz, refl },
    cases (lt_trichotomy k 0) with hlt heqgt;
    [ {}, { cases heqgt with heq hgt } ],
    {
      existsi (- abs (i - znum.dot_prod ks zs)), intros z hz,
      simp [inf_minus_le_eq_of_lt hlt],
      constructor; intro h,
      {
        simp [formula.eval,  atom.eval, znum.dot_prod],
        rw sub_le_iff_le_add'.symm,
        apply calc
              i - znum.dot_prod ks zs
            ≤ abs (i - znum.dot_prod ks zs) : le_abs_self _
        ... ≤ -z : begin rw lt_neg at hz, apply le_of_lt hz end
        ... ≤ k * z :
            begin
              rw (znum.neg_one_mul_eq_neg).symm, repeat {rw mul_comm _ z},
              rw znum.mul_le_mul_iff_le_of_neg_left,
              apply znum.le_of_lt_add_one, apply hlt,
              apply lt_of_lt_of_le hz (neg_le_of_neg_le _),
              have h := abs_nonneg (i - znum.dot_prod ks zs), apply h
            end
      },
      { trivial }
    },
    { subst heq, simp [inf_minus_le_eq_of_eq] },
    {
      existsi (- abs (i - znum.dot_prod ks zs)), intros z hz,
      simp [inf_minus_le_eq_of_gt hgt], constructor; intro h,
      { cases h },
      { apply absurd h,
        simp [formula.eval,  atom.eval, znum.dot_prod],
        rw lt_sub_iff_add_lt'.symm,
        apply calc
              k * z
            ≤ 1 * z :
              begin
                repeat {rw (mul_comm _ z)},
                rw znum.mul_le_mul_iff_le_of_neg_left,
                apply znum.add_one_le_of_lt hgt,
                apply lt_of_lt_of_le hz (neg_le_of_neg_le _),
                apply abs_nonneg (i - znum.dot_prod ks zs)
              end
        ... = z : one_mul _
        ... < - abs (i - znum.dot_prod ks zs) : hz
        ... ≤ i - znum.dot_prod ks zs :
              begin
                rw neg_le,
                apply neg_le_abs_self (i - znum.dot_prod ks zs),
              end
      }
    }
  end
| (A' (atom.dvd d i ks)) := begin simp [inf_minus] end
| (A' (atom.ndvd d i ks)) := begin simp [inf_minus] end
| (p ∧' q) :=
  begin
    cases (inf_minus_prsv p) with x hx,
    cases (inf_minus_prsv q) with y hy,
    cases (znum.exists_lt_and_lt x y) with z hz,
    cases hz with hz1 hz2, existsi z, intros w hw,
    simp [inf_minus, eval_and_o, eval_and,
      hx w (lt.trans hw hz1), hy w (lt.trans hw hz2)]
  end
| (p ∨' q) :=
  begin
    cases (inf_minus_prsv p) with x hx,
    cases (inf_minus_prsv q) with y hy,
    cases (znum.exists_lt_and_lt x y) with z hz,
    cases hz with hz1 hz2, existsi z, intros w hw,
    simp [inf_minus, eval_or_o, eval_or,
      hx w (lt.trans hw hz1), hy w (lt.trans hw hz2)]
  end
| (¬' p) := begin simp [inf_minus] end
| (∃' p) := begin simp [inf_minus] end

lemma divisors_lcm_pos {p : formula} :
  formula.wf p → 0 < divisors_lcm p :=
begin
  intro hn, apply znum.lcms_pos,
  intros z hz, rewrite list.mem_map at hz,
  cases hz with a ha, cases ha with ha1 ha2,
  subst ha2, unfold formula.atoms_dep_0 at ha1,
  rw (@mem_filter _ dep_0 _ a (p.atoms)) at ha1,
  rewrite wf_iff_wf_alt at hn,
  rewrite iff.symm normal_iff_divisor_nonzero,
  apply hn, apply ha1^.elim_left
end

lemma divisors_lcm_dvd_eq {d i k : znum} {ks : list znum} :
  k ≠ 0 → divisors_lcm (A' (atom.dvd d i (k::ks))) = abs d :=
begin
  intro h, simp [divisors_lcm, formula.atoms_dep_0, formula.atoms,
    dep_0, filter, head_coeff], rw if_pos,
  simp [map, divisor, znum.lcms, znum.lcm, num.lcm, znum.abs_eq_abs_to_znum,
    num.to_znum, znum.abs_one, num.gcd_one_right, num.div_one],
  apply h
end

lemma divisors_lcm_ndvd_eq {d i k : znum} {ks : list znum} :
  k ≠ 0 → divisors_lcm (A' (atom.ndvd d i (k::ks))) = abs d :=
begin
  intro h, simp [divisors_lcm, formula.atoms_dep_0,
    formula.atoms, dep_0, filter, head_coeff], rw if_pos,
  simp [map, divisor, znum.lcms, znum.lcm, num.lcm, znum.abs_eq_abs_to_znum,
    num.to_znum, znum.abs_one, num.gcd_one_right, num.div_one],
  apply h
end

lemma divisors_lcm_and_eq (p q) :
  divisors_lcm (p ∧' q) = znum.lcm (divisors_lcm p) (divisors_lcm q) :=
begin
  apply znum.lcms_distrib, apply list.equiv.trans,
  apply list.map_equiv_map_of_equiv,
  simp [formula.atoms_dep_0, formula.atoms], apply equiv.refl,
  simp [map_append, formula.atoms_dep_0],
  apply equiv.symm union_equiv_append,
end

lemma divisors_lcm_or_eq (p q) :
  divisors_lcm (p ∨' q) = znum.lcm (divisors_lcm p) (divisors_lcm q) :=
begin
  apply znum.lcms_distrib, apply list.equiv.trans,
  apply list.map_equiv_map_of_equiv,
  simp [formula.atoms_dep_0, formula.atoms], apply equiv.refl,
  simp [map_append, formula.atoms_dep_0],
  apply equiv.symm union_equiv_append,
end

lemma inf_minus_mod {k z zs} :
  ∀ {p}, nqfree p → (has_dvd.dvd (divisors_lcm p) k)
    → ( (inf_minus p).eval (z % k :: zs)
         ↔ (inf_minus p).eval (z :: zs) )
| ⊤' _ _ := begin constructor; intro h; trivial end
| ⊥' _ _ := begin constructor; intro hc; cases hc end
| (A' (atom.le i [])) hf hdvd :=
  begin simp [inf_minus, eval_le] end
| (A' (atom.le i (k'::ks'))) hf hdvd :=
  begin
    cases (lt_trichotomy k' 0) with hlt heqgt;
    [ {}, { cases heqgt with heq hgt } ],
    { simp [inf_minus_le_eq_of_lt hlt], trivial },
    { subst heq, simp [inf_minus_le_eq_of_eq, eval_le, znum.dot_prod] },
    { simp [inf_minus_le_eq_of_gt hgt], trivial },
  end
| (A' (atom.dvd d i [])) hf hdvd :=
  begin simp [inf_minus, eval_dvd] end
| (A' (atom.dvd d i (k::ks))) hf hdvd :=
  begin
    simp [inf_minus], by_cases hkz : k = 0,
    { subst hkz, simp [eval_dvd, znum.dot_prod] },
    { apply eval_mod_dvd,
      simp [divisors_lcm_dvd_eq hkz] at hdvd,
      rw znum.abs_dvd at hdvd, assumption }
  end
| (A' (atom.ndvd d i [])) hf hdvd :=
  begin simp [inf_minus, eval_ndvd] end
| (A' (atom.ndvd d i (k::ks))) hf hdvd :=
  begin
    simp [inf_minus], by_cases hkz : k = 0,
    { subst hkz, simp [eval_ndvd, znum.dot_prod] },
    { apply eval_mod_ndvd,
      simp [divisors_lcm_ndvd_eq hkz] at hdvd,
      rw znum.abs_dvd at hdvd, assumption }
  end
| (p ∧' q) hf hdvd :=
  begin
    cases hf with hfp hfq, simp [inf_minus, eval_and_o],
    rw [@inf_minus_mod p, @inf_minus_mod q]; try {assumption};
    apply dvd.trans _ hdvd; rw [divisors_lcm_and_eq],
    apply znum.dvd_lcm_right, apply znum.dvd_lcm_left,
  end
| (p ∨' q) hf hdvd :=
  begin
    cases hf with hfp hfq, simp [inf_minus, eval_or_o],
    rw [@inf_minus_mod p, @inf_minus_mod q]; try {assumption};
    apply dvd.trans _ hdvd; rw [divisors_lcm_or_eq],
    apply znum.dvd_lcm_right, apply znum.dvd_lcm_left,
  end
| (¬' p) hf _ := by cases hf
| (∃' p) hf _ := by cases hf

lemma no_lb_inf_minus {p : formula} (hf : nqfree p) (hn : formula.wf p) (z : znum) (zs) :
  (inf_minus p).eval (z::zs) → ∀ y, ∃ x, (x < y ∧ (inf_minus p).eval (x::zs)) :=
begin
  intros h y,
  have hlt : z - ((abs z + abs y + 1) * divisors_lcm p) < y,
  { simp [add_mul],
    repeat {rw (add_assoc _ _ _).symm}, rw (add_comm z),
    apply calc
          -divisors_lcm p + z + -(abs z * divisors_lcm p)
          + -(abs y * divisors_lcm p)
        < -(abs y * divisors_lcm p) :
          begin
            apply add_lt_of_neg_of_le,
            { rw add_assoc, apply add_neg_of_neg_of_nonpos,
              { rw neg_lt, apply divisors_lcm_pos hn },
              { rw le_sub_iff_add_le.symm, rw [zero_sub, neg_neg],
                apply le_trans (le_abs_self z), rw mul_comm,
                apply znum.le_mul_of_pos_left (abs_nonneg _),
                apply divisors_lcm_pos hn } },
            { apply le_refl (-(abs y * divisors_lcm p)) }
          end
    ... ≤ -(abs y) * 1:
          begin
            rw [neg_mul_eq_neg_mul],
            apply @mul_le_mul_of_nonpos_left _ _ _ _ (-abs y),
            apply @znum.add_one_le_of_lt 0 (divisors_lcm p),
            apply divisors_lcm_pos hn, rw neg_le, apply abs_nonneg y
          end
    ... = -(abs y): mul_one _
    ... ≤ y : begin rw neg_le, apply neg_le_abs_self y end
  },
  existsi (z - (abs z + abs y + 1) * divisors_lcm p),
  constructor, assumption,
  rw (inf_minus_mod hf (dvd_refl _)).symm,
  rw (inf_minus_mod hf (dvd_refl _)).symm at h,
  have heq : (z - (abs z + abs y + 1) * divisors_lcm p) % divisors_lcm p = z % divisors_lcm p,
  { rw [sub_eq_add_neg, neg_mul_eq_neg_mul],
    apply znum.add_mul_mod_self },
  rw heq, assumption,
end

lemma nqfree_inf_minus_of_nqfree :
  ∀ {p}, nqfree p → nqfree (inf_minus p)
| ⊤' h := h
| ⊥' h := h
| (A' a) h :=
  begin
    cases a with i ks d i ks di ks;
    cases ks with k ks;
    unfold inf_minus,
    apply ite.rec; intro _, trivial,
    apply ite.rec; intro _; trivial
  end
| (p ∧' q) h :=
  begin
    cases h with h1 h2, unfold inf_minus,
    apply cases_and_o, trivial,
    repeat {apply nqfree_inf_minus_of_nqfree, assumption},
    apply and.intro; apply nqfree_inf_minus_of_nqfree;
    assumption
  end
| (p ∨' q) h :=
  begin
    cases h with h1 h2, unfold inf_minus,
    apply cases_or_o, trivial,
    repeat {apply nqfree_inf_minus_of_nqfree, assumption},
    apply and.intro; apply nqfree_inf_minus_of_nqfree;
    assumption
  end
| (¬' p) h := by cases h
| (∃' p) h := by cases h

lemma ex_iff_inf_or_bnd (P : znum → Prop) :
  (∃ z, P z) ↔ ((∀ y, ∃ x, x < y ∧ P x) ∨ (∃ y, (P y ∧ ∀ x, x < y → ¬ P x))) :=
begin
  apply iff.intro; intro h1,
  { rw @or_iff_not_imp_left _ _ (classical.dec _), intro h2,
    rw (@not_forall _ _ (classical.dec _) (classical.dec_pred _)) at h2,
    cases h1 with w hw, cases h2 with lb hlb, simp at hlb,
    apply znum.exists_min_of_exists_lb hw hlb },
  { cases h1 with hinf hbnd, cases (hinf 0) with z hz,
    existsi z, apply hz^.elim_right, cases hbnd with z hz,
    existsi z, apply hz^.elim_left }
end

lemma mod_znum.mem_range :
  ∀ {x y}, (0 ≠ y) → x % y ∈ znum.range y :=
begin
  intros x y hy, apply znum.mem_range',
  apply znum.mod_nonneg _ hy.symm,
  apply znum.mod_lt _ hy.symm,
end

lemma unified_and_iff (p q : formula) : unified (p ∧' q) ↔ (unified p ∧ unified q) :=
begin unfold unified, unfold formula.atoms, apply list.forall_mem_append end

lemma unified_or_iff (p q : formula) : unified (p ∨' q) ↔ (unified p ∧ unified q) :=
begin unfold unified, unfold formula.atoms, apply list.forall_mem_append end

lemma bnd_points_and_equiv {p q} :
  bnd_points (p ∧' q) ≃ (bnd_points p ∪ bnd_points q) :=
begin
  simp [bnd_points, formula.atoms_dep_0,
    dep_0, formula.atoms, filter_map_append_eq],
  apply equiv.symm union_equiv_append,
end

lemma bnd_points_or_equiv {p q} :
  bnd_points (p ∨' q) ≃ (bnd_points p ∪ bnd_points q) :=
begin
  simp [bnd_points, formula.atoms_dep_0,
    dep_0, formula.atoms, filter_map_append_eq],
  apply equiv.symm union_equiv_append,
end

lemma eval_sqe_core_iff_aux {z : znum} {zs : list znum} :
∀ {p : formula}, nqfree p → formula.wf p → unified p
  → ∀ {k}, 0 < k → (has_dvd.dvd (divisors_lcm p) k)
    → ¬ p.eval (z :: zs) → p.eval ((z + k)::zs)
    →  ∃ iks, iks ∈ bnd_points p ∧
        ∃ (d : znum), (0 ≤ d ∧ d < k
          ∧ z + k = (d + (prod.fst iks) - znum.dot_prod ((iks.snd)) zs))
| ⊤' hf hn hu k _ hk h1 h2 := by trivial
| ⊥' hf hn hu k _ hk h1 h2 := by trivial
| (A' (atom.le i ks)) hf hn hu k hkp hk h1 h2 :=
  begin
    have hex : ∃ ks', ks = (1::ks'),
    {
      simp [formula.eval,  atom.eval, znum.dot_prod] at *,
      have hlt := lt_of_lt_of_le h1 h2,
      cases ks with k' ks',
      { exfalso, cases hlt },
      {
        cases (hu _ (or.inl rfl)) with hk' hk' hk';
        simp [head_coeff] at hk',
        { exfalso, subst hk', simp [znum.dot_prod, lt_neg, neg_zero] at hlt,
          apply znum.lt_irrefl _ (lt.trans hlt hkp) },
        { cases hk',
          { exfalso, subst hk', simp [znum.dot_prod] at hlt,
            apply znum.lt_irrefl _ hlt },
          { subst hk', constructor, refl }
        }
      }
    },
    cases hex with xs hxs, subst hxs,
    existsi (i,xs), constructor,
    { rw bnd_points_le_eq, apply or.inl rfl, apply zero_lt_one },
    {
      simp, existsi (z + k - (i - (znum.dot_prod xs zs))), constructor,
      { simp [formula.eval,  atom.eval, znum.dot_prod] at h2,
        rw [le_sub_iff_add_le, add_sub, sub_le_iff_le_add,
            zero_add, add_assoc], assumption, },
      { constructor,
        { simp [formula.eval,  atom.eval, znum.dot_prod] at h1,
          rw [sub_lt_iff_lt_add', add_lt_add_iff_right, lt_sub_iff_add_lt],
          assumption },
        { simp } }
    }
  end
| (A' (atom.ndvd d i ks)) hf hn hu k hkp hk h1 h2 :=
  begin
    exfalso, simp [formula.eval,  atom.eval, znum.dot_prod] at h1 h2,
    have h3 : (d ∣ i + znum.dot_prod ks (z :: zs))
      ↔ (d ∣ i + znum.dot_prod ks ((z + k) :: zs)),
    {
      cases ks with x ks; simp [znum.dot_prod],
      by_cases hx : x = 0,
      { subst hx, simp },
      { simp [mul_add], rw (add_assoc _ (x*z) _).symm,
        rw (add_assoc i _ (x*k)).symm, apply dvd_add_iff_left,
        apply dvd_mul_of_dvd_right, rw [divisors_lcm_ndvd_eq hx] at hk,
        rw znum.abs_dvd at hk, assumption }
    },
    rw h3 at h1, apply h2 h1
 end
| (A' (atom.dvd d i ks)) hf hn hu k hkp hk h1 h2 :=
begin
  exfalso, simp [formula.eval,  atom.eval, znum.dot_prod] at h1 h2,
  have h3 : (d ∣ i + znum.dot_prod ks (z :: zs))
    ↔ (d ∣ i + znum.dot_prod ks ((z + k) :: zs)),
  {
    cases ks with x ks; simp [znum.dot_prod],
    by_cases hx : x = 0,
    { subst hx, simp },
    { simp [mul_add], rw (add_assoc _ (x*z) _).symm,
      rw (add_assoc i _ (x*k)).symm, apply dvd_add_iff_left,
      apply dvd_mul_of_dvd_right, rw [divisors_lcm_dvd_eq hx] at hk,
      rw znum.abs_dvd at hk, assumption }
  },
  rw h3 at h1, apply h1 h2
end
| (p ∨' q) hf hn hu k hkp hk h1 h2 :=
  begin
    simp [eval_or, not_or_distrib] at h1,
    simp [eval_or] at h2, cases h1 with hp hq,
    cases hn with hnp hnq, cases hf with hfp hfq,
    rw unified_or_iff at hu, cases hu with hup huq,
    rw divisors_lcm_or_eq at hk,
    have hdp := dvd.trans (znum.dvd_lcm_left _ _) hk,
    have hdq := dvd.trans (znum.dvd_lcm_right _ _) hk,
    cases h2 with h2 h2;
    [ {cases (@eval_sqe_core_iff_aux p _ _ _ _ hkp _ _ _) with iks hiks},
      {cases (@eval_sqe_core_iff_aux q _ _ _ _ hkp _ _ _) with iks hiks} ];
    try {assumption};
    `[cases hiks with hm h, existsi iks, apply and.intro,
    rw mem_iff_mem_of_equiv (bnd_points_or_equiv) ],
    apply mem_union_left hm, assumption,
    apply mem_union_right _ hm, assumption
  end
| (p ∧' q) hf hn hu k hkp hk h1 h2 :=
  begin
    rw [eval_and] at h1, rw [@not_and_distrib' _ _ (classical.dec _)] at h1,
    simp [eval_and] at h2, cases h2 with hp hq,
    cases hn with hnp hnq, cases hf with hfp hfq,
    rw unified_and_iff at hu, cases hu with hup huq,
    rw divisors_lcm_and_eq at hk,
    have hdp := dvd.trans (znum.dvd_lcm_left _ _) hk,
    have hdq := dvd.trans (znum.dvd_lcm_right _ _) hk,
    cases h1 with h1 h1;
    [ {cases (@eval_sqe_core_iff_aux p _ _ _ _ hkp _ _ _) with iks hiks},
      {cases (@eval_sqe_core_iff_aux q _ _ _ _ hkp _ _ _) with iks hiks} ];
    try {assumption};
    `[ cases hiks with hm h, existsi iks, apply and.intro,
       rw mem_iff_mem_of_equiv (bnd_points_and_equiv) ],
    apply mem_union_left hm, assumption,
    apply mem_union_right _ hm, assumption
  end
| (¬' p) hf hn hu k _ hk h1 h2 := by cases hf
| (∃' p) hf hn hu k _ hk h1 h2 := by cases hf

lemma eval_sqe_core_iff :
  ∀ (p : formula), nqfree p → formula.wf p → unified p
  → ∀ (bs : list znum), (sqe_core p).eval bs ↔ ∃ (b : znum), p.eval (b :: bs) :=
begin
  intros p hf hn hu zs, constructor; intro h,
  {
    simp [sqe_core, sqe_inf, sqe_bnd, eval_or_o, eval_disj_map] at h,
    cases h with h h; cases h with z hz,
    {
      cases hz with hz1 hz2, rw eval_subst_iff at hz2,
      { simp [znum.nil_dot_prod, @add_zero znum] at hz2,
        cases (inf_minus_prsv zs p) with lb hlb,
        cases (no_lb_inf_minus hf hn z zs hz2 lb) with x hx,
        cases hx with hx1 hx2, rw hlb _ hx1 at hx2,
        existsi x, assumption },
      { apply nqfree_inf_minus_of_nqfree hf }
    },
    {
      cases hz with zs hzs,
      cases hzs with hzs1 hzs2, cases hzs2 with k hk,
      cases hk with hk1 hk2, rw (eval_subst_iff hf) at hk2,
      constructor, apply hk2,
    }
  },
  {
    simp [sqe_core, eval_or_o],
    rewrite ex_iff_inf_or_bnd at h, cases h with h h,
    {
      apply or.inl, simp [sqe_inf], rw eval_disj_map,
      have hw : ∃ w, formula.eval (w :: zs) (inf_minus p),
      { cases (inf_minus_prsv zs p) with lb hlb,
        cases h lb with w h, cases h with h1 h2,
        existsi w, rw (hlb _ h1), assumption },
      cases hw with w hw,
      have hwm : formula.eval ((w % divisors_lcm p)::zs) (inf_minus p),
      { rw inf_minus_mod; try {assumption}, apply dvd_refl },
      existsi (w % divisors_lcm p), constructor,
      { apply mod_znum.mem_range, apply ne.symm,
        apply znum.nonzero_of_pos, apply divisors_lcm_pos hn },
      { rw eval_subst_iff, simp [znum.dot_prod_nil, @zero_add znum],
        apply hwm, apply nqfree_inf_minus_of_nqfree hf }
    },
    {
      cases h with lb hlb, cases hlb with hlb1 hlb2, apply or.inr,

      have h :=
        @eval_sqe_core_iff_aux
          (lb - (divisors_lcm p)) zs p hf hn hu
          (divisors_lcm p) (divisors_lcm_pos hn)
          (dvd_refl _)
          (begin
            apply hlb2, rewrite sub_lt_self_iff,
            apply divisors_lcm_pos hn,
           end)
          (begin simp, apply hlb1 end),

      cases h with iks h, cases h with hiks h, cases h with k' h,
      cases h with h1 h, cases h with h2 h3, simp at h3, subst h3,

      simp [sqe_bnd, eval_disj_map],
      existsi iks.fst, existsi iks.snd, apply and.intro,
      { cases iks, simp, apply hiks },
      { existsi k', constructor,
        { apply znum.mem_range h1 h2 },
        { rw [eval_subst_iff, znum.map_neg_dot_prod],
          rw (add_comm iks.fst), rw add_assoc,
          apply hlb1, apply hf }
      }
     }
  }
end


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.sites.grothendieck
import Mathlib.PostPort

universes v u l

namespace Mathlib

/-!
# Grothendieck pretopologies

Definition and lemmas about Grothendieck pretopologies.
A Grothendieck pretopology for a category `C` is a set of families of morphisms with fixed codomain,
satisfying certain closure conditions.

We show that a pretopology generates a genuine Grothendieck topology, and every topology has
a maximal pretopology which generates it.

The pretopology associated to a topological space is defined in `spaces.lean`.

## Tags

coverage, pretopology, site

## References

* [https://ncatlab.org/nlab/show/Grothendieck+pretopology][nlab]
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]
* [https://stacks.math.columbia.edu/tag/00VG][Stacks]
-/

namespace category_theory

/--
Pullback a set of arrows with given codomain along a fixed map, by taking the pullback in the
category.
This is not the same as the arrow set of `sieve.pullback`, but there is a relation between them
in `pullback_arrows_comm`.
-/
inductive pullback_arrows {C : Type u} [category C] [limits.has_pullbacks C] {X : C} {Y : C} (f : Y ⟶ X) (S : presieve X) : presieve Y
where
| mk : ∀ (Z : C) (h : Z ⟶ X), S h → pullback_arrows f S limits.pullback.snd

theorem pullback_arrows_comm {C : Type u} [category C] [limits.has_pullbacks C] {X : C} {Y : C} (f : Y ⟶ X) (R : presieve X) : sieve.generate (pullback_arrows f R) = sieve.pullback f (sieve.generate R) := sorry

theorem pullback_singleton {C : Type u} [category C] [limits.has_pullbacks C] {X : C} {Y : C} {Z : C} (f : Y ⟶ X) (g : Z ⟶ X) : pullback_arrows f (presieve.singleton g) = presieve.singleton limits.pullback.snd := sorry

/--
A (Grothendieck) pretopology on `C` consists of a collection of families of morphisms with a fixed
target `X` for every object `X` in `C`, called "coverings" of `X`, which satisfies the following
three axioms:
1. Every family consisting of a single isomorphism is a covering family.
2. The collection of covering families is stable under pullback.
3. Given a covering family, and a covering family on each domain of the former, the composition
   is a covering family.

In some sense, a pretopology can be seen as Grothendieck topology with weaker saturation conditions,
in that each covering is not necessarily downward closed.

See: https://ncatlab.org/nlab/show/Grothendieck+pretopology, or
https://stacks.math.columbia.edu/tag/00VH, or [MM92] Chapter III, Section 2, Definition 2.
Note that Stacks calls a category together with a pretopology a site, and [MM92] calls this
a basis for a topology.
-/
structure pretopology (C : Type u) [category C] [limits.has_pullbacks C]
where
  coverings : (X : C) → set (presieve X)
  has_isos : ∀ {X Y : C} (f : Y ⟶ X) [_inst_3 : is_iso f], presieve.singleton f ∈ coverings X
  pullbacks : ∀ {X Y : C} (f : Y ⟶ X) (S : presieve X), S ∈ coverings X → pullback_arrows f S ∈ coverings Y
  transitive : ∀ {X : C} (S : presieve X) (Ti : {Y : C} → (f : Y ⟶ X) → S f → presieve Y),
  S ∈ coverings X → (∀ {Y : C} (f : Y ⟶ X) (H : S f), Ti f H ∈ coverings Y) → presieve.bind S Ti ∈ coverings X

namespace pretopology

protected instance has_coe_to_fun (C : Type u) [category C] [limits.has_pullbacks C] : has_coe_to_fun (pretopology C) :=
  has_coe_to_fun.mk (fun (J : pretopology C) => (X : C) → set (presieve X)) fun (J : pretopology C) => coverings J

protected instance partial_order (C : Type u) [category C] [limits.has_pullbacks C] : partial_order (pretopology C) :=
  partial_order.mk (fun (K₁ K₂ : pretopology C) => ⇑K₁ ≤ ⇑K₂)
    (preorder.lt._default fun (K₁ K₂ : pretopology C) => ⇑K₁ ≤ ⇑K₂) sorry sorry sorry

protected instance order_top (C : Type u) [category C] [limits.has_pullbacks C] : order_top (pretopology C) :=
  order_top.mk (mk (fun (_x : C) => set.univ) sorry sorry sorry) partial_order.le partial_order.lt sorry sorry sorry sorry

protected instance inhabited (C : Type u) [category C] [limits.has_pullbacks C] : Inhabited (pretopology C) :=
  { default := ⊤ }

/--
A pretopology `K` can be completed to a Grothendieck topology `J` by declaring a sieve to be
`J`-covering if it contains a family in `K`.

See https://stacks.math.columbia.edu/tag/00ZC, or [MM92] Chapter III, Section 2, Equation (2).
-/
def to_grothendieck (C : Type u) [category C] [limits.has_pullbacks C] (K : pretopology C) : grothendieck_topology C :=
  grothendieck_topology.mk (fun (X : C) (S : sieve X) => ∃ (R : presieve X), ∃ (H : R ∈ coe_fn K X), R ≤ ⇑S) sorry sorry
    sorry

theorem mem_to_grothendieck (C : Type u) [category C] [limits.has_pullbacks C] (K : pretopology C) (X : C) (S : sieve X) : S ∈ coe_fn (to_grothendieck C K) X ↔ ∃ (R : presieve X), ∃ (H : R ∈ coe_fn K X), R ≤ ⇑S :=
  iff.rfl

/--
The largest pretopology generating the given Grothendieck topology.

See [MM92] Chapter III, Section 2, Equations (3,4).
-/
def of_grothendieck (C : Type u) [category C] [limits.has_pullbacks C] (J : grothendieck_topology C) : pretopology C :=
  mk (fun (X : C) (R : presieve X) => sieve.generate R ∈ coe_fn J X) sorry sorry sorry

/-- We have a galois insertion from pretopologies to Grothendieck topologies. -/
def gi (C : Type u) [category C] [limits.has_pullbacks C] : galois_insertion (to_grothendieck C) (of_grothendieck C) :=
  galois_insertion.mk (fun (x : pretopology C) (hx : of_grothendieck C (to_grothendieck C x) ≤ x) => to_grothendieck C x)
    sorry sorry sorry

/--
The trivial pretopology, in which the coverings are exactly singleton isomorphisms. This topology is
also known as the indiscrete, coarse, or chaotic topology.

See https://stacks.math.columbia.edu/tag/07GE
-/
def trivial (C : Type u) [category C] [limits.has_pullbacks C] : pretopology C :=
  mk (fun (X : C) (S : presieve X) => ∃ (Y : C), ∃ (f : Y ⟶ X), ∃ (h : is_iso f), S = presieve.singleton f) sorry sorry
    sorry

protected instance order_bot (C : Type u) [category C] [limits.has_pullbacks C] : order_bot (pretopology C) :=
  order_bot.mk (trivial C) partial_order.le partial_order.lt sorry sorry sorry sorry

/-- The trivial pretopology induces the trivial grothendieck topology. -/
theorem to_grothendieck_bot (C : Type u) [category C] [limits.has_pullbacks C] : to_grothendieck C ⊥ = ⊥ :=
  galois_connection.l_bot (galois_insertion.gc (gi C))


import category_theory.abelian.homology
import algebra.homology.homotopy
import for_mathlib.homological_complex_op

open category_theory
open category_theory.limits

namespace homotopy

universes v u
variables {M : Type*} {c : complex_shape M}
  (A : Type u) [category.{v} A] [abelian A]

variables (C₁ C₂ : homological_complex A c) (f₁ f₂ : C₁ ⟶ C₂)

lemma kernel_ι_comp_comp_cokernel_π_of_homotopy (h : homotopy f₁ f₂) (i : M) :
  kernel.ι (C₁.d_from i) ≫ f₁.f i ≫ cokernel.π (C₂.d_to i) =
  kernel.ι _ ≫ f₂.f i ≫ cokernel.π _ :=
begin
  have := h.comm i,
  apply_fun (λ e, kernel.ι (C₁.d_from i) ≫ e ≫ cokernel.π (C₂.d_to i)) at this,
  simpa using this,
end

def homotopy_unop_functor_right_op_map_unop_of_homotopy
  (C₁ C₂ : homological_complex Aᵒᵖ c) (f₁ f₂ : C₁ ⟶ C₂) (h : homotopy f₁ f₂) :
  homotopy
    (homological_complex.unop_functor.right_op.map f₁).unop
    (homological_complex.unop_functor.right_op.map f₂).unop :=
{ hom := λ i j, (h.hom _ _).unop,
  zero' := λ i j hh, begin
    let z := _, change _ = z, rw ← z.unop_op,
    congr' 1,
    exact h.zero _ _ hh,
  end,
  comm := begin
    intros i,
    dsimp,
    rw h.comm i,
    simp only [unop_add, unop_comp, add_left_inj],
    rw add_comm,
    congr' 1,
    { rcases h : c.prev i with _ | ⟨j,hj⟩,
      all_goals { dsimp [d_next, prev_d],
        let e : c.symm.next i = _ := h,
        rw [e, h],
        refl } },
    { rcases h : c.next i with _ | ⟨j,hj⟩,
      all_goals { dsimp [d_next, prev_d],
        let e : c.symm.prev i = _ := h,
        rw [e, h],
        refl } }
  end }

end homotopy


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.sum.order
import order.locally_finite

/-!
# Finite intervals in a disjoint union

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

This file provides the `locally_finite_order` instance for the disjoint sum of two orders.

## TODO

Do the same for the lexicographic sum of orders.
-/

open function sum

namespace finset
variables {α₁ α₂ β₁ β₂ γ₁ γ₂ : Type*}

section sum_lift₂
variables (f f₁ g₁ : α₁ → β₁ → finset γ₁) (g f₂ g₂ : α₂ → β₂ → finset γ₂)

/-- Lifts maps `α₁ → β₁ → finset γ₁` and `α₂ → β₂ → finset γ₂` to a map
`α₁ ⊕ α₂ → β₁ ⊕ β₂ → finset (γ₁ ⊕ γ₂)`. Could be generalized to `alternative` functors if we can
make sure to keep computability and universe polymorphism. -/
@[simp] def sum_lift₂ : Π (a : α₁ ⊕ α₂) (b : β₁ ⊕ β₂), finset (γ₁ ⊕ γ₂)
| (inl a) (inl b) := (f a b).map embedding.inl
| (inl a) (inr b) := ∅
| (inr a) (inl b) := ∅
| (inr a) (inr b) := (g a b).map embedding.inr

variables {f f₁ g₁ g f₂ g₂} {a : α₁ ⊕ α₂} {b : β₁ ⊕ β₂} {c : γ₁ ⊕ γ₂}

lemma mem_sum_lift₂ :
  c ∈ sum_lift₂ f g a b ↔ (∃ a₁ b₁ c₁, a = inl a₁ ∧ b = inl b₁ ∧ c = inl c₁ ∧ c₁ ∈ f a₁ b₁)
    ∨ ∃ a₂ b₂ c₂, a = inr a₂ ∧ b = inr b₂ ∧ c = inr c₂ ∧ c₂ ∈ g a₂ b₂ :=
begin
  split,
  { cases a; cases b,
    { rw [sum_lift₂, mem_map],
      rintro ⟨c, hc, rfl⟩,
      exact or.inl ⟨a, b, c, rfl, rfl, rfl, hc⟩ },
    { refine λ h, (not_mem_empty _ h).elim },
    { refine λ h, (not_mem_empty _ h).elim },
    { rw [sum_lift₂, mem_map],
      rintro ⟨c, hc, rfl⟩,
      exact or.inr ⟨a, b, c, rfl, rfl, rfl, hc⟩ } },
  { rintro (⟨a, b, c, rfl, rfl, rfl, h⟩ | ⟨a, b, c, rfl, rfl, rfl, h⟩); exact mem_map_of_mem _ h }
end

lemma inl_mem_sum_lift₂ {c₁ : γ₁} :
  inl c₁ ∈ sum_lift₂ f g a b ↔ ∃ a₁ b₁, a = inl a₁ ∧ b = inl b₁ ∧ c₁ ∈ f a₁ b₁ :=
begin
  rw [mem_sum_lift₂, or_iff_left],
  simp only [exists_and_distrib_left, exists_eq_left'],
  rintro ⟨_, _, c₂, _, _, h, _⟩,
  exact inl_ne_inr h,
end

lemma inr_mem_sum_lift₂ {c₂ : γ₂} :
  inr c₂ ∈ sum_lift₂ f g a b ↔ ∃ a₂ b₂, a = inr a₂ ∧ b = inr b₂ ∧ c₂ ∈ g a₂ b₂ :=
begin
  rw [mem_sum_lift₂, or_iff_right],
  simp only [exists_and_distrib_left, exists_eq_left'],
  rintro ⟨_, _, c₂, _, _, h, _⟩,
  exact inr_ne_inl h,
end

lemma sum_lift₂_eq_empty :
  (sum_lift₂ f g a b) = ∅ ↔ (∀ a₁ b₁, a = inl a₁ → b = inl b₁ → f a₁ b₁ = ∅)
    ∧ ∀ a₂ b₂, a = inr a₂ → b = inr b₂ → g a₂ b₂ = ∅ :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { split; { rintro a b rfl rfl, exact map_eq_empty.1 h } },
  cases a; cases b,
  { exact map_eq_empty.2 (h.1 _ _ rfl rfl) },
  { refl },
  { refl },
  { exact map_eq_empty.2 (h.2 _ _ rfl rfl) }
end

lemma sum_lift₂_nonempty :
  (sum_lift₂ f g a b).nonempty ↔ (∃ a₁ b₁, a = inl a₁ ∧ b = inl b₁ ∧ (f a₁ b₁).nonempty)
    ∨ ∃ a₂ b₂, a = inr a₂ ∧ b = inr b₂ ∧ (g a₂ b₂).nonempty :=
by simp [nonempty_iff_ne_empty, sum_lift₂_eq_empty, not_and_distrib]

lemma sum_lift₂_mono (h₁ : ∀ a b, f₁ a b ⊆ g₁ a b) (h₂ : ∀ a b, f₂ a b ⊆ g₂ a b) :
  ∀ a b, sum_lift₂ f₁ f₂ a b ⊆ sum_lift₂ g₁ g₂ a b
| (inl a) (inl b) := map_subset_map.2 (h₁ _ _)
| (inl a) (inr b) := subset.rfl
| (inr a) (inl b) := subset.rfl
| (inr a) (inr b) := map_subset_map.2 (h₂ _ _)

end sum_lift₂
end finset

open finset function

namespace sum
variables {α β : Type*}

/-! ### Disjoint sum of orders -/

section disjoint
variables [preorder α] [preorder β] [locally_finite_order α] [locally_finite_order β]

instance : locally_finite_order (α ⊕ β) :=
{ finset_Icc := sum_lift₂ Icc Icc,
  finset_Ico := sum_lift₂ Ico Ico,
  finset_Ioc := sum_lift₂ Ioc Ioc,
  finset_Ioo := sum_lift₂ Ioo Ioo,
  finset_mem_Icc := by rintro (a | a) (b | b) (x | x); simp,
  finset_mem_Ico := by rintro (a | a) (b | b) (x | x); simp,
  finset_mem_Ioc := by rintro (a | a) (b | b) (x | x); simp,
  finset_mem_Ioo := by rintro (a | a) (b | b) (x | x); simp }

variables (a₁ a₂ : α) (b₁ b₂ : β) (a b : α ⊕ β)

lemma Icc_inl_inl : Icc (inl a₁ : α ⊕ β) (inl a₂) = (Icc a₁ a₂).map embedding.inl := rfl
lemma Ico_inl_inl : Ico (inl a₁ : α ⊕ β) (inl a₂) = (Ico a₁ a₂).map embedding.inl := rfl
lemma Ioc_inl_inl : Ioc (inl a₁ : α ⊕ β) (inl a₂) = (Ioc a₁ a₂).map embedding.inl := rfl

end disjoint
end sum


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro, Jeremy Avigad
-/
import data.set.basic data.equiv.basic data.rel

/-- `roption α` is the type of "partial values" of type `α`. It
  is similar to `option α` except the domain condition can be an
  arbitrary proposition, not necessarily decidable. -/
structure {u} roption (α : Type u) : Type u :=
(dom : Prop)
(get : dom → α)

namespace roption
variables {α : Type*} {β : Type*} {γ : Type*}

/-- Convert an `roption α` with a decidable domain to an option -/
def to_option (o : roption α) [decidable o.dom] : option α :=
if h : dom o then some (o.get h) else none

/-- `roption` extensionality -/
def ext' : Π {o p : roption α}
  (H1 : o.dom ↔ p.dom)
  (H2 : ∀h₁ h₂, o.get h₁ = p.get h₂), o = p
| ⟨od, o⟩ ⟨pd, p⟩ H1 H2 := have t : od = pd, from propext H1,
  by cases t; rw [show o = p, from funext $ λp, H2 p p]

/-- `roption` eta expansion -/
@[simp] theorem eta : Π (o : roption α), (⟨o.dom, λ h, o.get h⟩ : roption α) = o
| ⟨h, f⟩ := rfl

/-- `a ∈ o` means that `o` is defined and equal to `a` -/
protected def mem (a : α) (o : roption α) : Prop := ∃ h, o.get h = a

instance : has_mem α (roption α) := ⟨roption.mem⟩

theorem mem_eq (a : α) (o : roption α) : (a ∈ o) = (∃ h, o.get h = a) :=
rfl

theorem dom_iff_mem : ∀ {o : roption α}, o.dom ↔ ∃y, y ∈ o
| ⟨p, f⟩ := ⟨λh, ⟨f h, h, rfl⟩, λ⟨_, h, rfl⟩, h⟩

theorem get_mem {o : roption α} (h) : get o h ∈ o := ⟨_, rfl⟩

/-- `roption` extensionality -/
def ext {o p : roption α} (H : ∀ a, a ∈ o ↔ a ∈ p) : o = p :=
ext' ⟨λ h, ((H _).1 ⟨h, rfl⟩).fst,
     λ h, ((H _).2 ⟨h, rfl⟩).fst⟩ $
λ a b, ((H _).2 ⟨_, rfl⟩).snd

/-- The `none` value in `roption` has a `false` domain and an empty function. -/
def none : roption α := ⟨false, false.rec _⟩

@[simp] theorem not_mem_none (a : α) : a ∉ @none α := λ h, h.fst

/-- The `some a` value in `roption` has a `true` domain and the
  function returns `a`. -/
def some (a : α) : roption α := ⟨true, λ_, a⟩

theorem mem_unique : relator.left_unique ((∈) : α → roption α → Prop)
| _ ⟨p, f⟩ _ ⟨h₁, rfl⟩ ⟨h₂, rfl⟩ := rfl

theorem get_eq_of_mem {o : roption α} {a} (h : a ∈ o) (h') : get o h' = a :=
mem_unique ⟨_, rfl⟩ h

@[simp] theorem get_some {a : α} (ha : (some a).dom) : get (some a) ha = a := rfl

theorem mem_some (a : α) : a ∈ some a := ⟨trivial, rfl⟩

@[simp] theorem mem_some_iff {a b} : b ∈ (some a : roption α) ↔ b = a :=
⟨λ⟨h, e⟩, e.symm, λ e, ⟨trivial, e.symm⟩⟩

theorem eq_some_iff {a : α} {o : roption α} : o = some a ↔ a ∈ o :=
⟨λ e, e.symm ▸ mem_some _,
 λ ⟨h, e⟩, e ▸ ext' (iff_true_intro h) (λ _ _, rfl)⟩

theorem eq_none_iff {o : roption α} : o = none ↔ ∀ a, a ∉ o :=
⟨λ e, e.symm ▸ not_mem_none,
 λ h, ext (by simpa [not_mem_none])⟩

theorem eq_none_iff' {o : roption α} : o = none ↔ ¬ o.dom :=
⟨λ e, e.symm ▸ id, λ h, eq_none_iff.2 (λ a h', h h'.fst)⟩

@[simp] lemma some_inj {a b : α} : roption.some a = some b ↔ a = b :=
function.injective.eq_iff (λ a b h, congr_fun (eq_of_heq (roption.mk.inj h).2) trivial)

@[simp] lemma some_get {a : roption α} (ha : a.dom) :
  roption.some (roption.get a ha) = a :=
eq.symm (eq_some_iff.2 ⟨ha, rfl⟩)

lemma get_eq_iff_eq_some {a : roption α} {ha : a.dom} {b : α} :
  a.get ha = b ↔ a = some b :=
⟨λ h, by simp [h.symm], λ h, by simp [h]⟩

instance none_decidable : decidable (@none α).dom := decidable.false
instance some_decidable (a : α) : decidable (some a).dom := decidable.true

def get_or_else (a : roption α) [decidable a.dom] (d : α) :=
if ha : a.dom then a.get ha else d

@[simp] lemma get_or_else_none (d : α) : get_or_else none d = d :=
dif_neg id

@[simp] lemma get_or_else_some (a : α) (d : α) : get_or_else (some a) d = a :=
dif_pos trivial

@[simp] theorem mem_to_option {o : roption α} [decidable o.dom] {a : α} :
  a ∈ to_option o ↔ a ∈ o :=
begin
  unfold to_option,
  by_cases h : o.dom; simp [h],
  { exact ⟨λ h, ⟨_, h⟩, λ ⟨_, h⟩, h⟩ },
  { exact mt Exists.fst h }
end

/-- Convert an `option α` into an `roption α` -/
def of_option : option α → roption α
| option.none     := none
| (option.some a) := some a

@[simp] theorem mem_of_option {a : α} : ∀ {o : option α}, a ∈ of_option o ↔ a ∈ o
| option.none     := ⟨λ h, h.fst.elim, λ h, option.no_confusion h⟩
| (option.some b) := ⟨λ h, congr_arg option.some h.snd,
  λ h, ⟨trivial, option.some.inj h⟩⟩

@[simp] theorem of_option_dom {α} : ∀ (o : option α), (of_option o).dom ↔ o.is_some
| option.none     := by simp [of_option, none]
| (option.some a) := by simp [of_option]

theorem of_option_eq_get {α} (o : option α) : of_option o = ⟨_, @option.get _ o⟩ :=
roption.ext' (of_option_dom o) $ λ h₁ h₂, by cases o; [cases h₁, refl]

instance : has_coe (option α) (roption α) := ⟨of_option⟩

@[simp] theorem mem_coe {a : α} {o : option α} :
  a ∈ (o : roption α) ↔ a ∈ o := mem_of_option

@[simp] theorem coe_none : (@option.none α : roption α) = none := rfl
@[simp] theorem coe_some (a : α) : (option.some a : roption α) = some a := rfl

@[elab_as_eliminator] protected lemma roption.induction_on {P : roption α → Prop}
  (a : roption α) (hnone : P none) (hsome : ∀ a : α, P (some a)) : P a :=
(classical.em a.dom).elim
  (λ h, roption.some_get h ▸ hsome _)
  (λ h, (eq_none_iff'.2 h).symm ▸ hnone)

instance of_option_decidable : ∀ o : option α, decidable (of_option o).dom
| option.none     := roption.none_decidable
| (option.some a) := roption.some_decidable a

@[simp] theorem to_of_option (o : option α) : to_option (of_option o) = o :=
by cases o; refl

@[simp] theorem of_to_option (o : roption α) [decidable o.dom] : of_option (to_option o) = o :=
ext $ λ a, mem_of_option.trans mem_to_option

noncomputable def equiv_option : roption α ≃ option α :=
by haveI := classical.dec; exact
⟨λ o, to_option o, of_option, λ o, of_to_option o,
 λ o, eq.trans (by dsimp; congr) (to_of_option o)⟩

/-- `assert p f` is a bind-like operation which appends an additional condition
  `p` to the domain and uses `f` to produce the value. -/
def assert (p : Prop) (f : p → roption α) : roption α :=
⟨∃h : p, (f h).dom, λha, (f ha.fst).get ha.snd⟩

/-- The bind operation has value `g (f.get)`, and is defined when all the
  parts are defined. -/
protected def bind (f : roption α) (g : α → roption β) : roption β :=
assert (dom f) (λb, g (f.get b))

/-- The map operation for `roption` just maps the value and maintains the same domain. -/
def map (f : α → β) (o : roption α) : roption β :=
⟨o.dom, f ∘ o.get⟩

theorem mem_map (f : α → β) {o : roption α} :
  ∀ {a}, a ∈ o → f a ∈ map f o
| _ ⟨h, rfl⟩ := ⟨_, rfl⟩

@[simp] theorem mem_map_iff (f : α → β) {o : roption α} {b} :
  b ∈ map f o ↔ ∃ a ∈ o, f a = b :=
⟨match b with _, ⟨h, rfl⟩ := ⟨_, ⟨_, rfl⟩, rfl⟩ end,
 λ ⟨a, h₁, h₂⟩, h₂ ▸ mem_map f h₁⟩

@[simp] theorem map_none (f : α → β) :
  map f none = none := eq_none_iff.2 $ λ a, by simp

@[simp] theorem map_some (f : α → β) (a : α) : map f (some a) = some (f a) :=
eq_some_iff.2 $ mem_map f $ mem_some _

theorem mem_assert {p : Prop} {f : p → roption α}
  : ∀ {a} (h : p), a ∈ f h → a ∈ assert p f
| _ _ ⟨h, rfl⟩ := ⟨⟨_, _⟩, rfl⟩

@[simp] theorem mem_assert_iff {p : Prop} {f : p → roption α} {a} :
  a ∈ assert p f ↔ ∃ h : p, a ∈ f h :=
⟨match a with _, ⟨h, rfl⟩ := ⟨_, ⟨_, rfl⟩⟩ end,
 λ ⟨a, h⟩, mem_assert _ h⟩

theorem mem_bind {f : roption α} {g : α → roption β} :
  ∀ {a b}, a ∈ f → b ∈ g a → b ∈ f.bind g
| _ _ ⟨h, rfl⟩ ⟨h₂, rfl⟩ := ⟨⟨_, _⟩, rfl⟩

@[simp] theorem mem_bind_iff {f : roption α} {g : α → roption β} {b} :
  b ∈ f.bind g ↔ ∃ a ∈ f, b ∈ g a :=
⟨match b with _, ⟨⟨h₁, h₂⟩, rfl⟩ := ⟨_, ⟨_, rfl⟩, ⟨_, rfl⟩⟩ end,
 λ ⟨a, h₁, h₂⟩, mem_bind h₁ h₂⟩

@[simp] theorem bind_none (f : α → roption β) :
  none.bind f = none := eq_none_iff.2 $ λ a, by simp

@[simp] theorem bind_some (a : α) (f : α → roption β) :
  (some a).bind f = f a := ext $ by simp

theorem bind_some_eq_map (f : α → β) (x : roption α) :
  x.bind (some ∘ f) = map f x :=
ext $ by simp [eq_comm]

theorem bind_assoc {γ} (f : roption α) (g : α → roption β) (k : β → roption γ) :
  (f.bind g).bind k = f.bind (λ x, (g x).bind k) :=
ext $ λ a, by simp; exact
 ⟨λ ⟨_, ⟨_, h₁, h₂⟩, h₃⟩, ⟨_, h₁, _, h₂, h₃⟩,
  λ ⟨_, h₁, _, h₂, h₃⟩, ⟨_, ⟨_, h₁, h₂⟩, h₃⟩⟩

@[simp] theorem bind_map {γ} (f : α → β) (x) (g : β → roption γ) :
  (map f x).bind g = x.bind (λ y, g (f y)) :=
by rw [← bind_some_eq_map, bind_assoc]; simp

@[simp] theorem map_bind {γ} (f : α → roption β) (x : roption α) (g : β → γ) :
  map g (x.bind f) = x.bind (λ y, map g (f y)) :=
by rw [← bind_some_eq_map, bind_assoc]; simp [bind_some_eq_map]

theorem map_map (g : β → γ) (f : α → β) (o : roption α) :
  map g (map f o) = map (g ∘ f) o :=
by rw [← bind_some_eq_map, bind_map, bind_some_eq_map]

instance : monad roption :=
{ pure := @some,
  map := @map,
  bind := @roption.bind }

instance : is_lawful_monad roption :=
{ bind_pure_comp_eq_map := @bind_some_eq_map,
  id_map := λ β f, by cases f; refl,
  pure_bind := @bind_some,
  bind_assoc := @bind_assoc }

theorem map_id' {f : α → α} (H : ∀ (x : α), f x = x) (o) : map f o = o :=
by rw [show f = id, from funext H]; exact id_map o

@[simp] theorem bind_some_right (x : roption α) : x.bind some = x :=
by rw [bind_some_eq_map]; simp [map_id']

@[simp] theorem ret_eq_some (a : α) : return a = some a := rfl

@[simp] theorem map_eq_map {α β} (f : α → β) (o : roption α) :
  f <$> o = map f o := rfl

@[simp] theorem bind_eq_bind {α β} (f : roption α) (g : α → roption β) :
  f >>= g = f.bind g := rfl

instance : monad_fail roption :=
{ fail := λ_ _, none, ..roption.monad }

/- `restrict p o h` replaces the domain of `o` with `p`, and is well defined when
  `p` implies `o` is defined. -/
def restrict (p : Prop) : ∀ (o : roption α), (p → o.dom) → roption α
| ⟨d, f⟩ H := ⟨p, λh, f (H h)⟩

@[simp]
theorem mem_restrict (p : Prop) (o : roption α) (h : p → o.dom) (a : α) :
  a ∈ restrict p o h ↔ p ∧ a ∈ o :=
begin
  cases o, dsimp [restrict, mem_eq], split,
  { rintro ⟨h₀, h₁⟩, exact ⟨h₀, ⟨_, h₁⟩⟩ },
  rintro ⟨h₀, h₁, h₂⟩, exact ⟨h₀, h₂⟩
end

/-- `unwrap o` gets the value at `o`, ignoring the condition.
  (This function is unsound.) -/
meta def unwrap (o : roption α) : α := o.get undefined

theorem assert_defined {p : Prop} {f : p → roption α} :
  ∀ (h : p), (f h).dom → (assert p f).dom := exists.intro

theorem bind_defined {f : roption α} {g : α → roption β} :
  ∀ (h : f.dom), (g (f.get h)).dom → (f.bind g).dom := assert_defined

@[simp] theorem bind_dom {f : roption α} {g : α → roption β} :
  (f.bind g).dom ↔ ∃ h : f.dom, (g (f.get h)).dom := iff.rfl

end roption

/-- `pfun α β`, or `α →. β`, is the type of partial functions from
  `α` to `β`. It is defined as `α → roption β`. -/
def pfun (α : Type*) (β : Type*) := α → roption β

infixr ` →. `:25 := pfun

namespace pfun
variables {α : Type*} {β : Type*} {γ : Type*}

/-- The domain of a partial function -/
def dom (f : α →. β) : set α := λ a, (f a).dom

theorem mem_dom (f : α →. β) (x : α) : x ∈ dom f ↔ ∃ y, y ∈ f x :=
by simp [dom, set.mem_def, roption.dom_iff_mem]

theorem dom_eq (f : α →. β) : dom f = {x | ∃ y, y ∈ f x} :=
set.ext (mem_dom f)

/-- Evaluate a partial function -/
def fn (f : α →. β) (x) (h : dom f x) : β := (f x).get h

/-- Evaluate a partial function to return an `option` -/
def eval_opt (f : α →. β) [D : decidable_pred (dom f)] (x : α) : option β :=
@roption.to_option _ _ (D x)

/-- Partial function extensionality -/
def ext' {f g : α →. β}
  (H1 : ∀ a, a ∈ dom f ↔ a ∈ dom g)
  (H2 : ∀ a p q, f.fn a p = g.fn a q) : f = g :=
funext $ λ a, roption.ext' (H1 a) (H2 a)

def ext {f g : α →. β} (H : ∀ a b, b ∈ f a ↔ b ∈ g a) : f = g :=
funext $ λ a, roption.ext (H a)

/-- Turn a partial function into a function out of a subtype -/
def as_subtype (f : α →. β) (s : {x // f.dom x}) : β := f.fn s.1 s.2

def equiv_subtype : (α →. β) ≃ (Σ p : α → Prop, subtype p → β) :=
⟨λ f, ⟨f.dom, as_subtype f⟩,
 λ ⟨p, f⟩ x, ⟨p x, λ h, f ⟨x, h⟩⟩,
 λ f, funext $ λ a, roption.eta _,
 λ ⟨p, f⟩, by dsimp; congr; funext a; cases a; refl⟩

theorem as_subtype_eq_of_mem {f : α →. β} {x : α} {y : β} (fxy : y ∈ f x) (domx : x ∈ f.dom) :
  f.as_subtype ⟨x, domx⟩ = y :=
roption.mem_unique (roption.get_mem _) fxy

/-- Turn a total function into a partial function -/
protected def lift (f : α → β) : α →. β := λ a, roption.some (f a)

instance : has_coe (α → β) (α →. β) := ⟨pfun.lift⟩

@[simp] theorem lift_eq_coe (f : α → β) : pfun.lift f = f := rfl

@[simp] theorem coe_val (f : α → β) (a : α) :
  (f : α →. β) a = roption.some (f a) := rfl

/-- The graph of a partial function is the set of pairs
  `(x, f x)` where `x` is in the domain of `f`. -/
def graph (f : α →. β) : set (α × β) := {p | p.2 ∈ f p.1}

def graph' (f : α →. β) : rel α β := λ x y, y ∈ f x

/-- The range of a partial function is the set of values
  `f x` where `x` is in the domain of `f`. -/
def ran (f : α →. β) : set β := {b | ∃a, b ∈ f a}

/-- Restrict a partial function to a smaller domain. -/
def restrict (f : α →. β) {p : set α} (H : p ⊆ f.dom) : α →. β :=
λ x, roption.restrict (p x) (f x) (@H x)

@[simp]
theorem mem_restrict {f : α →. β} {s : set α} (h : s ⊆ f.dom) (a : α) (b : β) :
  b ∈ restrict f h a ↔ a ∈ s ∧ b ∈ f a :=
by { simp [restrict], reflexivity }

def res (f : α → β) (s : set α) : α →. β :=
restrict (pfun.lift f) (set.subset_univ s)

theorem mem_res (f : α → β) (s : set α) (a : α) (b : β) :
  b ∈ res f s a ↔ (a ∈ s ∧ f a = b) :=
by { simp [res], split; {intro h, simp [h]} }

theorem res_univ (f : α → β) : pfun.res f set.univ = f :=
rfl

theorem dom_iff_graph (f : α →. β) (x : α) : x ∈ f.dom ↔ ∃y, (x, y) ∈ f.graph :=
roption.dom_iff_mem

theorem lift_graph {f : α → β} {a b} : (a, b) ∈ (f : α →. β).graph ↔ f a = b :=
show (∃ (h : true), f a = b) ↔ f a = b, by simp

/-- The monad `pure` function, the total constant `x` function -/
protected def pure (x : β) : α →. β := λ_, roption.some x

/-- The monad `bind` function, pointwise `roption.bind` -/
def bind (f : α →. β) (g : β → α →. γ) : α →. γ :=
λa, roption.bind (f a) (λb, g b a)

/-- The monad `map` function, pointwise `roption.map` -/
def map (f : β → γ) (g : α →. β) : α →. γ :=
λa, roption.map f (g a)

instance : monad (pfun α) :=
{ pure := @pfun.pure _,
  bind := @pfun.bind _,
  map := @pfun.map _ }

instance : is_lawful_monad (pfun α) :=
{ bind_pure_comp_eq_map := λ β γ f x, funext $ λ a, roption.bind_some_eq_map _ _,
  id_map := λ β f, by funext a; dsimp [functor.map, pfun.map]; cases f a; refl,
  pure_bind := λ β γ x f, funext $ λ a, roption.bind_some.{u_1 u_2} _ (f x),
  bind_assoc := λ β γ δ f g k,
    funext $ λ a, roption.bind_assoc (f a) (λ b, g b a) (λ b, k b a) }

theorem pure_defined (p : set α) (x : β) : p ⊆ (@pfun.pure α _ x).dom := set.subset_univ p

theorem bind_defined {α β γ} (p : set α) {f : α →. β} {g : β → α →. γ}
  (H1 : p ⊆ f.dom) (H2 : ∀x, p ⊆ (g x).dom) : p ⊆ (f >>= g).dom :=
λa ha, (⟨H1 ha, H2 _ ha⟩ : (f >>= g).dom a)

def fix (f : α →. β ⊕ α) : α →. β := λ a,
roption.assert (acc (λ x y, sum.inr x ∈ f y) a) $ λ h,
@well_founded.fix_F _ (λ x y, sum.inr x ∈ f y) _
  (λ a IH, roption.assert (f a).dom $ λ hf,
    by cases e : (f a).get hf with b a';
      [exact roption.some b, exact IH _ ⟨hf, e⟩])
  a h

theorem dom_of_mem_fix {f : α →. β ⊕ α} {a : α} {b : β}
  (h : b ∈ fix f a) : (f a).dom :=
let ⟨h₁, h₂⟩ := roption.mem_assert_iff.1 h in
by rw well_founded.fix_F_eq at h₂; exact h₂.fst.fst

theorem mem_fix_iff {f : α →. β ⊕ α} {a : α} {b : β} :
  b ∈ fix f a ↔ sum.inl b ∈ f a ∨ ∃ a', sum.inr a' ∈ f a ∧ b ∈ fix f a' :=
⟨λ h, let ⟨h₁, h₂⟩ := roption.mem_assert_iff.1 h in
  begin
    rw well_founded.fix_F_eq at h₂,
    simp at h₂,
    cases h₂ with h₂ h₃,
    cases e : (f a).get h₂ with b' a'; simp [e] at h₃,
    { subst b', refine or.inl ⟨h₂, e⟩ },
    { exact or.inr ⟨a', ⟨_, e⟩, roption.mem_assert _ h₃⟩ }
  end,
λ h, begin
  simp [fix],
  rcases h with ⟨h₁, h₂⟩ | ⟨a', h, h₃⟩,
  { refine ⟨⟨_, λ y h', _⟩, _⟩,
    { injection roption.mem_unique ⟨h₁, h₂⟩ h' },
    { rw well_founded.fix_F_eq, simp [h₁, h₂] } },
  { simp [fix] at h₃, cases h₃ with h₃ h₄,
    refine ⟨⟨_, λ y h', _⟩, _⟩,
    { injection roption.mem_unique h h' with e,
      exact e ▸ h₃ },
    { cases h with h₁ h₂,
      rw well_founded.fix_F_eq, simp [h₁, h₂, h₄] } }
end⟩

@[elab_as_eliminator] theorem fix_induction
  {f : α →. β ⊕ α} {b : β} {C : α → Sort*} {a : α} (h : b ∈ fix f a)
  (H : ∀ a, b ∈ fix f a →
    (∀ a', b ∈ fix f a' → sum.inr a' ∈ f a → C a') → C a) : C a :=
begin
  replace h := roption.mem_assert_iff.1 h,
  have := h.snd, revert this,
  induction h.fst with a ha IH, intro h₂,
  refine H a (roption.mem_assert_iff.2 ⟨⟨_, ha⟩, h₂⟩)
    (λ a' ha' fa', _),
  have := (roption.mem_assert_iff.1 ha').snd,
  exact IH _ fa' ⟨ha _ fa', this⟩ this
end

end pfun

namespace pfun

variables {α : Type*} {β : Type*} (f : α →. β)

def image (s : set α) : set β := rel.image f.graph' s

lemma image_def (s : set α) : image f s = {y | ∃ x ∈ s, y ∈ f x} := rfl

lemma mem_image (y : β) (s : set α) : y ∈ image f s ↔ ∃ x ∈ s, y ∈ f x :=
iff.refl _

lemma image_mono {s t : set α} (h : s ⊆ t) : f.image s ⊆ f.image t :=
rel.image_mono _ h

lemma image_inter (s t : set α) : f.image (s ∩ t) ⊆ f.image s ∩ f.image t :=
rel.image_inter _ s t

lemma image_union (s t : set α) : f.image (s ∪ t) = f.image s ∪ f.image t :=
rel.image_union _ s t

def preimage (s : set β) : set α := rel.preimage (λ x y, y ∈ f x) s

lemma preimage_def (s : set β) : preimage f s = {x | ∃ y ∈ s, y ∈ f x} := rfl

def mem_preimage (s : set β) (x : α) : x ∈ preimage f s ↔ ∃ y ∈ s, y ∈ f x :=
iff.refl _

lemma preimage_subset_dom (s : set β) : f.preimage s ⊆ f.dom :=
assume x ⟨y, ys, fxy⟩, roption.dom_iff_mem.mpr ⟨y, fxy⟩

lemma preimage_mono {s t : set β} (h : s ⊆ t) : f.preimage s ⊆ f.preimage t :=
rel.preimage_mono _ h

lemma preimage_inter (s t : set β) : f.preimage (s ∩ t) ⊆ f.preimage s ∩ f.preimage t :=
rel.preimage_inter _ s t

lemma preimage_union (s t : set β) : f.preimage (s ∪ t) = f.preimage s ∪ f.preimage t :=
rel.preimage_union _ s t

lemma preimage_univ : f.preimage set.univ = f.dom :=
by ext; simp [mem_preimage, mem_dom]

def core (s : set β) : set α := rel.core f.graph' s

lemma core_def (s : set β) : core f s = {x | ∀ y, y ∈ f x → y ∈ s} := rfl

lemma mem_core (x : α) (s : set β) : x ∈ core f s ↔ (∀ y, y ∈ f x → y ∈ s) :=
iff.rfl

lemma compl_dom_subset_core (s : set β) : -f.dom ⊆ f.core s :=
assume x hx y fxy,
absurd ((mem_dom f x).mpr ⟨y, fxy⟩) hx

lemma core_mono {s t : set β} (h : s ⊆ t) : f.core s ⊆ f.core t :=
rel.core_mono _ h

lemma core_inter (s t : set β) : f.core (s ∩ t) = f.core s ∩ f.core t :=
rel.core_inter _ s t

lemma mem_core_res (f : α → β) (s : set α) (t : set β) (x : α) :
  x ∈ core (res f s) t ↔ (x ∈ s → f x ∈ t) :=
begin
  simp [mem_core, mem_res], split,
  { intros h h', apply h _ h', reflexivity },
  intros h y xs fxeq, rw ←fxeq, exact h xs
end

section
local attribute  [instance] classical.prop_decidable

lemma core_res (f : α → β) (s : set α) (t : set β) : core (res f s) t = -s ∪ f ⁻¹' t :=
by { ext, rw mem_core_res, by_cases h : x ∈ s; simp [h] }

end

lemma core_restrict (f : α → β) (s : set β) : core (f : α →. β) s = set.preimage f s :=
by ext x; simp [core_def]

lemma preimage_subset_core (f : α →. β) (s : set β) : f.preimage s ⊆ f.core s :=
assume x ⟨y, ys, fxy⟩ y' fxy',
have y = y', from roption.mem_unique fxy fxy',
this ▸ ys

lemma preimage_eq (f : α →. β) (s : set β) : f.preimage s = f.core s ∩ f.dom :=
set.eq_of_subset_of_subset
  (set.subset_inter (preimage_subset_core f s) (preimage_subset_dom f s))
  (assume x ⟨xcore, xdom⟩,
    let y := (f x).get xdom in
    have ys : y ∈ s, from xcore _ (roption.get_mem _),
    show x ∈ preimage f s, from  ⟨(f x).get xdom, ys, roption.get_mem _⟩)

lemma core_eq (f : α →. β) (s : set β) : f.core s = f.preimage s ∪ -f.dom :=
by rw [preimage_eq, set.union_distrib_right, set.union_comm (dom f), set.compl_union_self,
        set.inter_univ, set.union_eq_self_of_subset_right (compl_dom_subset_core f s)]

lemma preimage_as_subtype (f : α →. β) (s : set β) :
  f.as_subtype ⁻¹' s = subtype.val ⁻¹' pfun.preimage f s :=
begin
  ext x,
  simp only [set.mem_preimage_eq, set.mem_set_of_eq, pfun.as_subtype, pfun.mem_preimage],
  show pfun.fn f (x.val) _ ∈ s ↔ ∃ y ∈ s, y ∈ f (x.val),
  exact iff.intro
    (assume h, ⟨_, h, roption.get_mem _⟩)
    (assume ⟨y, ys, fxy⟩,
      have f.fn x.val x.property ∈ f x.val := roption.get_mem _,
      roption.mem_unique fxy this ▸ ys)
end

end pfun