/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Algdata.Init.Logic
import Algdata.Init.Order

section LawfulLE

/-
  `LE` with the axioms of pre-orderings
-/
class LawfulLE (α : Type _) extends LE α where
  refl : ∀ a, le a a
  trans : ∀ {a b c}, le a b → le b c → le a c

instance (α : Type _) [LawfulLE α] : Trans (α:=α) (β:=α) (γ:=α) (·≤·) (·≤·) (·≤·) where
  trans := LawfulLE.trans

instance instLawfulLENat : LawfulLE Nat where
  refl := Nat.le_refl
  trans := Nat.le_trans

end LawfulLE

section LawfulLT

/-!
  `LT` with the axioms of strict partial orderings
-/
class LawfulLT (α : Type _) extends LT α, Trans (α:=α) (β:=α) (γ:=α) LT.lt LT.lt LT.lt, Irreflective (α:=α) LT.lt where

attribute [instance] LawfulLT.mk

instance instLawfulLTProd (α β : Type _) [LawfulLT α] [LawfulLT β] : LawfulLT (α × β) where
  lt := Prod.lexLt
  irrefl := by
    intro (a,b); simp [LT.lt]
    apply not_or_iff_and_not.mpr
    constructor
    case left => exact Irreflective.irrefl _
    case right => intro h; exact Irreflective.irrefl b h.right
  trans := by
    intro (a₁,a₂) (b₁,b₂) (c₁,c₂); simp [LT.lt]
    intro hab hbc
    cases hab
    case inl hab1 =>
      cases hbc
      case inl hbc1 =>
        exact Or.inl $ calc
          a₁ < b₁ := hab1
          _  < c₁ := hbc1
      case inr hbc2 =>
        cases hbc2.1; exact Or.inl hab1
    case inr hab2 =>
      cases hab2.1
      cases hbc
      case inl hbc1 => exact Or.inl hbc1
      case inr hbc2 =>
        cases hbc2.1
        exact Or.inr $ And.intro rfl $ calc
          a₂ < b₂ := hab2.2
          _  < c₂ := hbc2.2

namespace LawfulLT

variable {α : Type _} [LawfulLT α]

theorem eq_or_lt_trans {a b c : α} : a = b ∨ a < b → b = c ∨ b < c → a = c ∨ a < c := by
  intro hab hbc
  cases hab
  case inl haeqb => cases haeqb; exact hbc
  case inr haltb =>
    apply Or.inr
    cases hbc
    case inl hbeqc => cases hbeqc; exact haltb
    case inr hbltc => exact trans haltb hbltc

theorem lt_of_eq_or_lt_of_lt {a b c : α} : a = b ∨ a < b → b < c → a < c := by
  intro hab hbc
  cases hab
  case inl h => cases h; exact hbc
  case inr h => exact trans h hbc

theorem lt_of_lt_of_eq_or_lt {a b c : α} : a < b → b = c ∨ b < c → a < c := by
  intro hab hbc
  cases hbc
  case inl h => cases h; exact hab
  case inr h => exact trans hab h

end /- namespace -/ LawfulLT

end /- section -/ LawfulLT

section ConnectedLT

/-
  `LT` such that `x ≲ y := ¬ y < x` defines a total preordering compatible with the original strict ordering.
-/
class ConnectedLT (α : Type _) extends LawfulLT α where
  not_gt_trans : ∀ {a b c : α}, ¬ a > b → ¬ b > c → ¬ a > c
  lt_of_lt_of_not_gt : ∀ {a b c : α}, a < b → ¬ b > c → a < c
  lt_of_not_gt_of_lt : ∀ {a b c : α}, ¬ a > b → b < c → a < c

protected
def ConnectedLT.qle {α : Type _} [ConnectedLT α] : α → α → Prop :=
  λ a b => ¬ a > b

@[reducible]
protected
def ConnectedLT.qge {α : Type _} [ConnectedLT α] : α → α → Prop :=
  λ a b => ConnectedLT.qle b a

protected
def ConnectedLT.Equiv {α : Type _} [ConnectedLT α] : α → α → Prop :=
  λ a b => ConnectedLT.qle a b ∧ ConnectedLT.qge a b

infix:50 " ≲ " => ConnectedLT.qle
infix:50 " ≳ " => ConnectedLT.qge

instance (α : Type _) [ConnectedLT α] : HasEquiv α where
  Equiv := ConnectedLT.Equiv

instance (α : Type _) [ConnectedLT α] : Trans (α:=α) (·≲·) (·<·) (·<·) where
  trans := ConnectedLT.lt_of_not_gt_of_lt

instance (α : Type _) [ConnectedLT α] : Trans (α:=α) (·<·) (·≲·) (·<·) where
  trans := ConnectedLT.lt_of_lt_of_not_gt

instance (α : Type _) [ConnectedLT α] : Trans (α:=α) (·≈·) (·<·) (·<·) where
  trans hab hbc := trans hab.left hbc

instance (α : Type _) [ConnectedLT α] : Trans (α:=α) (·<·) (·≈·) (·<·) where
  trans hab hbc := trans hab hbc.left

instance (α : Type _) [ConnectedLT α] : Trans (α:=α) (·≲·) (·≲·) (·≲·) where
  trans := ConnectedLT.not_gt_trans

instance (α : Type _) [ConnectedLT α] : Trans (α:=α) (·≈·) (·≈·) (·≈·) where
  trans hab hbc := by
    simp [HasEquiv.Equiv, ConnectedLT.Equiv, ConnectedLT.qge] at *
    apply And.intro
    case left => exact trans hab.left hbc.left
    case right => exact trans hbc.right hab.right

namespace ConnectedLT

variable {α : Type _} [ConnectedLT α]

theorem qle_of_lt {a b : α} : a < b → a ≲ b := Asymmetry.asymm _ _
theorem qge_of_gt {a b : α} : a > b → a ≳ b := Asymmetry.asymm (r:=LT.lt) _ _

theorem equiv_refl (a : α) : a ≈ a :=
  And.intro (Irreflective.irrefl (r:=LT.lt) a) (Irreflective.irrefl (r:=LT.lt) a)

theorem equiv_symm {a b : α} : a ≈ b → b ≈ a := And.comm.mp

protected
theorem subst {a₁ a₂ b₁ b₂ : α} : a₁ ≈ a₂ → b₁ ≈ b₂ → a₁ < b₁ → a₂ < b₂ := by
  intro ha hb h₁
  apply ConnectedLT.lt_of_lt_of_not_gt _ hb.left
  apply ConnectedLT.lt_of_not_gt_of_lt ha.right h₁

protected
theorem subst_right {a b₁ b₂ : α} : b₁ ≈ b₂ → a < b₁ → a < b₂ :=
  ConnectedLT.subst (equiv_refl _)

protected
theorem subst_left {a₁ a₂ b : α} : a₁ ≈ a₂ → a₁ < b → a₂ < b :=
  flip ConnectedLT.subst (equiv_refl _)

end /-namespace-/ ConnectedLT

end ConnectedLT

section LinearLT

/-
  `LT` of strict linear orderings
-/
class LinearLT (α : Type _) extends LawfulLT α, Trichotomous (α:=α) LT.lt where

namespace LinearLT

variable {α : Type _} [LinearLT α]

example : StrictLinearOrder (α:=α) (r:=LT.lt) := inferInstance
example : Asymmetry (α:=α) (r:=LT.lt) := inferInstance

theorem not_lt_iff_eq_or_gt {a b : α} : ¬ a < b ↔ (a = b ∨ a > b) where
  mp := by
    apply trichotCases (r:=LT.lt) (motive:=λ a b => ¬ a < b → a=b ∨ a > b)
    case of_rfl => exact λ _ _ => Or.inl rfl
    case of_rel => exact λ _ _ => absurd
    case of_opp => exact λ _ _ h _ => Or.inr h
  mpr := by
    intro hor hlt
    cases hor
    case inl heq => cases heq; exact Irreflective.irrefl _ hlt
    case inr hgt => exact Asymmetry.asymm _ _ hlt hgt

theorem not_gt_iff_eq_or_lt {a b : α} : ¬ a > b ↔ (a = b ∨ a < b) where
  mp hngt := Or.map Eq.symm id $ not_lt_iff_eq_or_gt.mp hngt
  mpr hor := not_lt_iff_eq_or_gt.mpr $ hor.map Eq.symm id

theorem not_eq_iff_lt_or_gt {a b : α} : a ≠ b ↔ (a < b ∨ a > b) where
  mp :=
    trichotCasesOn (r:=LT.lt) (motive:=λ a b => a ≠ b → a < b ∨ a > b) a b (λ _ hneq => absurd rfl hneq) (λ _ _ h _ => Or.inl h) (λ _ _ h _ => Or.inr h)
  mpr hor := by
    intro heq; cases heq
    cases hor
    case inl h => exact LinearLT.toLawfulLT.irrefl _ h
    case inr h => exact LinearLT.toLawfulLT.irrefl _ h

end /- namespace -/ LinearLT

instance instLinearLTPUnit : LinearLT PUnit where
  lt _ _ := False
  irrefl _ := id
  trans _ := id
  trichot | (), () => Or.inl rfl

instance instLinearLTNat : LinearLT Nat where
  irrefl := Nat.lt_irrefl
  trans := Nat.lt_trans
  trichot := Trichotomous.trichot (r:=Nat.lt)

instance instLinearLTFin (n : Nat) : LinearLT (Fin n) where
  irrefl x := Nat.lt_irrefl x.val
  trans := Nat.lt_trans
  trichot x y := by
    apply Or.map Fin.eq_of_val_eq id
    exact Trichotomous.trichot (r:=LT.lt) x.val y.val

instance instLinearLTUTF32 : LinearLT UInt32 where
  irrefl x := Nat.lt_irrefl x.val.val
  trans := Nat.lt_trans
  trichot x y  := by
    have : {x y : UInt32} → x.val = y.val → x=y := by
      intro x y hxy
      cases x; cases y; cases hxy; rfl
    apply Or.map this id
    exact Trichotomous.trichot (r:=LT.lt) x.val y.val

instance instLinearLTChar : LinearLT Char where
  irrefl c := Nat.lt_irrefl c.val.val.val
  trans := Nat.lt_trans
  trichot x y := by
    have : {x y : Char} → x.val = y.val → x=y := by
      intro x y hxy
      cases x; cases y; cases hxy; rfl
    apply Or.map this id
    exact Trichotomous.trichot (r:=LT.lt) x.val y.val

instance instLinearLTProd (α β : Type _) [LinearLT α] [LinearLT β] : LinearLT (α × β) where
  trichot := by
    intro (a₁,b₁) (a₂,b₂)
    apply trichotCasesOn (motive:=λ x y => (x,b₁) = (y,b₂) ∨ (x,b₁) < (y,b₂) ∨ (x,b₁) > (y,b₂)) LT.lt a₁ a₂
    case of_rfl =>
      intro a
      apply trichotCasesOn (motive:=λ x y => (a,x) = (a,y) ∨ (a,x) < (a,y) ∨ (a,x) > (a,y)) LT.lt b₁ b₂
      case of_rfl => intros; exact Or.inl rfl
      case of_rel => intro _ _; exact Or.inr ∘ Or.inl ∘ Or.inr ∘ And.intro rfl
      case of_opp => intro _ _; exact Or.inr ∘ Or.inr ∘ Or.inr ∘ And.intro rfl
    case of_rel => intro _ _; exact Or.inr ∘ Or.inl ∘ Or.inl
    case of_opp => intro _ _; exact Or.inr ∘ Or.inr ∘ Or.inl

instance instLinearLTList {α : Type _} [LinearLT α] : LinearLT (List α) where
  irrefl := by
    intro x hlt; induction x
    case nil => cases hlt
    case cons a as h_ind =>
      cases hlt
      case head h => exact Irreflective.irrefl a h
      case tail h => exact h_ind h
  trans := by
    intro x; induction x<;> intro y z hxy hyz
    case nil =>  cases hyz <;> exact List.lt.nil _ _
    case cons a as h_ind =>
      cases y; case nil => cases hxy
      case cons b bs =>
      cases z; case nil => cases hyz
      case cons c cs =>
      cases hxy
      case head hab =>
        apply List.lt.head
        cases hyz
        case a.head hbc => exact trans hab hbc
        case a.tail hab hbc hcb htail =>
          have := Trichotomous.eq_of_incomp ⟨hbc,hcb⟩
          exact this ▸ hab
      case tail hab hba htail =>
        have := Trichotomous.eq_of_incomp ⟨hab,hba⟩
        cases this
        cases hyz
        case head hac => exact List.lt.head _ _ hac
        case tail hac hca htail =>
          apply List.lt.tail hac hca
          exact h_ind ‹as < bs› htail
  trichot := by
    intro x; induction x <;> intro y
    case nil =>
      cases y
      case nil => exact Or.inl rfl
      case cons b bs => exact Or.inr (Or.inl (List.lt.nil _ _))
    case cons a as h_ind =>
      cases y
      case nil => exact Or.inr (Or.inr (List.lt.nil _ _))
      case cons b bs =>
        cases Trichotomous.trichot (r:=LT.lt) a b
        case inl heq =>
          cases heq
          apply Or.map (congrArg (List.cons a)) (Or.map (List.lt.tail (Irreflective.irrefl a) (Irreflective.irrefl a)) (List.lt.tail (Irreflective.irrefl a) (Irreflective.irrefl a)))
          exact h_ind bs
        case inr h =>
          cases h
          case inl hab => exact Or.inr (Or.inl (List.lt.head _ _ hab))
          case inr hba => exact Or.inr (Or.inr (List.lt.head _ _ hba))

instance instLinearLTString : LinearLT String where
  irrefl x := by cases x with | mk cs => exact Irreflective.irrefl (α:=List Char) (r:=LT.lt) cs
  trans {x} {y} {z} hxy hyz :=
    by cases x; cases y; cases z; exact Trans.trans (r:=LT.lt (α:=List Char)) (s:=LT.lt (α:=List Char)) hxy hyz
  trichot x y :=
    by cases x with | mk xs => cases y with | mk ys =>
    have : xs = ys → String.mk xs = String.mk ys := λ h => by cases h; rfl
    apply Or.imp_left this
    exact Trichotomous.trichot (r:=LT.lt (α:=List Char)) xs ys

instance instConnectedLTLinearLT (α : Type _) [LinearLT α] : ConnectedLT α where
  not_gt_trans := by
    intro a b c hab hbc
    apply LinearLT.not_gt_iff_eq_or_lt.mpr
    have hab := LinearLT.not_gt_iff_eq_or_lt.mp hab
    have hbc := LinearLT.not_gt_iff_eq_or_lt.mp hbc
    exact LawfulLT.eq_or_lt_trans hab hbc
  lt_of_not_gt_of_lt := by
    intro a b c hab hbc
    have := LinearLT.not_gt_iff_eq_or_lt.mp hab
    exact LawfulLT.lt_of_eq_or_lt_of_lt this hbc
  lt_of_lt_of_not_gt := by
    intro a b c hab hbc
    have := LinearLT.not_gt_iff_eq_or_lt.mp hbc
    exact LawfulLT.lt_of_lt_of_eq_or_lt hab this

end LinearLT


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro, Johan Commelin, Amelia Livingston, Anne Baanen
-/
import ring_theory.localization.fraction_ring
import ring_theory.localization.ideal
import ring_theory.principal_ideal_domain

/-!
# Submodules in localizations of commutative rings

## Implementation notes

See `src/ring_theory/localization/basic.lean` for a design overview.

## Tags
localization, ring localization, commutative ring localization, characteristic predicate,
commutative ring, field of fractions
-/
variables {R : Type*} [comm_ring R] (M : submonoid R) (S : Type*) [comm_ring S]
variables [algebra R S] {P : Type*} [comm_ring P]

namespace is_localization

/-- Map from ideals of `R` to submodules of `S` induced by `f`. -/
-- This was previously a `has_coe` instance, but if `S = R` then this will loop.
-- It could be a `has_coe_t` instance, but we keep it explicit here to avoid slowing down
-- the rest of the library.
def coe_submodule (I : ideal R) : submodule R S := submodule.map (algebra.linear_map R S) I

