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

import category_theory.limits.shapes.finite_products
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.terminal
import tactic.rcases
import pfin

/-! # Stuff that should be in the catthy library. -/
namespace category_theory

universe w
def discrete.equiv_of_iso {J K : Type w} (h : J ≃ K) : (discrete J ≌ discrete K) :=
equivalence.mk
  (functor.of_function h.to_fun) -- C ⥤ D
  (functor.of_function h.inv_fun) -- D ⥤ C
  { hom := {
      app := λ X, begin
        apply eq_to_hom,
        simp only [functor.id_obj, functor.of_function_obj, functor.comp_obj],
        exact (h.left_inv X).symm,
      end,
      naturality' := λ X Y f, dec_trivial },
    inv := {
      app := λ X, begin
        apply eq_to_hom,
        simp only [functor.id_obj, functor.of_function_obj, functor.comp_obj],
        exact h.left_inv X,
      end,
      naturality' := λ X Y f, dec_trivial },
    hom_inv_id' := by ext1; exact dec_trivial,
    inv_hom_id' := by ext1; exact dec_trivial }
  { hom := {
      app := λ X, begin
        apply eq_to_hom,
        simp only [functor.id_obj, functor.of_function_obj, functor.comp_obj],
        exact h.right_inv X
      end,
      naturality' := λ X Y f, dec_trivial },
    inv := {
      app := λ X, begin
        apply eq_to_hom,
        simp only [functor.id_obj, functor.of_function_obj, functor.comp_obj],
        exact (h.right_inv X).symm,
      end,
      naturality' := λ X Y f, dec_trivial },
    hom_inv_id' := by ext1; exact dec_trivial,
    inv_hom_id' := by ext1; exact dec_trivial }

namespace limits

universes v u
variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞

lemma prod.lift_fst {X Y Z : C} [has_limit (pair X Y)] (f : Z ⟶ X) (g : Z ⟶ Y) : prod.lift f g ≫ prod.fst = f :=
by simp only [binary_fan.mk_π_app_left, limit.lift_π]

lemma prod.lift_snd {X Y Z : C} [has_limit (pair X Y)] (f : Z ⟶ X) (g : Z ⟶ Y) : prod.lift f g ≫ prod.snd = g :=
by simp only [binary_fan.mk_π_app_right, limit.lift_π]

lemma prod.lift_uniq {X Y Z : C} [has_limit (pair X Y)] (f : Z ⟶ X) (g : Z ⟶ Y) (m : Z ⟶ X ⨯ Y)
  (hLeft : m ≫ prod.fst = f) (hRight : m ≫ prod.snd = g)
  : m = prod.lift f g :=
begin
  apply limit.hom_ext,
  intro j,
  cases hLeft, cases hRight, cases j,
    simp only [limit.lift_π, binary_fan.mk_π_app_left],
  simp only [limit.lift_π, binary_fan.mk_π_app_right],
end

end limits
end category_theory

/-!
# Constructing finite products from binary products and a terminal object

If a category has all binary products, and a terminal object, then it has all finite products.
-/

namespace category_theory.limits
open category_theory

universes v u
variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞

-- We hide the "implementation details" inside a namespace
namespace has_finite_products_of_binary_products_and_terminal_object

@[reducible]
def match_statement_lol [has_binary_products.{v} C]
  {n : ℕ} (F: discrete (pfin (nat.succ n)) ⥤ C) (limF': has_limit (discrete.lift pfin.succ ⋙ F))
  : Π (j: pfin (nat.succ n)), F.obj ⟨0, nat.succ_pos n⟩ ⨯ limF'.cone.X ⟶ F.obj j
| ⟨0, _⟩ := prod.fst
| w@⟨nat.succ j, _⟩ := prod.snd ≫
  limF'.cone.π.app (w.pred (λ h, nat.succ_ne_zero j (pfin.veq_of_eq h)))

set_option eqn_compiler.zeta true
def has_limit_for_pfin_diagram [has_binary_products.{v} C] [has_terminal.{v} C]
: Π {n: ℕ} (F: (discrete (pfin n)) ⥤ C)
, has_limit F
| 0 F :=
  -- In the base case, the category of cones over a diagram of shape ∅ is simply 𝒞, so
  -- the limit cone is 𝒞's terminal object.
  let absurdJ (x : pfin 0) : false := x.elim0 in
  let myCone : cone F :=
    { X := terminal C,
      π := nat_trans.of_homs (λ j, (absurdJ j).elim) } in
  { cone := myCone,
    is_limit :=
      { lift := λ s, terminal.from s.X
      , fac' := λ s j, (absurdJ j).elim
      , uniq' := λ s m h, dec_trivial } }

| (nat.succ n) F :=
  -- In the inductive case, we construct a limit cone with apex (F 0) ⨯ (apex of smaller limit cone)
  -- where the smaller cone is obtained from the below functor.
  let F' : discrete (pfin n) ⥤ C := discrete.lift pfin.succ ⋙ F in
  let limF' : has_limit F' := has_limit_for_pfin_diagram F' in
  let myCone : cone F :=
    { X := (F.obj ⟨0, nat.succ_pos n⟩) ⨯ limF'.cone.X
    , π := nat_trans.of_homs (match_statement_lol F limF') } in -- TODO(WN): using an actual match statement here
                                                                -- is hard to unfold later, but would obv be nicer.
  { cone := myCone,
    is_limit :=
      { lift := λ s,
          -- Show that s.X is also the apex of a cone over F' ..
          let s' : cone F' :=
            { X := s.X
            , π := nat_trans.of_homs (λ j, s.π.app j.succ) } in
          -- .. in order to get from s.X to limF'.cone.X in the right morphism
          -- using the fact that limF' is a limit cone over F'.
          prod.lift
            (s.π.app $ ⟨0, nat.succ_pos n⟩)
            (eq_to_hom rfl ≫ limF'.is_limit.lift s')
      -- Show that lift is in fact a morphism of cones from s into myCone.
      , fac' := λ s j, begin
        rcases j with ⟨j, hj⟩, cases j;
        simp only [category.id_comp, nat_trans.of_homs_app, eq_to_hom_refl, match_statement_lol,
          prod.lift_fst, limit.lift_π_assoc, is_limit.fac, nat_trans.of_homs_app,
          binary_fan.mk_π_app_right], congr
      end
      -- Show that lift is the unique morphism into myCone.
      , uniq' := λ s m h, begin
        have h0 := h ⟨0, nat.succ_pos n⟩,
        simp [match_statement_lol] at h0,
        let s' : cone F' :=
          { X := s.X
          , π := nat_trans.of_homs (λ j, s.π.app j.succ) },
        have hS : m ≫ prod.snd = eq_to_hom rfl ≫ limF'.is_limit.lift s',
        { -- m ≫ prod.snd is a morphism of cones over F' into limF'.X ..
          have hN : ∀ (j: discrete (pfin n)), (m ≫ prod.snd) ≫ limF'.cone.π.app j = s'.π.app j,
          { intro j,
            unfold_projs, simp [(h j.succ).symm],
            rcases j with ⟨j, hj⟩, refl },
          -- .. and therefore unique.
          have hUniq' : m ≫ prod.snd = limF'.is_limit.lift s',
          from limF'.is_limit.uniq' s' (m ≫ prod.snd) hN,
          simp only [hUniq', category.id_comp, eq_to_hom_refl] },
        exact prod.lift_uniq _ _ _ h0 hS
      end } }
set_option eqn_compiler.zeta false

end has_finite_products_of_binary_products_and_terminal_object

open has_finite_products_of_binary_products_and_terminal_object

-- TODO(WN): instance or def? Is there another way one might want to construct limits of shape pfin?
instance has_limits_of_shape_pfin [has_binary_products.{v} C] [has_terminal.{v} C] (n : ℕ)
  : @has_limits_of_shape (discrete $ pfin n) _ C 𝒞 :=
⟨λ F, has_limit_for_pfin_diagram F⟩

-- TODO(WN): trunc? #22
def has_trunc_finite_products [has_binary_products.{v} C] [has_terminal.{v} C]
  {J : Type v} [fintype J] [decidable_eq J]
  : trunc (has_limits_of_shape (discrete J) C) :=
trunc.lift_on (fintype.equiv_pfin J)
  (λ h,
    let hIso : discrete (pfin $ fintype.card J) ≌ discrete J :=
      discrete.equiv_of_iso h.symm in
    let limsPfin : @has_limits_of_shape (discrete (pfin $ fintype.card J)) _ C 𝒞 :=
      by apply_instance in
    trunc.mk $ has_limits_of_shape_of_equivalence hIso)
  (λ a b, trunc.eq _ _)

end category_theory.limits


import analysis.topology.topological_space data.set
import analysis.topology.continuity
import Kenny_comm_alg.Zariski
import tag00EJ
import localization
import localization_UMP
import tag00E0
import tag00DY
import tag006E -- presheaf of types
import tag006N -- presheaf of rings
import tag006T -- sheaves of types
import tag0072 -- sheaves of rings
import Kenny_comm_alg.temp
import mathlib_someday.topology
import tag01HR
import tag007N -- poor mans direct limit

universes u

local attribute [class] topological_space.is_open

definition presheaf_of_types_pushforward
  {α : Type u} [Tα : topological_space α]
  {β : Type u} [Tβ : topological_space β]
  (f : α → β)
  (fcont: continuous f)
  (FPT : presheaf_of_types α) :
  presheaf_of_types β :=
{ F := λ V OV, FPT.F (fcont V OV),
  res := λ V₁ V₂ OV₁ OV₂ H,
    FPT.res (f ⁻¹' V₁) (f⁻¹' V₂) (fcont V₁ OV₁) (fcont V₂ OV₂) (λ x Hx,H Hx),
  Hid := λ V OV, FPT.Hid (f ⁻¹' V) (fcont V OV),
  Hcomp := λ Uβ Vβ Wβ OUβ OVβ OWβ HUV HVW,
    FPT.Hcomp (f ⁻¹' Uβ)(f ⁻¹' Vβ)(f ⁻¹' Wβ) (fcont Uβ OUβ) (fcont Vβ OVβ) (fcont Wβ OWβ)
    (λ x Hx, HUV Hx) (λ x Hx, HVW Hx) }

definition presheaf_of_rings_pushforward
  {α : Type u} [Tα : topological_space α]
  {β : Type u} [Tβ : topological_space β]
  (f : α → β)
  (fcont: continuous f)
  (FPR : presheaf_of_rings α) :
  presheaf_of_rings β :=
{ Fring := λ U OU,FPR.Fring (fcont U OU),
  res_is_ring_morphism := λ U V OU OV H,
    FPR.res_is_ring_morphism (f ⁻¹' U) (f ⁻¹' V) (fcont U OU) (fcont V OV) (λ x Hx, H Hx),
  .. presheaf_of_types_pushforward f fcont FPR.to_presheaf_of_types }

definition presheaf_of_types_pullback_under_open_immersion
  {α : Type u} [Tα : topological_space α]
  {β : Type u} [Tβ : topological_space β]
  (PT : presheaf_of_types β)
  (f : α → β)
  (H : topological_space.open_immersion f) :
  presheaf_of_types α :=
{ F := λ U HU,PT.F ((H.fopens U).1 HU),
  res := λ U V OU OV H2,PT.res (f '' U) (f '' V) ((H.fopens U).1 OU) ((H.fopens V).1 OV)
    (set.image_subset f H2),
  Hid := λ _ _,PT.Hid _ _,
  Hcomp := λ U V W _ _ _ HUV HVW,
    PT.Hcomp _ _ _ _ _ _ (set.image_subset f HUV) (set.image_subset f HVW) }

definition presheaf_of_rings_pullback_under_open_immersion
  {α : Type u} [Tα : topological_space α]
  {β : Type u} [Tβ : topological_space β]
  (PR : presheaf_of_rings β)
  (f : α → β)
  (H : topological_space.open_immersion f) :
  presheaf_of_rings α :=
{ Fring := λ U OU,PR.Fring (topological_space.open_of_open_immersion_open f H U OU),
  res_is_ring_morphism := λ U V OU OV H2,PR.res_is_ring_morphism (f '' U) (f '' V)
    (topological_space.open_of_open_immersion_open f H U OU)
    (topological_space.open_of_open_immersion_open f H V OV)
    (set.image_subset f H2),
  .. presheaf_of_types_pullback_under_open_immersion PR.to_presheaf_of_types f H }

lemma zariski.univ_is_basic (R : Type u) [comm_ring R] : is_zariski.standard_open (@set.univ (X R)) :=
⟨(1 : R),eq.symm $ set.univ_subset_iff.1 $ λ ⟨P,HP⟩ _,@@is_prime_ideal.one_not_mem _ P HP⟩

instance zariski.structure_presheaf_of_rings_on_basis_stalk_is_ring (R : Type u) [comm_ring R] (x : X R) :
comm_ring (presheaf_on_basis_stalk
  (zariski.structure_presheaf_of_rings_on_basis_of_standard R).to_presheaf_of_types_on_basis x) :=
presheaf_of_rings_on_basis_stalk.stalks_of_presheaf_of_rings_on_basis_are_rings
  (zariski.structure_presheaf_of_rings_on_basis_of_standard R) x
  (zariski.standard_basis_has_FIP R)
  (zariski.univ_is_basic R)

instance zariski.structure_presheaf_of_types_on_basis_stalk_is_ring (R : Type u) [comm_ring R] (x : X R) :
comm_ring (presheaf_on_basis_stalk (zariski.structure_presheaf_of_types_on_basis_of_standard R) x)
:=
presheaf_of_rings_on_basis_stalk.stalks_of_presheaf_of_rings_on_basis_are_rings
  (zariski.structure_presheaf_of_rings_on_basis_of_standard R) x
  (zariski.standard_basis_has_FIP R)
  (zariski.univ_is_basic R)

instance zariski.structure_sheaf_of_types_sections_has_add
(R : Type u) [comm_ring R] (U : set (X R)) (OU : is_open U) :
has_add ((zariski.structure_presheaf_of_types R).F OU) :=
⟨λ s t,⟨λ x HUx,s.1 x HUx + t.1 x HUx,begin
  intros x HUx,
  cases s.2 x HUx with Us Hs, -- kenny says use rcases
  cases Hs with BUs Hs, -- rcases s.2 x HUx with \<Us, BUs, HxUs, sigmas\>
  cases Hs with HxUs Hs,
  cases Hs with sigmas Hs,
  cases t.2 x HUx with Ut Ht,
  cases Ht with BUt Ht,
  cases Ht with HxUt Ht,
  cases Ht with sigmat Ht,
  let Ust := Us ∩ Ut,
  existsi Ust,
  let BUst := zariski.standard_basis_has_FIP R _ _ BUs BUt,
  existsi BUst,
  existsi (⟨HxUs,HxUt⟩ : x ∈ Us ∩ Ut),
  let sigma :=
  ((zariski.structure_presheaf_of_types_on_basis_of_standard R).res
      BUs BUst (set.inter_subset_left Us Ut) sigmas) +
  ((zariski.structure_presheaf_of_types_on_basis_of_standard R).res
      BUt BUst (set.inter_subset_right Us Ut) sigmat),
  existsi sigma,
  intros y Hy,
  funext HyU,
  have Hsy := Hs y ⟨HyU,Hy.2.1⟩,
  have Hty := Ht y ⟨HyU,Hy.2.2⟩,
  rw [Hsy,Hty],
  apply quotient.sound,
  existsi Ust,
  existsi Hy.2,
  existsi BUst,
  existsi (set.subset.refl _: Ust ⊆ Us ∩ Ut),
  existsi (set.subset.refl _: Ust ⊆ Ust),
  dsimp,
  rw (presheaf_of_rings_on_basis.res_is_ring_morphism
    (zariski.structure_presheaf_of_rings_on_basis_of_standard R)
    _ _ _).map_add,
  rw ←(presheaf_of_rings_on_basis.to_presheaf_of_types_on_basis
        (zariski.structure_presheaf_of_rings_on_basis_of_standard R)).Hcomp',
  rw ←(presheaf_of_rings_on_basis.to_presheaf_of_types_on_basis
        (zariski.structure_presheaf_of_rings_on_basis_of_standard R)).Hcomp',
  rw (presheaf_of_rings_on_basis.res_is_ring_morphism
       (zariski.structure_presheaf_of_rings_on_basis_of_standard R)
        _ _ _).map_add,
  show _ = (zariski.structure_presheaf_of_types_on_basis_of_standard R).res BUst BUst _
        ((zariski.structure_presheaf_of_types_on_basis_of_standard R).res BUs BUst _ sigmas) +
           (zariski.structure_presheaf_of_types_on_basis_of_standard R).res BUst BUst _
        ((zariski.structure_presheaf_of_types_on_basis_of_standard R).res BUt BUst _ sigmat),
  rw ←(zariski.structure_presheaf_of_types_on_basis_of_standard R).Hcomp',
  rw ←(zariski.structure_presheaf_of_types_on_basis_of_standard R).Hcomp',
  refl,
end
⟩⟩

instance zariski.structure_sheaf_of_types_sections_has_zero
(R : Type u) [comm_ring R] (U : set (X R)) (OU : is_open U) :
has_zero ((zariski.structure_presheaf_of_types R).F OU) := ⟨⟨λ x Hx,0,
begin
  intros x Hx,
  existsi (set.univ),
  existsi zariski.univ_is_basic R,
  existsi trivial,
  existsi (0 : (zariski.structure_presheaf_of_types_on_basis_of_standard R).F _),
    tactic.swap,apply_instance, -- shrug
  intros y Hy,
  funext,
  apply quotient.sound,
  refl,
end⟩⟩

instance zariski.structure_sheaf_of_types_sections_has_neg
(R : Type u) [comm_ring R] (U : set (X R)) (OU : is_open U) :
has_neg ((zariski.structure_presheaf_of_types R).F OU) :=
⟨λ s,⟨λ x HUx,-(s.1 x HUx),begin
  intros x HUx,
  rcases (s.2 x HUx) with ⟨Us,BUs,HxUs,sigmas,Hs⟩,
  existsi Us,existsi BUs,existsi HxUs,existsi -sigmas,
  intros y Hy,
  funext,
  rw (Hs y Hy),
  apply quotient.sound,
  refl,
end
⟩⟩

instance zariski.structure_sheaf_of_types_sections_has_mul
(R : Type u) [comm_ring R] (U : set (X R)) (OU : is_open U) :
has_mul ((zariski.structure_presheaf_of_types R).F OU) :=
⟨λ s t,⟨λ x HUx,s.1 x HUx * t.1 x HUx,begin
  intros x HUx,
  rcases (s.2 x HUx) with ⟨Us,BUs,HxUs,sigmas,Hs⟩,
  rcases (t.2 x HUx) with ⟨Ut,BUt,HxUt,sigmat,Ht⟩,
  let Ust := Us ∩ Ut,
  existsi Ust,
  let BUst := zariski.standard_basis_has_FIP R _ _ BUs BUt,
  existsi BUst,
  existsi (⟨HxUs,HxUt⟩ : x ∈ Us ∩ Ut),
  let sigma :=
  ((zariski.structure_presheaf_of_types_on_basis_of_standard R).res
      BUs BUst (set.inter_subset_left Us Ut) sigmas) *
  ((zariski.structure_presheaf_of_types_on_basis_of_standard R).res
      BUt BUst (set.inter_subset_right Us Ut) sigmat),
  existsi sigma,
  intros y Hy,
  funext HyU,
  have Hsy := Hs y ⟨HyU,Hy.2.1⟩,
  have Hty := Ht y ⟨HyU,Hy.2.2⟩,
  rw [Hsy,Hty],
  apply quotient.sound,
  existsi Ust,
  existsi Hy.2,
  existsi BUst,
  existsi (set.subset.refl _: Ust ⊆ Us ∩ Ut),
  existsi (set.subset.refl _: Ust ⊆ Ust),
  dsimp,
  rw (presheaf_of_rings_on_basis.res_is_ring_morphism
    (zariski.structure_presheaf_of_rings_on_basis_of_standard R)
    _ _ _).map_mul,
  rw ←(presheaf_of_rings_on_basis.to_presheaf_of_types_on_basis
        (zariski.structure_presheaf_of_rings_on_basis_of_standard R)).Hcomp',
  rw ←(presheaf_of_rings_on_basis.to_presheaf_of_types_on_basis
        (zariski.structure_presheaf_of_rings_on_basis_of_standard R)).Hcomp',
  rw (presheaf_of_rings_on_basis.res_is_ring_morphism
       (zariski.structure_presheaf_of_rings_on_basis_of_standard R)
        _ _ _).map_mul,
  show _ = (zariski.structure_presheaf_of_types_on_basis_of_standard R).res BUst BUst _
        ((zariski.structure_presheaf_of_types_on_basis_of_standard R).res BUs BUst _ sigmas) *
           (zariski.structure_presheaf_of_types_on_basis_of_standard R).res BUst BUst _
        ((zariski.structure_presheaf_of_types_on_basis_of_standard R).res BUt BUst _ sigmat),
  rw ←(zariski.structure_presheaf_of_types_on_basis_of_standard R).Hcomp',
  rw ←(zariski.structure_presheaf_of_types_on_basis_of_standard R).Hcomp',
  refl,
end
⟩⟩

instance zariski.structure_sheaf_of_types_sections_has_one
(R : Type u) [comm_ring R] (U : set (X R)) (OU : is_open U) :
has_one ((zariski.structure_presheaf_of_types R).F OU) := ⟨⟨λ x Hx,1,
begin
  intros x Hx,
  existsi (set.univ),
  existsi zariski.univ_is_basic R,
  existsi trivial,
  existsi (1 : (zariski.structure_presheaf_of_types_on_basis_of_standard R).F _),
    tactic.swap,apply_instance, -- shrug
  intros y Hy,
  funext,
  apply quotient.sound,
  refl,
end⟩⟩

instance zariski.structure_sheaf_of_types_sections_are_rings (R : Type u) [comm_ring R]
(U : set (X R)) (OU : is_open U) :
comm_ring ((zariski.structure_presheaf_of_types R).F OU) :=
by refine
{ add := has_add.add,
  add_assoc := λ _ _ _, subtype.eq $ by funext;exact add_assoc _ _ _,
  zero := has_zero.zero _,
  zero_add := λ _, subtype.eq $ by funext;exact zero_add _,
  add_zero := λ _, subtype.eq $ by funext;exact add_zero _,
  neg := has_neg.neg,
  add_left_neg := λ _, subtype.eq $ by funext;exact add_left_neg _,
  add_comm := λ _ _, subtype.eq $ by funext;exact add_comm _ _,
  mul := has_mul.mul,
  mul_assoc := λ _ _ _,subtype.eq $ by funext;exact mul_assoc _ _ _,
  one := has_one.one _,
  one_mul := λ _, subtype.eq $ by funext;exact one_mul _,
  mul_one := λ _, subtype.eq $ by funext;exact mul_one _,
  left_distrib := λ _ _ _,subtype.eq $ by funext;exact left_distrib _ _ _,
  right_distrib := λ _ _ _,subtype.eq $ by funext;exact right_distrib _ _ _,
  mul_comm := λ _ _,subtype.eq $ by funext;exact mul_comm _ _ }

definition zariski.structure_presheaf_of_rings (R : Type u) [comm_ring R] :
presheaf_of_rings (X R) := begin refine {
res_is_ring_morphism := _,
..zariski.structure_presheaf_of_types R},
  intros U V OU OV HVU,
  constructor;intros;apply subtype.eq;funext;refl
end

theorem zariski.structure_presheaf_is_sheaf_of_rings (R : Type u) [comm_ring R] :
is_sheaf_of_rings (zariski.structure_presheaf_of_rings R) :=
zariski.structure_sheaf_is_sheaf_of_types R

structure scheme :=
(α : Type u)
(T : topological_space α)
(O_X : presheaf_of_rings α)
(O_X_sheaf : is_sheaf_of_rings O_X)
(locally_affine : ∃ β : Type u,
  ∃ cov : β → set α,
  ∃ cov_open : ∀ b, T.is_open $ cov b,
  (∀ x, ∃ b, x ∈ cov b) ∧
  ∀ b : β, ∃ R : Type u, ∃ RR : comm_ring R, ∃ fR : (X R) → α,
    set.range fR = cov b ∧ -- thanks Johan Commelin!!
    ∃ H : topological_space.open_immersion fR,
    are_isomorphic_presheaves_of_rings
      (presheaf_of_rings_pullback_under_open_immersion O_X fR H)
      (zariski.structure_presheaf_of_rings R)
)

definition scheme_of_affine_scheme (R : Type u) [comm_ring R] : scheme :=
{ α := X R,
  T := by apply_instance,
  O_X := zariski.structure_presheaf_of_rings R,
  O_X_sheaf := zariski.structure_presheaf_is_sheaf_of_rings R,
  locally_affine := begin
    existsi (punit : Type u),
    existsi (λ _, set.univ),
    existsi (λ _, is_open_univ),
    split,
    { intro x,
      existsi punit.star,
      trivial },
    intro _,
    existsi R,
    existsi _,tactic.swap,apply_instance,
    existsi id,
    split,
    { apply set.eq_univ_of_forall,
      intro x, existsi x, refl },
    existsi topological_space.open_immersion_id _,
    constructor,tactic.swap,
    { constructor,tactic.swap,
      { constructor,tactic.swap,
          { intros U HU, -- should I use res again??
            refine (zariski.structure_presheaf_of_rings R).res _ _ _ _ _,
              rwa set.image_id,
              rwa set.image_id,
          },
          intros U V HU HV Hsub,
          refl,
        },
        intros,constructor,
        {refl,
        },
        { intros x y,refl,
        },
        { intros x y,refl
        },
      },
    { existsi _,tactic.swap,
      { constructor,tactic.swap,
        { constructor,tactic.swap,
          { intros U HU, -- should I use res again??
            refine (zariski.structure_presheaf_of_rings R).res _ _ _ _ _,
              rwa set.image_id,
              rwa set.image_id,
          },
          intros U V HU HV Hsub,
          refl,
        },
        intros,constructor,
        {refl,
        },
        { intros x y,refl,
        },
        { intros x y,refl
        }
      },
    constructor,
    {
      unfold is_identity_morphism_of_presheaves_of_types,
      intros,
      funext,
      unfold composition_of_morphisms_of_presheaves_of_types,
      dsimp,
      show (zariski.structure_presheaf_of_types R).res U (id '' U) OU _ _
      ((zariski.structure_presheaf_of_types R).res (id '' U) U _ OU _ x) =
    x,
      rw ←presheaf_of_types.Hcomp',
      simp,
    },
    { unfold is_identity_morphism_of_presheaves_of_types,
      intros,
      funext,
      unfold composition_of_morphisms_of_presheaves_of_types,
      dsimp,
      show (zariski.structure_presheaf_of_types R).res (id '' U) U _ OU _
      ((zariski.structure_presheaf_of_types R).res U (id '' U) OU _ _ x) =
    x,
      rw ←presheaf_of_types.Hcomp',
      simp,
    },
  }
  end
}


constants p q : Prop
axiom Hq : q
theorem th : p → q := λ Hp : p, Hq
check th           -- th : p → q


import geometry.tarski_3
open classical set
namespace Euclidean_plane
variables {point : Type} [Euclidean_plane point]

local attribute [instance, priority 0] prop_decidable

-- Planes and Half-planes

def Bl (a : point) (A : set point) (b : point) : Prop := line A ∧ a ∉ A ∧ b ∉ A ∧ ∃ t, t ∈ A ∧ B a t b

theorem nine1 {a p : point} {A : set point} : line A → a ∈ A → p ∉ A → Bl p A (S a p) :=
λ h h1 h2, ⟨h, h2, (λ h_2, h2 ((seven24 h h1).2 h_2)), a, h1, (seven5 a p).1⟩

theorem nine2 {a b : point} {A : set point} : Bl a A b → a ≠ b :=
begin
intros h h1,
subst h1,
unfold Bl at h,
apply h.2.1,
cases h.2.2.2 with x hx,
suffices : a = x,
  rw this,
  exact hx.1,
exact bet_same hx.2
end

theorem Bl.symm {a b : point} {A : set point} : Bl a A b → Bl b A a :=
begin
unfold Bl,
intro h,
split,
  exact h.1,
split,
  exact h.2.2.1,
split,
  exact h.2.1,
cases h.2.2.2 with t ht,
constructor,
split,
  exact ht.1,
exact ht.2.symm
end

lemma nine3 {a c m r : point} {A : set point} : Bl a A c → m ∈ A → M a m c → r ∈ A →
∀ {b}, sided r a b → Bl b A c :=
begin
unfold Bl,
intros h h1 h2 h3 b hb,
cases hb.2.2,
  have h4 := (seven15 m).1 h_1,
  have h5 := (seven6 h2).symm,
  rw h5 at h4,
  have h6 := seven5 m b,
  cases pasch h6.1 h4 with t ht,
  split,
    exact h.1,
  split,
    intro h_2,
    apply h.2.1,
    exact six27 h.1 h3 h_2 h_1,
  split,
    exact h.2.2.1,
  existsi t,
  split,
    have h_2 := (seven24 h.1 h1).1 h3,
    exact six27 h.1 h1 h_2 ht.1,
  exact ht.2.symm,
cases pasch h_1 h2.1.symm with t ht,
split,
  exact h.1,
split,
  intro h_2,
  apply h.2.1,
  have h_3 := six18 h.1 hb.2.1.symm h3 h_2,
  rw h_3,
  left,
  exact h_1,
split,
  exact h.2.2.1,
existsi t,
split,
  exact six27 h.1 h1 h3 ht.2,
exact ht.1
end

lemma nine4a {a c m r s t : point} {A : set point} (h3 : r ∈ A) (h4 : A ⊥ l a r) (h5 : s ∈ A) (h6 : A ⊥ l c s)
(h2 : Bl a A c) (ht : t ∈ A ∧ B a t c) (h_1 : ¬r = s) (h_2 : distle s c r a) :
M r m s → ∀ {u}, (sided r u a ↔ sided s (S m u) c) :=
begin
unfold Bl at h2,
have g2 := six18 h2.1 (ne.symm h_1) h5 h3,
have g3 : (l s r) ⊥ (l c s),
  rwa g2 at h6,
have g4 : (l s r) ⊥ (l a r),
  rwa g2 at h4,
have g5 : col s r t,
  rw g2 at ht,
  exact ht.1,
cases h_2 with b gb,
cases eight24 g3.symm g4.symm g5 ht.2.symm gb.1 gb.2 with m' hm,
intro h_2,
have h_3 : m' = m,
  exact unique_of_exists_unique (eight22 r s) hm.1.symm h_2,
subst m',
intro u,
have h_3 : sided r a b,
    split,
      exact six13 (eight14e h4).2,
    split,
      intro h_4,
      subst b,
      apply six13 (eight14e h6).2,
      exact id_eqd (two4 gb.2),
    right,
    exact gb.1,
split,
  intro h_4,
  have h_5 := sided.trans h_4 h_3,
  split,
    intro h_6,
    have h_7 := seven5 m u,
    rw h_6 at h_7,
    apply h_4.1,
    exact seven4 h_7.symm hm.1,
  split,
    exact six13 (eight14e h6).2,
  have h_6 := seven6 h_2,
  rw h_6,
  have h_7 := seven6 hm.2.symm,
  rw h_7,
  cases h_5.2.2,
    left,
    exact (seven15 m).1 h,
  right,
  exact (seven15 m).1 h,
intro h_4,
suffices : sided r u b,
  exact sided.trans this h_3.symm,
have h_5 := seven6 h_2,
have h_6 := seven6 hm.2.symm,
rw [h_5, h_6] at h_4,
split,
  intro h_7,
  subst u,
  apply h_4.1,
  refl,
split,
  exact h_3.2.1,
cases h_4.2.2,
  left,
  exact (seven15 m).2 h,
right,
exact (seven15 m).2 h
end

lemma nine4b {a c r s t : point} {A : set point} (h3 : r ∈ A) (h4 : A ⊥ l a r) (h5 : s ∈ A) (h6 : A ⊥ l c s)
(h2 : Bl a A c) (ht : t ∈ A ∧ B a t c) (h_1 : ¬r = s) (h_2 : distle s c r a) :
∀ {u v}, sided r u a → sided s v c → Bl u A v :=
begin
have g2 := six18 h2.1 (ne.symm h_1) h5 h3,
have g3 : (l s r) ⊥ (l c s),
  rwa g2 at h6,
have g4 : (l s r) ⊥ (l a r),
  rwa g2 at h4,
have g5 : col s r t,
  rw g2 at ht,
  exact ht.1,
cases h_2 with b gb,
cases eight24 g3.symm g4.symm g5 ht.2.symm gb.1 gb.2 with m hm,
unfold Bl at h2,
intros u v hu hv,
have h7 := nine4a h3 h4 h5 h6 h2 ht h_1 ⟨b, gb⟩ hm.1.symm,
have h8 := (h7).1 hu,
have h9 := sided.trans h8 hv.symm,
have h10 : u ∉ A,
  intro h_2,
  have h_3 := six18 h2.1 hu.1 h_2 h3,
  apply h2.2.1,
  rw h_3,
  cases hu.2.2 with,
    right, right,
    exact h.symm,
  right, left,
  exact h,
have h11 : m ∈ A,
  rw g2,
  right, left,
  exact hm.1.1.symm,
have h12 : Bl (S m u) A u,
  unfold Bl,
  split,
    exact h2.1,
  split,
    intro h_2,
    apply h10,
    exact (seven24 h2.1 h11).2 h_2,
  split,
    exact h10,
  existsi m,
  split,
    exact h11,
  exact (seven5 m u).1.symm,
apply Bl.symm,
exact nine3 h12 h11 (seven5 m u).symm h5 h9
end

theorem nine4 {a c m r s : point} {A : set point} : Bl a A c → r ∈ A → perp A (l a r) → s ∈ A → perp A (l c s) →
(M r m s → ∀ {u}, (sided r u a ↔ sided s (S m u) c)) ∧ ∀ {u v}, sided r u a → sided s v c → Bl u A v :=
begin
intros h2 h3 h4 h5 h6,
cases h2.2.2.2 with t ht,
cases em (r = s),
  have h_2 : xperp r (l a r) A,
    apply eight14c.2,
    split,
      exact h4.symm,
    split,
      exact (eight14e h4).2,
    split,
      exact h2.1,
    split,
      exact eight14a h4.symm,
    simp,
    exact h3,
  have h_3 : xperp s (l c s) A,
    apply eight14c.2,
    split,
      exact h6.symm,
    split,
      exact (eight14e h6).2,
    split,
      exact h2.1,
    split,
      exact eight14a h6.symm,
    simp,
    exact h5,
  have h_4 := h_2.2.2.2.2 (six17a a r) ht.1,
  have h_5 := h_3.2.2.2.2 (six17a c s) ht.1,
  subst h,
  have h_6 : r = t,
    exact eight6 h_4 h_5 ht.2,
  subst h_6,
  split,
    intros h7 u,
    have h_7 : m = r,
      exact (bet_same h7.1).symm,
    rw h_7,
    have h8 := seven5 r u,
    apply iff.intro,
      intro hu,
      unfold sided,
      split,
        intro h_9,
        apply hu.1,
        exact seven9 (eq.trans h_9 (seven11 r).symm),
      split,
        exact (six13 (eight14e h6).2),
      cases hu.2.2,
        have h7 : B u r c,
          exact three6a h.symm ht.2,
        exact five2 hu.1 h8.1 h7,
      have h7 : B u r c,
        exact three7a h.symm ht.2 (six13 (eight14e h4).2),
      exact five2 hu.1 h8.1 h7,
    intro hu,
    unfold sided,
    split,
      intro h_8,
      apply hu.1,
      simp [h_8],
    split,
      exact (six13 (eight14e h4).2),
    cases hu.2.2,
      have h7 : B (S r u) r a,
        exact three6a h.symm ht.2.symm,
      exact five2 hu.1 h8.1.symm h7,
    have h7 : B (S r u) r a,
      exact three7a h.symm ht.2.symm (six13 (eight14e h6).2),
    exact five2 hu.1 h8.1.symm h7,
  intros u v hu hv,
  unfold Bl,
  split,
    exact h2.1,
  split,
    intro h_6,
    have h_7 := six18 h2.1 hu.1 h_6 ht.1,
    rw h_7 at h2,
    exact h2.2.1 (six4.1 hu).1,
  split,
    intro h_6,
    have h_7 := six18 h2.1 hv.1 h_6 ht.1,
    rw h_7 at h2,
    exact h2.2.2.1 (six4.1 hv).1,
  existsi r,
  split,
    exact ht.1,
  exact six8 hu hv ht.2,
cases five10 s c r a,
  split,
    apply nine4a;
    assumption,
  apply nine4b;
  assumption,
have g2 := six18 h2.1 h h3 h5,
have g3 : (l r s) ⊥ (l c s),
  rwa g2 at h6,
have g4 : (l r s) ⊥ (l a r),
  rwa g2 at h4,
have g5 : col r s t,
  rw g2 at ht,
  exact ht.1,
cases h_1 with b gb,
cases eight24 g4.symm g3.symm g5 ht.2 gb.1 gb.2 with m' hm,
split,
  intro h_2,
  have h_3 := unique_of_exists_unique (eight22 r s) hm.1 h_2,
    subst m',
  intro u,
  suffices : sided r (S m (S m u)) a ↔ sided s (S m u) c,
    simp at this,
    exact this,
  exact (nine4a h5 h6 h3 h4 h2.symm ⟨ht.1, ht.2.symm⟩ (ne.symm h) ⟨b, gb⟩ hm.1.symm).symm,
intros u v hu hv,
apply Bl.symm,
apply nine4b h5 h6 h3 h4 h2.symm ⟨ht.1, ht.2.symm⟩ (ne.symm h) ⟨b, gb⟩ hv hu
end

theorem nine5 {a b c r : point} {A : set point} : Bl a A c → r ∈ A → sided r a b → Bl b A c :=
begin
intros h h1 h2,
have h3 : b ∉ A,
  intro h_1,
  have h_2 := six18 h.1 h2.2.1.symm h1 h_1,
  apply h.2.1,
  rw h_2,
  exact (four11 (six4.1 h2).1).2.2.1,
cases eight17 h.1 h.2.1 with x hx,
cases eight17 h.1 h3 with y hy,
cases eight17 h.1 h.2.2.1 with z hz,
cases eight22 x z with m hm,
dsimp at *,
have h4 := six27 h.1 hx.1.2.2.1 hz.1.2.2.1 hm.1.1,
have h5 : a ≠ x,
  intro h_1,
  apply h.2.1,
  rw h_1,
  exact hx.1.2.2.1,
have h6 : b ≠ y,
  intro h_1,
  apply h3,
  rw h_1,
  exact hy.1.2.2.1,
have h7 : c ≠ z,
  intro h_1,
  apply h.2.2.1,
  rw h_1,
  exact hz.1.2.2.1,
have h8 := nine4 h hx.1.2.2.1 ⟨x, hx.1⟩ hz.1.2.2.1 ⟨z, hz.1⟩,
have h9 := (h8.1 hm.1).1 (six5 h5),
have h10 := h8.2 (six5 h5) h9,
have h11 := nine3 h10 h4 (seven5 m a) h1 h2,
have h12 : (S m a) ≠ z,
  intro h_1,
  apply h5,
  apply unique_of_exists_unique (seven8 m z) h_1,
  exact (seven6 hm.1).symm,
have h13 : l c z = l (S m a) z,
  apply six18 (six14 h7),
      exact h12,
    exact (four11 (six4.1 h9).1).2.2.2.2,
  simp,
have h14 := hz.1,
rw h13 at h14,
have h15 := (nine4 h11 hy.1.2.2.1 ⟨y, hy.1⟩ h14.2.2.1 ⟨z, h14⟩).2 (six5 h6) h9.symm,
exact h15,
exact a
end

theorem nine6 {a b c p q : point} : B a c p → B b q c → ∃ x, B a x b ∧ B p q x :=
begin
intros h h1,
cases em (col p q c),
  cases em (B p q c),
    have h_3 := three6b h_2 h.symm,
    constructor,
    split,
      exact three3 a b,
    exact h_3,
  have h_3 : sided q p c,
    exact six4.2 ⟨h_1, h_2⟩,
  constructor,
  split,
    exact three1 a b,
  exact (six6 h1 h_3.symm).symm,
cases em (b ∈ l p q),
  suffices : b = q,
    constructor,
    split,
      exact three1 a b,
    rw this,
    exact three1 p q,
  by_contradiction h_3,
  apply h_1,
  suffices : c ∈ l p q,
    exact this,
  suffices : l p q = l b q,
    rw this,
    left,
    exact h1,
  exact six18 (six14 (six26 h_1).1) h_3 h_2 (six17b p q),
have h3 : Bl c (l p q) b,
  split,
    exact six14 (six26 h_1).1,
  split,
    exact h_1,
  split,
    exact h_2,
  constructor,
  split,
    exact (six17b p q),
  exact h1.symm,
have h4 : sided p c a,
  split,
    exact (six26 h_1).2.2.symm,
  split,
    intro h_1,
    subst h_1,
    apply (six26 h_1).2.2,
    exact bet_same h,
  left,
  exact h.symm,
have h5 := nine5 h3 (six17a p q) h4,
cases h5.2.2.2 with x hx,
constructor,
split,
  exact hx.2,
cases pasch h.symm hx.2.symm with t ht,
suffices : t = q,
  subst t,
  exact ht.2.symm,
apply six21a (six14 (nine2 h3.symm)) (six14 (six26 h_1).1) _ (or.inr (or.inl ht.1)) _ (or.inr (or.inl h1.symm)) (six17b p q),
  intro h_1,
  exact absurd (six17a b c) (h_1.symm ▸ h_2),
exact (six27 (six14 (six26 h_1).1) (six17a p q) hx.1 ht.2.symm)
end

def side (A : set point) (a b : point) : Prop := ∃ c, Bl a A c ∧ Bl b A c

theorem nine8 {a b c : point} {A : set point} : Bl a A c → (Bl b A c ↔ side A a b) :=
begin
intro h,
split,
  intro h1,
  constructor,
  exact ⟨h, h1⟩,
intro h1,
cases h1 with d hd,
cases hd.1.2.2.2 with x hx,
cases hd.2.2.2.2 with y hy,
cases pasch hx.2 hy.2 with z hz,
cases em (x = y),
  subst y,
  suffices : sided x a b,
    exact nine5 h hx.1 this,
  split,
    intro h_1,
    subst x,
    apply hd.1.2.1,
    exact hx.1,
  split,
    intro h_1,
    subst x,
    apply hd.2.2.1,
    exact hx.1,
  suffices : d ≠ x,
    exact five2 this hx.2.symm hy.2.symm,
  intro h_1,
  subst d,
  apply hd.1.2.2.1,
  exact hx.1,
have h1 : A = l x y,
  exact six18 h.1 h_1 hx.1 hy.1,
have h2 : z ≠ x,
  intro h_1,
  subst h1,
  subst h_1,
  apply hd.1.2.1,
  right, right,
  exact hz.2.symm,
have h3 : z ≠ y,
  intro h_1,
  subst h1,
  subst h_1,
  apply hd.2.2.1,
  left,
  exact hz.1,
have h4 := nine5 h hy.1 (six7 hz.2 h3).symm,
exact nine5 h4 hx.1 (six7 hz.1 h2)
end

theorem nine9 {a b : point} {A : set point} : Bl a A b → ¬side A a b :=
begin
intros h h1,
suffices : Bl b A b,
  apply nine2 this,
  refl,
exact (nine8 h).2 h1
end

theorem nine10 {a : point} {A : set point} : line A → a ∉ A → ∃ b, Bl a A b :=
begin
intros h h1,
rcases h with ⟨p, q, h⟩,
cases three14 a p with b hb,
existsi b,
split,
  rw h.2,
  exact six14 h.1,
split,
  exact h1,
split,
  intro h_1,
  apply h1,
  rw h.2 at *,
  suffices : l p q = l p b,
    rw this,
    right, right,
    exact hb.1,
  exact six18 (six14 h.1) hb.2 (six17a p q) h_1,
existsi p,
split,
  rw h.2,
  simp,
exact hb.1
end

theorem nine10a {a p : point} {A : set point} : line A → a ∈ A → p ∉ A → Bl p A (S a p) :=
λ h h1 h2, ⟨h, h2, λ h_1, h2 ((seven24 h h1).2 h_1), a, h1, (seven5 a p).1⟩

theorem nine11 {p q : point} {A : set point} : side A p q → line A ∧ p ∉ A ∧ q ∉ A :=
begin
intro h,
cases h with x hx,
split,
  exact hx.1.1,
split,
  exact hx.1.2.1,
exact hx.2.2.1
end

theorem nine12 {a b p : point} {A : set point} : line A → p ∈ A → sided p a b → a ∉ A → side A a b :=
λ h h1 h2 h3, let ⟨c, hc⟩ := nine10 h h3 in ⟨c, hc, nine5 hc h1 h2⟩

theorem side.refl {a : point} {A : set point} : line A → a ∉ A → side A a a :=
begin
intros h h1,
cases nine10 h h1 with b hb,
existsi b,
split;
assumption
end

theorem side.refla {a b c : point} : ¬col a b c → side (l a b) c c :=
λ h, side.refl (six14 (six26 h).1) h

theorem side.symm {a b : point} {A : set point} : side A a b → side A b a :=
begin
intro h,
cases h with c hc,
constructor,
exact ⟨hc.2, hc.1⟩
end

theorem side.trans {a b c : point} {A : set point} : side A a b → side A b c → side A a c :=
begin
intros h h1,
cases h with d hd,
constructor,
split,
  exact hd.1,
exact (nine8 hd.2).2 h1
end

def hp (A : set point) (a : point) : set point := {x | side A x a}

theorem nine14 {a b : point} {A : set point} : b ∈ hp A a → hp A a = hp A b :=
begin
intro h,
ext,
split,
  intro h1,
  exact side.trans h1 h.symm,
intro h1,
exact side.trans h1 h
end

theorem nine16 {a p : point} {A : set point} : line A → a ∉ A → p ∈ A → Bl a A (S p a) :=
λ h h1 h2, ⟨h, h1, λ h_1, h1 ((seven24 h h2).2 h_1), p, h2, (seven5 p a).1⟩

theorem nine17 {a b c : point} {A : set point} : side A a b → B a c b → side A c a :=
begin
intros h h1,
cases h with d hd,
cases hd.1.2.2.2 with x hx,
cases hd.2.2.2.2 with y hy,
cases three17 hx.2 hy.2 h1 with t ht,
have h2 : t ∈ A,
  exact six27 hd.1.1 hx.1 hy.1 ht.2,
have h3 : Bl c A d,
  split,
    exact hd.1.1,
  split,
    intro h_1,
    suffices : Bl b A b,
      apply nine2 this,
      refl,
    suffices : Bl a A b,
      apply (nine8 this).2,
      existsi d,
      exact hd,
    split,
      exact hd.1.1,
    split,
      exact hd.1.2.1,
    split,
      exact hd.2.2.1,
    existsi c,
    split,
      exact h_1,
    exact h1,
  split,
    exact hd.1.2.2.1,
  constructor,
  split,
    exact h2,
  exact ht.1,
existsi d,
split,
  exact h3,
exact hd.1
end

theorem nine17a {a b c p : point} {A : set point} : side A p a → side A p c → B a b c → side A p b :=
λ h h1 h2, h.trans (nine17 (h.symm.trans h1) h2).symm

theorem nine18 {a b p : point} {A : set point} : line A → p ∈ A → col a b p →
(Bl a A b ↔ B a p b ∧ a ∉ A ∧ b ∉ A) :=
begin
intros h h1 h2,
split,
  intro h3,
  split,
    cases h3.2.2.2 with q hq,
    suffices : p = q,
      rw this,
      exact hq.2,
    apply six21a h (six14 (nine2 h3)) _ h1 h2 hq.1 (or.inr (or.inl hq.2.symm)),
    intro h_1,
    apply h3.2.1,
    simpa [h_1] using (six17a a b),
  split,
    exact h3.2.1,
  exact h3.2.2.1,
intro h3,
split,
  exact h,
split,
  exact h3.2.1,
split,
  exact h3.2.2,
existsi p,
split,
  exact h1,
exact h3.1
end

theorem nine19 {a b p : point} {A : set point} : line A → p ∈ A → col a b p →
side A a b → sided p a b ∧ a ∉ A :=
begin
intros h h1 h2 h3,
  split,
    apply six4.2,
    split,
      exact (four11 h2).1,
    intro h,
    cases nine17 h3 h with x hx,
    exact hx.1.2.1 h1,
  cases h3 with d hd,
exact hd.1.2.1
end

theorem nine19a {a b c p : point} {A : set point} : side A a b → p ∈ A → sided p b c → side A a c :=
λ h h1 h2, h.trans (nine12 (nine11 h).1 h1 h2 (nine11 h).2.2)

theorem nine15 {a b x y p : point} : ¬col a b p → B a p x → B b p y → side (l a b) x y :=
λ h h1 h2, nine19a (nine12 (six14 (six26 h).1) (six17a a b) (six7 h1 (six26 h).2.2.symm) h).symm (six17b a b) (six7 h2 (six26 h).2.1.symm)

def pl (A : set point) (a : point) : set point := {x | side A x a ∨ x ∈ A ∨ Bl a A x}

def plane (P : set point) : Prop := ∃ p q r, ¬col p q r ∧ P = pl (l p q) r

theorem nine20 {a : point} {A : set point} : line A → a ∉ A → plane (pl A a) :=
begin
intros h h1,
rcases h with ⟨p, q, h⟩,
rw h.2 at *,
repeat {constructor},
exact h1
end

theorem nine21a {a b : point} {A : set point} : b ∈ pl A a → b ∉ A → line A ∧ a ∉ A :=
begin
intros h h1,
cases h,
  cases h with x hx,
  split,
    exact hx.1.1,
  exact hx.2.2.1,
cases h,
  contradiction,
split,
  exact h.1,
exact h.2.1
end

theorem nine21b {a b : point} {A : set point} : b ∈ pl A a → b ∉ A → pl A a = pl A b :=
begin
intros h h1,
ext,
cases h,
  split,
    intro h2,
    cases h2,
      left,
      exact side.trans h2 h.symm,
    cases h2,
      right, left,
      exact h2,
    right, right,
    exact (nine8 h2).2 h.symm,
  intro h2,
  cases h2,
    left,
    exact side.trans h2 h,
  cases h2,
    right, left,
    exact h2,
  right, right,
  exact (nine8 h2).2 h,
cases h,
  contradiction,
split,
  intro h2,
  cases h2,
    right, right,
    exact ((nine8 h).2 h2.symm).symm,
  cases h2,
    right, left,
    exact h2,
  left,
  existsi a,
  split,
    exact h2.symm,
  exact h.symm,
intro h2,
cases h2,
  right, right,
  exact ((nine8 h.symm).2 h2.symm).symm,
cases h2,
  right, left,
  exact h2,
left,
existsi b,
split,
  exact h2.symm,
exact h
end

theorem nine22 {a x : point} {A A' : set point} : is x A A' → a ∈ A' → a ≠ x → A' ⊆ pl A a :=
begin
intros h h1 h2,
intros p hp,
have h3 : a ∉ A,
  intro h_1,
  apply h.2.2.1,
  exact six21 h2 h.1 h.2.1 h_1 h1 h.2.2.2.1 h.2.2.2.2,
have h4 : A' = l a x,
  exact six18 h.2.1 h2 h1 h.2.2.2.2,
cases em (p = x),
  rw h_1,
  right, left,
  exact h.2.2.2.1,
have h5 : p ∉ A,
  intro h_2,
  apply h.2.2.1,
  exact six21 h_1 h.1 h.2.1 h_2 hp h.2.2.2.1 h.2.2.2.2,
rw h4 at hp,
have h6 : col a x p,
  exact hp,
cases hp,
  right, right,
  split,
    exact h.1,
  split,
    exact h3,
  split,
    exact h5,
  existsi x,
  split,
    exact h.2.2.2.1,
  exact hp,
left,
apply nine12 h.1 h.2.2.2.1 _ h5,
split,
  exact h_1,
split,
  exact h2,
cases hp,
  left,
  exact hp,
right,
exact hp.symm
end

def planeof (p q s : point) : set point := pl (l p q) s

theorem nine23 (a b c p : point) : a ≠ c → ¬col a b p → col a c p → planeof a b c = planeof a b p :=
begin
intros h_1 h h1,
unfold planeof,
apply nine21b,
  suffices : l a c ⊆ pl (l a b) c,
    exact this h1,
  apply nine22,
    split,
      exact (six14 (six26 h).1),
    split,
      exact six14 h_1,
    split,
      intro h_2,
      apply h,
      suffices : p ∈ l a c,
        rw ←h_2 at this,
        exact this,
      exact h1,
    split,
      exact (six17a a b),
    simp,
    simp,
  exact h_1.symm,
exact h
end

theorem nine24b {a b c x : point} : ¬col a b c → side (l a b) x c → x ∈ planeof a c b :=
begin
intros h hx,
have h1 := seven5 a c,
have h2 := seven5 a b,
have h3 : Bl c (l a b) (S a c),
  split,
    exact six14 (six26 h).1,
  split,
    exact h,
  split,
    intro h_1,
    apply h,
    exact (seven24 (six14 (six26 h).1) (six17a a b)).2 h_1,
  constructor,
  split,
    exact (six17a a b),
  exact h1.1,
have h4 : Bl b (l a c) (S a b),
  split,
    exact six14 (six26 h).2.2,
  split,
    exact (four10 h).1,
  split,
    intro h_1,
    apply (four10 h).1,
    exact (seven24 (six14 (six26 h).2.2) (six17a a c)).2 h_1,
  constructor,
  split,
    exact (six17a a c),
  exact h2.1,
have h5 : l a c = l a (S a c),
  apply six18 (six14 (six26 h).2.2),
    exact (seven12a (six26 h).2.2.symm).symm,
    simp,
  right, right,
  exact h1.1.symm,
unfold planeof,
have h6 := (nine8 h3).2 hx.symm,
cases h6.2.2.2 with t ht,
cases em (t = a),
  subst t,
  right, left,
  rw h5,
  right, right,
  exact ht.2,
have h7 : sided (S a c) t x,
  split,
    intro h_2,
    apply h3.2.2.1,
    rw ←h_2,
    exact ht.1,
  split,
    intro h_2,
    suffices : t = S a c,
      apply h3.2.2.1,
      rw ←this,
      exact ht.1,
    subst x,
    exact (bet_same ht.2).symm,
  left,
  exact ht.2.symm,
cases ht.1,
  left,
  have h_3 : B t a (S a b),
    exact three7a h_2.symm h2.1 (six26 h).1.symm,
  apply side.symm,
  suffices : Bl t (l a c) (S a b),
    have h8 : side (l a c) b t,
      constructor,
      split,
        exact h4,
      exact this,
    apply side.trans h8,
    apply (nine8 this).1,
    apply nine5 this,
      right, right,
      exact h1.1.symm,
    exact h7,
  split,
    exact six14 (six26 h).2.2,
  split,
    intro h_4,
    suffices : l a b = l a c,
      have h_5 : c ∈ l a b,
        rw this,
        simp,
      exact h h_5,
    exact six21 h_1 (six14 (six26 h).1) (six14 (six26 h).2.2) ht.1 h_4 (six17a a b) (six17a a c),
  split,
    intro h_4,
    apply (four10 h).1,
    exact (seven24 (six14 (six26 h).2.2) (six17a a c)).2 h_4,
  constructor,
  split,
    exact (six17a a c),
  exact h_3,
cases h_2,
  left,
  have h_3 : B t a (S a b),
    exact three6a h_2 h2.1,
  apply side.symm,
  suffices : Bl t (l a c) (S a b),
    have h8 : side (l a c) b t,
      constructor,
      split,
        exact h4,
      exact this,
    apply side.trans h8,
    apply (nine8 this).1,
    apply nine5 this,
      right, right,
      exact h1.1.symm,
    exact h7,
  split,
    exact six14 (six26 h).2.2,
  split,
    intro h_4,
    suffices : l a b = l a c,
      have h_5 : c ∈ l a b,
        rw this,
        simp,
      exact h h_5,
    exact six21 h_1 (six14 (six26 h).1) (six14 (six26 h).2.2) ht.1 h_4 (six17a a b) (six17a a c),
  split,
    intro h_4,
    apply (four10 h).1,
    exact (seven24 (six14 (six26 h).2.2) (six17a a c)).2 h_4,
  constructor,
  split,
    exact (six17a a c),
  exact h_3,
right, right,
apply Bl.symm,
apply nine5 _,
  exact (seven24 (six14 (six26 h).2.2) (six17a a c)).1 (six17b a c),
  exact h7,
split,
  exact six14 (six26 h).2.2,
split,
  intro h_3,
  suffices : l a b = l a c,
    have h_5 : c ∈ l a b,
      rw this,
      simp,
    exact h h_5,
  exact six21 h_1 (six14 (six26 h).1) (six14 (six26 h).2.2) ht.1 h_3 (six17a a b) (six17a a c),
split,
  intro h_3,
  exact (four10 h).1 h_3,
constructor,
split,
  exact (six17a a c),
exact h_2
end

theorem nine24c {a b c : point} : ¬col a b c → planeof a b c ⊆ planeof a c b :=
begin
intro h,
intros x hx,
cases hx,
  exact nine24b h hx,
cases hx,
  have h1 : l a b ⊆ planeof a c b,
    unfold planeof,
    apply nine22 (six28 (four10 h).1) (six17b a b) (six26 h).1.symm,
  exact h1 hx,
unfold planeof,
have h1 := seven5 a c,
have h2 : l a c = l a (S a c),
  apply six18 (six14 (six26 h).2.2),
    exact (seven12a (six26 h).2.2.symm).symm,
    simp,
  right, right,
  exact h1.1.symm,
rw h2,
have h3 : ¬col a b (S a c),
  intro h_1,
  apply h,
  exact (seven24 (six14 (six26 h).1) (six17a a b)).2 h_1,
have h4 : side (l a b) x (S a c),
  apply (nine8 hx.symm).1,
  split,
    exact (six14 (six26 h).1),
  split,
    exact h3,
  split,
    exact h,
  constructor,
  split,
    exact (six17a a b),
  exact h1.1.symm,
exact nine24b h3 h4
end

theorem nine24d {a b c : point} : ¬col a b c → planeof a b c = planeof a c b :=
begin
intro h,
ext,
split,
  intro h1,
  exact nine24c h h1,
intro h1,
exact nine24c (four10 h).1 h1
end

theorem nine24e (a b c : point) : planeof a b c = planeof b a c :=
begin
unfold planeof,
suffices : l a b = l b a,
  rwa this,
ext,
split,
  intro h,
  exact (four11 h).2.1,
intro h,
exact (four11 h).2.1
end

theorem nine24 {a b c : point} : ¬col a b c → planeof a b c = planeof a c b ∧ planeof a b c = planeof b a c
∧ planeof a b c = planeof b c a ∧ planeof a b c = planeof c a b ∧ planeof a b c = planeof c b a :=
begin
intro h,
repeat {split};
simp [nine24d h, nine24e];
exact eq.trans (nine24e a c b) (eq.trans (nine24d (four10 h).2.2.2.1) (nine24e c b a))
end

theorem nine24a {a b c : point} : ¬col a b c → l a b ⊆ planeof a b c ∧ l b c ⊆ planeof a b c ∧ l a c ⊆ planeof a b c :=
begin
intro h,
split,
  intros x hx,
  right, left,
  assumption,
split,
  rw (nine24 h).2.2.1,
  intros x hx,
  right, left,
  assumption,
rw (nine24 h).1,
intros x hx,
right, left,
assumption
end

lemma nine25a {a b p q r : point} (h : ¬col p q r) (h1 : a ∈ pl (l p q) r) (h2 : b ∈ pl (l p q) r) (h3 : a ≠ b)
(h_2 : b ∉ l p q) : l a b ⊆ pl (l p q) r ∧ ∃ c, pl (l p q) r = planeof a b c :=
begin
have h4 : p ≠ b,
  exact (six18a h_2).1.symm,
have h5 : pl (l p q) r = pl (l p q) b,
  exact nine21b h2 h_2,
rw h5,
have h6 : planeof p q b = planeof p b q,
    exact (nine24 h_2).1,
unfold planeof at h6,
rw h6,
cases em (a ∈ l p b) with h_3 h_3,
  have h7 : l p b = l a b,
        exact six18 (six14 h4) h3 h_3 (six17b p b) ,
  rw h7,
  have h8 : q ∉ l a b,
    intro h_4,
    rw ←h7 at h_4,
    exact h_2 (four11 h_4).1,
  split,
    exact (nine24a h8).1,
  existsi q,
  unfold planeof,
rw (eq.trans h5 h6) at h1,
have h7 : pl (l p b) q = pl (l p b) a,
  exact nine21b h1 h_3,
rw h7,
have h8 : planeof p b a = planeof a b p,
  exact (nine24 h_3).2.2.2.2,
unfold planeof at h8,
rw h8,
split,
  exact (nine24a (four10 h_3).2.2.2.2).1,
existsi p,
unfold planeof
end

theorem nine25 {a b : point} {P : set point} : plane P → a ∈ P → b ∈ P → a ≠ b → l a b ⊆ P ∧ ∃ c, P = planeof a b c :=
begin
intros h h1 h2 h3,
unfold plane at h,
rcases h with ⟨p, q, r, h⟩,
rw h.2 at *,
cases em (a ∈ l p q),
  cases em (b ∈ l p q),
    have h4 : l p q = l a b,
      exact six18 (six14 (six26 h.1).1) h3 h_1 h_2,
    split,
      rw ←h4,
      exact (nine24a h.1).1,
    existsi r,
    rw h4,
    unfold planeof,
  exact nine25a h.1 h1 h2 h3 h_2,
rw six17 a b,
split,
  exact (nine25a h.1 h2 h1 h3.symm h_1).1,
cases (nine25a h.1 h2 h1 h3.symm h_1).2 with c hc,
existsi c,
rw nine24e a b c,
exact hc
end

theorem nine26 {a b c : point} {P : set point} : ¬col a b c → plane P → a ∈ P → b ∈ P → c ∈ P → P = planeof a b c :=
begin
intros h h1 h2 h3 h4,
cases (nine25 h1 h2 h3 (six26 h).1).2 with c' hc',
subst P,
exact nine21b h4 h
end

theorem nine27 (a b c : point) : a ∈ planeof a b c ∧ b ∈ planeof a b c ∧ c ∈ planeof a b c :=
begin
split,
  right, left,
  simp,
split,
  right, left,
  simp,
by_cases h : a = b,
  subst b,
  right, left, left,
  exact three3 a c,
by_cases h1 : c ∈ l a b,
  right, left,
  exact h1,
left,
exact side.refl (six14 h) h1
end

theorem nine28 {p : point} {A : set point} : line A → plane (pl A p) → p ∉ A :=
begin
intros h h1 h2,
rcases h1 with ⟨x, y, z, h1⟩,
apply h1.1,
suffices : pl A p = A,
  rw this at h1,
  have h3 := nine27 x y z,
  rw [planeof, h1.2.symm] at h3,
  exact six23.2 ⟨A, h, h3⟩,
ext t,
split,
  intro h3,
  cases h3,
    exfalso,
    exact (nine11 h3).2.2 h2,
  cases h3,
    exact h3,
  exfalso,
  exact h3.2.1 h2,
intro h3,
right, left,
exact h3
end

theorem nine31 {p q r s : point} : side (l p q) s r → side (l p r) s q → Bl q (l p s) r :=
begin
intros h h1,
have h2 : ¬col p q r,
  cases h with x hx,
  exact hx.2.2.1,
have h3 := seven5 p r,
have h4 : Bl r (l p q) (S p r),
  split,
    exact (nine11 h).1,
  split,
    exact h2,
  split,
    intro h_1,
    apply h2,
    exact (seven24 (nine11 h).1 (six17a p q)).2 h_1,
  constructor,
  split,
    exact (six17a p q),
  exact h3.1,
have h5 : Bl (S p r) (l p q) s,
  exact ((nine8 h4).2 h.symm).symm,
cases h5.2.2.2 with t ht,
have h6 : sided (S p r) t s,
  apply six7 ht.2,
  intro h_1,
  subst t,
  exact h4.2.2.1 ht.1,
have h7 : side (l p r) t s,
  apply nine12 (nine11 h1).1 ((seven24 (nine11 h1).1 (six17a p r)).1 (six17b p r)) h6,
    intro h_1,
    suffices : (S p r) ≠ t,
      apply (nine11 h1).2.1,
      suffices : l p r = l (S p r) t,
        rw this,
        left,
        exact ht.2,
      apply six18 (six14 (six26 h2).2.2) this,
        right, right,
        exact h3.1.symm,
      exact h_1,
    intro h_2,
    subst t,
    apply h4.2.2.1,
    exact ht.1,
have h8 : sided p t q,
  apply (nine19 (six14 (six26 h2).2.2) (six17a p r) _ _).1,
    exact (four11 ht.1).2.2.2.2,
  exact side.trans h7 h1,
have h9 : p ≠ s,
  intro h_1,
  subst s,
  apply (nine11 h).2.1,
  simp,
have h10 : side (l p s) t q,
  apply nine12 (six14 h9) (six17a p s) h8 _,
  intro h_1,
  apply (nine11 h).2.1,
  suffices : l p q = l p s,
    rw this,
    simp,
  exact six21 h8.1 (nine11 h).1 (six14 h9) ht.1 h_1 (six17a p q) (six17a p s),
have h11 : Bl r (l p s) (S p r),
  split,
    exact six14 h9,
  split,
    exact (four10 (nine11 h1).2.1).1,
  split,
    intro h_1,
    apply (four10 (nine11 h1).2.1).1,
    exact (seven24 (six14 h9) (six17a p s)).2 h_1,
  existsi p,
  split,
    simp,
  exact h3.1,
apply (nine8 h11.symm).2 (side.trans _ h10),
apply (nine12 (six14 h9) (six17b p s) (six7 ht.2.symm _) (nine11 h10).2.1).symm,
intro h_1,
subst t,
exact (nine11 h10).2.1 (six17b p s)
end

end Euclidean_plane


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura, Jeremy Avigad
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.logic

universes u

namespace Mathlib

namespace subtype

def exists_of_subtype {α : Type u} {p : α → Prop} : (Subtype fun (x : α) => p x) → ∃ (x : α), p x :=
  sorry

theorem tag_irrelevant {α : Type u} {p : α → Prop} {a : α} (h1 : p a) (h2 : p a) : { val := a, property := h1 } = { val := a, property := h2 } :=
  rfl

protected theorem eq {α : Type u} {p : α → Prop} {a1 : Subtype fun (x : α) => p x} {a2 : Subtype fun (x : α) => p x} : val a1 = val a2 → a1 = a2 := sorry

theorem ne_of_val_ne {α : Type u} {p : α → Prop} {a1 : Subtype fun (x : α) => p x} {a2 : Subtype fun (x : α) => p x} : val a1 ≠ val a2 → a1 ≠ a2 :=
  mt (congr_arg fun {a1 : Subtype fun (x : α) => p x} => val a1)

@[simp] theorem eta {α : Type u} {p : α → Prop} (a : Subtype fun (x : α) => p x) (h : p (val a)) : { val := val a, property := h } = a :=
  subtype.eq rfl

end subtype

protected instance subtype.inhabited {α : Type u} {p : α → Prop} {a : α} (h : p a) : Inhabited (Subtype fun (x : α) => p x) :=
  { default := { val := a, property := h } }


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.PostPort

universes u v w z

namespace Mathlib

namespace list

/- forall₂ -/

theorem forall₂_iff {α : Type u} {β : Type v} (R : α → β → Prop) : ∀ (ᾰ : List α) (ᾰ_1 : List β),
  forall₂ R ᾰ ᾰ_1 ↔
    ᾰ = [] ∧ ᾰ_1 = [] ∨
      Exists
        fun {a : α} =>
          Exists
            fun {b : β} =>
              Exists
                fun {l₁ : List α} => Exists fun {l₂ : List β} => R a b ∧ forall₂ R l₁ l₂ ∧ ᾰ = a :: l₁ ∧ ᾰ_1 = b :: l₂ := sorry

@[simp] theorem forall₂_cons {α : Type u} {β : Type v} {R : α → β → Prop} {a : α} {b : β} {l₁ : List α} {l₂ : List β} : forall₂ R (a :: l₁) (b :: l₂) ↔ R a b ∧ forall₂ R l₁ l₂ := sorry

theorem forall₂.imp {α : Type u} {β : Type v} {R : α → β → Prop} {S : α → β → Prop} (H : ∀ (a : α) (b : β), R a b → S a b) {l₁ : List α} {l₂ : List β} (h : forall₂ R l₁ l₂) : forall₂ S l₁ l₂ := sorry

theorem forall₂.mp {α : Type u} {β : Type v} {r : α → β → Prop} {q : α → β → Prop} {s : α → β → Prop} (h : ∀ (a : α) (b : β), r a b → q a b → s a b) {l₁ : List α} {l₂ : List β} : forall₂ r l₁ l₂ → forall₂ q l₁ l₂ → forall₂ s l₁ l₂ := sorry

theorem forall₂.flip {α : Type u} {β : Type v} {r : α → β → Prop} {a : List α} {b : List β} : forall₂ (flip r) b a → forall₂ r a b := sorry

theorem forall₂_same {α : Type u} {r : α → α → Prop} {l : List α} : (∀ (x : α), x ∈ l → r x x) → forall₂ r l l := sorry

theorem forall₂_refl {α : Type u} {r : α → α → Prop} [is_refl α r] (l : List α) : forall₂ r l l :=
  forall₂_same fun (a : α) (h : a ∈ l) => is_refl.refl a

theorem forall₂_eq_eq_eq {α : Type u} : forall₂ Eq = Eq := sorry

@[simp] theorem forall₂_nil_left_iff {α : Type u} {β : Type v} {r : α → β → Prop} {l : List β} : forall₂ r [] l ↔ l = [] := sorry

@[simp] theorem forall₂_nil_right_iff {α : Type u} {β : Type v} {r : α → β → Prop} {l : List α} : forall₂ r l [] ↔ l = [] := sorry

theorem forall₂_cons_left_iff {α : Type u} {β : Type v} {r : α → β → Prop} {a : α} {l : List α} {u : List β} : forall₂ r (a :: l) u ↔ ∃ (b : β), ∃ (u' : List β), r a b ∧ forall₂ r l u' ∧ u = b :: u' := sorry

theorem forall₂_cons_right_iff {α : Type u} {β : Type v} {r : α → β → Prop} {b : β} {l : List β} {u : List α} : forall₂ r u (b :: l) ↔ ∃ (a : α), ∃ (u' : List α), r a b ∧ forall₂ r u' l ∧ u = a :: u' := sorry

theorem forall₂_and_left {α : Type u} {β : Type v} {r : α → β → Prop} {p : α → Prop} (l : List α) (u : List β) : forall₂ (fun (a : α) (b : β) => p a ∧ r a b) l u ↔ (∀ (a : α), a ∈ l → p a) ∧ forall₂ r l u := sorry

@[simp] theorem forall₂_map_left_iff {α : Type u} {β : Type v} {γ : Type w} {r : α → β → Prop} {f : γ → α} {l : List γ} {u : List β} : forall₂ r (map f l) u ↔ forall₂ (fun (c : γ) (b : β) => r (f c) b) l u := sorry

@[simp] theorem forall₂_map_right_iff {α : Type u} {β : Type v} {γ : Type w} {r : α → β → Prop} {f : γ → β} {l : List α} {u : List γ} : forall₂ r l (map f u) ↔ forall₂ (fun (a : α) (c : γ) => r a (f c)) l u := sorry

theorem left_unique_forall₂ {α : Type u} {β : Type v} {r : α → β → Prop} (hr : relator.left_unique r) : relator.left_unique (forall₂ r) := sorry

theorem right_unique_forall₂ {α : Type u} {β : Type v} {r : α → β → Prop} (hr : relator.right_unique r) : relator.right_unique (forall₂ r) := sorry

theorem bi_unique_forall₂ {α : Type u} {β : Type v} {r : α → β → Prop} (hr : relator.bi_unique r) : relator.bi_unique (forall₂ r) :=
  { left := fun (a : List α) (b : List β) (c : List α) => left_unique_forall₂ (and.left hr),
    right := fun (a : List α) (b c : List β) => right_unique_forall₂ (and.right hr) }

theorem forall₂_length_eq {α : Type u} {β : Type v} {R : α → β → Prop} {l₁ : List α} {l₂ : List β} : forall₂ R l₁ l₂ → length l₁ = length l₂ := sorry

theorem forall₂_zip {α : Type u} {β : Type v} {R : α → β → Prop} {l₁ : List α} {l₂ : List β} : forall₂ R l₁ l₂ → ∀ {a : α} {b : β}, (a, b) ∈ zip l₁ l₂ → R a b := sorry

theorem forall₂_iff_zip {α : Type u} {β : Type v} {R : α → β → Prop} {l₁ : List α} {l₂ : List β} : forall₂ R l₁ l₂ ↔ length l₁ = length l₂ ∧ ∀ {a : α} {b : β}, (a, b) ∈ zip l₁ l₂ → R a b := sorry

theorem forall₂_take {α : Type u} {β : Type v} {R : α → β → Prop} (n : ℕ) {l₁ : List α} {l₂ : List β} : forall₂ R l₁ l₂ → forall₂ R (take n l₁) (take n l₂) := sorry

theorem forall₂_drop {α : Type u} {β : Type v} {R : α → β → Prop} (n : ℕ) {l₁ : List α} {l₂ : List β} : forall₂ R l₁ l₂ → forall₂ R (drop n l₁) (drop n l₂) := sorry

theorem forall₂_take_append {α : Type u} {β : Type v} {R : α → β → Prop} (l : List α) (l₁ : List β) (l₂ : List β) (h : forall₂ R l (l₁ ++ l₂)) : forall₂ R (take (length l₁) l) l₁ :=
  (fun (h' : forall₂ R (take (length l₁) l) (take (length l₁) (l₁ ++ l₂))) =>
      eq.mp (Eq._oldrec (Eq.refl (forall₂ R (take (length l₁) l) (take (length l₁) (l₁ ++ l₂)))) (take_left l₁ l₂)) h')
    (forall₂_take (length l₁) h)

theorem forall₂_drop_append {α : Type u} {β : Type v} {R : α → β → Prop} (l : List α) (l₁ : List β) (l₂ : List β) (h : forall₂ R l (l₁ ++ l₂)) : forall₂ R (drop (length l₁) l) l₂ :=
  (fun (h' : forall₂ R (drop (length l₁) l) (drop (length l₁) (l₁ ++ l₂))) =>
      eq.mp (Eq._oldrec (Eq.refl (forall₂ R (drop (length l₁) l) (drop (length l₁) (l₁ ++ l₂)))) (drop_left l₁ l₂)) h')
    (forall₂_drop (length l₁) h)

theorem rel_mem {α : Type u} {β : Type v} {r : α → β → Prop} (hr : relator.bi_unique r) : relator.lift_fun r (forall₂ r ⇒ Iff) has_mem.mem has_mem.mem := sorry

theorem rel_map {α : Type u} {β : Type v} {γ : Type w} {δ : Type z} {r : α → β → Prop} {p : γ → δ → Prop} : relator.lift_fun (r ⇒ p) (forall₂ r ⇒ forall₂ p) map map := sorry

theorem rel_append {α : Type u} {β : Type v} {r : α → β → Prop} : relator.lift_fun (forall₂ r) (forall₂ r ⇒ forall₂ r) append append := sorry

theorem rel_join {α : Type u} {β : Type v} {r : α → β → Prop} : relator.lift_fun (forall₂ (forall₂ r)) (forall₂ r) join join := sorry

theorem rel_bind {α : Type u} {β : Type v} {γ : Type w} {δ : Type z} {r : α → β → Prop} {p : γ → δ → Prop} : relator.lift_fun (forall₂ r) ((r ⇒ forall₂ p) ⇒ forall₂ p) list.bind list.bind :=
  fun (a : List α) (b : List β) (h₁ : forall₂ r a b) (f : α → List γ) (g : β → List δ)
    (h₂ : relator.lift_fun r (forall₂ p) f g) => rel_join (rel_map h₂ h₁)

theorem rel_foldl {α : Type u} {β : Type v} {γ : Type w} {δ : Type z} {r : α → β → Prop} {p : γ → δ → Prop} : relator.lift_fun (p ⇒ r ⇒ p) (p ⇒ forall₂ r ⇒ p) foldl foldl := sorry

theorem rel_foldr {α : Type u} {β : Type v} {γ : Type w} {δ : Type z} {r : α → β → Prop} {p : γ → δ → Prop} : relator.lift_fun (r ⇒ p ⇒ p) (p ⇒ forall₂ r ⇒ p) foldr foldr := sorry

theorem rel_filter {α : Type u} {β : Type v} {r : α → β → Prop} {p : α → Prop} {q : β → Prop} [decidable_pred p] [decidable_pred q] (hpq : relator.lift_fun r Iff p q) : relator.lift_fun (forall₂ r) (forall₂ r) (filter p) (filter q) := sorry

theorem filter_map_cons {α : Type u} {β : Type v} (f : α → Option β) (a : α) (l : List α) : filter_map f (a :: l) = option.cases_on (f a) (filter_map f l) fun (b : β) => b :: filter_map f l := sorry

theorem rel_filter_map {α : Type u} {β : Type v} {γ : Type w} {δ : Type z} {r : α → β → Prop} {p : γ → δ → Prop} : relator.lift_fun (r ⇒ option.rel p) (forall₂ r ⇒ forall₂ p) filter_map filter_map := sorry

theorem rel_sum {α : Type u} {β : Type v} {r : α → β → Prop} [add_monoid α] [add_monoid β] (h : r 0 0) (hf : relator.lift_fun r (r ⇒ r) Add.add Add.add) : relator.lift_fun (forall₂ r) r sum sum :=
  rel_foldl hf h


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.limits.shapes.biproducts
import category_theory.limits.preserves.shapes.zero

/-!
# Preservation of biproducts

We define the image of a (binary) bicone under a functor that preserves zero morphisms and define
classes `preserves_biproduct` and `preserves_binary_biproduct`. We then

* show that a functor that preserves biproducts of a two-element type preserves binary biproducts,
* give the canonical isomorphism between the image of a biproduct and the biproduct of the images,
* show that in a preadditive category, a functor preserves a biproduct if and only if it preserves
  the corresponding product if and only if it preserves the corresponding coproduct.

-/

universes v u u₂

noncomputable theory

open category_theory
open category_theory.limits

namespace category_theory

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

section has_zero_morphisms
variables [has_zero_morphisms C] [has_zero_morphisms D]

namespace functor

section map
variables (F : C ⥤ D) [preserves_zero_morphisms F]

section bicone
variables {J : Type v} [decidable_eq J]

/-- The image of a bicone under a functor. -/
@[simps]
def map_bicone {f : J → C} (b : bicone f) : bicone (F.obj ∘ f) :=
{ X := F.obj b.X,
  π := λ j, F.map (b.π j),
  ι := λ j, F.map (b.ι j),
  ι_π := λ j j',
  begin
    rw ← F.map_comp,
    split_ifs,
    { subst h,
      simp only [bicone_ι_π_self, category_theory.functor.map_id, eq_to_hom_refl] },
    { rw [bicone_ι_π_ne _ h, F.map_zero] }
  end }

end bicone

/-- The image of a binary bicone under a functor. -/
@[simps]
def map_binary_bicone {X Y : C} (b : binary_bicone X Y) : binary_bicone (F.obj X) (F.obj Y) :=
{ X := F.obj b.X,
  fst := F.map b.fst,
  snd := F.map b.snd,
  inl := F.map b.inl,
  inr := F.map b.inr,
  inl_fst' := by rw [← F.map_comp, b.inl_fst, F.map_id],
  inl_snd' := by rw [← F.map_comp, b.inl_snd, F.map_zero],
  inr_fst' := by rw [← F.map_comp, b.inr_fst, F.map_zero],
  inr_snd' := by rw [← F.map_comp, b.inr_snd, F.map_id] }

end map

end functor

open category_theory.functor

namespace limits

section bicone
variables {J : Type v} [decidable_eq J]

/-- A functor `F` preserves biproducts of `f` if `F` maps every bilimit bicone over `f` to a
    bilimit bicone over `F.obj ∘ f`. -/
class preserves_biproduct (f : J → C) (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {b : bicone f}, b.is_bilimit → (F.map_bicone b).is_bilimit)

/-- A functor `F` preserves biproducts of `f` if `F` maps every bilimit bicone over `f` to a
    bilimit bicone over `F.obj ∘ f`. -/
def is_bilimit_of_preserves {f : J → C} (F : C ⥤ D) [preserves_zero_morphisms F]
  [preserves_biproduct f F] {b : bicone f} (hb : b.is_bilimit) : (F.map_bicone b).is_bilimit :=
preserves_biproduct.preserves hb

variables (J)

/-- A functor `F` preserves biproducts of shape `J` if it preserves biproducts of `f` for every
    `f : J → C`. -/
class preserves_biproducts_of_shape (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {f : J → C}, preserves_biproduct f F)

attribute [instance, priority 100] preserves_biproducts_of_shape.preserves

end bicone

/-- A functor `F` preserves finite biproducts if it preserves biproducts of shape `J` whenever
    `J` is a fintype. -/
class preserves_finite_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {J : Type v} [decidable_eq J] [fintype J], preserves_biproducts_of_shape J F)

attribute [instance, priority 100] preserves_finite_biproducts.preserves

/-- A functor `F` preserves biproducts if it preserves biproducts of any (small) shape `J`. -/
class preserves_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {J : Type v} [decidable_eq J], preserves_biproducts_of_shape J F)

attribute [instance, priority 100] preserves_biproducts.preserves

@[priority 100]
instance preserves_finite_biproducts_of_preserves_biproducts (F : C ⥤ D)
  [preserves_zero_morphisms F] [preserves_biproducts F] : preserves_finite_biproducts F :=
{ preserves := λ J _ _, infer_instance }

/-- A functor `F` preserves binary biproducts of `X` and `Y` if `F` maps every bilimit bicone over
    `X` and `Y` to a bilimit bicone over `F.obj X` and `F.obj Y`. -/
class preserves_binary_biproduct (X Y : C) (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {b : binary_bicone X Y}, b.is_bilimit → (F.map_binary_bicone b).is_bilimit)

/-- A functor `F` preserves binary biproducts of `X` and `Y` if `F` maps every bilimit bicone over
    `X` and `Y` to a bilimit bicone over `F.obj X` and `F.obj Y`. -/
def is_binary_bilimit_of_preserves {X Y : C} (F : C ⥤ D) [preserves_zero_morphisms F]
  [preserves_binary_biproduct X Y F] {b : binary_bicone X Y} (hb : b.is_bilimit) :
  (F.map_binary_bicone b).is_bilimit :=
preserves_binary_biproduct.preserves hb

/-- A functor `F` preserves binary biproducts if it preserves the binary biproduct of `X` and `Y`
    for all `X` and `Y`. -/
class preserves_binary_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {X Y : C}, preserves_binary_biproduct X Y F . tactic.apply_instance)

/-- A functor that preserves biproducts of a pair preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_biproduct (F : C ⥤ D) [preserves_zero_morphisms F]
  (X Y : C) [preserves_biproduct (pair X Y).obj F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb,
  { is_limit := is_limit.of_iso_limit
      ((is_limit.postcompose_hom_equiv (by exact diagram_iso_pair _) _).symm
        ((is_bilimit_of_preserves F (b.to_bicone_is_bilimit.symm hb)).is_limit)) $
      cones.ext (iso.refl _) (λ j, by { cases j, tidy }),
    is_colimit := is_colimit.of_iso_colimit
      ((is_colimit.precompose_inv_equiv (by exact diagram_iso_pair _ ) _).symm
        ((is_bilimit_of_preserves F (b.to_bicone_is_bilimit.symm hb)).is_colimit)) $
      cocones.ext (iso.refl _) (λ j, by { cases j, tidy }) } }

/-- A functor that preserves biproducts of a pair preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_biproducts (F : C ⥤ D)
  [preserves_zero_morphisms F] [preserves_biproducts_of_shape (discrete walking_pair.{v}) F] :
  preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_biproduct F X Y }

attribute [instance, priority 100] preserves_binary_biproducts.preserves

end limits

open category_theory.limits

namespace functor

section bicone
variables {J : Type v} [decidable_eq J] (F : C ⥤ D) [preserves_zero_morphisms F] (f : J → C)
  [has_biproduct f] [preserves_biproduct f F]

instance has_biproduct_of_preserves : has_biproduct (F.obj ∘ f) :=
has_biproduct.mk
{ bicone := F.map_bicone (biproduct.bicone f),
  is_bilimit := preserves_biproduct.preserves (biproduct.is_bilimit _) }

/-- If `F` preserves a biproduct, we get a definitionally nice isomorphism
    `F.obj (⨁ f) ≅ ⨁ (F.obj ∘ f)`. -/
@[simp]
def map_biproduct : F.obj (⨁ f) ≅ ⨁ (F.obj ∘ f) :=
biproduct.unique_up_to_iso _ (preserves_biproduct.preserves (biproduct.is_bilimit _))

lemma map_biproduct_hom : (map_biproduct F f).hom = biproduct.lift (λ j, F.map (biproduct.π f j)) :=
rfl

lemma map_biproduct_inv : (map_biproduct F f).inv = biproduct.desc (λ j, F.map (biproduct.ι f j)) :=
rfl

end bicone

variables (F : C ⥤ D) [preserves_zero_morphisms F] (X Y : C) [has_binary_biproduct X Y]
  [preserves_binary_biproduct X Y F]

instance has_binary_biproduct_of_preserves : has_binary_biproduct (F.obj X) (F.obj Y) :=
has_binary_biproduct.mk
{ bicone := F.map_binary_bicone (binary_biproduct.bicone X Y),
  is_bilimit := preserves_binary_biproduct.preserves (binary_biproduct.is_bilimit _ _) }

/-- If `F` preserves a binary biproduct, we get a definitionally nice isomorphism
    `F.obj (X ⊞ Y) ≅ F.obj X ⊞ F.obj Y`. -/
@[simp]
def map_biprod : F.obj (X ⊞ Y) ≅ F.obj X ⊞ F.obj Y :=
biprod.unique_up_to_iso _ _
  (preserves_binary_biproduct.preserves (binary_biproduct.is_bilimit _ _))

lemma map_biprod_hom : (map_biprod F X Y).hom = biprod.lift (F.map biprod.fst) (F.map biprod.snd) :=
rfl

lemma map_biprod_inv : (map_biprod F X Y).inv = biprod.desc (F.map biprod.inl) (F.map biprod.inr) :=
rfl

end functor

namespace limits
variables (F : C ⥤ D) [preserves_zero_morphisms F]

section bicone
variables {J : Type v} [decidable_eq J] (f : J → C) [has_biproduct f] [preserves_biproduct f F]
  {W : C}

lemma biproduct.map_lift_map_biprod (g : Π j, W ⟶ f j) :
  F.map (biproduct.lift g) ≫ (F.map_biproduct f).hom = biproduct.lift (λ j, F.map (g j)) :=
by { ext, simp [← F.map_comp] }

lemma biproduct.map_biproduct_inv_map_desc (g : Π j, f j ⟶ W) :
  (F.map_biproduct f).inv ≫ F.map (biproduct.desc g) = biproduct.desc (λ j, F.map (g j)) :=
by { ext, simp [← F.map_comp] }

lemma biproduct.map_biproduct_hom_desc (g : Π j, f j ⟶ W) :
  (F.map_biproduct f).hom ≫ biproduct.desc (λ j, F.map (g j)) = F.map (biproduct.desc g) :=
by rw [← biproduct.map_biproduct_inv_map_desc, iso.hom_inv_id_assoc]

end bicone

section binary_bicone
variables (X Y : C) [has_binary_biproduct X Y] [preserves_binary_biproduct X Y F] {W : C}

lemma biprod.map_lift_map_biprod (f : W ⟶ X) (g : W ⟶ Y) :
  F.map (biprod.lift f g) ≫ (F.map_biprod X Y).hom = biprod.lift (F.map f) (F.map g) :=
by ext; simp [← F.map_comp]

lemma biprod.lift_map_biprod (f : W ⟶ X) (g : W ⟶ Y) :
  biprod.lift (F.map f) (F.map g) ≫ (F.map_biprod X Y).inv = F.map (biprod.lift f g) :=
by rw [← biprod.map_lift_map_biprod, category.assoc, iso.hom_inv_id, category.comp_id]

lemma biprod.map_biprod_inv_map_desc (f : X ⟶ W) (g : Y ⟶ W) :
  (F.map_biprod X Y).inv ≫ F.map (biprod.desc f g) = biprod.desc (F.map f) (F.map g) :=
by ext; simp [← F.map_comp]

lemma biprod.map_biprod_hom_desc (f : X ⟶ W) (g : Y ⟶ W) :
 (F.map_biprod X Y).hom ≫ biprod.desc (F.map f) (F.map g) = F.map (biprod.desc f g) :=
by rw [← biprod.map_biprod_inv_map_desc, iso.hom_inv_id_assoc]

end binary_bicone

end limits

end has_zero_morphisms

open category_theory.functor

section preadditive
variables [preadditive C] [preadditive D] (F : C ⥤ D) [preserves_zero_morphisms F]

namespace limits

section fintype
variables {J : Type v} [decidable_eq J] [fintype J]

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite products. -/
def preserves_product_of_preserves_biproduct {f : J → C} [preserves_biproduct f F] :
  preserves_limit (discrete.functor f) F :=
{ preserves := λ c hc, is_limit.of_iso_limit
  ((is_limit.postcompose_inv_equiv (discrete.comp_nat_iso_discrete _ _) _).symm
    (is_bilimit_of_preserves F (bicone_is_bilimit_of_limit_cone_of_is_limit hc)).is_limit) $
  cones.ext (iso.refl _) (by tidy) }

section
local attribute [instance] preserves_product_of_preserves_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite products. -/
def preserves_products_of_shape_of_preserves_biproducts_of_shape
  [preserves_biproducts_of_shape J F] : preserves_limits_of_shape (discrete J) F :=
{ preserves_limit := λ f, preserves_limit_of_iso_diagram _ discrete.nat_iso_functor.symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) finite products
    preserves finite biproducts. -/
def preserves_biproduct_of_preserves_product {f : J → C} [preserves_limit (discrete.functor f) F] :
  preserves_biproduct f F :=
{ preserves := λ b hb, is_bilimit_of_is_limit _ $
    is_limit.of_iso_limit ((is_limit.postcompose_hom_equiv (discrete.comp_nat_iso_discrete _ _)
      (F.map_cone b.to_cone)).symm (is_limit_of_preserves F hb.is_limit)) $
      cones.ext (iso.refl _) (by tidy) }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite products
    preserves finite biproducts. -/
def preserves_biproducts_of_shape_of_preserves_products_of_shape
  [preserves_limits_of_shape (discrete J) F] : preserves_biproducts_of_shape J F :=
{ preserves := λ f, preserves_biproduct_of_preserves_product F }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite coproducts. -/
def preserves_coproduct_of_preserves_biproduct {f : J → C} [preserves_biproduct f F] :
  preserves_colimit (discrete.functor f) F :=
{ preserves := λ c hc, is_colimit.of_iso_colimit
    ((is_colimit.precompose_hom_equiv (discrete.comp_nat_iso_discrete _ _) _).symm
      (is_bilimit_of_preserves F
        (bicone_is_bilimit_of_colimit_cocone_of_is_colimit hc)).is_colimit) $
    cocones.ext (iso.refl _) (by tidy) }

section
local attribute [instance] preserves_coproduct_of_preserves_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite coproducts. -/
def preserves_coproducts_of_shape_of_preserves_biproducts_of_shape
  [preserves_biproducts_of_shape J F] : preserves_colimits_of_shape (discrete J) F :=
{ preserves_colimit := λ f, preserves_colimit_of_iso_diagram _ discrete.nat_iso_functor.symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) finite coproducts
    preserves finite biproducts. -/
def preserves_biproduct_of_preserves_coproduct {f : J → C}
  [preserves_colimit (discrete.functor f) F] : preserves_biproduct f F :=
{ preserves := λ b hb, is_bilimit_of_is_colimit _ $
    is_colimit.of_iso_colimit ((is_colimit.precompose_inv_equiv (discrete.comp_nat_iso_discrete _ _)
      (F.map_cocone b.to_cocone)).symm (is_colimit_of_preserves F hb.is_colimit)) $
      cocones.ext (iso.refl _) (by tidy) }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite coproducts
    preserves finite biproducts. -/
def preserves_biproducts_of_shape_of_preserves_coproducts_of_shape
  [preserves_colimits_of_shape (discrete J) F] : preserves_biproducts_of_shape J F :=
{ preserves := λ f, preserves_biproduct_of_preserves_coproduct F }

end fintype

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary products. -/
def preserves_binary_product_of_preserves_binary_biproduct {X Y : C}
  [preserves_binary_biproduct X Y F] : preserves_limit (pair X Y) F :=
{ preserves := λ c hc, is_limit.of_iso_limit
    ((is_limit.postcompose_inv_equiv (by exact diagram_iso_pair _) _).symm
      (is_binary_bilimit_of_preserves F
        (binary_bicone_is_bilimit_of_limit_cone_of_is_limit hc)).is_limit) $
    cones.ext (iso.refl _) (λ j, by { cases j, tidy }) }

section
local attribute [instance] preserves_binary_product_of_preserves_binary_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary products. -/
def preserves_binary_products_of_preserves_binary_biproducts
  [preserves_binary_biproducts F] : preserves_limits_of_shape (discrete walking_pair.{v}) F :=
{ preserves_limit := λ K, preserves_limit_of_iso_diagram _ (diagram_iso_pair _).symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) binary products
    preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_binary_product {X Y : C}
  [preserves_limit (pair X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb, is_binary_bilimit_of_is_limit _ $
    is_limit.of_iso_limit ((is_limit.postcompose_hom_equiv (by exact diagram_iso_pair _)
      (F.map_cone b.to_cone)).symm (is_limit_of_preserves F hb.is_limit)) $
        cones.ext (iso.refl _) (λ j, by { cases j, tidy }) }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary products
    preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_binary_products
  [preserves_limits_of_shape (discrete walking_pair.{v}) F] : preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_binary_product F }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary coproducts. -/
def preserves_binary_coproduct_of_preserves_binary_biproduct {X Y : C}
  [preserves_binary_biproduct X Y F] : preserves_colimit (pair X Y) F :=
{ preserves := λ c hc, is_colimit.of_iso_colimit
    ((is_colimit.precompose_hom_equiv (by exact diagram_iso_pair _) _).symm
      (is_binary_bilimit_of_preserves F
        (binary_bicone_is_bilimit_of_colimit_cocone_of_is_colimit hc)).is_colimit) $
      cocones.ext (iso.refl _) (λ j, by { cases j, tidy }) }

section
local attribute [instance] preserves_binary_coproduct_of_preserves_binary_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary coproducts. -/
def preserves_binary_coproducts_of_preserves_binary_biproducts
  [preserves_binary_biproducts F] : preserves_colimits_of_shape (discrete walking_pair.{v}) F :=
{ preserves_colimit := λ K, preserves_colimit_of_iso_diagram _ (diagram_iso_pair _).symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) binary coproducts
    preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_binary_coproduct {X Y : C}
  [preserves_colimit (pair X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb, is_binary_bilimit_of_is_colimit _ $
    is_colimit.of_iso_colimit ((is_colimit.precompose_inv_equiv (by exact diagram_iso_pair _)
      (F.map_cocone b.to_cocone)).symm (is_colimit_of_preserves F hb.is_colimit)) $
        cocones.ext (iso.refl _) (λ j, by { cases j, tidy }) }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary coproducts
    preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_binary_coproducts
  [preserves_colimits_of_shape (discrete walking_pair.{v}) F] : preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_binary_coproduct F }

end limits

end preadditive

end category_theory