import linear_algebra.dual
import linear_algebra.free_module.basic

import for_mathlib.nnrat

universe u
variables {Λ : Type u} [add_comm_group Λ]
variable {ι : Type*}

open_locale big_operators
open_locale nnreal

variable {α : Type*}

def nnrat_module {Λ : Type*} [add_comm_group Λ] [module ℚ Λ] : module (ℚ≥0) Λ :=
restrict_scalars.module (ℚ≥0) ℚ Λ

local attribute [instance] nnrat_module

instance nnrat_tower [module ℚ Λ] : is_scalar_tower (ℚ≥0) ℚ Λ :=
{ smul_assoc := λ x y z,
  begin
    rcases x with ⟨x, hx⟩,
    change (x • y) • z = x • _,
    simp [mul_smul],
  end }

variable [module ℚ Λ]
open module

def index_up_one (l : ι → Λ) : submodule (ℚ≥0) (dual ℚ Λ) :=
{ carrier := {x | ∀ i, 0 ≤ x (l i)},
  zero_mem' := λ i, le_rfl,
  add_mem' := λ x y hx hy i, by simpa only [linear_map.add_apply] using add_nonneg (hx _) (hy _),
  smul_mem' := λ c x hx i, mul_nonneg c.2 (hx i) }

@[simp] lemma mem_index_up_one (l : ι → Λ) (x : dual ℚ Λ) :
  x ∈ index_up_one l ↔ ∀ i, 0 ≤ x (l i) :=
iff.rfl

def set_up_one (s : set Λ) : submodule (ℚ≥0) (dual ℚ Λ) :=
index_up_one (coe : s → Λ)

lemma set_up_one_def (s : set Λ) : set_up_one s = index_up_one (coe : s → Λ) := rfl

lemma index_up_one_eq_set_up_one_range (l : ι → Λ) :
  index_up_one l = set_up_one (set.range l) :=
begin
  ext φ,
  split,
  { rintro hφ ⟨_, i, rfl⟩,
    apply hφ i },
  { rintro hφ i,
    apply hφ ⟨_, i, rfl⟩ },
end

@[simp] lemma mem_set_up_one (s : set Λ) (x : dual ℚ Λ) :
  x ∈ set_up_one s ↔ ∀ i ∈ s, 0 ≤ x i :=
begin
  change x ∈ index_up_one _ ↔ _,
  simp,
end

lemma set_up_one_antitone (s t : set Λ) :
  s ≤ t → set_up_one t ≤ set_up_one s :=
begin
  rintro h f hf ⟨i, hi⟩,
  apply hf ⟨_, h hi⟩,
end

/-- The submodule given by the intersection of the given functionals -/
def index_down_one (l : ι → Λ →ₗ[ℚ] ℚ) : submodule (ℚ≥0) Λ :=
{ carrier := {x | ∀ i, 0 ≤ l i x},
  zero_mem' := λ i, by simp only [linear_map.map_zero],
  add_mem' := λ x y hx hy i, by simpa only [linear_map.map_add] using add_nonneg (hx i) (hy i),
  smul_mem' := λ c x (hx : ∀ i, 0 ≤ l i x) i,
  begin
    rw linear_map.map_smul_of_tower,
    apply mul_nonneg c.2 (hx i),
  end }

@[simp] lemma mem_index_down_one (l : ι → dual ℚ Λ) (x : Λ) :
  x ∈ index_down_one l ↔ ∀ i, 0 ≤ l i x :=
iff.rfl

def set_down_one (s : set (dual ℚ Λ)) : submodule (ℚ≥0) Λ :=
index_down_one (coe : s → dual ℚ Λ)

lemma set_down_one_def (s : set (dual ℚ Λ)) :
  set_down_one s = index_down_one (coe : s → dual ℚ Λ) := rfl

lemma index_down_one_eq_set_down_one_range (l : ι → dual ℚ Λ) :
  index_down_one l = set_down_one (set.range l) :=
begin
  ext φ,
  split,
  { rintro hφ ⟨_, i, rfl⟩,
    apply hφ i },
  { rintro hφ i,
    apply hφ ⟨_, i, rfl⟩ },
end

@[simp] lemma mem_set_down_one (s : set (dual ℚ Λ)) (x : Λ) :
  x ∈ set_down_one s ↔ ∀ (i : dual ℚ Λ), i ∈ s → 0 ≤ i x :=
begin
  change x ∈ index_down_one _ ↔ _,
  simp,
end

lemma set_down_one_antitone (s t : set (dual ℚ Λ)) :
  s ≤ t → set_down_one t ≤ set_down_one s :=
begin
  rintro h f hf ⟨i, hi⟩,
  apply hf ⟨_, h hi⟩,
end

lemma set_up_one_span (s : set Λ) :
  set_up_one (submodule.span (ℚ≥0) s : set Λ) = set_up_one s :=
begin
  ext f,
  simp only [mem_set_up_one, set_like.mem_coe],
  split,
  { intros t y hy,
    apply t _ (submodule.subset_span hy) },
  { intros hf y hy,
    apply submodule.span_induction hy hf (by simp),
    { intros l₁ l₂ hl₁ hl₂,
      simp only [linear_map.map_add],
      apply add_nonneg hl₁ hl₂ },
    { intros q y hy,
      simp only [linear_map.map_smul_of_tower],
      apply mul_nonneg q.2 hy } }
end

lemma set_down_one_span (s : set (dual ℚ Λ)) :
  set_down_one (submodule.span (ℚ≥0) s : set (dual ℚ Λ)) = set_down_one s :=
begin
  ext x,
  simp only [mem_set_down_one, set_like.mem_coe],
  split,
  { intros t y hy,
    apply t _ (submodule.subset_span hy) },
  { intros hx y hy,
    apply submodule.span_induction hy hx (by simp),
    { intros l₁ l₂ hl₁ hl₂,
      apply add_nonneg hl₁ hl₂ },
    { intros q f hf,
      simp only [linear_map.smul_apply],
      apply mul_nonneg q.2 hf } }
end

lemma le_up_down (l : set (dual ℚ Λ)) : l ≤ set_up_one (set_down_one l : set Λ) :=
begin
  rintro x hx ⟨i, hi⟩,
  apply hi ⟨_, hx⟩,
end

lemma le_down_up (l : set Λ) : l ≤ set_down_one (set_up_one l : set (dual ℚ Λ)) :=
begin
  rintro x hx ⟨i, hi⟩,
  apply hi ⟨_, hx⟩,
end

noncomputable def down_two [finite_dimensional ℚ Λ] :
  submodule (ℚ≥0) (dual ℚ (dual ℚ Λ)) → submodule (ℚ≥0) Λ :=
submodule.comap (linear_equiv.restrict_scalars (ℚ≥0) (eval_equiv ℚ Λ) : Λ →ₗ[ℚ≥0] dual ℚ (dual ℚ Λ))

lemma down_two_def [finite_dimensional ℚ Λ] (C : submodule (ℚ≥0) (dual ℚ (dual ℚ Λ))) :
  down_two C =
  C.comap (linear_equiv.restrict_scalars (ℚ≥0) (eval_equiv ℚ Λ) : Λ →ₗ[ℚ≥0] dual ℚ (dual ℚ Λ)) :=
rfl

noncomputable def up_two [finite_dimensional ℚ Λ] :
  submodule (ℚ≥0) Λ → submodule (ℚ≥0) (dual ℚ (dual ℚ Λ)) :=
submodule.map (linear_equiv.restrict_scalars (ℚ≥0) (eval_equiv ℚ Λ) : Λ →ₗ[ℚ≥0] dual ℚ (dual ℚ Λ))

lemma down_two_up [finite_dimensional ℚ Λ] (C : submodule (ℚ≥0) Λ) :
  down_two (up_two C) = C :=
begin
  dunfold up_two down_two,
  rw linear_equiv.map_eq_comap,
  rw ←submodule.comap_comp,
  simp only [linear_equiv.refl_to_linear_map, linear_equiv.self_trans_symm, linear_equiv.comp_coe,
    submodule.comap_id],
end

lemma up_two_down [finite_dimensional ℚ Λ] (C : submodule (ℚ≥0) (dual ℚ (dual ℚ Λ))) :
  up_two (down_two C) = C :=
begin
  dunfold up_two down_two,
  rw linear_equiv.map_eq_comap,
  rw ←submodule.comap_comp,
  simp [submodule.comap_id],
end

lemma down_two_index_up_one [finite_dimensional ℚ Λ] (l : ι → dual ℚ Λ) :
  down_two (index_up_one l) = index_down_one l :=
begin
  ext x,
  simp only [down_two, submodule.mem_comap, linear_equiv.coe_coe,
    linear_equiv.restrict_scalars_apply, mem_index_up_one, mem_index_down_one],
  refl
end

lemma down_two_set_up_one [finite_dimensional ℚ Λ] (l : set (dual ℚ Λ)) :
  down_two (set_up_one l) = set_down_one l :=
down_two_index_up_one _

lemma up_two_index_down_one [finite_dimensional ℚ Λ] (l : ι → dual ℚ Λ) :
  up_two (index_down_one l) = index_up_one l :=
begin
  rw ←down_two_index_up_one,
  simp only [up_two_down],
end

lemma up_two_set_down_one [finite_dimensional ℚ Λ] (l : set (dual ℚ Λ)) :
  up_two (set_down_one l) = set_up_one l :=
up_two_index_down_one _

lemma down_up_down_eq (l : set (dual ℚ Λ)) :
  set_down_one (set_up_one (set_down_one l : set Λ) : set (dual ℚ Λ)) = set_down_one l :=
begin
  apply le_antisymm,
  { apply set_down_one_antitone,
    apply le_up_down },
  { apply le_down_up }
end

lemma up_down_up_eq (l : set Λ) :
  set_up_one (set_down_one (set_up_one l : set (dual ℚ Λ)) : set Λ) = set_up_one l :=
begin
  apply le_antisymm,
  { apply set_up_one_antitone,
    apply le_down_up },
  { apply le_up_down }
end

lemma down_two_up_one_up_one [finite_dimensional ℚ Λ]
  (C : submodule (ℚ≥0) Λ) (hC : ∃ (l : set (dual ℚ Λ)), C = set_down_one l) :
  down_two (set_up_one (set_up_one (C : set Λ) : set (dual ℚ Λ))) = C :=
begin
  rw down_two_set_up_one,
  rcases hC with ⟨l, rfl⟩,
  rw down_up_down_eq
end

lemma down_eval_eq [finite_dimensional ℚ Λ] (C : set Λ) :
  set_down_one (eval_equiv ℚ Λ '' C) = set_up_one C :=
begin
  ext x,
  simp only [and_imp, set.mem_image, mem_set_down_one, mem_set_up_one, forall_apply_eq_imp_iff₂,
    exists_imp_distrib],
  refl
end

lemma down_one_up_two [finite_dimensional ℚ Λ] (C : submodule (ℚ≥0) Λ) :
  set_down_one (up_two C : set (dual ℚ (dual ℚ Λ))) = set_up_one C :=
down_eval_eq _

lemma up_one_down_two [finite_dimensional ℚ Λ] (C : submodule (ℚ≥0) (dual ℚ (dual ℚ Λ))) :
  set_up_one (down_two C : set Λ) = set_down_one C :=
begin
  simp only [←down_one_up_two],
  simp only [up_two_down],
end

lemma up_one_down_one [finite_dimensional ℚ Λ] (C : set (dual ℚ Λ)) :
  set_up_one (set_down_one C : set Λ) = set_down_one (set_up_one C) :=
begin
  rw ←down_two_set_up_one,
  simp only [up_one_down_two],
end

/-- A submodule is polyhedral if it is the intersection of finitely many half spaces. -/
def is_polyhedral_cone (C : submodule (ℚ≥0) Λ) : Prop :=
  ∃ (ι : Type u) (_ : fintype ι) (l : ι → Λ →ₗ[ℚ] ℚ), C = index_down_one l

lemma is_polyhedral_cone_iff_finset (C : submodule (ℚ≥0) Λ) :
  is_polyhedral_cone C ↔ ∃ (s : finset (dual ℚ Λ)), C = set_down_one s :=
begin
  classical,
  split,
  { rintro ⟨ι, hι, l, rfl⟩,
    resetI,
    refine ⟨finset.univ.image l, _⟩,
    rw index_down_one_eq_set_down_one_range l,
    simp },
  { rintro ⟨s, rfl⟩,
    exact ⟨(s : set (dual ℚ Λ)), infer_instance, _, set_down_one_def _⟩ }
end

lemma down_two_up_one_up_one_cone [finite_dimensional ℚ Λ]
  (C : submodule (ℚ≥0) Λ) (hC : is_polyhedral_cone C) :
  down_two (set_up_one (set_up_one (C : set Λ) : set (dual ℚ Λ))) = C :=
begin
  apply down_two_up_one_up_one,
  rw is_polyhedral_cone_iff_finset at hC,
  rcases hC with ⟨_, rfl⟩,
  refine ⟨_, rfl⟩,
end

lemma is_polyhedral_cone_of_equiv {Λ' : Type u} [add_comm_group Λ'] [module ℚ Λ']
  (e : Λ ≃ₗ[ℚ] Λ') (C : submodule (ℚ≥0) Λ) (hC : is_polyhedral_cone C) :
  is_polyhedral_cone (submodule.map (e.to_linear_map.restrict_scalars (ℚ≥0)) C) :=
begin
  rcases hC with ⟨ι, hι, l, rfl⟩,
  refine ⟨ι, hι, λ i, _, _⟩,
  apply (l i).comp e.symm.to_linear_map,
  ext x,
  simp only [submodule.mem_map, function.comp_app, linear_map.coe_comp,
    mem_index_down_one, linear_equiv.coe_to_linear_map,
    linear_map.coe_restrict_scalars_eq_coe],
  split,
  { rintro ⟨y, hy, rfl⟩,
    simpa },
  { intro t,
    refine ⟨e.symm x, t, by simp⟩ }
end

lemma is_polyhedral_cone_bot_aux [fintype α] : is_polyhedral_cone (⊥ : submodule (ℚ≥0) (α → ℚ)) :=
⟨α ⊕ α, sum.fintype α α,
    sum.elim (λ i, ⟨λ f, f i, λ x y, rfl, λ _ _, rfl⟩)
             (λ i, -⟨λ f, f i, λ x y, rfl, λ _ _, rfl⟩),
begin
  ext,
  simp only [linear_map.coe_proj, sum.elim_inl, function.eval_apply, linear_map.neg_apply,
    sum.elim_inr, mem_index_down_one, sum.forall, submodule.mem_bot, neg_nonneg],
  split,
  { rintro rfl,
    simp only [linear_map.map_zero, and_self],
    intro a,
    apply le_rfl },
  { rintro ⟨h₁, h₂⟩,
    ext1 i,
    apply le_antisymm,
    { apply h₂ i },
    { apply h₁ i } }
end⟩

lemma is_polyhedral_cone_bot [finite_dimensional ℚ Λ] :
  is_polyhedral_cone (⊥ : submodule (ℚ≥0) Λ) :=
begin
  let l := (basis.of_vector_space ℚ Λ).equiv_fun,
  have := is_polyhedral_cone_of_equiv l.symm ⊥ is_polyhedral_cone_bot_aux,
  simpa using this,
end

lemma coe_min' (s : finset (ℚ≥0)) (hs : s.nonempty) :
  (coe (s.min' hs) : ℚ) = (s.image coe).min' (hs.image _) :=
begin
  revert hs,
  apply finset.induction_on s,
  { simp },
  { intros x s hx ih t,
    rcases finset.eq_empty_or_nonempty s with (rfl | hs),
    { simp },
    simp_rw [finset.image_insert, finset.min'_insert x s hs, nnrat.coe_min, ih hs,
      ← finset.min'_insert] }
end

def extended_half_spaces_index {ι : Type*} (s : ι → Λ →ₗ[ℚ] ℚ) (x : Λ) : Type* :=
{i : ι // 0 ≤ s i x} ⊕ ({i : ι // 0 < s i x} × {i : ι // s i x < 0})

instance {ι : Type*} [fintype ι] (s : ι → Λ →ₗ[ℚ] ℚ) (x : Λ) :
  fintype (extended_half_spaces_index s x) :=
begin
  rw extended_half_spaces_index,
  apply_instance
end

def extended_half_spaces {ι : Type*} (s : ι → Λ →ₗ[ℚ] ℚ) (x : Λ) :
  extended_half_spaces_index s x → Λ →ₗ[ℚ] ℚ :=
sum.elim (s ∘ coe) (λ ij, (s ij.1 x) • s ij.2 - (s ij.2 x) • s ij.1)

lemma span_le_extended [decidable_eq Λ] {ι : Type*} {s : ι → Λ →ₗ[ℚ] ℚ}
  {l : finset Λ} (hs : submodule.span ℚ≥0 (l : set Λ) = index_down_one s)
  {x : Λ} (hx : x ∉ l) :
  submodule.span ℚ≥0 ↑(insert x l) ≤ index_down_one (extended_half_spaces s x) :=
begin
  rw submodule.span_le,
  intros f hf,
  simp only [finset.coe_insert, set.mem_insert_iff, finset.mem_coe] at hf,
  simp only [set_like.mem_coe, mem_index_down_one, extended_half_spaces],
  rcases hf with (rfl | hf),
  { rintro (⟨i, hi⟩ | ⟨⟨i, hi⟩, j, hj⟩),
    { simpa },
    { simp [mul_comm] } },
  { have f_mem : f ∈ index_down_one s,
    { rw ←hs,
      exact submodule.subset_span hf },
    rintro (⟨i, hi⟩ | ⟨⟨i, hi⟩, j, hj⟩),
    { simpa using f_mem i },
    { have : 0 ≤ s i f, by apply f_mem,
      have : 0 ≤ s j f, by apply f_mem,
      simp only [algebra.id.smul_eq_mul, sub_nonneg, linear_map.smul_apply, sum.elim_inr,
        subtype.coe_mk, linear_map.sub_apply],
      nlinarith } },
end

lemma extended_le_span [decidable_eq Λ] {ι : Type*} [fintype ι] {s : ι → Λ →ₗ[ℚ] ℚ}
  {l : finset Λ} (hs : submodule.span ℚ≥0 (l : set Λ) = index_down_one s)
  {x : Λ} (hx : x ∉ l) :
  index_down_one (extended_half_spaces s x) ≤ submodule.span ℚ≥0 ↑(insert x l) :=
begin
  intros y hy,
  simp only [finset.coe_insert, submodule.mem_span_insert, exists_prop, hs],
  suffices : ∃ (t : ℚ≥0), y - t • x ∈ index_down_one s,
  { rcases this with ⟨a, ha⟩,
    refine ⟨a, _, ha, by simp⟩ },
  simp only [mem_index_down_one] at hy,
  have y_nonneg : ∀ i, 0 ≤ s i x → 0 ≤ s i y,
  { intros i hi,
    apply hy (sum.inl ⟨i, hi⟩) },
  have y_neg : ∀ i j, 0 < s i x → s j x < 0 → s j x * s i y ≤ s i x * s j y,
  { intros i j hi hj,
    simpa [extended_half_spaces] using hy (sum.inr ⟨⟨i, hi⟩, ⟨j, hj⟩⟩) },
  let a : {i // 0 < s i x} → ℚ≥0 := λ i, ⟨s i.1 y, y_nonneg _ i.2.le⟩ / ⟨s i.1 x, i.2.le⟩,
  let as : finset (ℚ≥0) := finset.univ.image a,
  let b : {i // s i x < 0} → ℚ := λ i, s i.1 y / s i.1 x,
  let bs : finset ℚ := finset.univ.image b,
  by_cases h : nonempty {i // 0 < s i x},
  { have : as.nonempty,
    { rwa [finset.nonempty.image_iff, finset.univ_nonempty_iff] },
    refine ⟨as.min' ‹as.nonempty›, _⟩,
    rw [mem_index_down_one],
    intros i,
    rw [linear_map.map_sub, sub_nonneg],
    simp only [linear_map.map_smul_of_tower, subtype.val_eq_coe],
    change (coe (_ : ℚ≥0)) * (s i x) ≤ s i y,
    rcases lt_trichotomy 0 (s i x) with (lt | eq | gt),
    { rw [coe_min', ←le_div_iff lt],
      apply finset.min'_le,
      simp only [finset.mem_univ, finset.mem_image, exists_prop],
      refine ⟨_, ⟨⟨i, lt⟩, ⟨⟩, rfl⟩, _⟩,
      simp },
    { rw [←eq, mul_zero],
      apply y_nonneg _ (eq.le) },
    { rw [coe_min', ←div_le_iff_of_neg gt],
      apply finset.le_min',
      simp only [and_imp, exists_prop, finset.mem_univ, bex_imp_distrib, finset.mem_image,
        exists_true_left, subtype.exists, exists_imp_distrib],
      rintro _ _ j hj ⟨⟨⟩, rfl⟩ rfl,
      simp only [nnrat.coe_div, subtype.coe_mk], erw [subtype.coe_mk, subtype.coe_mk],
      have := y_neg _ _ hj gt,
      rwa [div_le_iff_of_neg gt, ←mul_right_comm, mul_comm (s j y), mul_inv_le_iff hj] } },
  by_cases h' : nonempty {i // s i x < 0},
  { have : bs.nonempty,
    { rwa [finset.nonempty.image_iff, finset.univ_nonempty_iff] },
    refine ⟨nnrat.of_rat (bs.max' ‹bs.nonempty›), _⟩,
    intros i,
    rw [linear_map.map_sub, sub_nonneg],
    simp only [linear_map.map_smul_of_tower, subtype.val_eq_coe],
    rcases lt_trichotomy 0 (s i x) with (lt | eq | gt),
    { exfalso,
      apply h,
      refine ⟨⟨_, lt⟩⟩ },
    { rw [←eq, smul_zero],
      apply y_nonneg,
      apply eq.le, },
    change max _ _ * _ ≤ _,
    rw ←div_le_iff_of_neg gt,
    rw le_max_iff,
    left,
    apply finset.le_max',
    simp only [finset.mem_univ, finset.mem_image, exists_true_left, subtype.exists],
    refine ⟨i, gt, rfl⟩ },
  refine ⟨0, _⟩,
  intros i,
  rw [linear_map.map_sub, sub_nonneg, zero_smul, linear_map.map_zero],
  simp only [linear_map.map_smul_of_tower, subtype.val_eq_coe],
  rcases le_or_lt 0 (s i x) with (lt | lt),
  { apply y_nonneg _ lt },
  { exfalso,
    apply h',
    refine ⟨⟨_, lt⟩⟩ },
end

lemma eliminate_inductive_step [decidable_eq Λ] (ι : Type u) [fintype ι] (s : ι → Λ →ₗ[ℚ] ℚ)
  {l : finset Λ} (hs : submodule.span ℚ≥0 (l : set Λ) = index_down_one s)
  (x : Λ) (hx : x ∉ l) :
  is_polyhedral_cone (submodule.span ℚ≥0 (coe (insert x l) : set Λ)) :=
begin
  refine ⟨extended_half_spaces_index s x, infer_instance, extended_half_spaces _ _, _⟩,
  apply le_antisymm,
  apply span_le_extended hs hx,
  apply extended_le_span hs hx,
end

lemma elimination_aux [finite_dimensional ℚ Λ] (l : finset Λ) :
  is_polyhedral_cone (submodule.span (ℚ≥0) (l : set Λ)) :=
begin
  classical,
  apply finset.induction_on l,
  { simp only [finset.coe_empty, submodule.span_empty],
    apply is_polyhedral_cone_bot },
  { clear l,
    rintro x l hx ⟨ι, hι, s, hs⟩,
    resetI,
    convert eliminate_inductive_step ι s hs x hx }
end

lemma is_polyhedral_cone_of_fg [finite_dimensional ℚ Λ] (C : submodule (ℚ≥0) Λ) (hC : C.fg) :
  is_polyhedral_cone C :=
begin
  rcases hC with ⟨l, rfl⟩,
  apply elimination_aux
end

lemma one_sixteen_c [finite_dimensional ℚ Λ] (ι : Type u) [fintype ι] (l : ι → Λ →ₗ[ℚ] ℚ) :
  set_up_one (index_down_one l : set Λ) =
    submodule.span (ℚ≥0) (set.range l) :=
begin
  set C : submodule (ℚ≥0) Λ := index_down_one l,
  set C_star := set_up_one (C : set Λ),
  set C' : submodule _ (dual ℚ Λ) := submodule.span (ℚ≥0) (set.range l),
  let C'_star := down_two (set_up_one (C' : set (dual ℚ Λ))),
  have C_eq : C = C'_star,
  { change C = down_two (set_up_one (C' : set (dual ℚ Λ))),
    rw down_two_set_up_one,
    rw set_down_one_span,
    apply index_down_one_eq_set_down_one_range },
  have C'pc : is_polyhedral_cone C',
  { apply is_polyhedral_cone_of_fg,
    classical,
    refine ⟨finset.univ.image l, _⟩,
    simp },
  change set_up_one (C : set Λ) = _,
  rw C_eq,
  change set_up_one (down_two (set_up_one (C' : set (dual ℚ Λ))) : set Λ) = _,
  rw down_two_set_up_one,
  rw is_polyhedral_cone_iff_finset at C'pc,
  clear_value C', clear' C C_star C'_star C_eq l,
  rcases C'pc with ⟨s, rfl⟩,
  simp_rw [up_one_down_one (set_down_one (s : set (dual ℚ (dual ℚ Λ))) : set (dual ℚ Λ))],
  rw down_up_down_eq,
end

lemma dual_fg_of_cone [finite_dimensional ℚ Λ] (C : submodule (ℚ≥0) Λ)
  (hC : is_polyhedral_cone C) :
  (set_up_one (C : set Λ) : submodule (ℚ≥0) (dual ℚ Λ)).fg :=
begin
  rcases hC with ⟨ι, hι, l, rfl⟩,
  resetI,
  simp only [one_sixteen_c],
  classical,
  refine ⟨finset.univ.image l, by simp⟩,
end

lemma fg_of_is_polyhedral_cone [finite_dimensional ℚ Λ] (C : submodule (ℚ≥0) Λ)
  (hC : is_polyhedral_cone C) :
  C.fg :=
begin
  have t := dual_fg_of_cone _ (is_polyhedral_cone_of_fg _ (dual_fg_of_cone _ hC)),
  have t2 : (submodule.map
      (((eval_equiv ℚ Λ).restrict_scalars (ℚ≥0)).symm : dual ℚ (dual ℚ Λ) →ₗ[ℚ≥0] Λ) _).fg,
  { refine submodule.fg.map _ t, },
  rwa [linear_equiv.map_eq_comap, linear_equiv.symm_symm, ← down_two_def,
    down_two_up_one_up_one_cone _ hC] at t2,
end

lemma fg_iff_is_polyhedral_cone [finite_dimensional ℚ Λ] (C : submodule (ℚ≥0) Λ) :
  is_polyhedral_cone C ↔ C.fg :=
⟨fg_of_is_polyhedral_cone C, is_polyhedral_cone_of_fg C⟩


structure Equiv (α β : Type _) where
  to : α → β
  inv : β → α
  to_inv : ∀ x, to (inv x) = x
  inv_to : ∀ x, inv (to x) = x

attribute [simp] Equiv.to_inv Equiv.inv_to

namespace Equiv

def id : Equiv α α where
  to := _root_.id
  inv := _root_.id
  to_inv := by intros; simp
  inv_to := by intros; simp

def comp (f : Equiv β γ) (g : Equiv α β) : Equiv α γ where
  to := f.to ∘ g.to
  inv := g.inv ∘ f.inv
  to_inv := by intros; simp [Function.comp, to_inv]
  inv_to := by intros; simp [Function.comp, inv_to]

def symm (f : Equiv α β) : Equiv β α where
  to := f.inv
  inv := f.to
  to_inv := f.inv_to
  inv_to := f.to_inv

def prodCongr (f : Equiv α β) (g : Equiv α' β') : Equiv (α × α') (β × β') where
  to | (a, b) => (f.to a, g.to b)
  inv | (a, b) => (f.inv a, g.inv b)
  to_inv := by intro x; cases x; simp
  inv_to := by intro x; cases x; simp

section Congr

variable (f : Equiv α β ) (g : Equiv α' β')

@[simp]
theorem to_prodCongr : (prodCongr f g).to x = (f.to x.1, g.to x.2) := rfl

@[simp]
theorem inv_prodCongr : (prodCongr f g).inv x = (f.inv x.1, g.inv x.2) := rfl

end Congr

def left_unitor : Equiv (PUnit × α) α where
  to | (_, a) => a
  inv | a => ((), a)
  to_inv := by intro x; simp
  inv_to := by intro x; cases x; simp

def right_unitor : Equiv (α × PUnit) α where
  to | (a, _) => a
  inv | a => (a, ())
  to_inv := by intro x; simp
  inv_to := by intro x; cases x; simp

section Unitors

@[simp]
theorem to_left_unitor (x : PUnit × β) : left_unitor.to x = x.2 := rfl

@[simp]
theorem inv_left_unitor (x : α) : left_unitor.inv x = ((), x) := rfl

@[simp]
theorem to_right_unitor (x : α × PUnit) : right_unitor.to x = x.1 := rfl

@[simp]
theorem inv_right_unitor (x : α) : right_unitor.inv x = (x, ()) := rfl

end Unitors

def assoc : Equiv ((α × β) × γ) (α × β × γ) where
  to | ((a, b), c) => (a, b, c)
  inv | (a, b, c) => ((a, b), c)
  to_inv := by intro x; cases x; simp
  inv_to := by intro x; cases x; simp

section Assoc

@[simp]
theorem to_assoc (x : (α × β) × γ) : assoc.to x = (x.1.1, x.1.2, x.2) := rfl

@[simp]
theorem inv_assoc (x : α × β × γ) : assoc.inv x = ((x.1, x.2.1), x.2.2) := rfl

end Assoc

local infix:60 " ⊚ " => comp

theorem ext (f g : Equiv α β)
  (H : ∀ x, f.to x = g.to x):
  f = g := by
cases f; cases g; simp
next f f' f_inv f_to =>
next g g' g_inv g_to =>
have : g = f := by apply funext; apply H
exists this; apply funext; intro x
have f_inv := congrArg g' <| f_inv x
rewrite [← this, g_to] at f_inv
apply Eq.symm; assumption

@[simp]
theorem to_id : (@id α).to x = x := rfl

@[simp]
theorem to_comp (f : Equiv α β) (g : Equiv β γ) :
  (g ⊚ f).to x = g.to (f.to x) := rfl

@[simp]
theorem to_symm (f : Equiv α β) :
  (f.symm).to x = f.inv x := rfl

@[simp]
theorem inv_id : (@id α).inv x = x := rfl

@[simp]
theorem inv_comp (f : Equiv α β) (g : Equiv β γ) :
  (g ⊚ f).inv x = f.inv (g.inv x) := rfl

@[simp]
theorem inv_symm (f : Equiv α β) :
  (f.symm).inv x = f.to x := rfl

@[simp]
theorem id_comp (f : Equiv α β) :
  id ⊚ f = f := by
apply ext; intro x; simp

@[simp]
theorem comp_id (f : Equiv α β) :
  f ⊚ id = f := by
apply ext; intro x; simp

@[simp]
theorem comp_assoc (f : Equiv α β) (g : Equiv β γ) (h : Equiv γ ϕ) :
  (h ⊚ g) ⊚ f = h ⊚ (g ⊚ f) := by
apply ext; intro x; simp

@[simp]
theorem symm_id :
  (@id α).symm = id := by
apply ext; intro x; simp

@[simp]
theorem symm_comp (f : Equiv α β) (g : Equiv β γ) :
  (g ⊚ f).symm = f.symm ⊚ g.symm := by
apply ext; intro x; simp

theorem eq_inv_iff (f : Equiv α β) x y :
  x = f.inv y ↔ f.to x = y := by
constructor <;> intros h <;> subst h
<;> simp [*]

end Equiv


-- Copyright (c) Microsoft Corporation. All rights reserved.
-- Licensed under the MIT license.

import .common
import .ops
import .bitvector
import smt2.syntax
import smt2.builder

universes u

mutual inductive sbool, sbitvec
with sbool : Type
| tt: sbool | ff:sbool
| var: string → sbool -- unbound variable
| and: sbool → sbool → sbool
| or: sbool → sbool → sbool
| xor: sbool → sbool → sbool
| eqb: sbool → sbool → sbool
| neb: sbool → sbool → sbool
| ite: sbool → sbool → sbool → sbool
| not: sbool → sbool
| eqbv: Π {sz:size}, sbitvec sz → sbitvec sz → sbool
| nebv: Π {sz:size}, sbitvec sz → sbitvec sz → sbool
| sle: Π {sz:size}, sbitvec sz → sbitvec sz → sbool
| slt: Π {sz:size}, sbitvec sz → sbitvec sz → sbool
| ule: Π {sz:size}, sbitvec sz → sbitvec sz → sbool
| ult: Π {sz:size}, sbitvec sz → sbitvec sz → sbool
with sbitvec : size → Type
| const: Π (sz:size) (n:nat), sbitvec sz
| var: Π (sz:size), string → sbitvec sz -- unbound variable
| add: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| sub: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| mul: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| udiv: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| urem: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| sdiv: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| srem: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| and: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| or: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| xor: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| shl: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| lshr: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| ashr: Π {sz:size}, sbitvec sz → sbitvec sz → sbitvec sz
| zext: Π {sz:size} (sz':size), sbitvec sz → sbitvec sz'
| sext: Π {sz:size} (sz':size), sbitvec sz → sbitvec sz'
| trunc: Π {sz:size} (sz':size), sbitvec sz → sbitvec sz'
| extract: Π {sz sz':size} (highbit lowbit:nat)
    (H:sz'.val = highbit - lowbit + 1), sbitvec sz → sbitvec sz'
| ite: Π {sz:size}, sbool → sbitvec sz → sbitvec sz → sbitvec sz

namespace sbool

open smt2.term
open smt2.builder

def of_bool (b:bool):sbool :=
  cond b sbool.tt sbool.ff

def and_simpl (t1 t2:sbool):sbool :=
match t1 with
| sbool.tt := t2
| sbool.ff := sbool.ff
| _ :=
  match t2 with
  | sbool.tt := t1
  | sbool.ff := sbool.ff
  | _ := sbool.and t1 t2
  end
end

end sbool

instance sbool_is_bool_like : bool_like sbool :=
⟨sbool.tt, sbool.ff, sbool.and, sbool.or, sbool.xor, sbool.not⟩

instance sbool_has_ite : has_ite sbool sbool :=
⟨sbool.ite⟩

namespace sbitvec

open smt2.term
open smt2.builder

def of_int (sz:size) : ℤ → sbitvec sz
| x@(int.of_nat q) := sbitvec.const sz (q % (2^sz.val))
| x@(int.neg_succ_of_nat p) :=
  sbitvec.const sz (((2 ^ sz.val) - p - 1) % (2^sz.val))

@[simp]
def one (sz:size) : sbitvec sz := of_int sz 1

@[simp]
def zero (sz:size) : sbitvec sz := of_int sz 0

@[simp]
def intmin (sz:size) : sbitvec sz := of_int sz (int_min_nat sz)

@[simp]
def intmax (sz:size) : sbitvec sz := of_int sz (int.of_nat ((2^(sz.val-1))-1))

@[simp]
def uintmax (sz:size) : sbitvec sz := of_int sz (all_one_nat sz)

def of_bool (b:sbool) : sbitvec (size.one) :=
    sbitvec.ite b (sbitvec.one size.one) (sbitvec.zero size.one)

def of_bv {sz:size} (b:bitvector sz) : sbitvec sz := of_int sz b.1

private theorem add_size_eq (n m:size):
  subtype.mk ((n.1 + m.1 - 1) - n.1 + 1) dec_trivial = m :=
begin apply subtype.eq, simp,
  rewrite nat.add_sub_assoc,
  { -- 1 + (n.val + (m.val - 1) - n.val) = m.val
    rewrite nat.add_sub_cancel_left, -- 1 + (m.val - 1) = m.val
    rewrite ← nat.add_sub_assoc, -- 1 + m.val - 1 = m.val
    rewrite nat.add_sub_cancel_left, -- 1 ≤ m.val
    apply m.2
  },
  { -- 1 ≤ m.val
    apply m.2 }
end

theorem decr_sbitvec: ∀ (sz:size) (v:sbitvec sz), 0 < sbitvec.sizeof sz v
:= begin
  intros, induction v,
  any_goals { unfold sbitvec.sizeof, try {simp}, rw nat.one_add, exact dec_trivial }
end

variable {sz:size}

@[simp]
def mk_zext (m:size) (a:sbitvec sz): sbitvec (sz.add m) :=
  sbitvec.zext (sz.add m) a

@[simp]
def mk_sext (m:size) (a:sbitvec sz): sbitvec (sz.add m) :=
  sbitvec.sext (sz.add m) a

-- Returns false if it overflows.
def overflow_chk (f:Π {sz':size}, sbitvec sz' → sbitvec sz' → sbitvec sz')
    (m:size) (signed:bool)
    (a b:sbitvec sz):sbool :=
  if signed then
    let a'  := sbitvec.mk_sext m a,
        b'  := sbitvec.mk_sext m b,
        r'  := f a' b',
        r   := f a  b,
        r'' := sbitvec.mk_sext m r in
    sbool.nebv r' r''
  else
    let a' := sbitvec.mk_zext m a,
        b' := sbitvec.mk_zext m b,
        r'  := f a' b' in
    let H:(m.val = (sz.val + m.val - 1) - sz.val + 1) := begin
      rw nat.add_comm sz.val m.val,
      rw nat.sub.right_comm,
      rw nat.add_sub_cancel,
      rw nat.sub_add_cancel,
      cases m, assumption
    end in
    let padding := sbitvec.extract (sz+m-1) sz H r' in
    sbool.nebv padding (sbitvec.zero m)

def shl_overflow_chk (m:size) (signed:bool) (a b:sbitvec sz):sbool :=
  overflow_chk (@sbitvec.shl) sz signed a (sbitvec.urem b (sbitvec.of_int sz sz.val))
end sbitvec

instance sbitvec_is_uint_like
: uint_like (sbitvec) :=
⟨@sbitvec.add, @sbitvec.sub, @sbitvec.mul,
  @sbitvec.udiv, @sbitvec.urem, @sbitvec.sdiv, @sbitvec.srem,
  @sbitvec.and, @sbitvec.or, @sbitvec.xor,
  @sbitvec.shl, @sbitvec.lshr, @sbitvec.ashr,
  sbitvec.zero, sbitvec.uintmax, sbitvec.intmin,
  sbitvec.of_int, @sbitvec.zext, @sbitvec.sext, @sbitvec.trunc⟩

instance sbool_sbitvec_has_coe: has_coe sbool (sbitvec size.one) :=
⟨sbitvec.of_bool⟩

@[reducible]
instance sbitvec_has_comp
: has_comp sbitvec sbool :=
⟨@sbool.eqbv, @sbool.nebv, @sbool.sle, @sbool.slt, @sbool.ule, @sbool.ult⟩

instance sbitvec_has_ite {sz:size} : has_ite sbool (sbitvec sz) :=
⟨sbitvec.ite⟩

instance sbitvec_has_overflow_check
: has_overflow_check sbitvec sbool :=
⟨(λ {sz:size}, @sbitvec.overflow_chk sz @sbitvec.add size.one),
(λ {sz:size}, @sbitvec.overflow_chk sz @sbitvec.sub size.one),
(λ {sz:size}, @sbitvec.overflow_chk sz @sbitvec.mul sz),
(λ {sz:size}, @sbitvec.shl_overflow_chk sz sz)⟩


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.list.sigma
import data.int.range
import tactic.pretty_cases
import testing.slim_check.sampleable
import testing.slim_check.testable

/-!
## `slim_check`: generators for functions

This file defines `sampleable` instances for `α → β` functions and
`ℤ → ℤ` injective functions.

Functions are generated by creating a list of pairs and one more value
using the list as a lookup table and resorting to the additional value
when a value is not found in the table.

Injective functions are generated by creating a list of numbers and
a permutation of that list. The permutation insures that every input
is mapped to a unique output. When an input is not found in the list
the input itself is used as an output.

Injective functions `f : α → α` could be generated easily instead of
`ℤ → ℤ` by generating a `list α`, removing duplicates and creating a
permutations. One has to be careful when generating the domain to make
if vast enough that, when generating arguments to apply `f` to,
they argument should be likely to lie in the domain of `f`. This is
the reason that injective functions `f : ℤ → ℤ` are generated by
fixing the domain to the range `[-2*size .. -2*size]`, with `size`
the size parameter of the `gen` monad.

Much of the machinery provided in this file is applicable to generate
injective functions of type `α → α` and new instances should be easy
to define.

Other classes of functions such as monotone functions can generated using
similar techniques. For monotone functions, generating two lists, sorting them
and matching them should suffice, with appropriate default values.
Some care must be taken for shrinking such functions to make sure
their defining property is invariant through shrinking. Injective
functions are an example of how complicated it can get.
-/

universes u v w
variables {α : Type u} {β : Type v} {γ : Sort w}

namespace slim_check

/-- Data structure specifying a total function using a list of pairs
and a default value returned when the input is not in the domain of
the partial function.

`with_default f y` encodes `x ↦ f x` when `x ∈ f` and `x ↦ y`
otherwise.

We use `Σ` to encode mappings instead of `×` because we
rely on the association list API defined in `data.list.sigma`.
 -/
inductive total_function (α : Type u) (β : Type v) : Type (max u v)
| with_default : list (Σ _ : α, β) → β → total_function

instance total_function.inhabited [inhabited β] : inhabited (total_function α β) :=
⟨ total_function.with_default ∅ (default _) ⟩

namespace total_function

/-- Apply a total function to an argument. -/
def apply [decidable_eq α] : total_function α β → α → β
| (total_function.with_default m y) x := (m.lookup x).get_or_else y

/--
Implementation of `has_repr (total_function α β)`.

Creates a string for a given `finmap` and output, `x₀ ↦ y₀, .. xₙ ↦ yₙ`
for each of the entries. The brackets are provided by the calling function.
-/
def repr_aux [has_repr α] [has_repr β] (m : list (Σ _ : α, β)) : string :=
string.join $ list.qsort (λ x y, x < y)
  (m.map $ λ x, sformat!"{repr $ sigma.fst x} ↦ {repr $ sigma.snd x}, ")

/--
Produce a string for a given `total_function`.
The output is of the form `[x₀ ↦ f x₀, .. xₙ ↦ f xₙ, _ ↦ y]`.
-/
protected def repr [has_repr α] [has_repr β] : total_function α β → string
| (total_function.with_default m y) := sformat!"[{repr_aux m}_ ↦ {has_repr.repr y}]"

instance (α : Type u) (β : Type v) [has_repr α] [has_repr β] : has_repr (total_function α β) :=
⟨ total_function.repr ⟩

/-- Create a `finmap` from a list of pairs. -/
def list.to_finmap' (xs : list (α × β)) : list (Σ _ : α, β) :=
xs.map prod.to_sigma

section

variables [sampleable α] [sampleable β]

/-- Redefine `sizeof` to follow the structure of `sampleable` instances. -/
def total.sizeof : total_function α β → ℕ
| ⟨m, x⟩ := 1 + @sizeof _ sampleable.wf m + sizeof x

@[priority 2000]
instance : has_sizeof (total_function α β) :=
⟨ total.sizeof ⟩

variables [decidable_eq α]

/-- Shrink a total function by shrinking the lists that represent it. -/
protected def shrink : shrink_fn (total_function α β)
| ⟨m, x⟩ := (sampleable.shrink (m, x)).map $ λ ⟨⟨m', x'⟩, h⟩, ⟨⟨list.erase_dupkeys m', x'⟩,
            lt_of_le_of_lt
              (by unfold_wf; refine @list.sizeof_erase_dupkeys _ _ _ (@sampleable.wf _ _) _) h ⟩

variables [has_repr α] [has_repr β]

instance pi.sampleable_ext : sampleable_ext (α → β) :=
{ proxy_repr := total_function α β,
  interp := total_function.apply,
  sample := do
  { xs ← (sampleable.sample (list (α × β)) : gen ((list (α × β)))),
    ⟨x⟩ ← (uliftable.up $ sample β : gen (ulift.{max u v} β)),
    pure $ total_function.with_default (list.to_finmap' xs) x },
  shrink := total_function.shrink }

end

section sampleable_ext
open sampleable_ext

@[priority 2000]
instance pi_pred.sampleable_ext [sampleable_ext (α → bool)] :
  sampleable_ext.{u+1} (α → Prop) :=
{ proxy_repr := proxy_repr (α → bool),
  interp := λ m x, interp (α → bool) m x,
  sample := sample (α → bool),
  shrink := shrink }

@[priority 2000]
instance pi_uncurry.sampleable_ext
  [sampleable_ext (α × β → γ)] : sampleable_ext.{(imax (u+1) (v+1) w)} (α → β → γ) :=
{ proxy_repr := proxy_repr (α × β → γ),
  interp := λ m x y, interp (α × β → γ) m (x, y),
  sample := sample (α × β → γ),
  shrink := shrink }

end sampleable_ext

end total_function

/--
Data structure specifying a total function using a list of pairs
and a default value returned when the input is not in the domain of
the partial function.

`map_to_self f` encodes `x ↦ f x` when `x ∈ f` and `x ↦ x`,
i.e. `x` to itself, otherwise.

We use `Σ` to encode mappings instead of `×` because we
rely on the association list API defined in `data.list.sigma`.
-/
inductive injective_function (α : Type u) : Type u
| map_to_self (xs : list (Σ _ : α, α)) :
    xs.map sigma.fst ~ xs.map sigma.snd → list.nodup (xs.map sigma.snd) → injective_function

instance : inhabited (injective_function α) :=
⟨ ⟨ [], list.perm.nil, list.nodup_nil ⟩ ⟩

namespace injective_function

/-- Apply a total function to an argument. -/
def apply [decidable_eq α] : injective_function α → α → α
| (injective_function.map_to_self m _ _) x := (m.lookup x).get_or_else x

/--
Produce a string for a given `total_function`.
The output is of the form `[x₀ ↦ f x₀, .. xₙ ↦ f xₙ, x ↦ x]`.
Unlike for `total_function`, the default value is not a constant
but the identity function.
-/
protected def repr [has_repr α] : injective_function α → string
| (injective_function.map_to_self m _ _) := sformat!"[{total_function.repr_aux m}x ↦ x]"

instance (α : Type u) [has_repr α] : has_repr (injective_function α) :=
⟨ injective_function.repr ⟩

/-- Interpret a list of pairs as a total function, defaulting to
the identity function when no entries are found for a given function -/
def list.apply_id [decidable_eq α] (xs : list (α × α)) (x : α) : α :=
((xs.map prod.to_sigma).lookup x).get_or_else x

@[simp]
lemma list.apply_id_cons [decidable_eq α] (xs : list (α × α)) (x y z : α) :
  list.apply_id ((y, z) :: xs) x = if y = x then z else list.apply_id xs x :=
by simp only [list.apply_id, list.lookup, eq_rec_constant, prod.to_sigma, list.map]; split_ifs; refl

open function _root_.list _root_.prod (to_sigma)
open _root_.nat

lemma list.apply_id_zip_eq [decidable_eq α] {xs ys : list α} (h₀ : list.nodup xs)
  (h₁ : xs.length = ys.length) (x y : α) (i : ℕ)
  (h₂ : xs.nth i = some x) :
  list.apply_id.{u} (xs.zip ys) x = y ↔ ys.nth i = some y :=
begin
  induction xs generalizing ys i,
  case list.nil : ys i h₁ h₂
  { cases h₂ },
  case list.cons : x' xs xs_ih ys i h₁ h₂
  { cases i,
    { injection h₂ with h₀ h₁, subst h₀,
      cases ys,
      { cases h₁ },
      { simp only [list.apply_id, to_sigma, option.get_or_else_some, nth, lookup_cons_eq,
                   zip_cons_cons, list.map], } },
    { cases ys,
      { cases h₁ },
      { cases h₀ with _ _ h₀ h₁,
        simp only [nth, zip_cons_cons, list.apply_id_cons] at h₂ ⊢,
        rw if_neg,
        { apply xs_ih; solve_by_elim [succ.inj] },
        { apply h₀, apply nth_mem h₂ } } } }
end

lemma apply_id_mem_iff [decidable_eq α] {xs ys : list α} (h₀ : list.nodup xs)
  (h₁ : xs ~ ys)
  (x : α) :
  list.apply_id.{u} (xs.zip ys) x ∈ ys ↔ x ∈ xs :=
begin
  simp only [list.apply_id],
  cases h₃ : (lookup x (map prod.to_sigma (xs.zip ys))),
  { dsimp [option.get_or_else],
    rw h₁.mem_iff },
  { have h₂ : ys.nodup := h₁.nodup_iff.1 h₀,
    replace h₁ : xs.length = ys.length := h₁.length_eq,
    dsimp,
    induction xs generalizing ys,
    case list.nil : ys h₃ h₂ h₁
    { contradiction },
    case list.cons : x' xs xs_ih ys h₃ h₂ h₁
    { cases ys with y ys,
      { cases h₃ },
      dsimp [lookup] at h₃, split_ifs at h₃,
      { subst x', subst val,
        simp only [mem_cons_iff, true_or, eq_self_iff_true], },
      { cases h₀ with _ _ h₀ h₅,
        cases h₂ with _ _ h₂ h₄,
        have h₆ := nat.succ.inj h₁,
        specialize @xs_ih h₅ ys h₃ h₄ h₆,
        simp only [ne.symm h, xs_ih, mem_cons_iff, false_or],
        suffices : val ∈ ys, tauto!,
        erw [← option.mem_def, mem_lookup_iff] at h₃,
        simp only [to_sigma, mem_map, heq_iff_eq, prod.exists] at h₃,
        rcases h₃ with ⟨a, b, h₃, h₄, h₅⟩,
        subst a, subst b,
        apply (mem_zip h₃).2,
        simp only [nodupkeys, keys, comp, prod.fst_to_sigma, map_map],
        rwa map_fst_zip _ _ (le_of_eq h₆) } } }
end

lemma list.apply_id_eq_self [decidable_eq α] {xs ys : list α} (x : α) :
  x ∉ xs → list.apply_id.{u} (xs.zip ys) x = x :=
begin
  intro h,
  dsimp [list.apply_id],
  rw lookup_eq_none.2, refl,
  simp only [keys, not_exists, to_sigma, exists_and_distrib_right, exists_eq_right, mem_map,
             comp_app, map_map, prod.exists],
  intros y hy,
  exact h (mem_zip hy).1,
end

lemma apply_id_injective [decidable_eq α] {xs ys : list α} (h₀ : list.nodup xs)
  (h₁ : xs ~ ys) : injective.{u+1 u+1} (list.apply_id (xs.zip ys)) :=
begin
  intros x y h,
  by_cases hx : x ∈ xs;
    by_cases hy : y ∈ xs,
  { rw mem_iff_nth at hx hy,
    cases hx with i hx,
    cases hy with j hy,
    suffices : some x = some y,
    { injection this },
    have h₂ := h₁.length_eq,
    rw [list.apply_id_zip_eq h₀ h₂ _ _ _ hx] at h,
    rw [← hx, ← hy], congr,
    apply nth_injective _ (h₁.nodup_iff.1 h₀),
    { symmetry, rw h,
      rw ← list.apply_id_zip_eq; assumption },
    { rw ← h₁.length_eq,
      rw nth_eq_some at hx,
      cases hx with hx hx',
      exact hx } },
  { rw ← apply_id_mem_iff h₀ h₁ at hx hy,
    rw h at hx,
    contradiction, },
  { rw ← apply_id_mem_iff h₀ h₁ at hx hy,
    rw h at hx,
    contradiction, },
  { rwa [list.apply_id_eq_self, list.apply_id_eq_self] at h; assumption },
end

open total_function (list.to_finmap')
open sampleable

/--
Remove a slice of length `m` at index `n` in a list and a permutation, maintaining the property
that it is a permutation.
-/
def perm.slice [decidable_eq α] (n m : ℕ) :
  (Σ' xs ys : list α, xs ~ ys ∧ ys.nodup) → (Σ' xs ys : list α, xs ~ ys ∧ ys.nodup)
| ⟨xs, ys, h, h'⟩ :=
  let xs' := list.slice n m xs in
  have h₀ : xs' ~ ys.inter xs',
    from perm.slice_inter _ _ h h',
  ⟨xs', ys.inter xs', h₀, nodup_inter_of_nodup _ h'⟩

/--
A lazy list, in decreasing order, of sizes that should be
sliced off a list of length `n`
-/
def slice_sizes : ℕ → lazy_list ℕ+
| n :=
if h : 0 < n then
  have n / 2 < n, from div_lt_self h dec_trivial,
  lazy_list.cons ⟨_, h⟩ (slice_sizes $ n / 2)
else lazy_list.nil

/--
Shrink a permutation of a list, slicing a segment in the middle.

The sizes of the slice being removed start at `n` (with `n` the length
of the list) and then `n / 2`, then `n / 4`, etc down to 1. The slices
will be taken at index `0`, `n / k`, `2n / k`, `3n / k`, etc.
-/
protected def shrink_perm {α : Type} [decidable_eq α] [has_sizeof α] :
  shrink_fn (Σ' xs ys : list α, xs ~ ys ∧ ys.nodup)
| xs := do
  let k := xs.1.length,
  n ← slice_sizes k,
  i ← lazy_list.of_list $ list.fin_range $ k / n,
  have ↑i * ↑n < xs.1.length,
    from nat.lt_of_div_lt_div
      (lt_of_le_of_lt (by simp only [nat.mul_div_cancel, gt_iff_lt, fin.val_eq_coe, pnat.pos]) i.2),
  pure ⟨perm.slice (i*n) n xs,
    by rcases xs with ⟨a,b,c,d⟩; dsimp [sizeof_lt]; unfold_wf; simp only [perm.slice];
       unfold_wf; apply list.sizeof_slice_lt _ _ n.2 _ this⟩

instance [has_sizeof α] : has_sizeof (injective_function α) :=
⟨ λ ⟨xs,_,_⟩, sizeof (xs.map sigma.fst) ⟩

/--
Shrink an injective function slicing a segment in the middle of the domain and removing
the corresponding elements in the codomain, hence maintaining the property that
one is a permutation of the other.
-/
protected def shrink {α : Type} [has_sizeof α] [decidable_eq α] : shrink_fn (injective_function α)
| ⟨xs, h₀, h₁⟩ := do
  ⟨⟨xs', ys', h₀, h₁⟩, h₂⟩ ← injective_function.shrink_perm ⟨_, _, h₀, h₁⟩,
  have h₃ : xs'.length ≤ ys'.length, from le_of_eq (perm.length_eq h₀),
  have h₄ : ys'.length ≤ xs'.length, from le_of_eq (perm.length_eq h₀.symm),
  pure ⟨⟨(list.zip xs' ys').map prod.to_sigma,
    by simp only [comp, map_fst_zip, map_snd_zip, *, prod.fst_to_sigma, prod.snd_to_sigma, map_map],
    by simp only [comp, map_snd_zip, *, prod.snd_to_sigma, map_map] ⟩,
    by revert h₂; dsimp [sizeof_lt]; unfold_wf;
       simp only [has_sizeof._match_1, map_map, comp, map_fst_zip, *, prod.fst_to_sigma];
       unfold_wf; intro h₂; convert h₂ ⟩

/-- Create an injective function from one list and a permutation of that list. -/
protected def mk (xs ys : list α) (h : xs ~ ys) (h' : ys.nodup) : injective_function α :=
have h₀ : xs.length ≤ ys.length, from le_of_eq h.length_eq,
have h₁ : ys.length ≤ xs.length, from le_of_eq h.length_eq.symm,
injective_function.map_to_self (list.to_finmap' (xs.zip ys))
  (by { simp only [list.to_finmap', comp, map_fst_zip, map_snd_zip, *,
                   prod.fst_to_sigma, prod.snd_to_sigma, map_map] })
  (by { simp only [list.to_finmap', comp, map_snd_zip, *, prod.snd_to_sigma, map_map] })

protected lemma injective [decidable_eq α] (f : injective_function α) :
  injective (apply f) :=
begin
  cases f with xs hperm hnodup,
  generalize h₀ : map sigma.fst xs = xs₀,
  generalize h₁ : xs.map (@id ((Σ _ : α, α) → α) $ @sigma.snd α (λ _ : α, α)) = xs₁,
  dsimp [id] at h₁,
  have hxs : xs = total_function.list.to_finmap' (xs₀.zip xs₁),
  { rw [← h₀, ← h₁, list.to_finmap'], clear h₀ h₁ xs₀ xs₁ hperm hnodup,
    induction xs,
    case list.nil
    { simp only [zip_nil_right, map_nil] },
    case list.cons : xs_hd xs_tl xs_ih
    { simp only [true_and, to_sigma, eq_self_iff_true, sigma.eta, zip_cons_cons, list.map],
      exact xs_ih }, },
  revert hperm hnodup,
  rw hxs, intros,
  apply apply_id_injective,
  { rwa [← h₀, hxs, hperm.nodup_iff], },
  { rwa [← hxs, h₀, h₁] at hperm, },
end

instance pi_injective.sampleable_ext : sampleable_ext { f : ℤ → ℤ // function.injective f } :=
{ proxy_repr := injective_function ℤ,
  interp := λ f, ⟨ apply f, f.injective ⟩,
  sample := gen.sized $ λ sz, do
  { let xs' := int.range (-(2*sz+2)) (2*sz + 2),
    ys ← gen.permutation_of xs',
    have Hinj : injective (λ (r : ℕ), -(2*sz + 2 : ℤ) + ↑r),
      from λ x y h, int.coe_nat_inj (add_right_injective _ h),
    let r : injective_function ℤ :=
      injective_function.mk.{0} xs' ys.1 ys.2 (ys.2.nodup_iff.1 $ nodup_map Hinj (nodup_range _)) in
    pure r },
  shrink := @injective_function.shrink ℤ _ _ }

end injective_function

open function

instance injective.testable (f : α → β)
  [I : testable (named_binder "x" $
    ∀ x : α, named_binder "y" $ ∀ y : α, named_binder "H" $ f x = f y → x = y)] :
  testable (injective f) := I

instance monotone.testable [preorder α] [preorder β] (f : α → β)
  [I : testable (named_binder "x" $
    ∀ x : α, named_binder "y" $ ∀ y : α, named_binder "H" $ x ≤ y → f x ≤ f y)] :
  testable (monotone f) := I

instance antitone.testable [preorder α] [preorder β] (f : α → β)
  [I : testable (named_binder "x" $
    ∀ x : α, named_binder "y" $ ∀ y : α, named_binder "H" $ x ≤ y → f y ≤ f x)] :
  testable (antitone f) := I

end slim_check


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

! This file was ported from Lean 3 source module algebraic_geometry.Scheme
! leanprover-community/mathlib commit 06c75afebd8b612d3b20fe836424298f2387ca53
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicGeometry.Spec
import Mathbin.Algebra.Category.Ring.Constructions

/-!
# The category of schemes

A scheme is a locally ringed space such that every point is contained in some open set
where there is an isomorphism of presheaves between the restriction to that open set,
and the structure sheaf of `Spec R`, for some commutative ring `R`.

A morphism of schemes is just a morphism of the underlying locally ringed spaces.

-/

noncomputable section

open TopologicalSpace

open CategoryTheory

open TopCat

open Opposite

namespace AlgebraicGeometry

/- ./././Mathport/Syntax/Translate/Command.lean:417:11: unsupported: advanced extends in structure -/
/-- We define `Scheme` as a `X : LocallyRingedSpace`,
along with a proof that every point has an open neighbourhood `U`
so that that the restriction of `X` to `U` is isomorphic,
as a locally ringed space, to `Spec.to_LocallyRingedSpace.obj (op R)`
for some `R : CommRing`.
-/
structure Scheme extends
  "./././Mathport/Syntax/Translate/Command.lean:417:11: unsupported: advanced extends in structure" where
  local_affine :
    ∀ x : to_LocallyRingedSpace,
      ∃ (U : OpenNhds x)(R : CommRingCat),
        Nonempty
          (to_LocallyRingedSpace.restrict U.OpenEmbedding ≅ Spec.toLocallyRingedSpace.obj (op R))
#align algebraic_geometry.Scheme AlgebraicGeometry.Scheme

namespace Scheme

-- There isn't nessecarily a morphism between two schemes.
/-- A morphism between schemes is a morphism between the underlying locally ringed spaces. -/
@[nolint has_nonempty_instance]
def Hom (X Y : Scheme) : Type _ :=
  X.toLocallyRingedSpace ⟶ Y.toLocallyRingedSpace
#align algebraic_geometry.Scheme.hom AlgebraicGeometry.Scheme.Hom

/-- Schemes are a full subcategory of locally ringed spaces.
-/
instance : Category Scheme :=
  { InducedCategory.category Scheme.toLocallyRingedSpace with Hom := Hom }

/-- The structure sheaf of a Scheme. -/
protected abbrev sheaf (X : Scheme) :=
  X.toSheafedSpace.Sheaf
#align algebraic_geometry.Scheme.sheaf AlgebraicGeometry.Scheme.sheaf

/-- The forgetful functor from `Scheme` to `LocallyRingedSpace`. -/
@[simps]
def forgetToLocallyRingedSpace : Scheme ⥤ LocallyRingedSpace :=
  inducedFunctor _ deriving Full, Faithful
#align algebraic_geometry.Scheme.forget_to_LocallyRingedSpace AlgebraicGeometry.Scheme.forgetToLocallyRingedSpace

@[simp]
theorem forgetToLocallyRingedSpace_preimage {X Y : Scheme} (f : X ⟶ Y) :
    Scheme.forgetToLocallyRingedSpace.preimage f = f :=
  rfl
#align algebraic_geometry.Scheme.forget_to_LocallyRingedSpace_preimage AlgebraicGeometry.Scheme.forgetToLocallyRingedSpace_preimage

/-- The forgetful functor from `Scheme` to `Top`. -/
@[simps]
def forgetToTop : Scheme ⥤ TopCat :=
  Scheme.forgetToLocallyRingedSpace ⋙ LocallyRingedSpace.forgetToTop
#align algebraic_geometry.Scheme.forget_to_Top AlgebraicGeometry.Scheme.forgetToTop

@[simp]
theorem id_val_base (X : Scheme) : (𝟙 X : _).1.base = 𝟙 _ :=
  rfl
#align algebraic_geometry.Scheme.id_val_base AlgebraicGeometry.Scheme.id_val_base

@[simp]
theorem id_app {X : Scheme} (U : (Opens X.carrier)ᵒᵖ) :
    (𝟙 X : _).val.c.app U =
      X.Presheaf.map
        (eqToHom
          (by
            induction U using Opposite.rec
            cases U
            rfl)) :=
  PresheafedSpace.id_c_app X.toPresheafedSpace U
#align algebraic_geometry.Scheme.id_app AlgebraicGeometry.Scheme.id_app

@[reassoc.1]
theorem comp_val {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g).val = f.val ≫ g.val :=
  rfl
#align algebraic_geometry.Scheme.comp_val AlgebraicGeometry.Scheme.comp_val

@[reassoc.1, simp]
theorem comp_coeBase {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) :
    (f ≫ g).val.base = f.val.base ≫ g.val.base :=
  rfl
#align algebraic_geometry.Scheme.comp_coe_base AlgebraicGeometry.Scheme.comp_coeBase

@[reassoc.1, elementwise]
theorem comp_val_base {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) :
    (f ≫ g).val.base = f.val.base ≫ g.val.base :=
  rfl
#align algebraic_geometry.Scheme.comp_val_base AlgebraicGeometry.Scheme.comp_val_base

@[reassoc.1, simp]
theorem comp_val_c_app {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
    (f ≫ g).val.c.app U = g.val.c.app U ≫ f.val.c.app _ :=
  rfl
#align algebraic_geometry.Scheme.comp_val_c_app AlgebraicGeometry.Scheme.comp_val_c_app

theorem congr_app {X Y : Scheme} {f g : X ⟶ Y} (e : f = g) (U) :
    f.val.c.app U = g.val.c.app U ≫ X.Presheaf.map (eqToHom (by subst e)) :=
  by
  subst e
  dsimp
  simp
#align algebraic_geometry.Scheme.congr_app AlgebraicGeometry.Scheme.congr_app

theorem app_eq {X Y : Scheme} (f : X ⟶ Y) {U V : Opens Y.carrier} (e : U = V) :
    f.val.c.app (op U) =
      Y.Presheaf.map (eqToHom e.symm).op ≫
        f.val.c.app (op V) ≫ X.Presheaf.map (eqToHom (congr_arg (Opens.map f.val.base).obj e)).op :=
  by
  rw [← is_iso.inv_comp_eq, ← functor.map_inv, f.val.c.naturality, presheaf.pushforward_obj_map]
  congr
#align algebraic_geometry.Scheme.app_eq AlgebraicGeometry.Scheme.app_eq

instance is_locallyRingedSpace_iso {X Y : Scheme} (f : X ⟶ Y) [IsIso f] :
    @IsIso LocallyRingedSpace _ _ _ f :=
  forgetToLocallyRingedSpace.map_isIso f
#align algebraic_geometry.Scheme.is_LocallyRingedSpace_iso AlgebraicGeometry.Scheme.is_locallyRingedSpace_iso

@[simp]
theorem inv_val_c_app {X Y : Scheme} (f : X ⟶ Y) [IsIso f] (U : Opens X.carrier) :
    (inv f).val.c.app (op U) =
      X.Presheaf.map
          (eqToHom <| by
                rw [is_iso.hom_inv_id]
                ext1
                rfl :
              (Opens.map (f ≫ inv f).1.base).obj U ⟶ U).op ≫
        inv (f.val.c.app (op <| (Opens.map _).obj U)) :=
  by
  rw [is_iso.eq_comp_inv]
  erw [← Scheme.comp_val_c_app]
  rw [Scheme.congr_app (is_iso.hom_inv_id f), Scheme.id_app, ← functor.map_comp, eq_to_hom_trans,
    eq_to_hom_op]
  rfl
#align algebraic_geometry.Scheme.inv_val_c_app AlgebraicGeometry.Scheme.inv_val_c_app

/-- Given a morphism of schemes `f : X ⟶ Y`, and open sets `U ⊆ Y`, `V ⊆ f ⁻¹' U`,
this is the induced map `Γ(Y, U) ⟶ Γ(X, V)`. -/
abbrev Hom.appLe {X Y : Scheme} (f : X ⟶ Y) {V : Opens X.carrier} {U : Opens Y.carrier}
    (e : V ≤ (Opens.map f.1.base).obj U) : Y.Presheaf.obj (op U) ⟶ X.Presheaf.obj (op V) :=
  f.1.c.app (op U) ≫ X.Presheaf.map (homOfLE e).op
#align algebraic_geometry.Scheme.hom.app_le AlgebraicGeometry.Scheme.Hom.appLe

/-- The spectrum of a commutative ring, as a scheme.
-/
def specObj (R : CommRingCat) : Scheme
    where
  local_affine x := ⟨⟨⊤, trivial⟩, R, ⟨(Spec.toLocallyRingedSpace.obj (op R)).restrictTopIso⟩⟩
  toLocallyRingedSpace := Spec.locallyRingedSpaceObj R
#align algebraic_geometry.Scheme.Spec_obj AlgebraicGeometry.Scheme.specObj

@[simp]
theorem specObj_toLocallyRingedSpace (R : CommRingCat) :
    (specObj R).toLocallyRingedSpace = Spec.locallyRingedSpaceObj R :=
  rfl
#align algebraic_geometry.Scheme.Spec_obj_to_LocallyRingedSpace AlgebraicGeometry.Scheme.specObj_toLocallyRingedSpace

/-- The induced map of a ring homomorphism on the ring spectra, as a morphism of schemes.
-/
def specMap {R S : CommRingCat} (f : R ⟶ S) : specObj S ⟶ specObj R :=
  (Spec.locallyRingedSpaceMap f : Spec.locallyRingedSpaceObj S ⟶ Spec.locallyRingedSpaceObj R)
#align algebraic_geometry.Scheme.Spec_map AlgebraicGeometry.Scheme.specMap

@[simp]
theorem specMap_id (R : CommRingCat) : specMap (𝟙 R) = 𝟙 (specObj R) :=
  Spec.locallyRingedSpaceMap_id R
#align algebraic_geometry.Scheme.Spec_map_id AlgebraicGeometry.Scheme.specMap_id

theorem specMap_comp {R S T : CommRingCat} (f : R ⟶ S) (g : S ⟶ T) :
    specMap (f ≫ g) = specMap g ≫ specMap f :=
  Spec.locallyRingedSpaceMap_comp f g
#align algebraic_geometry.Scheme.Spec_map_comp AlgebraicGeometry.Scheme.specMap_comp

/-- The spectrum, as a contravariant functor from commutative rings to schemes.
-/
@[simps]
def spec : CommRingCatᵒᵖ ⥤ Scheme where
  obj R := specObj (unop R)
  map R S f := specMap f.unop
  map_id' R := by rw [unop_id, Spec_map_id]
  map_comp' R S T f g := by rw [unop_comp, Spec_map_comp]
#align algebraic_geometry.Scheme.Spec AlgebraicGeometry.Scheme.spec

/-- The empty scheme.
-/
@[simps]
def empty.{u} : Scheme.{u} where
  carrier := TopCat.of PEmpty
  Presheaf := (CategoryTheory.Functor.const _).obj (CommRingCat.of PUnit)
  IsSheaf := Presheaf.isSheaf_of_isTerminal _ CommRingCat.punitIsTerminal
  LocalRing x := PEmpty.elim x
  local_affine x := PEmpty.elim x
#align algebraic_geometry.Scheme.empty AlgebraicGeometry.Scheme.empty

instance : EmptyCollection Scheme :=
  ⟨empty⟩

instance : Inhabited Scheme :=
  ⟨∅⟩

/-- The global sections, notated Gamma.
-/
def Γ : Schemeᵒᵖ ⥤ CommRingCat :=
  (inducedFunctor Scheme.toLocallyRingedSpace).op ⋙ LocallyRingedSpace.Γ
#align algebraic_geometry.Scheme.Γ AlgebraicGeometry.Scheme.Γ

theorem Γ_def : Γ = (inducedFunctor Scheme.toLocallyRingedSpace).op ⋙ LocallyRingedSpace.Γ :=
  rfl
#align algebraic_geometry.Scheme.Γ_def AlgebraicGeometry.Scheme.Γ_def

@[simp]
theorem Γ_obj (X : Schemeᵒᵖ) : Γ.obj X = (unop X).Presheaf.obj (op ⊤) :=
  rfl
#align algebraic_geometry.Scheme.Γ_obj AlgebraicGeometry.Scheme.Γ_obj

theorem Γ_obj_op (X : Scheme) : Γ.obj (op X) = X.Presheaf.obj (op ⊤) :=
  rfl
#align algebraic_geometry.Scheme.Γ_obj_op AlgebraicGeometry.Scheme.Γ_obj_op

@[simp]
theorem Γ_map {X Y : Schemeᵒᵖ} (f : X ⟶ Y) : Γ.map f = f.unop.1.c.app (op ⊤) :=
  rfl
#align algebraic_geometry.Scheme.Γ_map AlgebraicGeometry.Scheme.Γ_map

theorem Γ_map_op {X Y : Scheme} (f : X ⟶ Y) : Γ.map f.op = f.1.c.app (op ⊤) :=
  rfl
#align algebraic_geometry.Scheme.Γ_map_op AlgebraicGeometry.Scheme.Γ_map_op

section BasicOpen

variable (X : Scheme) {V U : Opens X.carrier} (f g : X.Presheaf.obj (op U))

/-- The subset of the underlying space where the given section does not vanish. -/
def basicOpen : Opens X.carrier :=
  X.toLocallyRingedSpace.toRingedSpace.basicOpen f
#align algebraic_geometry.Scheme.basic_open AlgebraicGeometry.Scheme.basicOpen

@[simp]
theorem mem_basicOpen (x : U) : ↑x ∈ X.basicOpen f ↔ IsUnit (X.Presheaf.germ x f) :=
  RingedSpace.mem_basicOpen _ _ _
#align algebraic_geometry.Scheme.mem_basic_open AlgebraicGeometry.Scheme.mem_basicOpen

@[simp]
theorem mem_basicOpen_top (f : X.Presheaf.obj (op ⊤)) (x : X.carrier) :
    x ∈ X.basicOpen f ↔ IsUnit (X.Presheaf.germ (⟨x, trivial⟩ : (⊤ : Opens _)) f) :=
  RingedSpace.mem_basicOpen _ f ⟨x, trivial⟩
#align algebraic_geometry.Scheme.mem_basic_open_top AlgebraicGeometry.Scheme.mem_basicOpen_top

@[simp]
theorem basicOpen_res (i : op U ⟶ op V) : X.basicOpen (X.Presheaf.map i f) = V ⊓ X.basicOpen f :=
  RingedSpace.basicOpen_res _ i f
#align algebraic_geometry.Scheme.basic_open_res AlgebraicGeometry.Scheme.basicOpen_res

-- This should fire before `basic_open_res`.
@[simp]
theorem basicOpen_res_eq (i : op U ⟶ op V) [IsIso i] :
    X.basicOpen (X.Presheaf.map i f) = X.basicOpen f :=
  RingedSpace.basicOpen_res_eq _ i f
#align algebraic_geometry.Scheme.basic_open_res_eq AlgebraicGeometry.Scheme.basicOpen_res_eq

@[sheaf_restrict]
theorem basicOpen_le : X.basicOpen f ≤ U :=
  RingedSpace.basicOpen_le _ _
#align algebraic_geometry.Scheme.basic_open_le AlgebraicGeometry.Scheme.basicOpen_le

@[simp]
theorem preimage_basicOpen {X Y : Scheme} (f : X ⟶ Y) {U : Opens Y.carrier}
    (r : Y.Presheaf.obj <| op U) :
    (Opens.map f.1.base).obj (Y.basicOpen r) =
      @Scheme.basicOpen X ((Opens.map f.1.base).obj U) (f.1.c.app _ r) :=
  LocallyRingedSpace.preimage_basicOpen f r
#align algebraic_geometry.Scheme.preimage_basic_open AlgebraicGeometry.Scheme.preimage_basicOpen

@[simp]
theorem basicOpen_zero (U : Opens X.carrier) : X.basicOpen (0 : X.Presheaf.obj <| op U) = ⊥ :=
  LocallyRingedSpace.basicOpen_zero _ U
#align algebraic_geometry.Scheme.basic_open_zero AlgebraicGeometry.Scheme.basicOpen_zero

@[simp]
theorem basicOpen_mul : X.basicOpen (f * g) = X.basicOpen f ⊓ X.basicOpen g :=
  RingedSpace.basicOpen_mul _ _ _
#align algebraic_geometry.Scheme.basic_open_mul AlgebraicGeometry.Scheme.basicOpen_mul

theorem basicOpen_of_isUnit {f : X.Presheaf.obj (op U)} (hf : IsUnit f) : X.basicOpen f = U :=
  RingedSpace.basicOpen_of_isUnit _ hf
#align algebraic_geometry.Scheme.basic_open_of_is_unit AlgebraicGeometry.Scheme.basicOpen_of_isUnit

end BasicOpen

end Scheme

theorem basicOpen_eq_of_affine {R : CommRingCat} (f : R) :
    (Scheme.spec.obj <| op R).basicOpen ((specΓIdentity.app R).inv f) = PrimeSpectrum.basicOpen f :=
  by
  ext
  erw [Scheme.mem_basic_open_top]
  suffices IsUnit (structure_sheaf.to_stalk R x f) ↔ f ∉ PrimeSpectrum.asIdeal x by exact this
  erw [← isUnit_map_iff (structure_sheaf.stalk_to_fiber_ring_hom R x),
    structure_sheaf.stalk_to_fiber_ring_hom_to_stalk]
  exact
    (IsLocalization.AtPrime.isUnit_to_map_iff (Localization.AtPrime (PrimeSpectrum.asIdeal x))
        (PrimeSpectrum.asIdeal x) f :
      _)
#align algebraic_geometry.basic_open_eq_of_affine AlgebraicGeometry.basicOpen_eq_of_affine

@[simp]
theorem basicOpen_eq_of_affine' {R : CommRingCat}
    (f : (Spec.toSheafedSpace.obj (op R)).Presheaf.obj (op ⊤)) :
    (Scheme.spec.obj <| op R).basicOpen f = PrimeSpectrum.basicOpen ((specΓIdentity.app R).Hom f) :=
  by
  convert basic_open_eq_of_affine ((Spec_Γ_identity.app R).Hom f)
  exact (iso.hom_inv_id_apply _ _).symm
#align algebraic_geometry.basic_open_eq_of_affine' AlgebraicGeometry.basicOpen_eq_of_affine'

end AlgebraicGeometry


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import .mathlib

/-!
# Witnesses of non uniformity
-/

open_locale classical

variables {α : Type*}

namespace simple_graph
variables (G : simple_graph α)

lemma not_witness_prop {G : simple_graph α} {ε : ℝ} {U V : finset α} (h : ¬G.is_uniform ε U V) :
  ∃ U', U' ⊆ U ∧ ∃ V', V' ⊆ V ∧ ↑U.card * ε ≤ U'.card ∧ ↑V.card * ε ≤ V'.card ∧
    ε ≤ |G.edge_density U' V' - G.edge_density U V| :=
by { rw [is_uniform] at h, push_neg at h, exact h }

/-- Extracts a witness of the non-uniformity of `(U, V)`. Witnesses for `(U, V)` and `(V, U)` don't
necessarily match. Hence the motivation to define `witness_aux`. -/
noncomputable def witness_aux (ε : ℝ) (U V : finset α) : finset α × finset α :=
if h : ¬G.is_uniform ε U V
  then ((not_witness_prop h).some, (not_witness_prop h).some_spec.2.some)
  else (U, V)

/-- Extracts a witness of the non-uniformity of `(U, V)`. It uses an arbitrary ordering of
`finset α` (`well_ordering_rel`) to ensure that the witnesses of `(U, V)` and `(V, U)` are related
(the existentials don't ensure we would take the same from `¬G.is_uniform ε U V` and
`¬G.is_uniform ε V U`). -/
noncomputable def witness (ε : ℝ) (U V : finset α) : finset α :=
ite (well_ordering_rel U V) (G.witness_aux ε U V).1 (G.witness_aux ε V U).2

variables (G) {ε : ℝ} {U V : finset α}

lemma left_witness_aux_subset (h : ¬G.is_uniform ε U V) : (G.witness_aux ε U V).1 ⊆ U :=
by { rw [witness_aux, dif_pos h], apply (not_witness_prop h).some_spec.1 }

lemma left_witness_aux_card (h : ¬ G.is_uniform ε U V) :
  (U.card : ℝ) * ε ≤ (G.witness_aux ε U V).1.card :=
by { rw [witness_aux, dif_pos h], apply (not_witness_prop h).some_spec.2.some_spec.2.1 }

lemma right_witness_aux_subset (h : ¬ G.is_uniform ε U V) : (G.witness_aux ε U V).2 ⊆ V :=
by { rw [witness_aux, dif_pos h], apply (not_witness_prop h).some_spec.2.some_spec.1 }

lemma right_witness_aux_card (h : ¬ G.is_uniform ε U V) :
  (V.card : ℝ) * ε ≤ (G.witness_aux ε U V).2.card :=
by { rw [witness_aux, dif_pos h], apply (not_witness_prop h).some_spec.2.some_spec.2.2.1 }

lemma witness_aux_pair_spec (h : ¬ G.is_uniform ε U V) :
  ε ≤ |G.edge_density (G.witness_aux ε U V).1 (G.witness_aux ε U V).2 - G.edge_density U V| :=
by { rw [witness_aux, dif_pos h], apply (not_witness_prop h).some_spec.2.some_spec.2.2.2 }

lemma witness_subset (h : ¬ G.is_uniform ε U V) : G.witness ε U V ⊆ U :=
begin
  dsimp [witness],
  split_ifs,
  { apply G.left_witness_aux_subset h },
  { apply G.right_witness_aux_subset (λ i, h i.symm) },
end

lemma witness_card (h : ¬ G.is_uniform ε U V) : (U.card : ℝ) * ε ≤ (G.witness ε U V).card :=
begin
  dsimp [witness],
  split_ifs,
  { apply G.left_witness_aux_card h },
  { apply G.right_witness_aux_card (λ i, h i.symm) }
end

lemma witness_pair_spec (h₁ : U ≠ V) (h₂ : ¬ G.is_uniform ε U V) :
  ε ≤ |G.edge_density (G.witness ε U V) (G.witness ε V U) - G.edge_density U V| :=
begin
  unfold witness,
  rcases trichotomous_of well_ordering_rel U V with lt | rfl | gt,
  { rw [if_pos lt, if_neg (asymm lt)],
    exact G.witness_aux_pair_spec h₂ },
  { cases h₁ rfl },
  { rw [if_neg (asymm gt), if_pos gt, edge_density_comm, edge_density_comm _ U],
    apply G.witness_aux_pair_spec (λ i, h₂ i.symm) }
end

end simple_graph


import category_theory.epi_mono
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.finite_limits
import category_theory.limits.shapes.finite_products
-- import category.kernel_pair
import power

universes v u

open category_theory category_theory.category category_theory.limits

namespace category_theory

noncomputable theory

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

-- A relation should be mono, but we restrict this at the use site instead.
abbreviation relation (R A : C) := R ⟶ A ⨯ A

namespace relation

variables {A R : C}

abbreviation a (r : relation R A) : R ⟶ A := r ≫ limits.prod.fst
abbreviation b (r : relation R A) : R ⟶ A := r ≫ limits.prod.snd
def of_pair (f : R ⟶ A) (g : R ⟶ A) : relation R A := prod.lift f g
@[simp] lemma of_pair_a (f : R ⟶ A) (g : R ⟶ A) : (of_pair f g).a = f := prod.lift_fst _ _
@[simp] lemma of_pair_b (f : R ⟶ A) (g : R ⟶ A) : (of_pair f g).b = g := prod.lift_snd _ _

end relation

variables {A R : C} (rel : relation.{v} R A)

class reflexive :=
(r : A ⟶ R)
(cancel_a : r ≫ rel.a = 𝟙 _)
(cancel_b : r ≫ rel.b = 𝟙 _)

attribute [simp] reflexive.cancel_a reflexive.cancel_b

lemma reflexive_prop [reflexive rel] :
  reflexive.r rel ≫ rel = prod.lift (𝟙 _) (𝟙 _) :=
begin
  apply prod.hom_ext;
  simp only [assoc, prod.lift_fst, prod.lift_snd, reflexive.cancel_a, reflexive.cancel_b],
end

class symmetric :=
(s : R ⟶ R)
(w₁ : s ≫ rel.a = rel.b)
(w₂ : s ≫ rel.b = rel.a)

@[reassoc] lemma symmetric_idem [mono rel] [symmetric rel] : symmetric.s rel ≫ symmetric.s rel = 𝟙 _ :=
begin
  rw ← cancel_mono rel,
  apply prod.hom_ext;
  { simp only [assoc, id_comp, prod.lift_fst, prod.lift_snd, symmetric.w₁, symmetric.w₂] },
end
@[reassoc] lemma symmetric_pair [symmetric rel] :
  symmetric.s rel ≫ rel = prod.lift rel.b rel.a :=
begin
  apply prod.hom_ext;
  simp only [assoc, prod.lift_fst, prod.lift_snd, symmetric.w₁, symmetric.w₂],
end

-- represents triples (x,y,z) such that Rxy and Ryz
def triples : C := pullback rel.b rel.a

-- get Rxy out of the triple
def p : triples rel ⟶ R := pullback.fst
-- get Ryz out of the triple
def q : triples rel ⟶ R := pullback.snd

@[reassoc] lemma consistent : p rel ≫ rel.b = q rel ≫ rel.a := pullback.condition

/-- Show Rxz holds if Rxy and Ryz hold -/
class transitive :=
(t : triples rel ⟶ R)
(w₁ : t ≫ rel.a = p rel ≫ rel.a)
(w₂ : t ≫ rel.b = q rel ≫ rel.b)

lemma transitive_pair [transitive rel] :
  (transitive.t : triples rel ⟶ R) ≫ rel = prod.lift (p rel ≫ rel.a) (q rel ≫ rel.b) :=
begin
  apply prod.hom_ext,
  rw [assoc, prod.lift_fst, transitive.w₁],
  rw [assoc, prod.lift_snd, transitive.w₂],
end

-- Proving the note in 1.3.6(e)
instance subsingleton_reflexive [mono rel] :
  subsingleton (reflexive rel) :=
⟨begin
  rintros ⟨r₁, h₁r₁, h₂r₁⟩ ⟨r₂, h₁r₂, h₂r₂⟩,
  congr,
  rw ← cancel_mono rel,
  apply prod.hom_ext,
  { simp [h₁r₁, h₁r₂] },
  { simp [h₂r₁, h₂r₂] },
end⟩

instance subsingleton_symmetric [mono rel] :
  subsingleton (symmetric rel) :=
⟨begin
  rintros ⟨r₁, h₁r₁, h₂r₁⟩ ⟨r₂, h₁r₂, h₂r₂⟩,
  congr,
  rw ← cancel_mono rel,
  apply prod.hom_ext,
  { simp [h₁r₁, h₁r₂] },
  { simp [h₂r₁, h₂r₂] },
end⟩

instance subsingleton_transitive [mono rel] :
  subsingleton (transitive rel) :=
⟨begin
  rintros ⟨r₁, h₁r₁, h₂r₁⟩ ⟨r₂, h₁r₂, h₂r₂⟩,
  congr,
  rw ← cancel_mono rel,
  apply prod.hom_ext,
  { simp [h₁r₁, h₁r₂] },
  { simp [h₂r₁, h₂r₂] },
end⟩.

-- That was nice and easy!

section equiv_of_kernel_pair

variables {B : C} {f : A ⟶ B} {a b : R ⟶ A} (k : is_kernel_pair f a b)

instance of_kernel_pair_mono (k : is_kernel_pair f a b) : mono (relation.of_pair a b) :=
⟨λ Z g h eq, begin
  apply k.is_limit.hom_ext,
  apply (pullback_cone.mk a b _).equalizer_ext,
  { simpa [relation.of_pair] using eq =≫ limits.prod.fst },
  { simpa [relation.of_pair] using eq =≫ limits.prod.snd },
end⟩

instance (k : is_kernel_pair f a b) : reflexive (relation.of_pair a b) :=
{ r := (k.lift' (𝟙 _) (𝟙 _) rfl).1,
  cancel_a := by rw [relation.of_pair_a, (k.lift' (𝟙 _) (𝟙 _) rfl).2.1],
  cancel_b := by rw [relation.of_pair_b, (k.lift' (𝟙 _) (𝟙 _) rfl).2.2] }

instance (k : is_kernel_pair f a b) : symmetric (relation.of_pair a b) :=
{ s := (k.lift' b a k.comm.symm).1,
  w₁ := by rw [relation.of_pair_a, relation.of_pair_b, (k.lift' b a k.comm.symm).2.1],
  w₂ := by rw [relation.of_pair_a, relation.of_pair_b, (k.lift' b a k.comm.symm).2.2] }

instance (k : is_kernel_pair f a b) : transitive (relation.of_pair a b) :=
{ t :=
  begin
    apply (k.lift' (p _ ≫ (relation.of_pair a b).a) (q _ ≫ (relation.of_pair a b).b) _).1,
    have : (relation.of_pair a b).a ≫ f = (relation.of_pair a b).b ≫ f,
      simp [k.comm],
    erw [assoc, this, pullback.condition_assoc, this, assoc, assoc, assoc],
    refl,
  end,
  w₁ := by simp only [relation.of_pair_a, (k.lift' _ _ _).2.1],
  w₂ := by simp only [relation.of_pair_b, (k.lift' _ _ _).2.2] }

end equiv_of_kernel_pair

-- Now we show the converse: any equivalence relation is a kernel pair.

lemma left_pb_comm [transitive rel] :
  (transitive.t : triples rel ⟶ _) ≫ rel = prod.lift (p rel) (q rel ≫ rel.b) ≫ limits.prod.map rel.a (𝟙 _) :=
begin
  rw [prod.lift_map, comp_id, transitive_pair],
end

lemma right_pb_comm :
  q rel ≫ rel =
prod.lift (p rel) (q rel ≫ rel.b) ≫ limits.prod.map rel.b (𝟙 _) :=
begin
  rw [prod.lift_map, comp_id],
  apply prod.hom_ext,
  { rw [assoc, prod.lift_fst, consistent] },
  { rw [assoc, prod.lift_snd] }
end

local attribute [instance] has_finite_products_of_has_finite_limits
variables [has_subobject_classifier.{v} C] [cartesian_closed.{v} C]

def named [mono rel] : A ⟶ P A := hat rel

def right_pb_square [mono rel] : is_limit (pullback_cone.mk _ _ (right_pb_comm rel)) :=
is_limit.mk'' _ $ λ c,
begin
  have c₁ := c.condition =≫ limits.prod.fst,
  rw [assoc, assoc, limits.prod.map_fst] at c₁,
  have c₂ := c.condition =≫ limits.prod.snd,
  rw [assoc, assoc, limits.prod.map_snd, comp_id] at c₂,
  refine ⟨pullback.lift (c.snd ≫ limits.prod.fst) c.fst _, _, λ m m₁ m₂, _⟩,
  { rw [assoc, c₁] },
  { change pullback.lift _ _ _ ≫ prod.lift _ _ = _,
    apply prod.hom_ext,
    { rw [assoc, prod.lift_fst], apply pullback.lift_fst },
    { rw [assoc, prod.lift_snd, ← assoc, ← c₂], congr' 1, apply pullback.lift_snd } },
  { apply pullback.hom_ext,
    { erw [pullback.lift_fst, ← m₂, assoc, prod.lift_fst], refl },
    { rw pullback.lift_snd, exact m₁ } }
end

instance pbq_mono [mono rel] : mono (prod.lift (p rel) (q rel ≫ rel.b)) :=
pullback_mono_is_mono _ (right_pb_square rel)

def left_pb_square [mono rel] [symmetric rel] [transitive rel] : is_limit (pullback_cone.mk _ _ (left_pb_comm rel)) :=
is_limit.mk''' _ (category_theory.pbq_mono rel) $ λ c,
begin
  have c₁ := c.condition =≫ limits.prod.fst,
  rw [assoc, assoc, limits.prod.map_fst] at c₁,
  have c₂ := c.condition =≫ limits.prod.snd,
  rw [assoc, assoc, limits.prod.map_snd, comp_id] at c₂,
  have comm : (c.snd ≫ limits.prod.fst ≫ symmetric.s rel) ≫ rel.b = c.fst ≫ rel.a,
    rw [assoc, assoc, symmetric.w₂, c₁],
  let yRz : c.X ⟶ R := pullback.lift (c.snd ≫ limits.prod.fst ≫ symmetric.s rel) c.fst comm ≫ transitive.t,
  refine ⟨pullback.lift (c.snd ≫ limits.prod.fst) yRz _, _⟩,
  { simp only [assoc, transitive.w₁, p, pullback.lift_fst_assoc, symmetric.w₁] },
  { change _ ≫ prod.lift _ _ = _,
    apply prod.hom_ext,
    { simp only [assoc, prod.lift_fst, p, pullback.lift_fst] },
    { simp only [assoc, prod.lift_snd, q, pullback.lift_snd_assoc, transitive.w₂, c₂] } },
end

lemma relation_square_commutes [mono rel] [symmetric rel] [transitive rel] :
  rel.a ≫ named rel = rel.b ≫ named rel :=
begin
  rw [named, ← hat_natural_left, ← hat_natural_left],
  transitivity (hat (prod.lift (p rel) (q rel ≫ rel.b))),
  { apply lifting ((left_pb_square rel).lift _) (pullback.lift _ _ (left_pb_comm rel)) _ _,
    apply ((left_pb_square rel).fac _ walking_cospan.right),
    apply pullback.lift_snd },
  { apply lifting (pullback.lift _ _ (right_pb_comm rel)) ((right_pb_square rel).lift _) _ _,
    apply pullback.lift_snd,
    apply (right_pb_square rel).fac _ walking_cospan.right }
end

def makes_kernel_pair [mono rel] [reflexive rel] [symmetric rel] [transitive rel] :
  is_limit (pullback_cone.mk _ _ (relation_square_commutes rel)) :=
is_limit.mk' _ $ λ c,
begin
  have frgr : c.fst ≫ hat _ = c.snd ≫ hat _ := c.condition,
  let ab' : subq (A ⨯ A) := ⟦sub.mk' rel⟧,
  have subs : (subq.pullback (limits.prod.map c.fst (𝟙 _))).obj ab' = (subq.pullback (limits.prod.map c.snd (𝟙 _))).obj ab',
    apply name_bijection.right_inv.injective,
    change name_subobject ((subq.pullback (limits.prod.map c.fst (𝟙 _))).obj ab') = name_subobject ((subq.pullback (limits.prod.map c.snd (𝟙 _))).obj ab'),
    rw [name_pullback ab', name_pullback ab'],
    exact frgr,
  have subs2 : (subq.pullback (prod.lift c.fst c.snd)).obj ab' = (subq.pullback (prod.lift c.snd c.snd)).obj ab',
    have s₁ : prod.lift c.fst c.snd = prod.lift (𝟙 _) c.snd ≫ limits.prod.map c.fst (𝟙 _),
      rw [prod.lift_map, id_comp, comp_id],
    have s₂ : prod.lift c.snd c.snd = prod.lift (𝟙 _) c.snd ≫ limits.prod.map c.snd (𝟙 _),
      rw [prod.lift_map, id_comp, comp_id],
    rw [s₁, s₂, subq.pullback_comp, subs, subq.pullback_comp],
  have subs3 : (subq.pullback (prod.lift c.snd c.snd)).obj ab' = ⊤,
    have s₃ : prod.lift c.snd c.snd = c.snd ≫ prod.lift (𝟙 _) (𝟙 _),
      apply prod.hom_ext;
      simp only [prod.lift_fst, prod.lift_snd, assoc, comp_id],
    rw s₃,
    suffices : (subq.pullback (prod.lift (𝟙 _) (𝟙 _))).obj ab' = ⊤,
      rw [subq.pullback_comp, this, subq.pullback_top],
    rw [eq_top_iff],
    refine ⟨sub.hom_mk _ _⟩,
    refine pullback.lift (reflexive.r rel) (𝟙 _) _,
      rw [id_comp], apply reflexive_prop,
    apply pullback.lift_snd,
  rw [← subs2, eq_top_iff] at subs3,
  obtain ⟨t, ht⟩ : { t : c.X ⟶ pullback rel _ // t ≫ pullback.snd = 𝟙 _ } := raised_factors subs3,
  let u := t ≫ pullback.fst,
  have t' : u ≫ rel = prod.lift c.fst c.snd,
    rw [assoc, pullback.condition, reassoc_of ht],
  have t₁ := t' =≫ limits.prod.fst,
    rw [assoc, prod.lift_fst] at t₁,
  have t₂ := t' =≫ limits.prod.snd,
    rw [assoc, prod.lift_snd] at t₂,
  refine ⟨u, t₁, t₂, λ m m₁ m₂, _⟩,
  rw [← cancel_mono rel, t'],
  apply prod.hom_ext,
  { simpa only [assoc, prod.lift_fst] using m₁ },
  { simpa only [assoc, prod.lift_snd] using m₂ },
end

def equiv_to_kernel_pair [mono rel] [reflexive rel] [symmetric rel] [transitive rel] :
  is_kernel_pair (named rel) rel.a rel.b :=
{ comm := relation_square_commutes rel,
  is_limit := makes_kernel_pair rel }

namespace disjoint

lemma A242_commutes {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) [mono f] :
  g ≫ singleton_arrow Z = f ≫ hat (prod.lift f g) :=
begin
  rw [← seven_six_one, ← hat_natural_left],
  apply lifting (pullback.lift (𝟙 _) (prod.lift (𝟙 _) g) _) pullback.fst _ _,
  rw [id_comp, prod.lift_map, id_comp, comp_id],
  rw pullback.lift_snd,
  rw [← cancel_mono (limits.prod.map f (𝟙 _)), ← pullback.condition, assoc, prod.lift_map, id_comp, comp_id],
  apply_instance,
end

def kata_is_pullback {X Y Z U V : C} {f : X ⟶ Y} {g : X ⟶ Z} {u₁ : Y ⟶ U} {u₂ : Z ⟶ U}
  {v₁ : Y ⟶ V} {v₂ : Z ⟶ V} (hu : f ≫ u₁ = g ≫ u₂) (hv : f ≫ v₁ = g ≫ v₂)
  (is_pullback : is_limit (pullback_cone.mk _ _ hu))
  (is_pushout : is_colimit (pushout_cocone.mk _ _ hv)) :
  is_limit (pullback_cone.mk _ _ hv) :=
is_limit.mk' _ $ λ s,
begin
  let h : V ⟶ U := is_pushout.desc (pushout_cocone.mk _ _ hu),
  have hh₁ : v₁ ≫ h = u₁ := is_pushout.fac _ walking_span.left,
  have hh₂ : v₂ ≫ h = u₂ := is_pushout.fac _ walking_span.right,
  have comm : s.fst ≫ u₁ = s.snd ≫ u₂,
    rw [← hh₁, s.condition_assoc, hh₂],
  refine ⟨is_pullback.lift (pullback_cone.mk _ _ comm), is_pullback.fac _ walking_cospan.left, is_pullback.fac _ walking_cospan.right, λ m m₁ m₂, _⟩,
  apply is_pullback.hom_ext,
  apply (pullback_cone.mk f g hu).equalizer_ext,
  erw [m₁, is_pullback.fac _ walking_cospan.left], refl,
  erw [m₂, is_pullback.fac _ walking_cospan.right], refl,
end

def A242_pullback {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) [m : mono f] :
  is_limit (pullback_cone.mk _ _ (A242_commutes f g)) :=
is_limit.mk''' _ m $ λ c,
begin
  have prop : c.fst ≫ _ = c.snd ≫ hat _ := c.condition,
  rw [← seven_six_one, ← hat_natural_left] at prop,
  let π₂ : pullback (prod.lift f g) (limits.prod.map c.snd (𝟙 _)) ⟶ _ := pullback.snd,
  refine ⟨(how_inj_is_hat prop).hom ≫ pullback.fst, _⟩,
  have hq : _ ≫ π₂ = _ := very_inj prop,
  have pbc₁ : (pullback.fst ≫ _) ≫ _ = (π₂ ≫ _) ≫ _ := pullback.condition =≫ limits.prod.fst,
    rw [assoc, prod.lift_fst, assoc, limits.prod.map_fst] at pbc₁,
  erw [assoc, pbc₁, reassoc_of hq, prod.lift_fst_assoc, id_comp]
end

def A243_part1 {W X Y Z : C} {g : W ⟶ Y} {d : Y ⟶ Z} {f : W ⟶ X} {e : X ⟶ Z} [mono f] (comm : g ≫ d = f ≫ e)
  (t : is_colimit (pushout_cocone.mk _ _ comm)) : mono d :=
begin
  have : _ = singleton_arrow _ := t.fac (pushout_cocone.mk (singleton_arrow Y) (hat (prod.lift f g)) (A242_commutes _ _)) walking_span.left,
  apply mono_of_mono_fac this,
end

def A243_part2 {W X Y Z : C} {g : W ⟶ Y} {d : Y ⟶ Z} {f : W ⟶ X} {e : X ⟶ Z} [mono f] (comm : g ≫ d = f ≫ e)
  (t : is_colimit (pushout_cocone.mk _ _ comm)) : is_limit (pullback_cone.mk _ _ comm) :=
kata_is_pullback (A242_commutes _ _) _ (A242_pullback _ _) t

def pushout_coprod {A B : C} :
  is_colimit (pushout_cocone.mk coprod.inl coprod.inr (subsingleton.elim _ _) : pushout_cocone (default (⊥_ C ⟶ A)) (default (⊥_ C ⟶ B))) :=
pushout_cocone.is_colimit.mk _ _ _
  (λ s, coprod.desc s.inl s.inr)
  (λ s, coprod.inl_desc _ _)
  (λ s, coprod.inr_desc _ _) $
λ s m w₁ w₂,
begin
  apply coprod.hom_ext,
  { rwa [coprod.inl_desc] },
  { rwa [coprod.inr_desc] },
end

instance mono_coprod_inr {A B : C} : mono (coprod.inl : A ⟶ A ⨿ B) := A243_part1 _ pushout_coprod
instance mono_coprod_inl {A B : C} : mono (coprod.inr : B ⟶ A ⨿ B) :=
begin
  suffices : (coprod.inr : B ⟶ A ⨿ B) ≫ (coprod.braiding A B).hom = coprod.inl,
    exact mono_of_mono_fac this,
  simp only [coprod.inr_desc, coprod.braiding_hom]
end

def intersect_coprojections {A B : C} : pullback (coprod.inl : A ⟶ A ⨿ B) coprod.inr ≅ ⊥_ C :=
begin
  have : is_limit (pullback_cone.mk (default (⊥_ C ⟶ A)) (default (⊥_ C ⟶ B)) _) := A243_part2 _ pushout_coprod,
  apply is_limit.cone_point_unique_up_to_iso (limit.is_limit _) this,
end

end disjoint

end category_theory


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Andrew Yang
-/
import category_theory.limits.shapes.terminal
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.binary_products
import category_theory.limits.preserves.shapes.pullbacks
import category_theory.limits.preserves.shapes.terminal

/-!
# Constructing binary product from pullbacks and terminal object.

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

The product is the pullback over the terminal objects. In particular, if a category
has pullbacks and a terminal object, then it has binary products.

We also provide the dual.
-/

universes v v' u u'

open category_theory category_theory.category category_theory.limits

variables {C : Type u} [category.{v} C] {D : Type u'} [category.{v'} D] (F : C ⥤ D)

/-- If a span is the pullback span over the terminal object, then it is a binary product. -/
def is_binary_product_of_is_terminal_is_pullback (F : discrete walking_pair ⥤ C) (c : cone F)
  {X : C} (hX : is_terminal X)
  (f : F.obj ⟨walking_pair.left⟩ ⟶ X) (g : F.obj ⟨walking_pair.right⟩ ⟶ X)
  (hc : is_limit (pullback_cone.mk (c.π.app ⟨walking_pair.left⟩) (c.π.app ⟨walking_pair.right⟩ : _)
    $ hX.hom_ext (_ ≫ f) (_ ≫ g))) : is_limit c :=
{ lift := λ s, hc.lift
    (pullback_cone.mk (s.π.app ⟨walking_pair.left⟩) (s.π.app ⟨walking_pair.right⟩)
      (hX.hom_ext _ _)),
  fac' := λ s j, discrete.cases_on j
    (λ j, walking_pair.cases_on j (hc.fac _ walking_cospan.left) (hc.fac _ walking_cospan.right)),
  uniq' := λ s m J,
    begin
      let c' := pullback_cone.mk
        (m ≫ c.π.app ⟨walking_pair.left⟩) (m ≫ c.π.app ⟨walking_pair.right⟩ : _)
        (hX.hom_ext (_ ≫ f) (_ ≫ g)),
      rw [←J, ←J],
      apply hc.hom_ext,
      rintro (_|(_|_)); simp only [pullback_cone.mk_π_app_one, pullback_cone.mk_π_app],
      exacts [(category.assoc _ _ _).symm.trans (hc.fac_assoc c' walking_cospan.left f).symm,
        (hc.fac c' walking_cospan.left).symm, (hc.fac c' walking_cospan.right).symm]
    end }

/-- The pullback over the terminal object is the product -/
def is_product_of_is_terminal_is_pullback {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) (h : W ⟶ X)
  (k : W ⟶ Y) (H₁ : is_terminal Z)
  (H₂ : is_limit (pullback_cone.mk _ _ (show h ≫ f = k ≫ g, from H₁.hom_ext _ _))) :
  is_limit (binary_fan.mk h k) :=
begin
  apply is_binary_product_of_is_terminal_is_pullback _ _ H₁,
  exact H₂
end

/-- The product is the pullback over the terminal object. -/
def is_pullback_of_is_terminal_is_product {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) (h : W ⟶ X)
  (k : W ⟶ Y) (H₁ : is_terminal Z)
  (H₂ : is_limit (binary_fan.mk h k)) :
  is_limit (pullback_cone.mk _ _ (show h ≫ f = k ≫ g, from H₁.hom_ext _ _)) :=
begin
  apply pullback_cone.is_limit_aux',
  intro s,
  use H₂.lift (binary_fan.mk s.fst s.snd),
  use H₂.fac (binary_fan.mk s.fst s.snd) ⟨walking_pair.left⟩,
  use H₂.fac (binary_fan.mk s.fst s.snd) ⟨walking_pair.right⟩,
  intros m h₁ h₂,
  apply H₂.hom_ext,
  rintro ⟨⟨⟩⟩,
  { exact h₁.trans (H₂.fac (binary_fan.mk s.fst s.snd) ⟨walking_pair.left⟩).symm },
  { exact h₂.trans (H₂.fac (binary_fan.mk s.fst s.snd) ⟨walking_pair.right⟩).symm }
end

/-- Any category with pullbacks and a terminal object has a limit cone for each walking pair. -/
noncomputable def limit_cone_of_terminal_and_pullbacks [has_terminal C] [has_pullbacks C]
  (F : discrete walking_pair ⥤ C) : limit_cone F :=
{ cone :=
  { X := pullback (terminal.from (F.obj ⟨walking_pair.left⟩))
                  (terminal.from (F.obj ⟨walking_pair.right⟩)),
    π := discrete.nat_trans (λ x, discrete.cases_on x
      (λ x, walking_pair.cases_on x pullback.fst pullback.snd)) },
  is_limit := is_binary_product_of_is_terminal_is_pullback
    F _ terminal_is_terminal _ _ (pullback_is_pullback _ _) }

variable (C)

/-- Any category with pullbacks and terminal object has binary products. -/
-- This is not an instance, as it is not always how one wants to construct binary products!
lemma has_binary_products_of_has_terminal_and_pullbacks
  [has_terminal C] [has_pullbacks C] :
  has_binary_products C :=
{ has_limit := λ F, has_limit.mk (limit_cone_of_terminal_and_pullbacks F) }

variable {C}

/-- A functor that preserves terminal objects and pullbacks preserves binary products. -/
noncomputable
def preserves_binary_products_of_preserves_terminal_and_pullbacks
  [has_terminal C] [has_pullbacks C]
  [preserves_limits_of_shape (discrete.{0} pempty) F]
  [preserves_limits_of_shape walking_cospan F] :
  preserves_limits_of_shape (discrete walking_pair) F :=
⟨λ K, preserves_limit_of_preserves_limit_cone (limit_cone_of_terminal_and_pullbacks K).2
begin
  apply is_binary_product_of_is_terminal_is_pullback _ _
    (is_limit_of_has_terminal_of_preserves_limit F),
  apply is_limit_of_has_pullback_of_preserves_limit,
end⟩

/-- In a category with a terminal object and pullbacks,
a product of objects `X` and `Y` is isomorphic to a pullback. -/
noncomputable
def prod_iso_pullback [has_terminal C] [has_pullbacks C] (X Y : C) [has_binary_product X Y] :
  X ⨯ Y ≅ pullback (terminal.from X) (terminal.from Y) :=
limit.iso_limit_cone (limit_cone_of_terminal_and_pullbacks _)

/-- If a cospan is the pushout cospan under the initial object, then it is a binary coproduct. -/
def is_binary_coproduct_of_is_initial_is_pushout (F : discrete walking_pair ⥤ C) (c : cocone F)
  {X : C} (hX : is_initial X)
  (f : X ⟶ F.obj ⟨walking_pair.left⟩) (g : X ⟶ F.obj ⟨walking_pair.right⟩)
  (hc : is_colimit (pushout_cocone.mk (c.ι.app ⟨walking_pair.left⟩)
    (c.ι.app ⟨walking_pair.right⟩ : _) $ hX.hom_ext (f ≫ _) (g ≫ _))) : is_colimit c :=
{ desc := λ s, hc.desc
    (pushout_cocone.mk (s.ι.app ⟨walking_pair.left⟩) (s.ι.app ⟨walking_pair.right⟩)
      (hX.hom_ext _ _)),
  fac' := λ s j, discrete.cases_on j
    (λ j, walking_pair.cases_on j (hc.fac _ walking_span.left) (hc.fac _ walking_span.right)),
  uniq' := λ s m J,
    begin
      let c' := pushout_cocone.mk
        (c.ι.app ⟨walking_pair.left⟩ ≫ m) (c.ι.app ⟨walking_pair.right⟩ ≫ m)
        (hX.hom_ext (f ≫ _) (g ≫ _)),
      rw [←J, ←J],
      apply hc.hom_ext,
      rintro (_|(_|_));
        simp only [pushout_cocone.mk_ι_app_zero, pushout_cocone.mk_ι_app, category.assoc],
      congr' 1,
      exacts [(hc.fac c' walking_span.left).symm,
        (hc.fac c' walking_span.left).symm, (hc.fac c' walking_span.right).symm]
    end }

/-- The pushout under the initial object is the coproduct -/
def is_coproduct_of_is_initial_is_pushout {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) (h : W ⟶ X)
  (k : W ⟶ Y) (H₁ : is_initial W)
  (H₂ : is_colimit (pushout_cocone.mk _ _ (show h ≫ f = k ≫ g, from H₁.hom_ext _ _))) :
  is_colimit (binary_cofan.mk f g) :=
begin
  apply is_binary_coproduct_of_is_initial_is_pushout _ _ H₁,
  exact H₂
end

/-- The coproduct is the pushout under the initial object. -/
def is_pushout_of_is_initial_is_coproduct {W X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) (h : W ⟶ X)
  (k : W ⟶ Y) (H₁ : is_initial W)
  (H₂ : is_colimit (binary_cofan.mk f g)) :
  is_colimit (pushout_cocone.mk _ _ (show h ≫ f = k ≫ g, from H₁.hom_ext _ _)) :=
begin
  apply pushout_cocone.is_colimit_aux',
  intro s,
  use H₂.desc (binary_cofan.mk s.inl s.inr),
  use H₂.fac (binary_cofan.mk s.inl s.inr) ⟨walking_pair.left⟩,
  use H₂.fac (binary_cofan.mk s.inl s.inr) ⟨walking_pair.right⟩,
  intros m h₁ h₂,
  apply H₂.hom_ext,
  rintro ⟨⟨⟩⟩,
  { exact h₁.trans (H₂.fac (binary_cofan.mk s.inl s.inr) ⟨walking_pair.left⟩).symm },
  { exact h₂.trans (H₂.fac (binary_cofan.mk s.inl s.inr) ⟨walking_pair.right⟩).symm }
end

/-- Any category with pushouts and an initial object has a colimit cocone for each walking pair. -/
noncomputable def colimit_cocone_of_initial_and_pushouts [has_initial C] [has_pushouts C]
  (F : discrete walking_pair ⥤ C) : colimit_cocone F :=
{ cocone :=
  { X := pushout (initial.to (F.obj ⟨walking_pair.left⟩))
                  (initial.to (F.obj ⟨walking_pair.right⟩)),
    ι := discrete.nat_trans (λ x, discrete.cases_on x
      (λ x, walking_pair.cases_on x pushout.inl pushout.inr)) },
  is_colimit := is_binary_coproduct_of_is_initial_is_pushout
    F _ initial_is_initial _ _ (pushout_is_pushout _ _) }

variable (C)

/-- Any category with pushouts and initial object has binary coproducts. -/
-- This is not an instance, as it is not always how one wants to construct binary coproducts!
lemma has_binary_coproducts_of_has_initial_and_pushouts
  [has_initial C] [has_pushouts C] :
  has_binary_coproducts C :=
{ has_colimit := λ F, has_colimit.mk (colimit_cocone_of_initial_and_pushouts F) }

variable {C}

/-- A functor that preserves initial objects and pushouts preserves binary coproducts. -/
noncomputable
def preserves_binary_coproducts_of_preserves_initial_and_pushouts
  [has_initial C] [has_pushouts C]
  [preserves_colimits_of_shape (discrete.{0} pempty) F]
  [preserves_colimits_of_shape walking_span F] :
  preserves_colimits_of_shape (discrete walking_pair) F :=
⟨λ K, preserves_colimit_of_preserves_colimit_cocone (colimit_cocone_of_initial_and_pushouts K).2
begin
  apply is_binary_coproduct_of_is_initial_is_pushout _ _
    (is_colimit_of_has_initial_of_preserves_colimit F),
  apply is_colimit_of_has_pushout_of_preserves_colimit,
end⟩

/-- In a category with an initial object and pushouts,
a coproduct of objects `X` and `Y` is isomorphic to a pushout. -/
noncomputable
def coprod_iso_pushout [has_initial C] [has_pushouts C] (X Y : C) [has_binary_coproduct X Y] :
  X ⨿ Y ≅ pushout (initial.to X) (initial.to Y) :=
colimit.iso_colimit_cocone (colimit_cocone_of_initial_and_pushouts _)