lemma mem_coe_submodule (I : ideal R) {x : S} :
  x ∈ coe_submodule S I ↔ ∃ y : R, y ∈ I ∧ algebra_map R S y = x :=
iff.rfl

lemma coe_submodule_mono {I J : ideal R} (h : I ≤ J) :
  coe_submodule S I ≤ coe_submodule S J :=
submodule.map_mono h

@[simp] lemma coe_submodule_bot : coe_submodule S (⊥ : ideal R) = ⊥ :=
by rw [coe_submodule, submodule.map_bot]

@[simp] lemma coe_submodule_top : coe_submodule S (⊤ : ideal R) = 1 :=
by rw [coe_submodule, submodule.map_top, submodule.one_eq_range]

@[simp] lemma coe_submodule_sup (I J : ideal R) :
  coe_submodule S (I ⊔ J) = coe_submodule S I ⊔ coe_submodule S J :=
submodule.map_sup _ _ _

@[simp] lemma coe_submodule_mul (I J : ideal R) :
  coe_submodule S (I * J) = coe_submodule S I * coe_submodule S J :=
submodule.map_mul _ _ (algebra.of_id R S)

lemma coe_submodule_fg
  (hS : function.injective (algebra_map R S)) (I : ideal R) :
  submodule.fg (coe_submodule S I) ↔ submodule.fg I :=
⟨submodule.fg_of_fg_map _ (linear_map.ker_eq_bot.mpr hS), submodule.fg.map _⟩

@[simp]
lemma coe_submodule_span (s : set R) :
  coe_submodule S (ideal.span s) = submodule.span R ((algebra_map R S) '' s) :=
by { rw [is_localization.coe_submodule, ideal.span, submodule.map_span], refl }

@[simp]
lemma coe_submodule_span_singleton (x : R) :
  coe_submodule S (ideal.span {x}) = submodule.span R {(algebra_map R S) x} :=
by rw [coe_submodule_span, set.image_singleton]

variables {g : R →+* P}
variables {T : submonoid P} (hy : M ≤ T.comap g) {Q : Type*} [comm_ring Q]
variables [algebra P Q] [is_localization T Q]
variables [is_localization M S]

section

include M

lemma is_noetherian_ring (h : is_noetherian_ring R) : is_noetherian_ring S :=
begin
  rw [is_noetherian_ring_iff, is_noetherian_iff_well_founded] at h ⊢,
  exact order_embedding.well_founded ((is_localization.order_embedding M S).dual) h
end

end

variables {S Q M}

@[mono]
lemma coe_submodule_le_coe_submodule (h : M ≤ non_zero_divisors R)
  {I J : ideal R} :
  coe_submodule S I ≤ coe_submodule S J ↔ I ≤ J :=
submodule.map_le_map_iff_of_injective (is_localization.injective _ h) _ _

@[mono]
lemma coe_submodule_strict_mono (h : M ≤ non_zero_divisors R) :
  strict_mono (coe_submodule S : ideal R → submodule R S) :=
strict_mono_of_le_iff_le (λ _ _, (coe_submodule_le_coe_submodule h).symm)

variables (S) {Q M}

lemma coe_submodule_injective (h : M ≤ non_zero_divisors R) :
  function.injective (coe_submodule S : ideal R → submodule R S) :=
injective_of_le_imp_le _ (λ _ _, (coe_submodule_le_coe_submodule h).mp)

lemma coe_submodule_is_principal {I : ideal R} (h : M ≤ non_zero_divisors R) :
  (coe_submodule S I).is_principal ↔ I.is_principal :=
begin
  split; unfreezingI { rintros ⟨⟨x, hx⟩⟩ },
  { have x_mem : x ∈ coe_submodule S I := hx.symm ▸ submodule.mem_span_singleton_self x,
    obtain ⟨x, x_mem, rfl⟩ := (mem_coe_submodule _ _).mp x_mem,
    refine ⟨⟨x, coe_submodule_injective S h _⟩⟩,
    rw [ideal.submodule_span_eq, hx, coe_submodule_span_singleton] },
  { refine ⟨⟨algebra_map R S x, _⟩⟩,
    rw [hx, ideal.submodule_span_eq, coe_submodule_span_singleton] }
end

variables {S} (M)
lemma mem_span_iff {N : Type*} [add_comm_group N] [module R N] [module S N] [is_scalar_tower R S N]
  {x : N} {a : set N} :
  x ∈ submodule.span S a ↔ ∃ (y ∈ submodule.span R a) (z : M), x = mk' S 1 z • y :=
begin
  split, intro h,
  { refine submodule.span_induction h _ _ _ _,
    { rintros x hx,
      exact ⟨x, submodule.subset_span hx, 1, by rw [mk'_one, _root_.map_one, one_smul]⟩ },
    { exact ⟨0, submodule.zero_mem _, 1, by rw [mk'_one, _root_.map_one, one_smul]⟩ },
    { rintros _ _ ⟨y, hy, z, rfl⟩ ⟨y', hy', z', rfl⟩,
      refine ⟨(z' : R) • y + (z : R) • y',
        (submodule.add_mem _ (submodule.smul_mem _ _ hy) (submodule.smul_mem _ _ hy')), z * z', _⟩,
      rw [smul_add, ← is_scalar_tower.algebra_map_smul S (z : R),
          ← is_scalar_tower.algebra_map_smul S (z' : R), smul_smul, smul_smul],
      congr' 1,
      { rw [← mul_one (1 : R), mk'_mul, mul_assoc, mk'_spec,
            _root_.map_one, mul_one, mul_one] },
      { rw [← mul_one (1 : R), mk'_mul, mul_right_comm, mk'_spec,
            _root_.map_one, mul_one, one_mul] },
      all_goals { apply_instance } },
    { rintros a _ ⟨y, hy, z, rfl⟩,
      obtain ⟨y', z', rfl⟩ := mk'_surjective M a,
      refine ⟨y' • y, submodule.smul_mem _ _ hy, z' * z, _⟩,
      rw [← is_scalar_tower.algebra_map_smul S y', smul_smul, ← mk'_mul,
          smul_smul, mul_comm (mk' S _ _), mul_mk'_eq_mk'_of_mul],
      all_goals { apply_instance } } },
  { rintro ⟨y, hy, z, rfl⟩,
    exact submodule.smul_mem _ _ (submodule.span_subset_span R S _ hy) }
end

lemma mem_span_map {x : S} {a : set R} :
  x ∈ ideal.span (algebra_map R S '' a) ↔
    ∃ (y ∈ ideal.span a) (z : M), x = mk' S y z :=
begin
  refine (mem_span_iff M).trans _,
  split,
  { rw ← coe_submodule_span,
    rintros ⟨_, ⟨y, hy, rfl⟩, z, hz⟩,
    refine ⟨y, hy, z, _⟩,
    rw [hz, algebra.linear_map_apply, smul_eq_mul, mul_comm, mul_mk'_eq_mk'_of_mul, mul_one] },
  { rintros ⟨y, hy, z, hz⟩,
    refine ⟨algebra_map R S y, submodule.map_mem_span_algebra_map_image _ _ hy, z, _⟩,
    rw [hz, smul_eq_mul, mul_comm, mul_mk'_eq_mk'_of_mul, mul_one] },
end

end is_localization

namespace is_fraction_ring

open is_localization

variables {R} {A K : Type*} [comm_ring A]

section comm_ring

variables [comm_ring K] [algebra R K] [is_fraction_ring R K] [algebra A K] [is_fraction_ring A K]

@[simp, mono]
lemma coe_submodule_le_coe_submodule
  {I J : ideal R} : coe_submodule K I ≤ coe_submodule K J ↔ I ≤ J :=
is_localization.coe_submodule_le_coe_submodule le_rfl

@[mono]
lemma coe_submodule_strict_mono :
  strict_mono (coe_submodule K : ideal R → submodule R K) :=
strict_mono_of_le_iff_le (λ _ _, coe_submodule_le_coe_submodule.symm)

variables (R K)

lemma coe_submodule_injective :
  function.injective (coe_submodule K : ideal R → submodule R K) :=
injective_of_le_imp_le _ (λ _ _, (coe_submodule_le_coe_submodule).mp)

@[simp]
lemma coe_submodule_is_principal {I : ideal R} :
  (coe_submodule K I).is_principal ↔ I.is_principal :=
is_localization.coe_submodule_is_principal _ le_rfl

end comm_ring

end is_fraction_ring


/-
This file contains the recursive encoding for parity.
Both the pooled and linear encodings are included here.

Authors: Cayden Codel, Jeremy Avidgad, Marijn Heule
Carnegie Mellon University
-/

import cnf.literal
import cnf.clause
import cnf.cnf
import cnf.encoding
import cnf.gensym
import parity.parity
import parity.direct_parity

import data.list.basic
import data.nat.basic

variables {V : Type*} [inhabited V] [decidable_eq V]

open literal clause cnf parity encoding gensym assignment
open nat list list.perm function

namespace recursive_parity

variables {l : list (literal V)} {g : gensym V} {k : nat} (hk : k ≥ 3) {v : V} {τ : assignment V}

lemma disjoint_fresh_of_disjoint (k : nat) : disj l g →
  disj ((Pos g.fresh.1) :: (l.drop (k - 1))) g.fresh.2 :=
begin
  intro hdis,
  apply disj_left.mpr,
  intros v hv,
  simp only [clause.vars_cons, finset.mem_union, finset.mem_singleton, var] at hv,
  rcases hv with (rfl | hv),
  { exact fresh_not_mem_fresh_stock _ },
  { exact disj_left.mp (disj_fresh_of_disj hdis)
      (((vars_subset_of_subset (drop_subset (k - 1) l)) hv)) }
end

lemma drop_len_lt (lit : literal V) (hk : k ≥ 3) :
  length l > k → length (lit :: (l.drop (k - 1))) < length l :=
begin
  intro hl,
  rcases exists_append_of_gt_length hl with ⟨x₁, x₂, rfl, hl₁⟩,
  simp only [length_cons, hl₁, length_drop, length_append],
  rw [add_comm k x₂.length, nat.add_sub_assoc (nat.sub_le k 1),
      nat.sub_sub_self (le_of_add_le_right hk), add_assoc],
  apply add_lt_add_left,
  exact succ_le_iff.mp hk,
end

variables {p : list (literal V) → list (literal V)} (hp : ∀ l, perm l (p l))

def recursive_parity : enc_fn V
| l g :=  if h : length l ≤ k then direct_parity l g else
    have length (p (Pos g.fresh.1 :: (l.drop (k - 1)))) < length l,
      from (perm.length_eq (hp (Pos g.fresh.1 :: (l.drop (k - 1))))) ▸
             (drop_len_lt _ hk (not_le.mp h)),
    ⟨(direct_parity (l.take (k - 1) ++ [(Neg g.fresh.1)]) g.fresh.2).1 ++
     (recursive_parity (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2).1,
     (recursive_parity (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2).2⟩
using_well_founded {
  rel_tac := λ a b, `[exact ⟨_, measure_wf (λ σ, list.length σ.1)⟩],
  dec_tac := tactic.assumption
}

def recursive_parity' : enc_fn V
| l g :=  if h : length l ≤ k then direct_parity l g else
    let ⟨y, g₁⟩ := g.fresh in
    have length (p (Pos y :: (l.drop (k - 1)))) < length l,
      from (perm.length_eq (hp (Pos y :: (l.drop (k - 1))))) ▸
           (drop_len_lt _ hk (not_le.mp h)),
    let ⟨Frec, g₂⟩ := recursive_parity' (p (Pos y :: (l.drop (k - 1)))) g₁ in
      ⟨(direct_parity (l.take (k - 1) ++ [Neg y]) g₁).1 ++ Frec, g₂⟩
using_well_founded {
  rel_tac := λ a b, `[exact ⟨_, measure_wf (λ σ, list.length σ.1)⟩],
  dec_tac := tactic.assumption
}

theorem recursive_parity_eq_recursive_parity' : ∀ (l : list (literal V)) (g : gensym V),
  recursive_parity hk hp l g = recursive_parity' hk hp l g :=
begin
  intros l g,
  induction l using strong_induction_on_lists with l ih generalizing g,
  rw [recursive_parity, recursive_parity'],
  by_cases hl : length l ≤ k,
  { simp [hl] },
  { simp [hl, fresh],
    rw [recursive_parity'._match_2, prod.ext_self (recursive_parity' hk hp _ _), ← ih, recursive_parity'._match_1],
    exact (perm.length_eq (hp (Pos g.fresh.1 :: (l.drop (k - 1))))) ▸
             (drop_len_lt _ hk (not_le.mp hl)) }
end

lemma tseitin_base_case : length l ≤ k → (recursive_parity hk hp l g).1 = (direct_parity l g).1 :=
assume h, by { rw recursive_parity, simp only [h, if_true] }

theorem mem_recursive_parity_vars_of_mem_vars (hdis : disj l g) :
  clause.vars l ⊆ (recursive_parity hk hp l g).1.vars :=
begin
  induction l using strong_induction_on_lists with l ih generalizing g,
  by_cases hl : length l ≤ k,
  { rw [tseitin_base_case hk hp hl, ← direct_parity_eq_direct_parity, vars_direct_parity], refl },
  { intros v hv,
    rw recursive_parity,
    simp [hl],
    rw [← take_append_drop (k - 1) l, clause.vars_append] at hv,
    rcases finset.mem_union.mp hv with (h | h),
    { left,
      rw [← direct_parity_eq_direct_parity, vars_direct_parity, clause.vars_append],
      exact finset.mem_union_left _ h },
    { rw not_le at hl,
      have h₁ := drop_len_lt (Pos g.fresh.1) hk hl,
      have h₂ := disjoint_fresh_of_disjoint k hdis,
      rw perm.length_eq (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₁,
      rw (disj_perm hp) at h₂,
      have := ih _ h₁ h₂,
      rw ← clause.vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at this,
      exact or.inr (this (mem_vars_cons_of_mem_vars _ h)) } }
end

theorem recursive_parity_is_wb : is_wb (recursive_parity hk hp) :=
begin
  intros l g hdis,
  induction l using strong_induction_on_lists with l ih generalizing g,
  rw recursive_parity,
  by_cases hl : length l ≤ k,
  { simp [hl], exact (direct_parity_encodes_parity.2 hdis) },
  { simp [hl],
    have h₁ := drop_len_lt (Pos g.fresh.1) hk (not_le.mp hl),
    rw perm.length_eq (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₁,
    have h₂ := disjoint_fresh_of_disjoint k hdis,
    rw (disj_perm hp) at h₂,
    have ihred := ih _ h₁ h₂,
    split,
    { exact subset_trans ihred.1 (fresh_stock_subset g) },
    { split,
      { rw ← direct_parity_eq_direct_parity, -- TODO: shortcut vars_direct_parity
        rw vars_direct_parity,
        rw clause.vars_append,
        intros v hv,
        rcases finset.mem_union.mp hv with (h | h),
        { exact set.mem_union_left _ (clause.vars_subset_of_subset (take_subset _ l) h) },
        { simp [literal.var] at h, subst h,
          apply set.mem_union_right,
          apply (set.mem_diff _).mpr,
          exact ⟨fresh_mem_stock _, λ hcon, (fresh_not_mem_fresh_stock g) (ihred.1 hcon)⟩ } },
      { intros v hv,
        rcases (set.mem_union v _ _).mp (ihred.2 hv) with (h | h),
        { simp [← clause.vars_perm (hp _), clause.vars, literal.var] at h,
          rcases h with (rfl | h),
          { apply set.mem_union_right _,
            apply (set.mem_diff _).mpr,
            exact ⟨fresh_mem_stock _, λ hcon, (fresh_not_mem_fresh_stock g) (ihred.1 hcon)⟩ },
          { exact set.mem_union_left _ (clause.vars_subset_of_subset (drop_subset _ l) h) } },
        { apply set.mem_union_right,
          apply (set.mem_diff _).mpr,
          exact ⟨(fresh_stock_subset g) ((set.mem_diff _).mp h).1,
                 λ hcon, (((set.mem_diff _).mp h).2) hcon⟩ } } } }
end

-- TODO: make into a shorter lemma
theorem not_mem_recursive_parity_vars_of_not_mem_vars_of_not_mem_stock (hdis : disj l g) :
  v ∉ (clause.vars l) → v ∉ g.stock → v ∉ (recursive_parity hk hp l g).1.vars :=
begin
  induction l using strong_induction_on_lists with l ih generalizing g,
  by_cases hl : length l ≤ k,
  { rw [tseitin_base_case hk hp hl, ← direct_parity_eq_direct_parity, vars_direct_parity l], tautology },
  { intros hvars hg,
    rw recursive_parity,
    simp [hl, not_or_distrib],
    split,
    { rw [← direct_parity_eq_direct_parity, vars_direct_parity, clause.vars_append],
      apply finset.not_mem_union.mpr,
      split,
      { exact (λ hcon, absurd (((vars_subset_of_subset (take_subset (k - 1) l))) hcon) hvars) },
      { simp [var],
        intro hcon,
        rw hcon at hg,
        exact absurd (fresh_mem_stock g) hg } },
    { have h₁ := drop_len_lt (Pos g.fresh.1) hk (not_le.mp hl),
      have h₂ := disjoint_fresh_of_disjoint k hdis,
      have h₃ : v ∉ clause.vars (Pos g.fresh.1 :: drop (k - 1) l),
      { simp [clause.vars, var],
        rintros (rfl | h),
        { exact hg (fresh_mem_stock g) },
        { exact hvars (vars_subset_of_subset (drop_subset (k - 1) l) h) } },
      have h₄ : v ∉ g.fresh.2.stock,
      { exact (λ hcon, hg ((fresh_stock_subset g) hcon)) },
      rw perm.length_eq (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₁,
      rw (disj_perm hp) at h₂,
      rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₃,
      exact ih _ h₁ h₂ h₃ h₄ } }
end

lemma tseitin_reverse (hdis : disj l g) :
  (recursive_parity hk hp l g).1.eval τ = tt → parity.eval τ l = tt :=
begin
  intro he,
  induction l using strong_induction_on_lists with l ih generalizing g,
  by_cases hl : length l ≤ k,
  { rw [tseitin_base_case hk hp hl, ← direct_parity_eq_direct_parity, eval_direct_parity_eq_eval_parity] at he,
    exact he },
  { rw recursive_parity at he,
    simp [hl, cnf.eval_append] at he,
    rcases he with ⟨hdir, hrec⟩,
    have h₁ := drop_len_lt (Pos g.fresh.1) hk (not_le.mp hl),
    have h₂ := disjoint_fresh_of_disjoint k hdis,
    rw perm.length_eq (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₁,
    rw (disj_perm hp) at h₂,
    have ihred := ih _ h₁ h₂ hrec,
    rw [← direct_parity_eq_direct_parity, eval_direct_parity_eq_eval_parity] at hdir,
    rw eval_eq_bodd_count_tt at ihred hdir |-,
    rw ← clause.count_tt_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at ihred,
    have := congr_arg ((clause.count_tt τ)) (take_append_drop (k - 1) l).symm,
    have := congr_arg bodd this,
    cases hnew : (τ g.fresh.1),
    { simp [clause.count_tt_cons, clause.count_tt_append, hnew, literal.eval] at ihred hdir,
      rw [clause.count_tt_append, bodd_add, hdir, ihred, ff_bxor] at this,
      exact this },
    { simp [clause.count_tt_cons, clause.count_tt_append, hnew, literal.eval] at ihred hdir,
      rw [clause.count_tt_append, bodd_add, hdir, ihred, bxor_ff] at this,
      exact this } }
end

theorem recursive_parity_encodes_parity : encodes parity (recursive_parity hk hp) :=
begin
  split,
  { intros l g hdis τ,
    induction l using strong_induction_on_lists with l ih generalizing g τ,
    by_cases hl : length l ≤ k,
    { rw tseitin_base_case hk hp hl,
      exact direct_parity_formula_encodes_parity l τ },
    { have h₁ := drop_len_lt (Pos g.fresh.1) hk (not_le.mp hl),
      rw perm.length_eq (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₁,
      have h₂ := disjoint_fresh_of_disjoint k hdis,
      rw (disj_perm hp) at h₂,
      split,
      { rw recursive_parity,
        simp [hl],
        have hnotmem := set.disjoint_left.mp hdis (g.fresh_mem_stock),
        have htakevars := vars_subset_of_subset (take_subset (k - 1) l),
        have hdropvars := vars_subset_of_subset (drop_subset (k - 1) l),
        intro heval,
        rw [eval_eq_bodd_count_tt, ← (take_append_drop (k - 1) l), clause.count_tt_append, bodd_add] at heval,
        cases hevalsub : bodd (clause.count_tt τ (take (k - 1) l)),
        { rw [hevalsub, bool.bxor_ff_left] at heval,
          rcases exists_agree_on_and_eq_of_not_mem τ ff hnotmem with ⟨γ, hagree_on, hg⟩,
          have : bodd (clause.count_tt γ (Pos g.fresh.1 :: drop (k - 1) l)) = tt,
          { simp only [clause.count_tt_cons, literal.eval, hg, cond,
              ← count_tt_eq_of_agree_on (agree_on_subset hdropvars hagree_on), heval] },
          rw [← eval_eq_bodd_count_tt, eval_eq_of_perm (hp (Pos g.fresh.1 :: drop (k - 1) l))] at this,

          -- Apply the induction hypothesis
          rcases (ih _ h₁ _ h₂).mp this with ⟨γ₂, he₂, hg₂⟩,

          have hagree_on₂ : agree_on (aite ((recursive_parity hk hp (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2).1.vars) γ₂ γ) γ (clause.vars l),
          { intros v hv,
            by_cases hmem : v ∈ clause.vars (l.drop (k - 1)),
            { have h₃ := mem_vars_cons_of_mem_vars (Pos g.fresh.1) hmem,
              rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₃,
              rw [aite_pos (mem_recursive_parity_vars_of_mem_vars hk hp h₂ h₃), hg₂ v h₃] },
            { have hdis₂ := set.disjoint_right.mp hdis hv,
              have hne : v ≠ g.fresh.1,
              { exact (λ hcon, (hcon ▸ hdis₂) (fresh_mem_stock g)) },
              have : v ∉ clause.vars (Pos g.fresh.1 :: drop (k - 1) l),
              { simp [clause.vars, var],
                rintros (hcon | hcon),
                { exact hne hcon },
                { exact hmem hcon } },
              rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at this,
              have hstock : v ∉ g.fresh.2.stock,
              { exact (λ hcon, hdis₂ ((fresh_stock_subset g) hcon)) },
              rw aite_neg (not_mem_recursive_parity_vars_of_not_mem_vars_of_not_mem_stock hk hp h₂ this hstock) } },

          use aite (recursive_parity hk hp (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2).1.vars γ₂ γ,
          split,
          { split,
            { rw ← direct_parity_eq_direct_parity,
              simp [eval_direct_parity_eq_eval_parity, eval_eq_bodd_count_tt,
              clause.count_tt_append, bodd_add, literal.eval, hg],
              have : g.fresh.1 ∈ clause.vars (Pos g.fresh.1 :: (l.drop (k - 1))),
              { exact mem_vars_cons_self _ _ },
              rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at this,
              simp [aite_pos (mem_recursive_parity_vars_of_mem_vars hk hp h₂ this),
                ← (hg₂ g.fresh.1 this), hg,
                count_tt_eq_of_agree_on (agree_on_subset htakevars hagree_on₂),
                ← count_tt_eq_of_agree_on (agree_on_subset htakevars hagree_on), hevalsub] },
            { exact he₂ ▸ eval_eq_of_agree_on (aite_agree_on _ _ _) } },
          { exact agree_on.trans hagree_on (hagree_on₂.symm) } },
        { simp only [hevalsub, bnot_eq_true_eq_eq_ff, tt_bxor] at heval,
          rcases exists_agree_on_and_eq_of_not_mem τ tt hnotmem with ⟨γ, hagree_on, hg⟩,
          have : bodd (clause.count_tt γ (Pos g.fresh.1 :: drop (k - 1) l)) = tt,
          { simp only [clause.count_tt_cons, literal.eval, hg, cond,
              ← count_tt_eq_of_agree_on (agree_on_subset hdropvars hagree_on), heval, bodd_succ,
              bodd_add, bodd_zero, bool.bnot_ff, bxor_tt_left], },
          rw [← eval_eq_bodd_count_tt, eval_eq_of_perm (hp (Pos g.fresh.1 :: drop (k - 1) l))] at this,

          -- Apply the induction hypothesis
          rcases (ih _ h₁ _ h₂).mp this with ⟨γ₂, he₂, hg₂⟩,

          have hagree_on₂ : agree_on (aite (recursive_parity hk hp (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2).1.vars γ₂ γ) γ (clause.vars l),
          { intros v hv,
            by_cases hmem : v ∈ clause.vars (l.drop (k - 1)),
            { have h₃ := mem_vars_cons_of_mem_vars (Pos g.fresh.1) hmem,
              rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at h₃,
              rw [aite_pos (mem_recursive_parity_vars_of_mem_vars hk hp h₂ h₃), hg₂ v h₃] },
            { have hdis₂ := set.disjoint_right.mp hdis hv,
              have hne : v ≠ g.fresh.1,
              { exact (λ hcon, (hcon ▸ hdis₂) (fresh_mem_stock g)) },
              have : v ∉ clause.vars (Pos g.fresh.1 :: drop (k - 1) l),
              { simp [clause.vars, var],
                rintros (hcon | hcon),
                { exact hne hcon },
                { exact hmem hcon } },
              rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at this,
              have hstock : v ∉ g.fresh.2.stock,
              { exact (λ hcon, hdis₂ ((fresh_stock_subset g) hcon)) },
              rw aite_neg (not_mem_recursive_parity_vars_of_not_mem_vars_of_not_mem_stock hk hp h₂ this hstock) } },

          use aite (recursive_parity hk hp (p (Pos g.fresh.1 :: (l.drop (k - 1)))) g.fresh.2).1.vars γ₂ γ,
          split,
          { split,
            { rw ← direct_parity_eq_direct_parity,
              simp [eval_direct_parity_eq_eval_parity, eval_eq_bodd_count_tt,
                clause.count_tt_append, bodd_add, literal.eval, hg],
              have : g.fresh.1 ∈ clause.vars (Pos g.fresh.1 :: (l.drop (k - 1))),
              { exact mem_vars_cons_self _ _ },
              rw vars_perm (hp (Pos g.fresh.1 :: drop (k - 1) l)) at this,
              simp [aite_pos (mem_recursive_parity_vars_of_mem_vars hk hp h₂ this),
                ← (hg₂ g.fresh.1 this), hg,
                count_tt_eq_of_agree_on (agree_on_subset htakevars hagree_on₂),
                ← count_tt_eq_of_agree_on (agree_on_subset htakevars hagree_on), hevalsub] },
            { exact he₂ ▸ eval_eq_of_agree_on (aite_agree_on _ _ _) } },
        { exact agree_on.trans hagree_on hagree_on₂.symm } } },
      { rintros ⟨σ, heval, hagree_on⟩,
        rw parity.eval_eq_of_agree_on hagree_on,
        exact tseitin_reverse hk hp hdis heval } } },
  { exact recursive_parity_is_wb hk hp }
end

def linear_perm (l : list (literal V)) : list (literal V) := l

lemma linear_perm_is_perm : ∀ (l : list (literal V)), l ~ linear_perm l :=
begin
  intro l, rw linear_perm
end

def linear_parity : enc_fn V := recursive_parity hk linear_perm_is_perm

theorem linear_parity_encodes_parity : encodes parity (linear_parity hk : enc_fn V) :=
recursive_parity_encodes_parity hk linear_perm_is_perm

def pooled_perm : list (literal V) → list (literal V)
| []        := []
| (x :: xs) := xs ++ [x]

lemma pooled_perm_is_perm : ∀ (l : list (literal V)), l ~ pooled_perm l :=
begin
  intro l,
  cases l,
  { refl },
  { rw [pooled_perm, ← singleton_append],
    exact perm_append_comm }
end

def pooled_parity : enc_fn V := recursive_parity hk pooled_perm_is_perm

theorem pooled_parity_encodes_parity : encodes parity (pooled_parity hk : enc_fn V) :=
recursive_parity_encodes_parity hk pooled_perm_is_perm

end recursive_parity


import Categories.Product
import Categories.Initial

set_option autoImplicit false

namespace Mathematics

def isCocone {J C : Category} (F : Functor J C) (c : C.obj) :=
{ ψ : Π x, Hom C (F x) c // ∀ {i j : J.obj} (f : Hom J i j), ψ j ∘ F.map f = ψ i }

def Cocone.relative {J C : Category} (F : Functor J C) :=
Σ (c : C.obj), isCocone F c

notation F "-cocone" => Cocone.relative F

def isColimit {J C : Category} {F : Functor J C} (L : F-cocone) :=
∀ (N : F-cocone), ∃! (u : Hom C L.1 N.1), ∀ x, u ∘ L.2.val x = N.2.val x

def Cocone (J C : Category) :=
Σ (w : Functor J C × C.obj), isCocone w.1 w.2

def Cocone.cone {J C : Category} (L : Cocone J C) : L.1.1-cocone := ⟨L.1.2, L.2⟩

section
  variable {J C : Category}

  def Cocone.mor (D₁ D₂ : Cocone J C) :=
  { ε : Hom C D₁.1.2 D₂.1.2 × Natural D₁.1.1 D₂.1.1 // ∀ (i : J.obj), ε.1 ∘ D₁.2.val i = D₂.2.val i ∘ ε.2 i }

  def Cocone.id (D : Cocone J C) : Cocone.mor D D :=
  ⟨(C.id D.1.2, Natural.id D.1.1), λ _, begin simp [Natural.id]; rw [C.lid, C.rid] end⟩

  def Cocone.com {D₁ D₂ D₃ : Cocone J C} (f : Cocone.mor D₂ D₃) (g : Cocone.mor D₁ D₂) : Cocone.mor D₁ D₃ :=
  ⟨(f.1.1 ∘ g.1.1, Natural.vert f.1.2 g.1.2), λ x, begin rw [C.assoc, g.property x, ←C.assoc, f.property x]; apply C.assoc end⟩

  lemma Cocone.lid {D₁ D₂ : Cocone J C} (f : Cocone.mor D₁ D₂) : Cocone.com (Cocone.id D₂) f = f :=
  begin apply Subtype.eq; apply congr₂; apply C.lid; apply Natural.lid end

  lemma Cocone.rid {D₁ D₂ : Cocone J C} (f : Cocone.mor D₁ D₂) : Cocone.com f (Cocone.id D₁) = f :=
  begin apply Subtype.eq; apply congr₂; apply C.rid; apply Natural.rid end

  lemma Cocone.assoc {D₁ D₂ D₃ D₄ : Cocone J C} (f : Cocone.mor D₃ D₄) (g : Cocone.mor D₂ D₃) (h : Cocone.mor D₁ D₂) :
    Cocone.com (Cocone.com f g) h = Cocone.com f (Cocone.com g h) :=
  begin apply Subtype.eq; apply congr₂; apply C.assoc; apply Natural.assoc end
end

def Cocone.category (J C : Category) : Category :=
{ obj   := Cocone J C,
  hom   := Cocone.mor,
  id    := Cocone.id,
  com   := Cocone.com,
  lid   := Cocone.lid,
  rid   := Cocone.rid,
  assoc := Cocone.assoc }

notation "𝐶𝑜𝑐𝑜𝑛𝑒" => Cocone.category

class HasColimits (J C : Category) :=
(colim    : Functor J C → C.obj)
(cone     : ∀ F, isCocone F (colim F))
(property : ∀ F, isColimit ⟨colim F, cone F⟩)

open HasColimits (colim)

def colimInitial {J C : Category} {F : Functor J C} {L : F-cocone} (H₁ : ∀ x, isInitial C (F x)) (H₂ : isColimit L) : isInitial C L.1 :=
begin
  intro c; let N : F-cocone := ⟨c, ⟨λ _, (H₁ _ _).inh, λ _, (H₁ _ _).prop _ _⟩⟩; constructor; apply (H₂ N).val;
  { intro f g; apply Eq.trans; apply Eq.symm; repeat { apply (H₂ N).property.right; intros; apply (H₁ _ _).prop } }
end

def colimZero {J C : Category} {ε : C.obj} {L : (@Δ J C ε)-cocone} (H₁ : isInitial C ε) (H₂ : isColimit L) : isInitial C L.1 :=
begin apply colimInitial; intro; apply H₁; exact H₂ end

def Cocone.initial {J C : Category} {L : Cocone J C} (H₁ : isInitial C L.1.2) (H₂ : ∀ x, isInitial C (L.1.1 x)) : isInitial (𝐶𝑜𝑐𝑜𝑛𝑒 J C) L :=
begin
  intro c; constructor; apply Subtype.mk (_, _) _; apply (H₁ _).inh;
  { apply Subtype.mk _ _; intro; apply (H₂ _ _).inh; intros; apply (H₂ _ _).prop };
  { intro; apply (H₂ _ _).prop };
  { intro f g; apply Subtype.eq; apply Prod.eq; apply (H₁ _).prop;
    apply Subtype.eq; funext _; apply (H₂ _ _).prop }
end

def Cocone.iso {J C : Category} {D₁ D₂ : Cocone J C} (φ : D₁.1.2 ≅ D₂.1.2) (ψ : Functor.iso D₁.1.1 D₂.1.1)
  (H : ∀ i, φ.1 ∘ D₁.2.1 i = D₂.2.1 i ∘ ψ.1.1 i) (G : ∀ i, φ.2.1 ∘ D₂.2.1 i = D₁.2.1 i ∘ ψ.2.1 i) : @Iso (𝐶𝑜𝑐𝑜𝑛𝑒 J C) D₁ D₂ :=
begin
  apply Sigma.mk _ _; { apply Subtype.mk (φ.1, ψ.1) _; intro; apply H };
  apply Subtype.mk _ _; { apply Subtype.mk (φ.2.1, ψ.2.1) _; intro; apply G };
  constructor <;> apply Subtype.eq <;> apply Prod.eq;
  apply φ.2.2.left; apply ψ.2.2.left; apply φ.2.2.right; apply ψ.2.2.right
end

namespace HasColimits
  variable {J C : Category} [HasColimits J C] (F : Functor J C) (L : F-cocone)

  def recur : Hom C (colim F) L.1 :=
  (HasColimits.property F L).1

  def recurβ : ∀ x, recur F L ∘ (cone F).1 x = L.2.1 x :=
  (HasColimits.property F L).2.1

  def uniq : ∀ (u : Hom C (colim F) L.1), (∀ x, u ∘ (cone F).1 x = L.2.1 x) → recur F L = u :=
  (HasColimits.property F L).2.2

  def prop (u₁ u₂ : Hom C (colim F) L.1) (h₁ : ∀ x, u₁ ∘ (cone F).1 x = L.2.1 x) (h₂ : ∀ x, u₂ ∘ (cone F).1 x = L.2.1 x) : u₁ = u₂ :=
  Eq.trans (Eq.symm (uniq F L u₁ h₁)) (uniq F L u₂ h₂)
end HasColimits

def colimitUniq {J C : Category} (F : Functor J C) (c₁ c₂ : F-cocone) : isColimit c₁ → isColimit c₂ → c₁.1 ≅ c₂.1 :=
begin
  intro h₁ h₂; exists (h₁ c₂).1; exists (h₂ c₁).1; constructor;
  { apply Eq.trans; apply Eq.symm; apply (h₂ c₂).2.2;
    { intro x; apply Eq.symm; apply Eq.trans; apply Eq.symm; apply (h₁ c₂).2.1 x;
      rw [C.assoc]; apply congrArg; apply Eq.symm; apply (h₂ c₁).2.1 };
    { apply (h₂ c₂).2.2; intro; apply C.lid } };
  { apply Eq.trans; apply Eq.symm; apply (h₁ c₁).2.2;
    { intro x; apply Eq.symm; apply Eq.trans; apply Eq.symm; apply (h₂ c₁).2.1 x;
      rw [C.assoc]; apply congrArg; apply Eq.symm; apply (h₁ c₂).2.1 };
    { apply (h₁ c₁).2.2; intros; apply C.lid } }
end

section
  variable {J C : Category} [HasCoproducts C] [HasColimits J C] (F G : Functor J C)

  def coneAdd : isCocone (Functor.add F G) (colim F + colim G) :=
  ⟨λ x, madd ((HasColimits.cone F).1 x) ((HasColimits.cone G).1 x),
   begin
     intros; apply Eq.trans; apply maddRec;
     apply congr₂ <;> rw [C.assoc] <;> apply congrArg;
     apply (HasColimits.cone F).2; apply (HasColimits.cone G).2
   end⟩

  open HasCoproducts (inl inr)

  def sumOfColimits : isColimit ⟨colim F + colim G, coneAdd F G⟩ :=
  begin
    intro N; apply Subtype.mk _ _;
    { apply HasCoproducts.recur;
      { apply HasColimits.recur F ⟨_, ⟨λ x, N.2.1 x ∘ inl _ _, _⟩⟩;
        intros i j f; rw [C.assoc, ←maddInl (F.map f) (G.map f), ←C.assoc];
        apply congrArg (· ∘ inl _ _); apply N.2.2 };
      { apply HasColimits.recur G ⟨_, ⟨λ x, N.2.1 x ∘ inr _ _, _⟩⟩;
        intros i j f; rw [C.assoc, ←maddInr (F.map f) (G.map f), ←C.assoc];
        apply congrArg (· ∘ inr _ _); apply N.2.2 } }; constructor;
    { intro x; apply Eq.trans; apply maddRec; apply HasCoproducts.uniq <;>
      apply Eq.symm <;> apply HasColimits.recurβ };
    { intro φ H; apply HasCoproducts.uniq <;> apply Eq.symm <;>
      apply HasColimits.uniq <;> intro x <;> simp [*] <;> rw [← H x] <;>
      rw [C.assoc, C.assoc] <;> apply congrArg <;> apply Eq.symm;
      apply maddInl; apply maddInr }
  end

  def colimAdd : colim F + colim G ≅ colim (Functor.add F G) :=
  colimitUniq (Functor.add F G)
    ⟨colim F + colim G, coneAdd F G⟩
    ⟨colim (Functor.add F G), HasColimits.cone _⟩
    (sumOfColimits F G) (HasColimits.property _)
end


import YatimaStdLib.List
import YatimaStdLib.UInt

namespace ByteArray

/-- Read Nat from Little-Endian ByteArray -/
def asLEtoNat (b : ByteArray) : Nat :=
  b.data.data.enum.foldl (init := 0)
    fun acc (i, bᵢ) => acc + bᵢ.toNat.shiftLeft (i * 8)

/-- Read Nat from Big-Endian ByteArray -/
def asBEtoNat (b : ByteArray) : Nat :=
  b.data.data.foldl (init := 0) fun acc bᵢ => acc.shiftLeft 8 + bᵢ.toNat

/-- Returns the index of -/
def leadingZeroBits (bytes : ByteArray) : Nat := Id.run do
  let mut c := 0
  for byte in bytes do
    let zs := 8 - byte.toNat.sigBits
    if byte != 0
    then return c + zs
    else c := c + zs
  return c

/-- Appends `n` bytes of `0`s to a `ByteArray` -/
def pushZeros (bytes : ByteArray) (n : Nat) : ByteArray :=
  bytes ++ ⟨.mkArray n 0⟩

def beqL (a b : ByteArray) : Bool :=
  a.data == b.data

@[extern "lean_byte_array_beq"]
def beq : @& ByteArray → @& ByteArray → Bool :=
  beqL

def ordL (a b : ByteArray) : Ordering :=
  compare a.data.data b.data.data

@[extern "lean_byte_array_ord"]
def ord : @& ByteArray → @& ByteArray → Ordering :=
  ordL

instance : BEq ByteArray := ⟨ByteArray.beq⟩
instance : Ord ByteArray := ⟨ByteArray.ord⟩

instance : DecidableEq ByteArray
  | a, b => match decEq a.data b.data with
    | isTrue h₁  => isTrue $ congrArg ByteArray.mk h₁
    | isFalse h₂ => isFalse $ fun h => by cases h; exact (h₂ rfl)

def Subarray.asBA (s : Subarray UInt8) : ByteArray :=
  s.as.data.toByteArray

def toString (bs : ByteArray) : String := Id.run do
  if bs.isEmpty then "b[]" else
  let mut ans := "b["
  for u in bs do
    ans := ans ++ UInt8.showBits u ++ ","
  return ans.dropRight 1 ++ "]"

def toHexString (bs : ByteArray) : String := Id.run do
  if bs.isEmpty then "b[]" else
  let mut ans := "b["
  for u in bs do
    ans := ans ++ UInt8.toHexString u ++ ", "
  return ans.dropRight 2 ++ "]"

instance : Repr ByteArray where
  reprPrec bs _ := toString bs

def padLeft (bs : ByteArray) (u : UInt8) : Nat → ByteArray
  | 0 => bs
  | n + 1 => ByteArray.mk #[u] ++ padLeft bs u n

def getD (bs : ByteArray) (idx : Nat) (defaultValue : UInt8) : UInt8 :=
  bs.data.getD idx defaultValue

def getBit (bs : ByteArray) (n : Nat) : Bit :=
  let (idx, rem) := (n / 8, n % 8)
  UInt8.getBit (getD bs idx 0) rem

/--
Shifts the byte array left by 1 bit, preserves length (so in particular kills the
first coefficient
-/
def shiftLeft (bs : ByteArray) : ByteArray := Id.run do
  let mut answer : ByteArray := .mkEmpty bs.size
  for idx in [:bs.size] do
    answer := answer.push <|
      (getD bs idx 0 <<< 1 : UInt8) + (getD bs (idx + 1) 0 >>> 7 : UInt8)
  answer

/-- Shift the `ByteArray` right by `n` bytes by prepending the `n`-length array of `0`s -/
def shiftRight8n (bs : ByteArray) (n : Nat) := ⟨.mkArray n 0⟩ ++ bs

def shiftAdd (bs : ByteArray) (b : Bit) : ByteArray :=
  let ans := shiftLeft bs
  ans.set! (ans.size - 1) ((getD ans (ans.size - 1) 0) + b.toUInt8)

def sliceL (bs : ByteArray) (i n : Nat) : ByteArray :=
  let rec aux (acc : Array UInt8) : Nat → List UInt8 → Array UInt8
    | 0, _ => acc
    | n, [] => acc ++ (.mkArray n 0)
    | n + 1, b :: bs => aux (acc.push b) n bs
  .mk $ aux #[] n (bs.data.data.drop i)

@[extern "lean_byte_array_slice"]
def slice : @& ByteArray → Nat → Nat → ByteArray :=
  sliceL

theorem sliceL.aux_size : (sliceL.aux acc n bs).size = acc.size + n := by
  induction bs generalizing acc n
  · induction n <;> simp [sliceL.aux, ByteArray.size, Array.size]
  rename_i ih
  cases n
  · simp [sliceL.aux]
  simp [sliceL.aux, ByteArray.size, ih]
  rw [Nat.succ_eq_add_one, Nat.add_assoc, Nat.add_comm 1 _]

theorem slice_size : (slice bytes i n).size = n := by
  simp [slice, sliceL, sliceL.aux, sliceL.aux_size, ByteArray.size]

theorem set_size : (set arr i u).size = arr.size := by
  simp [size, set]

theorem set!_size : (set! arr i u).size = arr.size := by
  simp [size, set!, Array.set!, Array.setD]
  by_cases h : i < arr.data.size <;> simp [h]

/-
In this section we define Arithmetic on ByteArrays viewed as natural numbers encoded in
little-endian form
-/

section arithmetic

def uInt8OverFlowMul (u₁ u₂ : UInt8) : UInt8 × UInt8 :=
  let u16 := u₁.toUInt16 * u₂.toUInt16
  (u16 >>> 8 |>.toUInt8, u16.toUInt8)

private def uInt8OverFlowAdd (u₁ u₂ : UInt8) : UInt8 × UInt8 :=
  let u16 := u₁.toUInt16 + u₂.toUInt16
  (u16 >>> 8 |>.toUInt8, u16.toUInt8)

def uInt8Mul (x : ByteArray) (u : UInt8) : ByteArray := Id.run do
  let mut carry: UInt8 := 0
  let mut answer: ByteArray := default

  for uX in x do
    let (carry1, res') := uInt8OverFlowMul uX u
    let (carry2, res) := uInt8OverFlowAdd carry res'
    answer := answer.push res
    carry := carry1 + carry2

  answer := if carry == 0 then answer else answer.push carry
  return answer

instance : HMul ByteArray UInt8 ByteArray where
  hMul := uInt8Mul

def add (x y : ByteArray) : ByteArray := Id.run do
  let mut res := default
  let mut cin := 0
  let n := max x.size y.size

  for i in [0 : n] do
    let (r, o) := UInt8.sum3 cin (x.getD i 0) (y.getD i 0)
    res := res.push r
    cin := o

  res := if cin == 0 then res else res.push cin
  return res

instance : Add ByteArray where
  add := add

def sub (x y : ByteArray) : ByteArray := Id.run do
  let mut res := default
  let mut cin := 0
  let n := max x.size y.size

  for i in [0 : n] do
    let xi := x.getD i 0
    let yi := y.getD i 0
    if xi < yi + cin then
      let diff := (255 - yi - cin) + xi + 1
      res := res.push diff
      cin := 1 else
      let diff := xi - yi - cin
      res := res.push diff
      cin := 0

  return res

instance : Sub ByteArray where
  sub := sub

/-- "naiive" multiplication of two ByteArrays -/
def nmul (x y : ByteArray) : ByteArray := Id.run do
  let mut answer: ByteArray := default
  let mut idx := 0

  for u in x do
    let temp := y * u
    answer := answer + temp.shiftRight8n idx
    idx := idx + 1

  answer

/-- Karatsuba multiplication of two ByteArrays -/
partial def kmul (x y : ByteArray) : ByteArray :=
  let n := max x.size y.size
  if n ≤ 8 then nmul x y else
    let low := n / 2
    let high := n - low
    let xLow := x.slice 0 low
    let yLow := y.slice 0 low
    let xHigh := x.slice low high
    let yHigh := y.slice low high
    let xMid := xHigh + xLow
    let yMid := yHigh + yLow
    let lowMul := kmul xLow yLow
    let highMul := kmul xHigh yHigh
    let midMul := kmul xMid yMid - highMul - lowMul
    highMul.shiftRight8n (2 * high) + midMul.shiftRight8n high + lowMul

instance : Mul ByteArray where
  mul := kmul

end arithmetic

end ByteArray


/-
Copyright (c) 2022 Moritz Doll. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Moritz Doll, Mario Carneiro, Robert Y. Lewis
-/
import Mathlib.Tactic.Basic
import Mathlib.Tactic.NormCast
import Mathlib.Tactic.Qify.Attr
import Mathlib.Tactic.Zify
import Mathlib.Data.Rat.Cast

/-!
# `qify` tactic

The `qify` tactic is used to shift propositions from `ℕ` or `ℤ` to `ℚ`.
This is often useful since `ℚ` has well-behaved division.
```
example (a b c x y z : ℕ) (h : ¬ x*y*z < 0) : c < a + 3*b := by
  qify
  qify at h
  /-
  h : ¬↑x * ↑y * ↑z < 0
  ⊢ ↑c < ↑a + 3 * ↑b
  -/
  sorry
```
-/

namespace Mathlib.Tactic.Qify

open Lean
open Lean.Meta
open Lean.Parser.Tactic
open Lean.Elab.Tactic

/--
The `qify` tactic is used to shift propositions from `ℕ` or `ℤ` to `ℚ`.
This is often useful since `ℚ` has well-behaved division.
```
example (a b c x y z : ℕ) (h : ¬ x*y*z < 0) : c < a + 3*b := by
  qify
  qify at h
  /-
  h : ¬↑x * ↑y * ↑z < 0
  ⊢ ↑c < ↑a + 3 * ↑b
  -/
  sorry
```
`qify` can be given extra lemmas to use in simplification. This is especially useful in the
presence of nat subtraction: passing `≤` arguments will allow `push_cast` to do more work.
```
example (a b c : ℤ) (h : a / b = c) (hab : b ∣ a) (hb : b ≠ 0) : a = c * b := by
  qify [hab] at h hb ⊢
  exact (div_eq_iff hb).1 h
```
`qify` makes use of the `@[zify_simps]` and `@[qify_simps]` attributes to move propositions,
and the `push_cast` tactic to simplify the `ℚ`-valued expressions. -/
syntax (name := qify) "qify" (simpArgs)? (ppSpace location)? : tactic

macro_rules
| `(tactic| qify $[[$simpArgs,*]]? $[at $location]?) =>
  let args := simpArgs.map (·.getElems) |>.getD #[]
  `(tactic|
    simp (config := {decide := false}) only [zify_simps, qify_simps, push_cast, $args,*]
      $[at $location]?)

@[qify_simps] lemma int_cast_eq (a b : ℤ) : a = b ↔ (a : ℚ) = (b : ℚ) := by simp only [Int.cast_inj]
@[qify_simps] lemma int_cast_le (a b : ℤ) : a ≤ b ↔ (a : ℚ) ≤ (b : ℚ) := Int.cast_le.symm
@[qify_simps] lemma int_cast_lt (a b : ℤ) : a < b ↔ (a : ℚ) < (b : ℚ) := Int.cast_lt.symm
@[qify_simps] lemma int_cast_ne (a b : ℤ) : a ≠ b ↔ (a : ℚ) ≠ (b : ℚ) := by
  simp only [ne_eq, Int.cast_inj]


/- Under defintion 25.5.2 (tag 01HT) and before 25.5.3 (01HU) there is an
argument which defines the sheaf of rings on Spec(R), and also the
quasicoherent sheaf
of O_X-modules attached to an R-module.
-/

/- Let's just do this for rings at this point.

-/
import group_theory.submonoid
import ring_theory.localization
--import localization_UMP
import Kenny_comm_alg.Zariski
import tag00E0
import tag00EJ
import tag01HS
import tag009I -- presheaf of types on a basis
import tag00DY -- claim that D(f) form a basis
import tag006N -- presheaves / sheaves of rings on a basis
import tag00E8 -- standard basis on Spec(R) is quasi-compact
import tag009P -- presheaf of rings on a basis
import tag009L -- sheaf for finite covers on basis -> sheaf for basis
import tag009N -- sheaf for basis -> sheaf
import data.equiv.basic
import canonical_isomorphism_nonsense

universe u
--set_option profiler true

open localization -- should have done this ages ago

-- just under Definition 25.5.2

-- Definition of presheaf-of-sets on basis
definition zariski.structure_presheaf_of_types_on_basis_of_standard (R : Type u) [comm_ring R]
: presheaf_of_types_on_basis (D_f_form_basis R) :=
{ F := zariski.structure_presheaf_on_standard,
  res := λ _ _ _ _ H,localization.localize_superset (nonzero_on_U_mono H),
  Hid := λ _ _,eq.symm (localization.localize_superset.unique_algebra_hom _ _ (λ _,rfl)),
  Hcomp := λ _ _ _ _ _ _ _ _,eq.symm (localization.localize_superset.unique_algebra_hom _ _ (
    λ r, by simp [localization.localize_superset.is_algebra_hom]
  ))
}

-- now let's make it a presheaf of rings on the basis
definition zariski.structure_presheaf_of_rings_on_basis_of_standard (R : Type u) [comm_ring R]
: presheaf_of_rings_on_basis (D_f_form_basis R) :=
{ Fring := zariski.structure_presheaf_on_standard.comm_ring,
  res_is_ring_morphism := λ _ _ _ _ _,localization.localize_superset.is_ring_hom _,
  ..zariski.structure_presheaf_of_types_on_basis_of_standard R,
}

instance zariski.structure_presheaf_of_types_on_basis_of_standard_sections_is_ring
  (R : Type u) [comm_ring R] (U : set (X R)) (BU : U ∈ standard_basis R) :
comm_ring ((zariski.structure_presheaf_of_types_on_basis_of_standard R).F BU) :=
zariski.structure_presheaf_on_standard.comm_ring U BU

-- computation of stalk: I already did this for R I think.

/-
-- warm-up: I never use this.
-- f invertible in R implies R[1/f] uniquely R-iso to R
noncomputable definition localization.loc_unit {R : Type u} [comm_ring R] (f : R) (H : is_unit f) :
R_alg_equiv (id : R → R) (of_comm_ring R (powers f)) :=
R_alg_equiv.of_unique_homs
  (unique_R_alg_from_R (of_comm_ring R (powers f)))
  (away_universal_property f id H)
  (unique_R_alg_from_R id)
  (id_unique_R_alg_from_loc _)

-/

lemma tag01HR.unitf {R : Type u} [comm_ring R] (f g : R) : is_unit (of_comm_ring (loc R (powers f)) (powers (of_comm_ring R (powers f) g)) (of_comm_ring R (powers f) f)) :=
im_unit_of_unit (of_comm_ring (loc R (powers f)) (powers (of_comm_ring R (powers f) g))) $ unit_of_in_S $ away.in_powers f

lemma tag01HR.unitg {R : Type u} [comm_ring R] (f g : R) : is_unit (of_comm_ring (loc R (powers f)) (powers (of_comm_ring R (powers f) g)) (of_comm_ring R (powers f) g)) :=
unit_of_in_S (away.in_powers (of_comm_ring R (powers f) g))

lemma prod_unit {R : Type u} [comm_ring R] {f g : R} : is_unit f → is_unit g → is_unit (f * g) := λ ⟨u,Hu⟩ ⟨v,Hv⟩, ⟨u*v,by rw [mul_comm u,mul_assoc f,←mul_assoc g,Hv,one_mul,Hu]⟩

lemma tag01HR.unitfg {R : Type u} [comm_ring R] (f g : R) : is_unit (of_comm_ring (loc R (powers f)) (powers (of_comm_ring R (powers f) g)) (of_comm_ring R (powers f) (f * g))) :=
begin
  have H := prod_unit (tag01HR.unitf f g) (tag01HR.unitg f g),
  let φ := of_comm_ring (loc R (powers f)) (powers (of_comm_ring R (powers f) g)),
  have Hφ : is_ring_hom φ := by apply_instance,
  rw ←Hφ.map_mul at H,
  let ψ := of_comm_ring R (powers f),
  have Hψ : is_ring_hom ψ := by apply_instance,
  rw ←Hψ.map_mul at H,
  exact H
end

/-
set_option class.instance_max_depth 93
-- I don't use the next theorem, it was just a test for whether I had the right universal properties.
noncomputable definition loc_is_loc_loc {R : Type u} [comm_ring R] (f g : R) :
R_alg_equiv
  ((of_comm_ring (loc R (powers f)) (powers (of_comm_ring R (powers f) g)))
  ∘ (of_comm_ring R (powers f)))
  (of_comm_ring R (powers (f * g))) :=
R_alg_equiv.of_unique_homs
  (away_away_universal_property' f g (of_comm_ring R (powers (f * g)))
    (unit_of_loc_more_left f g) -- proof that f is aunit in R[1/fg]
    (unit_of_loc_more_right f g) -- proof that g is a unit in R[1/fg]
  )
  (away_universal_property (f*g)
    ((of_comm_ring (loc R (powers f)) (powers (of_comm_ring R (powers f) g)))
      ∘ (of_comm_ring R (powers f)))
    (tag01HR.unitfg f g) -- proof that fg is a unit in R[1/f][1/g]
  )
  (away_away_universal_property' f g ((of_comm_ring (loc R (powers f)) (powers (of_comm_ring R (powers f) g))) ∘ (of_comm_ring R (powers f)))
    (tag01HR.unitf f g) -- proof that f is a unit in R[1/f][1/g]
    (tag01HR.unitg f g) -- proof that g is a unit in R[1/f][1/g]
  )
  (id_unique_R_alg_from_loc _)
-/

-- cover of a standard open translates into a cover of Spec(localization)
theorem cover_of_cover_standard {R : Type u} [comm_ring R] {r : R}
{γ : Type u} (f : γ → R) (Hcover : (⋃ (i : γ), Spec.D' (f i)) = Spec.D' r)
: (⋃ (i : γ), Spec.D' (of_comm_ring R (powers r) (f i))) = set.univ :=
set.eq_univ_of_univ_subset (λ Pr HPr,
begin
  let φ := Zariski.induced (of_comm_ring R (powers r)),
  let P := φ Pr,
  have H : P ∈ Spec.D' r,
    rw ←(lemma_standard_open R r).2,
    existsi Pr,simp,
  rw ←Hcover at H,
  cases H with Vi HVi,
  cases HVi with HVi HP,
  cases HVi with i Hi,
  existsi φ ⁻¹' Vi,
  existsi _, -- sorry Mario
    exact HP,
  existsi i,
  rw Hi,
  exact Zariski.induced.preimage_D _ _,
end
)

local attribute [instance] classical.prop_decidable

/-
open finset
open presheaf_of_types_on_basis
theorem application_of_tag00EJ {R : Type u} [comm_ring R] (r : R) {γ : Type u} {H : fintype γ}
  (f : γ → R) (Hcover : (1 : away r) ∈ span (↑(univ.image (of_comm_ring R (powers r) ∘ f)) : set (loc R (powers r)))) :
  let FPTB := (zariski.structure_presheaf_of_types_on_basis_of_standard R) in

  (si : Π (i : γ), (zariski.structure_presheaf_of_types_on_basis_of_standard R).F ⟨f i,rfl⟩)
  (Hglue : ∀ i j : γ, res ⟨f i, rfl⟩ (Hstandard (BUi i) (BUi j) : B (Ui i ∩ Ui j)) (set.inter_subset_left _ _) (si i) =
              FPTB.res (BUi j) (Hstandard (BUi i) (BUi j) : B (Ui i ∩ Ui j)) (set.inter_subset_right _ _) (si j))
  → ∃! s : FPTB.F BU, ∀ i : γ, FPTB.res BU (BUi i) (Hcover ▸ (set.subset_Union Ui i)) s = si i

-/

-- Now let's try and prove the sheaf axiom for finite covers.

instance alpha_is_add_group_hom {R : Type u} {γ : Type u} [comm_ring R] [fintype γ] (f : γ → R) :
is_add_group_hom (tag00EJ.α f) :=
begin
  constructor,
  intros a b,
  funext,
  unfold tag00EJ.α,
  have H := localization.is_ring_hom R (powers (f i)),
  apply H.map_add,
end

instance beta_is_add_group_hom {R : Type u} {γ : Type u} [comm_ring R] [fintype γ] (f : γ → R) :
is_add_group_hom (@tag00EJ.β R γ _ _ f) := begin
--unfold is_add_group_hom,
constructor,
intros a b,
funext,
show _ = (tag00EJ.β a j k) + (tag00EJ.β b j k),
unfold tag00EJ.β,
have H1 : localize_more_left (f j) (f k) ((a + b) j) = localize_more_left (f j) (f k) (a j)
+ localize_more_left (f j) (f k) (b j) := is_add_group_hom.add (localize_more_left (f j) (f k)) (a j) (b j),
rw H1,
have H2 : localize_more_right (f j) (f k) ((a + b) k) = localize_more_right (f j) (f k) (a k)
+ localize_more_right (f j) (f k) (b k) := is_add_group_hom.add _ (a k) (b k),
rw H2,
simp,
end

-- first let's check the sheaf axiom for finite covers, using the fact that
-- the intersection of two basis opens is a basic open (meaning we can use
-- tag 009L instead of 009K).

lemma zariski.standard_basis_has_FIP (R : Type u) [comm_ring R] : ∀ (U V : set (X R)),
  U ∈ (standard_basis R) → V ∈ (standard_basis R) → U ∩ V ∈ (standard_basis R) :=
λ U V ⟨f,Hf⟩ ⟨g,Hg⟩,⟨f*g,Hf.symm ▸ Hg.symm ▸ (tag00E0.lemma15 _ f g).symm⟩

-- this should follow from
-- a) Chris' lemma [lemma_standard_covering₁ and ₂].
-- b) the fact (proved by Kenny) that localization of R at mult set of functions non-vanishing
--    on D(f) is isomorphic (as ring, but we will only need as ab group) to R[1/f]
-- c) the fact (which is probably done somewhere but I'm not sure where) that
--    D(f) is homeomorphic to Spec(R[1/f]) and this homeo identifies D(g) in D(f) with D(g)
--    in Spec(R[1/f])
--
-- What makes is so hard is checking that all the diagrams commute.
set_option class.instance_max_depth 72
theorem zariski.sheaf_of_types_on_standard_basis_for_finite_covers (R : Type u) [comm_ring R] :
  ∀ (U : set (X R)) (BU : U ∈ (standard_basis R)) (γ : Type u) (Fγ : fintype γ)
  (Ui : γ → set (X R)) (BUi :  ∀ i : γ, (Ui i) ∈ (standard_basis R))
  (Hcover: (⋃ (i : γ), (Ui i)) = U),
  sheaf_property_for_standard_basis (D_f_form_basis R) (zariski.structure_presheaf_of_types_on_basis_of_standard R)
    (zariski.standard_basis_has_FIP R)
    U BU γ Ui BUi Hcover :=
begin
  intros U BU γ Hfγ Ui BUi Hcover si Hglue,
  -- from all this data our job is to find a global section
  cases BU with r Hr,
  let Rr := away r, -- our job is to find an element of Rr
  -- will get this from lemma_standard_covering₂
  let f0 : γ → R := λ i, (classical.some (BUi i)),
  let f : γ → Rr := λ i, of_comm_ring R (powers r) (classical.some (BUi i)),
  let f_proof := λ i, (classical.some_spec (BUi i) : Ui i = Spec.D' (f0 i)),
  -- need to check 1 ∈ span ↑(finset.image f finset.univ)
  -- to apply the algebra lemma for coverings.

  -- first let's check the geometric assertion
  have Hcoverr : (⋃ (i : γ), Spec.D' (f i)) = set.univ,
  { refine cover_of_cover_standard _ _,
    rw ←Hr,
    rw ←Hcover,
    congr,
    apply funext,
    intro i,
    rw ←(f_proof i) },

  -- now let's deduce that the ideal of Rr gen by im f is all of Rr
  let F : set Rr := set.range f,
  have H2 : ⋃₀ (Spec.D' '' (set.range f)) = set.univ,
    rw [←Hcoverr,←set.image_univ,←set.image_comp],
    simp [set.Union_eq_sUnion_range],
  rw [tag00E0.lemma16] at H2,
  have H3 : Spec.V (set.range f) = ∅,
    rw [←set.compl_univ,←H2,set.compl_compl],
  rw ←tag00E0.lemma05 at H3,
  have H1 : is_submodule (span (set.range f)) := by apply_instance,
  have H1' : is_ideal (span (set.range f)) := {..H1},
  letI := H1',
  have H4 : span (set.range f) = set.univ := (tag00E0.lemma08 Rr _).1 H3,
  clear F H2 H3 H1,
  have H5 : set.range f = ↑(finset.image f finset.univ),
    apply set.ext,intro x,split;intro H2,
    cases H2 with i Hi,rw ←Hi,simp,existsi i,refl,
    have : ∃ (a : γ), f a = x := by simpa using H2, exact this,
  rw H5 at H4,
  have H2 : (1 : Rr) ∈ span ↑(finset.image f finset.univ),
    rw H4,trivial,
  clear H5 H4,

  -- H2 is one of the inputs to Chris' lemma.

  -- What we seem to need now is a proof that if V is a standard open and V ⊆ U,
  -- then R[1/S(V)] = R[1/r][1/f] for V = D(f), and the unique R-algebra hom is an isom.

  -- so let's prove this.

-- s_proof no longer needed: we have canonical_iso.

  -- next thing we need is (s : Π (i : γ), loc Rr (powers (f i))) .
  -- But before we do that, let's define a function which sends i to a proof
  -- that if Ui = D(f i) and fi = image of f i in R[1/r] then O_X(Ui) = R[1/r][1/fi]
  -- Note that this is data -- the "=" is a given isomorphism between two totally different types
  /-
  let s_proof := λ i, begin
    let sival := (zariski.structure_presheaf_of_types_on_basis_of_standard R).F (BUi i),
    let fi := classical.some (BUi i),
    have Hfi_proof : Ui i = Spec.D' (fi) := classical.some_spec (BUi i),
    -- α = R[1/r][1/fi] -- ring Chris proved something about
    -- β = R[1/fi] -- intermediate object
    -- γ = R[1/S(U)] -- definition of sheaf
    let sα : R → loc (away r) (powers (of_comm_ring R (powers r) fi)) :=
      of_comm_ring (away r) (powers (of_comm_ring R (powers r) fi)) ∘ of_comm_ring R (powers r),
    let sβ : R → loc R (powers fi) := of_comm_ring R (powers fi),
    let sγ := (of_comm_ring R (non_zero_on_U (Spec.D' fi))),
    let Hi : R_alg_equiv sγ sβ := zariski.structure_presheaf_on_standard_is_loc fi,
    -- rw ←Hfi_proof at Hi -- fails,
    -- exact Hi.to_fun (si i), -- this is *supposed* to fail -- I need R[1/f][1/g] = R[1/g] here
    -- loc R (powers fi) = loc Rr (powers (f i))
    -- recall Rr is R[1/r] and U = D(r). We have D(fi) in U so "fi = g and r = f"
    -- so D(fi) is a subset of D(U)
    have Hsub : Spec.D' fi ⊆ Spec.D' r,
      rw [←Hfi_proof,←Hr,←Hcover],
      exact set.subset_Union Ui i,
    let Hloc : R_alg_equiv sα sβ := localization.loc_loc_is_loc Hsub,
    -- now use symmetry and transitivity to deduce sα = sγ
    let Hαγ : R_alg_equiv sγ sα := R_alg_equiv.trans Hi (R_alg_equiv.symm Hloc),
    exact Hαγ,
  end,
-/

  -- now in a position to apply lemma_standard_covering₂
  have Hexact1 := lemma_standard_covering₁ H2,
  have Hexact2 := lemma_standard_covering₂ f H2,

  -- At this point we have Hexact1 and Hexact2, which together are the assertion that
  -- if Rr = R[1/r] (with U=D(r)) and f : gamma -> Rr gives us a cover of U by U_i=D(f i)
  -- then the comm algebra sequence 00EJ is exact.

  -- We want to deduce an analogous statement for the global sections of O_X
  -- defined as O_X(U) = R[1/S(U)] and O_X(U_i) = R[1/S(U_i)].
  -- We have s_proof i : R_alg_equiv (R->R[1/S(U_i)]) (R->R[1/r]->R[1/r][1/f_i])
  -- We will surely need R_alg_equiv (R->R[1/S(U)]) (R->R[1/r]) but we will have
  -- this somewhere : it will be zariski.structure_presheaf_on_standard_is_loc blah
  have HUbasic := zariski.structure_presheaf_on_standard_is_loc r,

  -- goal currently
  --∃! (s : (zariski.structure_presheaf_of_types_on_basis_of_standard R).F _),
  --  ∀ (i : γ), (zariski.structure_presheaf_of_types_on_basis_of_standard R).res _ _ _ s = si i

  -- This is the point where I want to say "done because everything is canonical".
  --
  -- A = Rr
  -- B = prod_i Rr[1/f i]
  -- C = prod_{j,k} Rr[1/(f j) * (f k)]
  -- A' = value of sheaf on U
  -- B' = prod_i values on D(f0 i)
  -- C' = prod j k values in D((f0 j) * (f0 k))

  have H4exact : ∀ (b : Π (i : γ), loc Rr (powers (f i))), tag00EJ.β b = 0 → (∃! (a : Rr), tag00EJ.α f a = b),
  { intros b Hb,
    cases ((Hexact2 b).1 Hb) with a Ha,
    existsi a,
    split,exact Ha,
    intros y Hy,
    apply Hexact1,
    rw Ha,
    rw Hy
  },

  let fa : R_alg_equiv
              (of_comm_ring R (powers r))
              (of_comm_ring R (non_zero_on_U U)) := begin
                rw Hr,
                exact (zariski.structure_presheaf_on_standard_is_loc r).symm,
              end,

--  have : is_add_group_hom fa.to_equiv := sorry, --fa.to_is_ring_hom.map_add,

  let fbi : ∀ i : γ, R_alg_equiv
               ((of_comm_ring Rr (powers (f i))) ∘ (of_comm_ring R (powers r)))
               (of_comm_ring R (non_zero_on_U (Ui i))) := begin
                 intro i,
                 rw f_proof i,
                 have H : Spec.D' (f0 i) ⊆ Spec.D' r,
                 { rw ←Hr,
                   rw ←(f_proof i),
                   rw ←Hcover,
                   apply set.subset_Union Ui i,
                 },
      exact (canonical_iso H).symm,

  end,

  let fcjk : ∀ j k : γ, R_alg_equiv
                ((of_comm_ring Rr (powers (f j * f k))) ∘ (of_comm_ring R (powers r)))
                (of_comm_ring R (non_zero_on_U (Ui j ∩ Ui k))) := begin
                  intros j k,
                  rw f_proof j,
                  rw f_proof k,
                  rw ←tag00E0.lemma15,
                  have H : f j * f k = of_comm_ring R (powers r) (f0 j * f0 k),
                    rw (localization.is_ring_hom R (powers r)).map_mul,
                  rw H,
                  have H' : Spec.D' (f0 j * f0 k) ⊆ Spec.D' r,
                  { rw tag00E0.lemma15,
                    apply set.subset.trans
                      (set.inter_subset_left (Spec.D' (f0 j)) (Spec.D' (f0 k))) (_ :
                      (Spec.D' (f0 j)) ⊆ Spec.D' r),
                    rw ←Hr,
                    rw ←(f_proof j),
                    rw ←Hcover,
                    apply set.subset_Union Ui j,
                  },
                  -- now rewrite Uj ∩ Uk as D(f0j * f0k)
                  -- and there might be an issue that f j * f k isn't
                  -- defeq to the image of f0 j * f0 k
                  -- Once these are fixed the below might work.
                  exact (canonical_iso H').symm,
                end,

  let H3 : ∀ (i : γ), loc Rr (powers (f i)) ≃ loc R (non_zero_on_U (Ui i)),
    intro i,exact (fbi i).to_equiv,
  let H3' : (Π (i : γ), loc Rr (powers (f i))) ≃ Π (i : γ), loc R (non_zero_on_U (Ui i)) := equiv.Pi_congr_right H3,

  let H4 : ∀ (j k : γ), loc Rr (powers (f j * f k)) ≃ loc R (non_zero_on_U (Ui j ∩ Ui k)),
    intros j k, exact (fcjk j k).to_equiv,

  let H4' : ∀ j, (Π k, loc Rr (powers (f j * f k))) ≃ (Π k, loc R (non_zero_on_U (Ui j ∩ Ui k))),
    intro j, exact equiv.Pi_congr_right (H4 j),

  let H4'' : (Π (j k : γ), loc Rr (powers (f j * f k))) ≃ Π (j k : γ),loc R (non_zero_on_U (Ui j ∩ Ui k)),
    exact equiv.Pi_congr_right H4',

  have Hcover' : ∀ (i : γ), Ui i ⊆ U := λ i, Hcover ▸ set.subset_Union Ui i,

  let ab' : loc R (non_zero_on_U U) → Π (i : γ), loc R (non_zero_on_U (Ui i)) := λ Fi i,
    localization.localize_superset (nonzero_on_U_mono (Hcover' i)) Fi,

  let bc'₁ : (Π (i : γ), loc R (non_zero_on_U (Ui i))) → Π (j k : γ), loc R (non_zero_on_U (Ui j ∩ Ui k)) :=
    λ Fi j k, localization.localize_superset (nonzero_on_U_mono $ set.inter_subset_left _ _) (Fi j),

  let bc'₂ : (Π (i : γ), loc R (non_zero_on_U (Ui i))) → Π (j k : γ), loc R (non_zero_on_U (Ui j ∩ Ui k)) :=
    λ Fi j k, localization.localize_superset (nonzero_on_U_mono $ set.inter_subset_right _ _) (Fi k),

  let bc' := λ x, bc'₁ x - bc'₂ x,

  have Hbc'_add_group_hom : is_add_group_hom bc' := ⟨_⟩,

  have Hcanonical := fourexact_from_iso_to_fourexact
   (tag00EJ.α f : Rr → (Π (i : γ), away (f i)))
   (tag00EJ.β)
   (H4exact) --H4exact
   (fa.to_equiv) -- fa
--   (equiv.prod H3 : (Π (i : γ), loc Rr (powers (f i))) ≃ Π (i : γ), loc R (non_zero_on_U (Ui i))) -- fb
--   (H3' : (Π (i : γ), loc Rr (powers (f i))) ≃ Π (i : γ), loc R (non_zero_on_U (Ui i))) -- fb
--   H3'
--   (H3' : ((Π (i : γ), loc Rr (powers (f i))) ≃ (Π (i : γ), loc R (non_zero_on_U (Ui i))))) -- fb
--   (by exact H3')
   (H3' : ((Π (i : γ), loc Rr (powers (f i))) ≃ (Π (i : γ), loc R (non_zero_on_U (Ui i))))) -- fb
   (H4'' : (Π (j k : γ), loc Rr (powers (f j * f k))) ≃ Π (j k : γ),loc R (non_zero_on_U (Ui j ∩ Ui k))) -- fa : A ≃ A', fb fc
    ab' -- ab' -- map
    bc' -- bc' -- map
    _ _, -- H1 H2 -- diags commute

  -- modulo the six extra goals which just appeared, we're nearly done!
  show ∀ (a : Rr), (H3' ∘ (tag00EJ.α f)) a = ab' (((fa.to_ring_equiv).to_equiv) a),
  -- map from Rr to B' = Π (i : γ), loc R (non_zero_on_U (Ui i))
  suffices : H3' ∘ (tag00EJ.α f) = ab' ∘ fa.to_ring_equiv.to_equiv,
    intro a,
    rw this,
  let F1 := H3' ∘ (tag00EJ.α f),
  let F2 := ab' ∘ fa.to_ring_equiv.to_equiv,
  -- the goal is to prove F1 = F2.
  -- Let's first prove that they agree on R.
  have HRalg : ∀ s : R, F1 (of_comm_ring R (powers r) s) = F2 (of_comm_ring R (powers r) s),
    intro s,
    funext i,
    -- F1 (of_comm_ring R (powers r) s) i = F2 (of_comm_ring R (powers r) s) i
    show (fbi i) (of_comm_ring Rr (powers (f i)) (of_comm_ring R (powers r) s)) =
         localize_superset (nonzero_on_U_mono (Hcover' i)) (( fa.to_ring_equiv.to_equiv.to_fun ∘ (of_comm_ring R (powers r))) s),
    show ((fbi i) ∘ (of_comm_ring Rr (powers (f i)))) (of_comm_ring R (powers r) s) = _,
    show ((fbi i).to_ring_equiv.to_equiv.to_fun ∘ (of_comm_ring Rr (powers (f i))) ∘ (of_comm_ring R (powers r))) s = _,
    rw ←fa.R_alg_hom,
    rw ←(fbi i).R_alg_hom,
    refine (localize_superset.is_algebra_hom _ s).symm,
  -- Now some general nonsense says they agree.
  have HH0 : is_ring_hom F1 := _,
  refine (unique_R_alg_from_loc F2).is_unique F1 _,
  funext s,
  exact (HRalg s).symm,

  have HRH1 : is_ring_hom (tag00EJ.α f) := {
    map_add := λ a b,begin
      funext j,
      show of_comm_ring Rr _ (a + b) = of_comm_ring Rr _ a + of_comm_ring Rr _ b,
      rw (localization.is_ring_hom Rr (powers (f j))).map_add,
    end,
    map_mul := λ a b, begin
      funext j,
      show of_comm_ring Rr _ (a * b) = of_comm_ring Rr _ a * of_comm_ring Rr _ b,
      rw (localization.is_ring_hom Rr (powers (f j))).map_mul,
    end,
    map_one := begin
      funext j,
      show of_comm_ring Rr _ 1 = 1,
      rw (localization.is_ring_hom Rr (powers (f j))).map_one
    end
  },

  have HRH2 : is_ring_hom H3',
    apply_instance,

  show is_ring_hom F1,
    apply_instance,

  show ∀ (a b : (Π (i : γ), loc R (non_zero_on_U (Ui i)))), bc' (a + b) = bc' a + bc' b,
    have HAG1 : is_add_group_hom bc'₁,
      constructor,
      show ∀ (a b : Π (i : γ), loc R (non_zero_on_U (Ui i))), bc'₁ (a + b) = bc'₁ a + bc'₁ b,
      intros a b,
      funext j k,
      show bc'₁ (a + b) j k = (bc'₁ a + bc'₁ b) j k,
      show localize_superset _ (a j + b j) = localize_superset _ (a j) + localize_superset _ (b j),
      rw (localize_superset.is_ring_hom _).map_add,

    have HAG2 : is_add_group_hom bc'₂,
      constructor,
      show ∀ (a b : Π (i : γ), loc R (non_zero_on_U (Ui i))), bc'₂ (a + b) = bc'₂ a + bc'₂ b,
      intros a b,
      funext j k,
      show bc'₂ (a + b) j k = (bc'₂ a + bc'₂ b) j k,
      show localize_superset _ (a k + b k) = localize_superset _ (a k) + localize_superset _ (b k),
      rw (localize_superset.is_ring_hom _).map_add,

    intros a b,
    show bc' (a + b) = (bc' a + bc' b),
    show bc'₁ (a + b) - bc'₂ (a + b) = (bc'₁ a - bc'₂ a) + (bc'₁ b - bc'₂ b),
    rw [is_add_group_hom.add bc'₁,is_add_group_hom.add bc'₂],
    simp,

  -- two goals left: one square commutes, and then the application.

  show ∀ (b : Π (i : γ), loc Rr (powers (f i))), H4'' (tag00EJ.β b) = bc' (H3' b),
    -- remember H3' is known to be a ring hom.
    -- and bc' is an additive group hom
    -- oh crap, I need that bc'₁ and 2 are ring homs!
    -- and that beta is a difference of two ring homs.

    -- I had better deduce the result from β₁ and β₂ commuting with bc'₁ and bc'₂.

  have Hb1 : ∀ (b : Π (i : γ), loc Rr (powers (f i))), H4'' (tag00EJ.β₁ b) = bc'₁ (H3' b),
  -- will also need
  --have Hb2 : ∀ (b : Π (i : γ), loc Rr (powers (f i))), H4'' (tag00EJ.β₂ b) = bc'₂ (H3' b),
  -- let's try and focus on one component.
    intro Fi,
    funext j k,
    show H4'' (tag00EJ.β₁ Fi) j k = bc'₁ (H3' Fi) j k,
    -- Fi : Π (i : γ), loc Rr (powers (f i)),
    -- and equality is between elements of
    -- loc R (non_zero_on_U (Ui j ∩ Ui k))
    -- show H4'' = (fcjk j k) : Rr (powers (f j * f k)) -> R (non_zero_on_U (Ui j ∩ Ui k)))
    -- β₁ : localize_more_left (f j) (f k)
    -- now let's figure out what we actually have to prove.
    -- H3' = (fbi i) : Rr[1/f i] -> R[1/non-zero_on_U (Ui i)]
    -- bc'₁ localize_superset _ (Fi j) from 1/Ui i -> 1/(Ui j ∩ Ui k)
    show (fcjk j k) (localize_more_left (f j) (f k) (Fi j)) = _,
    show _ = localize_superset _ ((fbi j) (Fi j)),
    let F1₁ := (fcjk j k) ∘ (localize_more_left (f j) (f k)),
    let F2₁ := (localize_superset (nonzero_on_U_mono (set.inter_subset_left (Ui j) (Ui k)))) ∘ (fbi j),
    have : is_ring_hom (fbi j) := by apply_instance,
    have : is_ring_hom (localize_superset (nonzero_on_U_mono (set.inter_subset_left (Ui j) (Ui k)))) := by apply_instance,
    have : is_ring_hom (F2₁) := by apply_instance,
    have : is_ring_hom (of_comm_ring Rr (powers (f j))) := by apply_instance,
    show F1₁ (Fi j) = F2₁ (Fi j),
    suffices : F1₁ = F2₁,
      rw this,
    -- these are both ring homs from loc Rr (powers (f j)) to R[1/S(Ui j ∩ Ui k)]
    -- the strategy is to prove that they're both R-alg homs and then that there's only one.

    --    let F2₁ := bc'₁ ∘ H3',
    --    suffices : F1₁ = F2₁,
    --      show ∀ (b : Π (i : γ), loc Rr (powers (f i))), F1₁ b = F2₁ b,
    --      rw this,
    --      intro b,refl,
    -- as before, the strat is to show they're R-alg homs
    -- proof should look like :
    --    rw ←fa.R_alg_hom,
    --    rw ←(fbi i).R_alg_hom,
    --    refine (localize_superset.is_algebra_hom _ s).symm,
    have HRalg₁ : F1₁ ∘ (of_comm_ring Rr (powers (f j))) ∘ (of_comm_ring R (powers r))
                        =  F2₁ ∘ (of_comm_ring Rr (powers (f j))) ∘ (of_comm_ring R (powers r)),
      show (fcjk j k).to_ring_equiv.to_equiv.to_fun ∘ (localize_more_left (f j) (f k)) ∘ (of_comm_ring Rr (powers (f j))) ∘ (of_comm_ring R (powers r))
        =  (localize_superset (nonzero_on_U_mono (set.inter_subset_left (Ui j) (Ui k)))) ∘ (fbi j).to_ring_equiv.to_equiv.to_fun ∘ (of_comm_ring Rr (powers (f j))) ∘ (of_comm_ring R (powers r)),
      rw ←(fbi j).R_alg_hom,
      -- rw ←(fcjk j k).R_alg_hom, -- (((fcjk j k).to_ring_equiv).to_equiv).to_fun ∘ of_comm_ring Rr (powers (f j * f k)) ∘ of_comm_ring R (powers r)
      rw ←(superset_universal_property _ _ _).R_alg_hom,
      -- what I now need is to replace
      -- localize_more_left (f j) (f k) ∘ of_comm_ring Rr (powers (f j))
      -- with
      -- of_comm_ring Rr (powers (f j * f k))
      -- rw ←(loc_more_left_universal_property (f j) (f k)).R_alg_hom, -- something like this should work.
      unfold localize_more_left,
      show (((fcjk j k).to_ring_equiv).to_equiv).to_fun ∘
        (away.extend_map_of_im_unit (of_comm_ring Rr (powers (f j * f k))) _ ∘
        of_comm_ring Rr (powers (f j))) ∘ of_comm_ring R (powers r) =
        of_comm_ring R (non_zero_on_U (Ui j ∩ Ui k)),
        rw ←(away_universal_property (f j) (of_comm_ring Rr (powers (f j * f k))) _).R_alg_hom,
      rw ←(fcjk j k).R_alg_hom,
      -- done :-)
    have HRralg₁ : F1₁ ∘ of_comm_ring Rr (powers (f j)) = F2₁ ∘ of_comm_ring Rr (powers (f j)),
      let Htemp := unique_R_alg_from_loc (F2₁ ∘ of_comm_ring Rr (powers (f j))),
      rw (Htemp.is_unique (F1₁ ∘ of_comm_ring Rr (powers (f j)))),
      exact HRalg₁.symm,
    let Htemp' := unique_R_alg_from_loc (F1₁),
    rwa Htemp'.is_unique (F2₁),

      -- now do it again!

    have Hb2 : ∀ (b : Π (i : γ), loc Rr (powers (f i))), H4'' (tag00EJ.β₂ b) = bc'₂ (H3' b),
    -- let's try and focus on one component.
    intro Fi,
    funext j k,
    show H4'' (tag00EJ.β₂ Fi) j k = bc'₂ (H3' Fi) j k,
    -- Fi : Π (i : γ), loc Rr (powers (f i)),
    -- and equality is between elements of
    -- loc R (non_zero_on_U (Ui j ∩ Ui k))
    -- show H4'' = (fcjk j k) : Rr (powers (f j * f k)) -> R (non_zero_on_U (Ui j ∩ Ui k)))
    -- β₁ : localize_more_left (f j) (f k)
    -- now let's figure out what we actually have to prove.
    -- H3' = (fbi i) : Rr[1/f i] -> R[1/non-zero_on_U (Ui i)]
    -- bc'₁ localize_superset _ (Fi j) from 1/Ui i -> 1/(Ui j ∩ Ui k)
    show (fcjk j k) (localize_more_right (f j) (f k) (Fi k)) = _,
    show _ = localize_superset _ ((fbi k) (Fi k)),
    let F1₂ := (fcjk j k) ∘ (localize_more_right (f j) (f k)),
    let F2₂ := (localize_superset (nonzero_on_U_mono (set.inter_subset_right (Ui j) (Ui k)))) ∘ (fbi k),     have : is_ring_hom (fbi j) := by apply_instance,
    have : is_ring_hom (localize_superset (nonzero_on_U_mono (set.inter_subset_right (Ui j) (Ui k)))) := by apply_instance,
    have : is_ring_hom (F2₂) := by apply_instance,
    have : is_ring_hom (of_comm_ring Rr (powers (f k))) := by apply_instance,
    have : is_ring_hom (F2₂ ∘ of_comm_ring Rr (powers (f k))) := by apply_instance,
    show F1₂ (Fi k) = F2₂ (Fi k),
    suffices : F1₂ = F2₂,
      rw this,
    -- the strategy is to prove that they're both R-alg homs and then that there's only one.

    have HRalg₂ : F1₂ ∘ (of_comm_ring Rr (powers (f k))) ∘ (of_comm_ring R (powers r))
                        =  F2₂ ∘ (of_comm_ring Rr (powers (f k))) ∘ (of_comm_ring R (powers r)),
      show (fcjk j k).to_ring_equiv.to_equiv.to_fun ∘ (localize_more_right (f j) (f k)) ∘ (of_comm_ring Rr (powers (f k))) ∘ (of_comm_ring R (powers r))
        =  (localize_superset (nonzero_on_U_mono (set.inter_subset_right (Ui j) (Ui k)))) ∘ (fbi k).to_ring_equiv.to_equiv.to_fun ∘ (of_comm_ring Rr (powers (f k))) ∘ (of_comm_ring R (powers r)),
      rw ←(fbi k).R_alg_hom,
      -- rw ←(fcjk j k).R_alg_hom, -- (((fcjk j k).to_ring_equiv).to_equiv).to_fun ∘ of_comm_ring Rr (powers (f j * f k)) ∘ of_comm_ring R (powers r)
      rw ←(superset_universal_property _ _ _).R_alg_hom,
      -- what I now need is to replace
      -- localize_more_left (f j) (f k) ∘ of_comm_ring Rr (powers (f j))
      -- with
      -- of_comm_ring Rr (powers (f j * f k))
      -- rw ←(loc_more_left_universal_property (f j) (f k)).R_alg_hom, -- something like this should work.
      unfold localize_more_right,
      show (((fcjk j k).to_ring_equiv).to_equiv).to_fun ∘
        (away.extend_map_of_im_unit (of_comm_ring Rr (powers (f j * f k))) _ ∘
        of_comm_ring Rr (powers (f k))) ∘ of_comm_ring R (powers r) =
        of_comm_ring R (non_zero_on_U (Ui j ∩ Ui k)),
        rw ←(away_universal_property (f k) (of_comm_ring Rr (powers (f j * f k))) _).R_alg_hom,
      rw ←(fcjk j k).R_alg_hom,
      -- done :-)
    have HRralg₂ : F1₂ ∘ of_comm_ring Rr (powers (f k)) = F2₂ ∘ of_comm_ring Rr (powers (f k)),
      let Htemp₂ := unique_R_alg_from_loc (F2₂ ∘ of_comm_ring Rr (powers (f k))),
      rw (Htemp₂.is_unique (F1₂ ∘ of_comm_ring Rr (powers (f k)))),
      exact HRalg₂.symm,
    let Htemp'₂ := unique_R_alg_from_loc (F1₂),
    rwa Htemp'₂.is_unique (F2₂),

  show ∀ (s : Π (i : γ), loc Rr (powers (f i))), H4'' (tag00EJ.β s) = bc' (H3' s),
  intro s,
  show H4'' (tag00EJ.β₁ s - tag00EJ.β₂ s) = bc'₁ (H3' s) - bc'₂ (H3' s),
  rw ←(Hb1 s),
  rw ←(Hb2 s),
  -- ⇑H4'' (tag00EJ.β₁ s - tag00EJ.β₂ s) = ⇑H4'' (tag00EJ.β₁ s) - ⇑H4'' (tag00EJ.β₂ s)
  show H4'' (tag00EJ.β₁ s + -tag00EJ.β₂ s) = H4'' (tag00EJ.β₁ s) + -H4'' (tag00EJ.β₂ s),
  rw ←is_add_group_hom.neg H4'',
  rw is_add_group_hom.add H4'',
  have H5 : bc' si = 0, -- follows from Hglue,
  { show bc'₁ si - bc'₂ si = 0,
      suffices this7 : bc'₁ si = bc'₂ si,
      rw this7,simp,
    funext j k,
    exact Hglue j k
  },
  have H6 := Hcanonical si H5,
  cases H6 with s Hs,
  existsi s,
  split,
    intro i,
    rw ←Hs.left,
    refl,

  intros y Hy,
  apply Hs.2 y,
  funext i,
  rw ←(Hy i),
  refl
end
-- now tags 009Hff should get us home

-- 009L should show we have a sheaf on a basis
-- 009N gives us a sheaf of sets on the space

lemma zariski.sheaf_of_types_on_standard_basis (R : Type u) [comm_ring R] :
  ∀ (U : set (X R)) (BU : U ∈ (standard_basis R)) (γ : Type u)
  (Ui : γ → set (X R)) (BUi :  ∀ i : γ, (Ui i) ∈ (standard_basis R))
  (Hcover: (⋃ (i : γ), (Ui i)) = U),
  sheaf_property_for_standard_basis (D_f_form_basis R) (zariski.structure_presheaf_of_types_on_basis_of_standard R)
   (zariski.standard_basis_has_FIP R) U BU γ Ui BUi Hcover :=
lemma_cofinal_systems_coverings_standard_case (D_f_form_basis R)
  (zariski.structure_presheaf_of_types_on_basis_of_standard R)
  (zariski.standard_basis_has_FIP R)
  (zariski.basis_is_compact R) -- standard basis is compact
  (zariski.sheaf_of_types_on_standard_basis_for_finite_covers R)-- (zariski.sheaf_of_types_on_standard_basis_for_finite_covers )

lemma zariski.sheaf_of_types_on_basis (R : Type u) [comm_ring R] :
  is_sheaf_of_types_on_basis (zariski.structure_presheaf_of_types_on_basis_of_standard R) :=
λ U BU γ Ui BUi Hcover β Hij Hijk Hcov2 si Hglue,
begin
  refine zariski.sheaf_of_types_on_standard_basis R U BU γ Ui BUi Hcover si _,
  intros i j,
  have H := zariski.sheaf_of_types_on_standard_basis R (Ui i ∩ Ui j)
    (zariski.standard_basis_has_FIP R (Ui i) (Ui j) (BUi i) (BUi j))
    (β i j) (Hij i j) (Hijk i j) (Hcov2 i j) (λ k,(zariski.structure_presheaf_of_types_on_basis_of_standard R).res (BUi i) (Hijk i j k)
        (is_sheaf_of_types_on_basis._proof_1 Ui Hij Hcov2 i j k)
        (si i)) _,
    tactic.swap,
    intros i' j',
    let Fres := (zariski.structure_presheaf_of_types_on_basis_of_standard R).res,
    show ((Fres _ _ _) ∘ (Fres _ _ _)) _ = ((Fres _ _ _) ∘ (Fres _ _ _)) _,
    rw [←(zariski.structure_presheaf_of_types_on_basis_of_standard R).Hcomp],
    rw [←(zariski.structure_presheaf_of_types_on_basis_of_standard R).Hcomp],
  cases H with s Hs,
  have H1 := Hs.2 ((zariski.structure_presheaf_of_types_on_basis_of_standard R).res (BUi i)
      (sheaf_property_for_standard_basis._proof_2 (zariski.standard_basis_has_FIP R) γ (λ (i : γ), Ui i)
         (λ (i : γ), BUi i)
         i
         j)
      (sheaf_property_for_standard_basis._proof_3 γ (λ (i : γ), Ui i) i j)
      (si i)),
  have H2 := Hs.2 ((zariski.structure_presheaf_of_types_on_basis_of_standard R).res (BUi j)
      (sheaf_property_for_standard_basis._proof_4 (zariski.standard_basis_has_FIP R) γ (λ (i : γ), Ui i)
         (λ (i : γ), BUi i)
         i
         j)
      (sheaf_property_for_standard_basis._proof_5 γ (λ (i : γ), Ui i) i j)
      (si j)),
  rw (H1 _),
    rw (H2 _),
    intro k,
    let Fres := (zariski.structure_presheaf_of_types_on_basis_of_standard R).res,
    show ((Fres _ _ _) ∘ (Fres _ _ _)) (si j) = (Fres _ _ _) (si i),
    rw [←(zariski.structure_presheaf_of_types_on_basis_of_standard R).Hcomp],
    exact (Hglue i j k).symm,
  intro k,
  let Fres := (zariski.structure_presheaf_of_types_on_basis_of_standard R).res,
  show ((Fres _ _ _) ∘ (Fres _ _ _)) (si i) = (Fres _ _ _) (si i),
    rw [←(zariski.structure_presheaf_of_types_on_basis_of_standard R).Hcomp],
end

definition zariski.structure_presheaf_of_types (R : Type u) [comm_ring R] :
presheaf_of_types (X R) :=
  extend_off_basis (zariski.structure_presheaf_of_types_on_basis_of_standard R)
  (zariski.sheaf_of_types_on_basis R)

/-- structure sheaf on Spec(R) is indeed a sheaf -/
theorem zariski.structure_sheaf_is_sheaf_of_types (R : Type u) [comm_ring R] :
is_sheaf_of_types (zariski.structure_presheaf_of_types R)
:= extension_is_sheaf
  (zariski.structure_presheaf_of_types_on_basis_of_standard R)
  (zariski.sheaf_of_types_on_basis R)

-- still need that it's a sheaf of rings


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Reid Barton, Bhavik Mehta
-/
import category_theory.over
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.wide_pullbacks
import category_theory.limits.shapes.finite_products

/-!
# Products in the over category

Shows that products in the over category can be derived from wide pullbacks in the base category.
The main result is `over_product_of_wide_pullback`, which says that if `C` has `J`-indexed wide
pullbacks, then `over B` has `J`-indexed products.
-/
universes w v u -- morphism levels before object levels. See note [category_theory universes].

open category_theory category_theory.limits

variables {J : Type w}
variables {C : Type u} [category.{v} C]
variable {X : C}

namespace category_theory.over

namespace construct_products

/--
(Implementation)
Given a product diagram in `C/B`, construct the corresponding wide pullback diagram
in `C`.
-/
@[reducible]
def wide_pullback_diagram_of_diagram_over (B : C) {J : Type w} (F : discrete J ⥤ over B) :
  wide_pullback_shape J ⥤ C :=
wide_pullback_shape.wide_cospan B (λ j, (F.obj ⟨j⟩).left) (λ j, (F.obj ⟨j⟩).hom)

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simps]
def cones_equiv_inverse_obj (B : C) {J : Type w} (F : discrete J ⥤ over B) (c : cone F) :
  cone (wide_pullback_diagram_of_diagram_over B F) :=
{ X := c.X.left,
  π :=
  { app := λ X, option.cases_on X c.X.hom (λ (j : J), (c.π.app ⟨j⟩).left),
  -- `tidy` can do this using `case_bash`, but let's try to be a good `-T50000` citizen:
    naturality' := λ X Y f,
    begin
      dsimp, cases X; cases Y; cases f,
      { rw [category.id_comp, category.comp_id], },
      { rw [over.w, category.id_comp], },
      { rw [category.id_comp, category.comp_id], },
    end } }

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simps]
def cones_equiv_inverse (B : C) {J : Type w} (F : discrete J ⥤ over B) :
  cone F ⥤ cone (wide_pullback_diagram_of_diagram_over B F) :=
{ obj := cones_equiv_inverse_obj B F,
  map := λ c₁ c₂ f,
  { hom := f.hom.left,
    w' := λ j,
    begin
      cases j,
      { simp },
      { dsimp,
        rw ← f.w ⟨j⟩,
        refl }
    end } }

local attribute [tidy] tactic.discrete_cases

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simps]
def cones_equiv_functor (B : C) {J : Type w} (F : discrete J ⥤ over B) :
  cone (wide_pullback_diagram_of_diagram_over B F) ⥤ cone F :=
{ obj := λ c,
  { X := over.mk (c.π.app none),
    π :=
    { app := λ ⟨j⟩, over.hom_mk (c.π.app (some j))
                    (by apply c.w (wide_pullback_shape.hom.term j)) } },
  map := λ c₁ c₂ f,
  { hom := over.hom_mk f.hom } }

local attribute [tidy] tactic.case_bash

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simp]
def cones_equiv_unit_iso (B : C) (F : discrete J ⥤ over B) :
  𝟭 (cone (wide_pullback_diagram_of_diagram_over B F)) ≅
    cones_equiv_functor B F ⋙ cones_equiv_inverse B F :=
nat_iso.of_components (λ _, cones.ext {hom := 𝟙 _, inv := 𝟙 _} (by tidy)) (by tidy)

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simp]
def cones_equiv_counit_iso (B : C) (F : discrete J ⥤ over B) :
  cones_equiv_inverse B F ⋙ cones_equiv_functor B F ≅ 𝟭 (cone F) :=
nat_iso.of_components
  (λ _, cones.ext {hom := over.hom_mk (𝟙 _), inv := over.hom_mk (𝟙 _)} (by tidy)) (by tidy)

-- TODO: Can we add `. obviously` to the second arguments of `nat_iso.of_components` and
--       `cones.ext`?
/--
(Impl) Establish an equivalence between the category of cones for `F` and for the "grown" `F`.
-/
@[simps]
def cones_equiv (B : C) (F : discrete J ⥤ over B) :
  cone (wide_pullback_diagram_of_diagram_over B F) ≌ cone F :=
{ functor := cones_equiv_functor B F,
  inverse := cones_equiv_inverse B F,
  unit_iso := cones_equiv_unit_iso B F,
  counit_iso := cones_equiv_counit_iso B F, }

/-- Use the above equivalence to prove we have a limit. -/
lemma has_over_limit_discrete_of_wide_pullback_limit {B : C} (F : discrete J ⥤ over B)
  [has_limit (wide_pullback_diagram_of_diagram_over B F)] :
  has_limit F :=
has_limit.mk
{ cone := _,
  is_limit := is_limit.of_right_adjoint
    (cones_equiv B F).functor (limit.is_limit (wide_pullback_diagram_of_diagram_over B F)) }

/-- Given a wide pullback in `C`, construct a product in `C/B`. -/
lemma over_product_of_wide_pullback [has_limits_of_shape (wide_pullback_shape J) C] {B : C} :
  has_limits_of_shape (discrete J) (over B) :=
{ has_limit := λ F, has_over_limit_discrete_of_wide_pullback_limit F }

/-- Given a pullback in `C`, construct a binary product in `C/B`. -/
lemma over_binary_product_of_pullback [has_pullbacks C] {B : C} :
  has_binary_products (over B) :=
over_product_of_wide_pullback

/-- Given all wide pullbacks in `C`, construct products in `C/B`. -/
lemma over_products_of_wide_pullbacks [has_wide_pullbacks.{w} C] {B : C} :
  has_products.{w} (over B) :=
λ J, over_product_of_wide_pullback

/-- Given all finite wide pullbacks in `C`, construct finite products in `C/B`. -/
lemma over_finite_products_of_finite_wide_pullbacks [has_finite_wide_pullbacks C] {B : C} :
  has_finite_products (over B) :=
⟨λ n, over_product_of_wide_pullback⟩

end construct_products

local attribute [tidy] tactic.discrete_cases

/--
Construct terminal object in the over category. This isn't an instance as it's not typically the
way we want to define terminal objects.
(For instance, this gives a terminal object which is different from the generic one given by
`over_product_of_wide_pullback` above.)
-/
lemma over_has_terminal (B : C) : has_terminal (over B) :=
{ has_limit := λ F, has_limit.mk
  { cone :=
    { X := over.mk (𝟙 _),
      π := { app := λ p, p.as.elim } },
    is_limit :=
      { lift := λ s, over.hom_mk _,
        fac' := λ _ j, j.as.elim,
        uniq' := λ s m _,
          begin
            ext,
            rw over.hom_mk_left,
            have := m.w,
            dsimp at this,
            rwa [category.comp_id, category.comp_id] at this
          end } } }

end category_theory.over


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module algebra.big_operators.option
! leanprover-community/mathlib commit 327c3c0d9232d80e250dc8f65e7835b82b266ea5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.BigOperators.Basic
import Mathbin.Data.Finset.Option

/-!
# Lemmas about products and sums over finite sets in `option α`

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

In this file we prove formulas for products and sums over `finset.insert_none s` and
`finset.erase_none s`.
-/

open BigOperators

open Function

namespace Finset

variable {α M : Type _} [CommMonoid M]

/- warning: finset.prod_insert_none -> Finset.prod_insertNone is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : CommMonoid.{u2} M] (f : (Option.{u1} α) -> M) (s : Finset.{u1} α), Eq.{succ u2} M (Finset.prod.{u2, u1} M (Option.{u1} α) _inst_1 (coeFn.{succ u1, succ u1} (OrderEmbedding.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Option.{u1} α)) (Preorder.toLE.{u1} (Finset.{u1} α) (PartialOrder.toPreorder.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α))) (Preorder.toLE.{u1} (Finset.{u1} (Option.{u1} α)) (PartialOrder.toPreorder.{u1} (Finset.{u1} (Option.{u1} α)) (Finset.partialOrder.{u1} (Option.{u1} α))))) (fun (_x : RelEmbedding.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Option.{u1} α)) (LE.le.{u1} (Finset.{u1} α) (Preorder.toLE.{u1} (Finset.{u1} α) (PartialOrder.toPreorder.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α)))) (LE.le.{u1} (Finset.{u1} (Option.{u1} α)) (Preorder.toLE.{u1} (Finset.{u1} (Option.{u1} α)) (PartialOrder.toPreorder.{u1} (Finset.{u1} (Option.{u1} α)) (Finset.partialOrder.{u1} (Option.{u1} α)))))) => (Finset.{u1} α) -> (Finset.{u1} (Option.{u1} α))) (RelEmbedding.hasCoeToFun.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Option.{u1} α)) (LE.le.{u1} (Finset.{u1} α) (Preorder.toLE.{u1} (Finset.{u1} α) (PartialOrder.toPreorder.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α)))) (LE.le.{u1} (Finset.{u1} (Option.{u1} α)) (Preorder.toLE.{u1} (Finset.{u1} (Option.{u1} α)) (PartialOrder.toPreorder.{u1} (Finset.{u1} (Option.{u1} α)) (Finset.partialOrder.{u1} (Option.{u1} α)))))) (Finset.insertNone.{u1} α) s) (fun (x : Option.{u1} α) => f x)) (HMul.hMul.{u2, u2, u2} M M M (instHMul.{u2} M (MulOneClass.toHasMul.{u2} M (Monoid.toMulOneClass.{u2} M (CommMonoid.toMonoid.{u2} M _inst_1)))) (f (Option.none.{u1} α)) (Finset.prod.{u2, u1} M α _inst_1 s (fun (x : α) => f (Option.some.{u1} α x))))
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : CommMonoid.{u1} M] (f : (Option.{u2} α) -> M) (s : Finset.{u2} α), Eq.{succ u1} M (Finset.prod.{u1, u2} M (Option.{u2} α) _inst_1 (FunLike.coe.{succ u2, succ u2, succ u2} (Function.Embedding.{succ u2, succ u2} (Finset.{u2} α) (Finset.{u2} (Option.{u2} α))) (Finset.{u2} α) (fun (_x : Finset.{u2} α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : Finset.{u2} α) => Finset.{u2} (Option.{u2} α)) _x) (EmbeddingLike.toFunLike.{succ u2, succ u2, succ u2} (Function.Embedding.{succ u2, succ u2} (Finset.{u2} α) (Finset.{u2} (Option.{u2} α))) (Finset.{u2} α) (Finset.{u2} (Option.{u2} α)) (Function.instEmbeddingLikeEmbedding.{succ u2, succ u2} (Finset.{u2} α) (Finset.{u2} (Option.{u2} α)))) (RelEmbedding.toEmbedding.{u2, u2} (Finset.{u2} α) (Finset.{u2} (Option.{u2} α)) (fun (x._@.Mathlib.Order.Hom.Basic._hyg.680 : Finset.{u2} α) (x._@.Mathlib.Order.Hom.Basic._hyg.682 : Finset.{u2} α) => LE.le.{u2} (Finset.{u2} α) (Preorder.toLE.{u2} (Finset.{u2} α) (PartialOrder.toPreorder.{u2} (Finset.{u2} α) (Finset.partialOrder.{u2} α))) x._@.Mathlib.Order.Hom.Basic._hyg.680 x._@.Mathlib.Order.Hom.Basic._hyg.682) (fun (x._@.Mathlib.Order.Hom.Basic._hyg.695 : Finset.{u2} (Option.{u2} α)) (x._@.Mathlib.Order.Hom.Basic._hyg.697 : Finset.{u2} (Option.{u2} α)) => LE.le.{u2} (Finset.{u2} (Option.{u2} α)) (Preorder.toLE.{u2} (Finset.{u2} (Option.{u2} α)) (PartialOrder.toPreorder.{u2} (Finset.{u2} (Option.{u2} α)) (Finset.partialOrder.{u2} (Option.{u2} α)))) x._@.Mathlib.Order.Hom.Basic._hyg.695 x._@.Mathlib.Order.Hom.Basic._hyg.697) (Finset.insertNone.{u2} α)) s) (fun (x : Option.{u2} α) => f x)) (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M (CommMonoid.toMonoid.{u1} M _inst_1)))) (f (Option.none.{u2} α)) (Finset.prod.{u1, u2} M α _inst_1 s (fun (x : α) => f (Option.some.{u2} α x))))
Case conversion may be inaccurate. Consider using '#align finset.prod_insert_none Finset.prod_insertNoneₓ'. -/
@[simp, to_additive]
theorem prod_insertNone (f : Option α → M) (s : Finset α) :
    (∏ x in s.insertNone, f x) = f none * ∏ x in s, f (some x) := by simp [insert_none]
#align finset.prod_insert_none Finset.prod_insertNone
#align finset.sum_insert_none Finset.sum_insertNone

/- warning: finset.prod_erase_none -> Finset.prod_eraseNone is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {M : Type.{u2}} [_inst_1 : CommMonoid.{u2} M] (f : α -> M) (s : Finset.{u1} (Option.{u1} α)), Eq.{succ u2} M (Finset.prod.{u2, u1} M α _inst_1 (coeFn.{succ u1, succ u1} (OrderHom.{u1, u1} (Finset.{u1} (Option.{u1} α)) (Finset.{u1} α) (PartialOrder.toPreorder.{u1} (Finset.{u1} (Option.{u1} α)) (Finset.partialOrder.{u1} (Option.{u1} α))) (PartialOrder.toPreorder.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α))) (fun (_x : OrderHom.{u1, u1} (Finset.{u1} (Option.{u1} α)) (Finset.{u1} α) (PartialOrder.toPreorder.{u1} (Finset.{u1} (Option.{u1} α)) (Finset.partialOrder.{u1} (Option.{u1} α))) (PartialOrder.toPreorder.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α))) => (Finset.{u1} (Option.{u1} α)) -> (Finset.{u1} α)) (OrderHom.hasCoeToFun.{u1, u1} (Finset.{u1} (Option.{u1} α)) (Finset.{u1} α) (PartialOrder.toPreorder.{u1} (Finset.{u1} (Option.{u1} α)) (Finset.partialOrder.{u1} (Option.{u1} α))) (PartialOrder.toPreorder.{u1} (Finset.{u1} α) (Finset.partialOrder.{u1} α))) (Finset.eraseNone.{u1} α) s) (fun (x : α) => f x)) (Finset.prod.{u2, u1} M (Option.{u1} α) _inst_1 s (fun (x : Option.{u1} α) => Option.elim'.{u1, u2} α M (OfNat.ofNat.{u2} M 1 (OfNat.mk.{u2} M 1 (One.one.{u2} M (MulOneClass.toHasOne.{u2} M (Monoid.toMulOneClass.{u2} M (CommMonoid.toMonoid.{u2} M _inst_1)))))) f x))
but is expected to have type
  forall {α : Type.{u2}} {M : Type.{u1}} [_inst_1 : CommMonoid.{u1} M] (f : α -> M) (s : Finset.{u2} (Option.{u2} α)), Eq.{succ u1} M (Finset.prod.{u1, u2} M α _inst_1 (OrderHom.toFun.{u2, u2} (Finset.{u2} (Option.{u2} α)) (Finset.{u2} α) (PartialOrder.toPreorder.{u2} (Finset.{u2} (Option.{u2} α)) (Finset.partialOrder.{u2} (Option.{u2} α))) (PartialOrder.toPreorder.{u2} (Finset.{u2} α) (Finset.partialOrder.{u2} α)) (Finset.eraseNone.{u2} α) s) (fun (x : α) => f x)) (Finset.prod.{u1, u2} M (Option.{u2} α) _inst_1 s (fun (x : Option.{u2} α) => Option.elim'.{u2, u1} α M (OfNat.ofNat.{u1} M 1 (One.toOfNat1.{u1} M (Monoid.toOne.{u1} M (CommMonoid.toMonoid.{u1} M _inst_1)))) f x))
Case conversion may be inaccurate. Consider using '#align finset.prod_erase_none Finset.prod_eraseNoneₓ'. -/
@[to_additive]
theorem prod_eraseNone (f : α → M) (s : Finset (Option α)) :
    (∏ x in s.eraseNone, f x) = ∏ x in s, Option.elim' 1 f x := by
  classical calc
      (∏ x in s.erase_none, f x) = ∏ x in s.erase_none.map embedding.some, Option.elim' 1 f x :=
        (Prod_map s.erase_none embedding.some <| Option.elim' 1 f).symm
      _ = ∏ x in s.erase none, Option.elim' 1 f x := by rw [map_some_erase_none]
      _ = ∏ x in s, Option.elim' 1 f x := prod_erase _ rfl

#align finset.prod_erase_none Finset.prod_eraseNone
#align finset.sum_erase_none Finset.sum_eraseNone

end Finset