/-
Copyright (c) 2018 Andreas Swerdlow. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Andreas Swerdlow
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.basic
import Mathlib.ring_theory.ring_invo
import Mathlib.PostPort

universes u v l u_1 u_2

namespace Mathlib

/-!
# Sesquilinear form

This file defines a sesquilinear form over a module. The definition requires a ring antiautomorphism
on the scalar ring. Basic ideas such as
orthogonality are also introduced.

A sesquilinear form on an `R`-module `M`, is a function from `M × M` to `R`, that is linear in the
first argument and antilinear in the second, with respect to an antiautomorphism on `R` (an
antiisomorphism from `R` to `R`).

## Notations

Given any term `S` of type `sesq_form`, due to a coercion, can use the notation `S x y` to
refer to the function field, ie. `S x y = S.sesq x y`.

## References

* <https://en.wikipedia.org/wiki/Sesquilinear_form#Over_arbitrary_rings>

## Tags

Sesquilinear form,
-/

/-- A sesquilinear form over a module  -/
structure sesq_form (R : Type u) (M : Type v) [ring R] (I : R ≃+* (Rᵒᵖ)) [add_comm_group M]
    [module R M]
    where
  sesq : M → M → R
  sesq_add_left : ∀ (x y z : M), sesq (x + y) z = sesq x z + sesq y z
  sesq_smul_left : ∀ (a : R) (x y : M), sesq (a • x) y = a * sesq x y
  sesq_add_right : ∀ (x y z : M), sesq x (y + z) = sesq x y + sesq x z
  sesq_smul_right : ∀ (a : R) (x y : M), sesq x (a • y) = opposite.unop (coe_fn I a) * sesq x y

namespace sesq_form

protected instance has_coe_to_fun {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} : has_coe_to_fun (sesq_form R M I) :=
  has_coe_to_fun.mk (fun (S : sesq_form R M I) => M → M → R) fun (S : sesq_form R M I) => sesq S

theorem add_left {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (x : M) (y : M) (z : M) :
    coe_fn S (x + y) z = coe_fn S x z + coe_fn S y z :=
  sesq_add_left S x y z

theorem smul_left {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (a : R) (x : M) (y : M) :
    coe_fn S (a • x) y = a * coe_fn S x y :=
  sesq_smul_left S a x y

theorem add_right {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (x : M) (y : M) (z : M) :
    coe_fn S x (y + z) = coe_fn S x y + coe_fn S x z :=
  sesq_add_right S x y z

theorem smul_right {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (a : R) (x : M) (y : M) :
    coe_fn S x (a • y) = opposite.unop (coe_fn I a) * coe_fn S x y :=
  sesq_smul_right S a x y

theorem zero_left {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (x : M) : coe_fn S 0 x = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn S 0 x = 0)) (Eq.symm (zero_smul R 0))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn S (0 • 0) x = 0)) (smul_left 0 0 x)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (0 * coe_fn S 0 x = 0)) (zero_mul (coe_fn S 0 x))))
        (Eq.refl 0)))

theorem zero_right {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (x : M) : coe_fn S x 0 = 0 :=
  sorry

theorem neg_left {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (x : M) (y : M) : coe_fn S (-x) y = -coe_fn S x y :=
  sorry

theorem neg_right {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (x : M) (y : M) : coe_fn S x (-y) = -coe_fn S x y :=
  sorry

theorem sub_left {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (x : M) (y : M) (z : M) :
    coe_fn S (x - y) z = coe_fn S x z - coe_fn S y z :=
  sorry

theorem sub_right {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (x : M) (y : M) (z : M) :
    coe_fn S x (y - z) = coe_fn S x y - coe_fn S x z :=
  sorry

theorem ext {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M] {I : R ≃+* (Rᵒᵖ)}
    {S : sesq_form R M I} {D : sesq_form R M I} (H : ∀ (x y : M), coe_fn S x y = coe_fn D x y) :
    S = D :=
  sorry

protected instance add_comm_group {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} : add_comm_group (sesq_form R M I) :=
  add_comm_group.mk
    (fun (S D : sesq_form R M I) =>
      mk (fun (x y : M) => coe_fn S x y + coe_fn D x y) sorry sorry sorry sorry)
    sorry (mk (fun (x y : M) => 0) sorry sorry sorry sorry) sorry sorry
    (fun (S : sesq_form R M I) => mk (fun (x y : M) => -sesq S x y) sorry sorry sorry sorry)
    (add_group.sub._default
      (fun (S D : sesq_form R M I) =>
        mk (fun (x y : M) => coe_fn S x y + coe_fn D x y) sorry sorry sorry sorry)
      sorry (mk (fun (x y : M) => 0) sorry sorry sorry sorry) sorry sorry
      fun (S : sesq_form R M I) => mk (fun (x y : M) => -sesq S x y) sorry sorry sorry sorry)
    sorry sorry

protected instance inhabited {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} : Inhabited (sesq_form R M I) :=
  { default := 0 }

/-- The proposition that two elements of a sesquilinear form space are orthogonal -/
def is_ortho {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M] {I : R ≃+* (Rᵒᵖ)}
    (S : sesq_form R M I) (x : M) (y : M) :=
  coe_fn S x y = 0

theorem ortho_zero {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (x : M) : is_ortho S 0 x :=
  zero_left x

theorem is_add_monoid_hom_left {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} (S : sesq_form R M I) (x : M) :
    is_add_monoid_hom fun (z : M) => coe_fn S z x :=
  is_add_monoid_hom.mk (zero_left x)

theorem is_add_monoid_hom_right {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} (S : sesq_form R M I) (x : M) :
    is_add_monoid_hom fun (z : M) => coe_fn S x z :=
  is_add_monoid_hom.mk (zero_right x)

theorem map_sum_left {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {α : Type u_1} (S : sesq_form R M I) (t : finset α) (g : α → M) (w : M) :
    coe_fn S (finset.sum t fun (i : α) => g i) w = finset.sum t fun (i : α) => coe_fn S (g i) w :=
  Eq.symm (finset.sum_hom t fun (z : M) => coe_fn S z w)

theorem map_sum_right {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {α : Type u_1} (S : sesq_form R M I) (t : finset α) (g : α → M) (w : M) :
    coe_fn S w (finset.sum t fun (i : α) => g i) = finset.sum t fun (i : α) => coe_fn S w (g i) :=
  Eq.symm (finset.sum_hom t fun (z : M) => coe_fn S w z)

protected instance to_module {R : Type u_1} [comm_ring R] {M : Type v} [add_comm_group M]
    [module R M] {J : R ≃+* (Rᵒᵖ)} : module R (sesq_form R M J) :=
  semimodule.mk sorry sorry

theorem ortho_smul_left {R : Type u_1} [domain R] {M : Type v} [add_comm_group M] [module R M]
    {K : R ≃+* (Rᵒᵖ)} {G : sesq_form R M K} {x : M} {y : M} {a : R} (ha : a ≠ 0) :
    is_ortho G x y ↔ is_ortho G (a • x) y :=
  sorry

theorem ortho_smul_right {R : Type u_1} [domain R] {M : Type v} [add_comm_group M] [module R M]
    {K : R ≃+* (Rᵒᵖ)} {G : sesq_form R M K} {x : M} {y : M} {a : R} (ha : a ≠ 0) :
    is_ortho G x y ↔ is_ortho G x (a • y) :=
  sorry

end sesq_form

namespace refl_sesq_form

/-- The proposition that a sesquilinear form is reflexive -/
def is_refl {R : Type u_1} {M : Type u_2} [ring R] [add_comm_group M] [module R M] {I : R ≃+* (Rᵒᵖ)}
    (S : sesq_form R M I) :=
  ∀ (x y : M), coe_fn S x y = 0 → coe_fn S y x = 0

theorem eq_zero {R : Type u_1} {M : Type u_2} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (H : is_refl S) {x : M} {y : M} :
    coe_fn S x y = 0 → coe_fn S y x = 0 :=
  H x y

theorem ortho_sym {R : Type u_1} {M : Type u_2} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (H : is_refl S) {x : M} {y : M} :
    sesq_form.is_ortho S x y ↔ sesq_form.is_ortho S y x :=
  { mp := eq_zero H, mpr := eq_zero H }

end refl_sesq_form

namespace sym_sesq_form

/-- The proposition that a sesquilinear form is symmetric -/
def is_sym {R : Type u_1} {M : Type u_2} [ring R] [add_comm_group M] [module R M] {I : R ≃+* (Rᵒᵖ)}
    (S : sesq_form R M I) :=
  ∀ (x y : M), opposite.unop (coe_fn I (coe_fn S x y)) = coe_fn S y x

theorem sym {R : Type u_1} {M : Type u_2} [ring R] [add_comm_group M] [module R M] {I : R ≃+* (Rᵒᵖ)}
    {S : sesq_form R M I} (H : is_sym S) (x : M) (y : M) :
    opposite.unop (coe_fn I (coe_fn S x y)) = coe_fn S y x :=
  H x y

theorem is_refl {R : Type u_1} {M : Type u_2} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (H : is_sym S) : refl_sesq_form.is_refl S :=
  sorry

theorem ortho_sym {R : Type u_1} {M : Type u_2} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (H : is_sym S) {x : M} {y : M} :
    sesq_form.is_ortho S x y ↔ sesq_form.is_ortho S y x :=
  refl_sesq_form.ortho_sym (is_refl H)

end sym_sesq_form

namespace alt_sesq_form

/-- The proposition that a sesquilinear form is alternating -/
def is_alt {R : Type u_1} {M : Type u_2} [ring R] [add_comm_group M] [module R M] {I : R ≃+* (Rᵒᵖ)}
    (S : sesq_form R M I) :=
  ∀ (x : M), coe_fn S x x = 0

theorem self_eq_zero {R : Type u_1} {M : Type u_2} [ring R] [add_comm_group M] [module R M]
    {I : R ≃+* (Rᵒᵖ)} {S : sesq_form R M I} (H : is_alt S) (x : M) : coe_fn S x x = 0 :=
  H x

theorem neg {R : Type u_1} {M : Type u_2} [ring R] [add_comm_group M] [module R M] {I : R ≃+* (Rᵒᵖ)}
    {S : sesq_form R M I} (H : is_alt S) (x : M) (y : M) : -coe_fn S x y = coe_fn S y x :=
  sorry

end Mathlib


import modal_logic.classes

class is_dense (α : Type*) (r : α → α → Prop) : Prop :=
(dense : ∀ a b, r a b → ∃ c, r a c ∧ r c b)

instance is_refl.is_dense {α r} [is_refl α r] : is_dense α r := ⟨λ a b h, ⟨a, refl a, h⟩⟩

class is_serial (α : Type*) (r : α → α → Prop) : Prop :=
(serial : ∀ a, ∃ b, r a b)

instance is_refl.is_serial {α r} [is_refl α r] : is_serial α r := ⟨λ a, ⟨a, refl a⟩⟩

class is_euclidean (α : Type*) (r : α → α → Prop) : Prop :=
(euc : ∀ a b c, r a b → r a c → r b c)

instance is_per.is_euclidean {α r} [is_per α r] : is_euclidean α r := ⟨λ a b c h h', trans (symm h) h'⟩

class is_semieuclidean (α : Type*) (r : α → α → Prop) :=
(semieuc : ∀ a b c, r a b → r a c → r b c ∨ r c b)

instance is_euclidean.is_semieuclidean {α r} [is_euclidean α r] : is_semieuclidean α r := ⟨λ a b c h h', or.inl (is_euclidean.euc a b c h h')⟩

class is_founded (α : Type*) (r : α → α → Prop) : Prop :=
(founded : ∀ a, ∃ b, r a b ∧ ∀ c, r b c → b = c)

class is_convergent (α : Type*) (r : α → α → Prop) : Prop :=
(conv : ∀ a b c, r a b → r a c → ∃ d, r b d ∧ r c d)

class is_discrete (α : Type*) (r : α → α → Prop) : Prop :=
(disc : ∀ a b, r a b → a = b)

class is_functional (α : Type*) (r : α → α → Prop) : Prop :=
(func : ∀ a b c, r a b → r a c → b = c)

class is_function (α : Type*) (r : α → α → Prop) extends is_serial α r, is_functional α r : Prop

instance is_discrete.is_functional {α r} [is_discrete α r] : is_functional α r := ⟨λ a b c h h', eq.trans (is_discrete.disc a b h).symm (is_discrete.disc a c h')⟩

class is_right_refl (α : Type*) (r : α → α → Prop) : Prop :=
(refl : ∀ a b, r a b → r b b)

instance is_refl.is_right_refl {α r} [is_refl α r] : is_right_refl α r := ⟨λ a b h, refl b⟩

namespace modal_logic

variables [_modal_model : modal_frame] (w : World) (p q : MProp)

lemma em : w ⊩ p ∨ ¬p := em _

@[simp] lemma not_sat : (¬(w ⊩ p)) = (w ⊩ ¬p) := rfl

lemma not_lam : (¬(λ w, p w)) = (λ w, ¬p w) := rfl

@[simp] lemma not_not : (¬¬p) = p :=
  by ext; simp only [not, iff, sat, not_not]

@[simp] lemma not_imp : (¬(p ⇒ q)) = (p ∧ ¬q) :=
  by ext; simp only [not, imp, and, iff, sat, not_imp]

@[simp] lemma not_and : (¬(p ∧ q)) = (¬p ∨ ¬q) :=
  by ext; simp only [not, and, or, iff, sat, not_and_distrib]

@[simp] lemma not_or : (¬(p ∨ q)) = (¬p ∧ ¬q) :=
  by ext; simp only [not, and, or, iff, sat, not_or_distrib]

@[simp] lemma not_poss : (¬◇p) = □¬p :=
  by ext; simp only [not, nec, poss, iff, sat, not_exists, _root_.not_and]

@[simp] lemma not_nec : (¬□p) = ◇¬p :=
  by ext; simp only [not, nec, poss, iff, sat, not_forall, exists_prop]

@[simp] lemma nec_and : □(p ∧ q) = (□p ∧ □q) :=
  by ext; simp only [nec, and, iff, sat, forall_and_distrib]

@[simp] lemma poss_or : ◇(p ∨ q) = (◇p ∨ ◇q) :=
  by ext; simp only [poss, or, iff, sat, ← exists_prop, exists_or_distrib]

lemma and_comm : (p ∧ q) = (q ∧ p) :=
  by ext; simp only [and, iff, sat, and_comm]

lemma or_comm : (p ∨ q) = (q ∨ p) :=
  by ext; simp only [or, iff, sat, or_comm]

lemma or_eq_not_imp_left : (p ∨ q) = (¬p ⇒ q) :=
  by ext; simp only [imp, not, or, iff, sat, or_iff_not_imp_left]

lemma or_eq_not_imp_right : (p ∨ q) = (¬q ⇒ p) :=
  by ext; simp only [imp, not, or, iff, sat, or_iff_not_imp_right]

lemma nec_imp_nec_of_nec_imp : w ⊩ □(p ⇒ q) ⇒ □p ⇒ □q :=
  λ h h' v h_v, h v h_v (h' v h_v)

lemma of_nec [is_refl World (≺)] : w ⊩ □p ⇒ p :=
  λ h, h w (refl w)

lemma nec_nec_of_nec [is_trans World (≺)] : w ⊩ □p ⇒ □□p :=
  λ h v h_v u h_u, h u (trans h_v h_u)

lemma nec_of_nec_nec [is_dense World (≺)] : w ⊩ □□p ⇒ □p :=
  λ h v h_v, let ⟨u, h_u, h_u'⟩ := is_dense.dense w v h_v in h u h_u v h_u'

lemma poss_of_nec [is_serial World (≺)] : w ⊩ □p ⇒ ◇p :=
  λ h, let ⟨v, h_v⟩ := is_serial.serial w in ⟨v, h_v, h v h_v⟩

lemma nec_poss [is_symm World (≺)] : w ⊩ p ⇒ □◇p :=
  λ h v h_v, ⟨w, symm h_v, h⟩

lemma nec_poss_of_poss [is_euclidean World (≺)] : w ⊩ ◇p ⇒ □◇p :=
  λ ⟨u, h_u, h⟩ v h_v, ⟨u, is_euclidean.euc w v u h_v h_u, h⟩

lemma nec_of_nec_nec_imp [is_trans World (≺)] (wf : well_founded (λ w v : World, v ≺ w)) : w ⊩ □(□p ⇒ p) ⇒ □p :=
  by apply well_founded.induction wf w; exact λ v ih h u h_u, h u h_u (ih u h_u (λ t h_t, h t (trans h_u h_t)))

lemma of_nec_nec_imp_nec_imp [is_preorder World (≺)] (wf : well_founded (λ w v : World, w ≠ v ∧ v ≺ w)) : w ⊩ □(□(p ⇒ □p) ⇒ p) ⇒ p :=
begin
  have : is_antisymm World (≺),
  {
    constructor,
    intros v u h_u h_v,
    rcases well_founded.has_min wf {v, u} ⟨v, set.mem_insert _ _⟩ with ⟨t, h_t, h⟩,
    simp only [set.mem_insert_iff, set.mem_singleton_iff, _root_.not_and, not_imp_not] at h h_t,
    rcases h_t with rfl | rfl,
    {
      exact (h u (or.inr rfl) h_u).symm,
    },
    {
      exact h v (or.inl rfl) h_v,
    },
  },
  intros h,
  by_contra h_w_p,
  obtain ⟨v, h_v, h_v_p, h'⟩ : ∃ v, w ≺ v ∧ ¬(v ⊩ p) ∧ ∀ u, u ≠ v → v ≺ u → u ⊩ p,
  {
    rcases well_founded.has_min wf { v | w ≺ v ∧ ¬(v ⊩ p) } ⟨w, refl w, h_w_p⟩ with ⟨v, ⟨h_v, h_v'⟩, h'⟩,
    simp only [set.mem_set_of_eq, and_imp, not_imp_not] at h',
    exact ⟨v, h_v, h_v', λ u h_u h_u', h' u (trans h_v h_u') h_u h_u'⟩,
  },
  refine h_v_p (h v h_v _),
  intros u h_u h_u_p t h_t,
  by_cases h'' : u = t,
  {
    exact h'' ▸ h_u_p,
  },
  {
    exactI h' t (λ h''', (h'' (antisymm h_t (h'''.symm ▸ h_u)))) (trans h_u h_t),
  },
end

lemma nec_nec_imp_or_nec_nec_imp [is_semieuclidean World (≺)] : w ⊩ □(□p ⇒ q) ∨ □(□q ⇒ p) :=
begin
  simp only [or_eq_not_imp_left, not_imp, not_nec],
  rintros ⟨v, h_v, h, h'⟩ u h_u h'',
  rcases is_semieuclidean.semieuc w v u h_v h_u with h_u' | h_v',
  {
    exact h u h_u',
  },
  {
    exact false.rec _ (h' (h'' v h_v')),
  },
end

lemma poss_nec_of_nec_poss [is_trans World (≺)] [is_founded World (≺)] : w ⊩ □◇p ⇒ ◇□p :=
  λ h, let ⟨v, h_v, h_v'⟩ := is_founded.founded w in ⟨v, h_v, λ u h_u, let ⟨t, h_t, h'⟩ := h v h_v in h_v' u h_u ▸ (h_v' t h_t).symm ▸ h'⟩

lemma nec_poss_of_poss_nec [is_convergent World (≺)] : w ⊩ ◇□p ⇒ □◇p :=
  λ ⟨u, h_u, h⟩ v h_v, let ⟨t, h_t, h_t'⟩ := is_convergent.conv w v u h_v h_u in ⟨t, h_t, h t h_t'⟩

lemma nec_of [is_discrete World (≺)] : w ⊩ p ⇒ □p :=
  λ h u h_u, is_discrete.disc w u h_u ▸ h

lemma nec_of_poss [is_functional World (≺)] : w ⊩ ◇p ⇒ □p :=
  λ ⟨v, h_v, h⟩ u h_u, is_functional.func w v u h_v h_u ▸ h

lemma nec_eq_poss [is_function World (≺)] : ◇p = □p :=
  by ext; exact ⟨nec_of_poss w p, poss_of_nec w p⟩

lemma nec_nec_imp [is_right_refl World (≺)] : w ⊩ □(□p ⇒ p) :=
  λ v h_v h, h v (is_right_refl.refl w v h_v)

end modal_logic


import algebra.module.submodule.lattice
import ring_theory.ideal.basic
import ring_theory.ideal.operations
import data.set.basic
import ring_theory.unique_factorization_domain
import ring_theory.principal_ideal_domain
import absorbing

variables {R : Type*} [comm_ring R] (S : submonoid R)

/-- Explication -/
def foo := {I : ideal R | (I : set R) ∩ S = ∅}

lemma foo_def (P : ideal R) : P ∈ foo S ↔ (P : set R) ∩ S = ∅ :=
iff.rfl

variables {P : ideal R} {S} (hP : P ∈ foo S) (hmax : ∀ I ∈ foo S, P ≤ I → I = P)

section basic

theorem P_neq_top (hP : P ∈ foo S) : P ≠ ⊤ := λ h, ((set.disjoint_left.1 (set.disjoint_iff_inter_eq_empty.2 ((foo_def _ _).1 hP))) (P.eq_top_iff_one.1 h)) S.one_mem

include hmax

lemma gt_inter {I : ideal R} (h : P < I) : ∃ (x : R), x ∈ (I : set R) ∩ S := set.inter_nonempty.1 (set.nonempty_iff_ne_empty.2 (λ h₂, (lt_iff_le_and_ne.1 h).2 (eq.symm ((hmax I) h₂ (lt_iff_le_and_ne.1 h).1))))

include hP

theorem mem_or_mem' : ∀ {x y : R}, x * y ∈ P → x ∈ P ∨ y ∈ P :=
begin
  rintro x y hxy,
  by_contra,
  push_neg at h,
  cases h with h' h'',
  let I := P ⊔ ideal.span {x},
  let J := P ⊔ ideal.span {y},

  have h₁ : ∃ (x : R), x ∈ (I : set R) ∩ S :=
  begin
    refine gt_inter hmax (lt_of_le_of_ne' le_sup_left _),
    intro hI,
    rw [← hI, ← ideal.span_singleton_le_iff_mem _] at h',
    exact h' le_sup_right,
  end,

  have h₂ : ∃ (x : R), x ∈ (J : set R) ∩ S :=
  begin
    refine gt_inter hmax (lt_of_le_of_ne' le_sup_left _),
    intro hJ,
    rw [← hJ, ← ideal.span_singleton_le_iff_mem _] at h'',
    exact h'' le_sup_right,
  end,

  rcases ⟨h₁, h₂⟩ with ⟨⟨s, ⟨hs, hs'⟩⟩, ⟨t, ⟨ht, ht'⟩⟩⟩,

  have h₃ : I*J ≤ P :=
  begin
    rw [ideal.mul_sup _ _ _, ideal.sup_mul _ _ _, ideal.sup_mul _ _ _, ideal.span_singleton_mul_span_singleton],
    exact sup_le (sup_le ideal.mul_le_right ideal.mul_le_left) (sup_le ideal.mul_le_right ((ideal.span_singleton_le_iff_mem _).2 hxy)),
  end,

  exact set.eq_empty_iff_forall_not_mem.1 hP (s*t) ⟨h₃ (ideal.mul_mem_mul hs ht), S.mul_mem hs' ht'⟩,
end

theorem theo3 : P.is_prime := ⟨P_neq_top hP, λ x y, mem_or_mem' hP hmax⟩

end basic

section existence

lemma condition_Zorns_lemma (C : set (ideal R)) (hC : C ⊆ foo S)
  (hC₂ : is_chain (≤) C) (I : ideal R) (hI : I ∈ C) :
  (∃ (P : ideal R) (H : P ∈ foo S), ∀ (J : ideal R), J ∈ C → J ≤ P) :=
begin
  refine ⟨Sup C, _, λ z hz, le_Sup hz⟩,
  rw [foo_def, set.eq_empty_iff_forall_not_mem],
  rintro x hx,
  rcases (submodule.mem_Sup_of_directed ⟨_, hI⟩ hC₂.directed_on).1 hx.1 with ⟨J, hJ₁, hJ₂⟩,
  have hx₂ : (J : set R) ∩ S ≠ ∅ := set.nonempty_iff_ne_empty.1 ⟨x, hJ₂, hx.2⟩,
  exact hx₂ (hC hJ₁),
end

lemma prop_2 (hS : (0 : R) ∉ S) : ∃ P ∈ foo S,  ∀ I ∈ foo S, P ≤ I → I = P :=
begin
  have hx : (0 : ideal R) ∈ foo S,
  { rw [foo_def, set.eq_empty_iff_forall_not_mem],
    rintro y ⟨hy₁, hy₂⟩,
    rw [set_like.mem_coe, ideal.zero_eq_bot, ideal.mem_bot] at hy₁,
    rw hy₁ at hy₂,
    exact hS hy₂ },
  rcases zorn_nonempty_partial_order₀ _ condition_Zorns_lemma 0 hx with
    ⟨J, ⟨hJ, ⟨hJ₂, hJ₃⟩⟩⟩,
  exact ⟨J, hJ, hJ₃⟩,
end

end existence

section Kaplansky

lemma multiset.prod_mem_ideal {I : ideal R} (s : multiset R) (hI : I.is_prime) : s.prod ∈ I ↔ ∃ (p : R) (H : p ∈ s), p ∈ I :=
begin
  classical,
  split,
  { intro hs,
    by_contra,
    push_neg at h,

    have hs₃ : s.prod ∉ I,
    refine multiset.prod_induction _ _ _ _ h,
    { rintro a b ha hb,
      by_contra,
      cases ((ideal.is_prime_iff.1 hI).2) h with hI₂ hI₃,
      exact ha hI₂,
      exact hb hI₃, },
    exact λ h₂, (ideal.is_prime_iff.1 hI).1 ((ideal.eq_top_iff_one _).2 h₂),

    exact hs₃ hs, },
  { intro hs,
    rcases hs with ⟨p, ⟨hs₂, hs₃⟩⟩,
    rw ← multiset.prod_erase hs₂,
    exact ideal.mul_mem_right _ _ hs₃, },
end

variable (R)

/-- The set of prime elements. -/
def primes := {r : R | prime r}

variables [is_domain R]

variable {R}

theorem theo1_droite [unique_factorization_monoid R] {I : ideal R} (hI : I ≠ ⊥) (hI₂ : I.is_prime) :
  ∃ x ∈ I, prime x :=
begin
  classical,
  have ha : ∃ (a : R), a ∈ I ∧ a ≠ 0 := submodule.exists_mem_ne_zero_of_ne_bot hI,

  rcases ha with ⟨a, ⟨ha₁, ha₂⟩⟩,
  cases (unique_factorization_monoid.factors_prod ha₂) with u ha₃,
  rw ← ha₃ at ha₁,
  cases ((ideal.is_prime.mem_or_mem hI₂) ha₁) with ha₄ ha₅,
  { rcases ((multiset.prod_mem_ideal (unique_factorization_monoid.factors a) hI₂).1 ha₄) with ⟨p, ⟨ha₅, ha₆⟩⟩,
    refine ⟨p, ha₆, unique_factorization_monoid.prime_of_factor p ha₅⟩, },
  { exfalso,
    exact (ideal.is_prime_iff.1 hI₂).1 (ideal.eq_top_of_is_unit_mem _ ha₅ (units.is_unit u)), },
end

variable (R)

lemma primes_mem_mul : (submonoid.closure (primes R)).absorbing :=
begin
  classical,
  rw [submonoid.absorbing_iff_of_comm],
  intros a b hab,
  obtain ⟨m, hm⟩ := submonoid.exists_multiset_of_mem_closure hab,
  revert hm a b,
  apply m.strong_induction_on,

  rintros s hind b a hab ⟨hprime, hprod⟩,
  rcases s.empty_or_exists_mem with (hempty | ⟨i, hi⟩),
  { simp [hempty] at hprod,
    exact ⟨1, submonoid.one_mem _, associated_one_of_mul_eq_one _ hprod.symm⟩ },

  rw [← multiset.prod_erase hi] at hprod,
  rcases (hprime i hi).dvd_or_dvd ⟨(s.erase i).prod, hprod.symm⟩ with (⟨x, hxb⟩ | ⟨x, hxa⟩),

  { suffices : ∃ z ∈ submonoid.closure (primes R), associated x z,
    { obtain ⟨z, hz, hzx⟩ := this,
      refine ⟨z * i, submonoid.mul_mem _ hz (submonoid.subset_closure (hprime _ hi)), _⟩,
      rw [hxb, mul_comm z i],
      exact associated.mul_left i hzx },

    rw [hxb, mul_assoc] at hprod,
    replace hprod := (is_domain.mul_left_cancel_of_ne_zero (hprime _ hi).ne_zero hprod),

    have hxamem : x * a ∈ submonoid.closure (primes R),
    { rw [← hprod],
      exact submonoid.multiset_prod_mem _ _ (λ x hx, submonoid.subset_closure (hprime _ (multiset.erase_subset _ _ hx))) },

    exact hind (s.erase i) (multiset.erase_lt.2 hi) _ _ hxamem ⟨λ y hy, hprime y ((s.erase_subset _) hy), hprod⟩ },

  { rw [hxa, ← mul_assoc, mul_comm b i, mul_assoc] at hprod,
    replace hprod := (is_domain.mul_left_cancel_of_ne_zero (hprime i hi).ne_zero hprod),

    have hbxmem : b * x ∈ submonoid.closure (primes R),
    { rw [← hprod],
      exact submonoid.multiset_prod_mem _ _ (λ x hx, submonoid.subset_closure (hprime _ (multiset.erase_subset _ _ hx))) },

    exact hind (s.erase i) (multiset.erase_lt.2 hi) _ _ hbxmem ⟨λ y hy, hprime y ((s.erase_subset _) hy), hprod⟩ },
end

variable {R}

theorem theo1_gauche (H : ∀ (I : ideal R) (hI : I ≠ ⊥) (hI₂ : I.is_prime), ∃ x ∈ I, prime x) :
  unique_factorization_monoid R :=
begin
  let S := submonoid.closure (primes R),
  have hzero : (0 : R) ∉ S,
  intro h,
  rcases (submonoid.exists_multiset_of_mem_closure h) with ⟨l, ⟨hl, hprod⟩⟩,
  exact not_prime_zero (hl 0 (multiset.prod_eq_zero_iff.1 hprod)),

  refine unique_factorization_monoid.of_exists_prime_factors (λ a ha, _),

  have ha₂ : ideal.span {a} ∉ foo S,
  { intro h,
    rcases prop_2 hzero with ⟨P, ⟨hP, hP₂⟩⟩,
    have hP₃ : P ≠ 0,
    { intro h₂,
      rw [h₂, ideal.zero_eq_bot] at hP₂,
      exact ha (ideal.span_singleton_eq_bot.1 (hP₂ (ideal.span {a}) h (zero_le (ideal.span {a})))) },
    rcases ((H P) hP₃ (theo3 hP hP₂)) with ⟨x, ⟨H₃, H₄⟩⟩,
    rw [foo_def, set.eq_empty_iff_forall_not_mem] at hP,
    exact hP x ⟨H₃, (submonoid.subset_closure H₄)⟩ },

  rw [foo_def, ← ne.def] at ha₂,
  rcases set.nonempty_iff_ne_empty.2 ha₂ with ⟨x, ⟨hx, hx₂⟩⟩,
  cases ideal.mem_span_singleton'.1 (set_like.mem_coe.1 hx) with b hb,
  rw [← hb, mul_comm] at hx₂,

  obtain ⟨z, hzmem, hass⟩ := (submonoid.absorbing_iff_of_comm.1 (primes_mem_mul _) _ _ hx₂),
  obtain ⟨m, hprime, hprod⟩ := submonoid.exists_multiset_of_mem_closure hzmem,
  refine ⟨m, hprime, _⟩,
  rwa [hprod, associated.comm],
end

end Kaplansky


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.omega.term
import Mathlib.PostPort

namespace Mathlib

/-
Definition of linear constrain clauses.
-/

namespace omega

/-- (([t₁,...tₘ],[s₁,...,sₙ]) : clause) encodes the constraints
0 = ⟦t₁⟧ ∧ ... ∧ 0 = ⟦tₘ⟧ ∧ 0 ≤ ⟦s₁⟧ ∧ ... ∧ 0 ≤ ⟦sₙ⟧, where
⟦t⟧ is the value of (t : term). -/
def clause := List term × List term

namespace clause

/-- holds v c := clause c holds under valuation v -/
def holds (v : ℕ → ℤ) : clause → Prop := sorry

/-- sat c := there exists a valuation v under which c holds -/
def sat (c : clause) := ∃ (v : ℕ → ℤ), holds v c

/-- unsat c := there is no valuation v under which c holds -/
def unsat (c : clause) := ¬sat c

/-- append two clauses by elementwise appending -/
def append (c1 : clause) (c2 : clause) : clause :=
  (prod.fst c1 ++ prod.fst c2, prod.snd c1 ++ prod.snd c2)

theorem holds_append {v : ℕ → ℤ} {c1 : clause} {c2 : clause} :
    holds v c1 → holds v c2 → holds v (append c1 c2) :=
  sorry

end clause

/-- There exists a satisfiable clause c in argument -/
def clauses.sat (cs : List clause) := ∃ (c : clause), ∃ (H : c ∈ cs), clause.sat c

/-- There is no satisfiable clause c in argument -/
def clauses.unsat (cs : List clause) := ¬clauses.sat cs

theorem clauses.unsat_nil : clauses.unsat [] := sorry

theorem clauses.unsat_cons (c : clause) (cs : List clause) :
    clause.unsat c → clauses.unsat cs → clauses.unsat (c :: cs) :=
  sorry

end Mathlib


inductive O
| int
| real
| bool
| unit
deriving Inhabited, BEq, Repr

-- only `Arrow.id` and `Arrow.comp` really matter for my problem
inductive Arrow : (_dom _cod : O) → Type
  -- identity
  | id : {α : O} → Arrow α α

  -- `α → α` arrows
  | unit : Arrow O.unit O.unit
  | not : Arrow O.bool O.bool
  | succᵢ : Arrow O.int O.int
  | succᵣ : Arrow O.real O.real

  | comp {α β γ} : Arrow β γ → Arrow α β → Arrow α γ

  -- `unit → bool`
  | tru : Arrow O.unit O.bool
  | fls : Arrow O.unit O.bool
  -- `unit → int`
  | zero : Arrow O.unit O.int
  -- `int → bool`
  | isZero : Arrow O.int O.bool
  -- `int → real`
  | toReal : Arrow O.int O.real
deriving Repr

def Arrow.compose₁ {α β γ : O} :
  Arrow β γ
  → Arrow α β
  → Arrow α γ
-- id.compose₁ g = g
| id, g => g
-- f.compose₁ id = f
| f, id => f
-- else
| comp f₁ f₂, g => comp f₁ (comp f₂ g)
| f, g => comp f g

#print Arrow.compose₁
-- def Arrow.compose₁ : {α β γ : O} → Arrow β γ → Arrow α β → Arrow α γ :=
-- fun {α β γ} x x_1 =>
--   match β, γ, x, x_1 with
--   | β, .(β), Arrow.id, g => g
--   | .(α), γ, f, Arrow.id => f
--   | β, γ, Arrow.comp f₁ f₂, g => Arrow.comp f₁ (Arrow.comp f₂ g)
--   | β, γ, f, g => Arrow.comp f g
#eval Arrow.compose₁ Arrow.unit Arrow.id
-- Arrow.comp (Arrow.unit) (Arrow.id) -- Error: it should be `Arrow.unit`

example : Arrow.compose₁ .id .id         = (.id (α := o)) := rfl
example : Arrow.compose₁ .id .unit       = .unit          := rfl
example : Arrow.compose₁ .id (.comp f g) = .comp f g      := rfl
example : Arrow.compose₁ .unit       .id = .unit := rfl
example : Arrow.compose₁ (.comp f g) .id = .comp f g := rfl
example : Arrow.compose₁ .unit .unit = .comp .unit .unit := rfl
example : Arrow.compose₁ (.comp f g) .unit = .comp f (.comp g .unit) := rfl
example : Arrow.compose₁ .unit (.comp f g) = .comp .unit (.comp f g) := rfl

theorem ex_1 : Arrow.compose₁ f .id = f := by
  cases f <;> simp!

theorem ex_2 : Arrow.compose₁ f .id = f := by
  cases f <;> simp!

theorem ex_3 : Arrow.compose₁ .id f = f := by
  cases f <;> simp!

theorem ex_4 : h ≠ .id → Arrow.compose₁ (.comp f g) h = .comp f (.comp g h) := by
  intros
  cases h <;> simp_all!

def Arrow.isId : Arrow dom com → Prop
  | .id => True
  | _ => False

def Arrow.isComp : Arrow dom com → Prop
  | .comp .. => True
  | _ => False

theorem ex_5 (f : Arrow β γ) (g : Arrow α β) : ¬ f.isId → ¬ g.isId → ¬ f.isComp → Arrow.compose₁ f g = .comp f g := by
  intros
  cases f <;> cases g <;> simp_all!


/-
Copyright (c) 2014 Parikshit Khanna. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Mario Carneiro

Extra definitions on lists.
-/
import data.option.defs logic.basic logic.relator

namespace list

open function nat
universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type x}

instance [decidable_eq α] : has_sdiff (list α) :=
⟨ list.diff ⟩

/-- Split a list at an index.

     split_at 2 [a, b, c] = ([a, b], [c]) -/
def split_at : ℕ → list α → list α × list α
| 0        a         := ([], a)
| (succ n) []        := ([], [])
| (succ n) (x :: xs) := let (l, r) := split_at n xs in (x :: l, r)

/-- Concatenate an element at the end of a list.

     concat [a, b] c = [a, b, c] -/
@[simp] def concat : list α → α → list α
| []     a := [a]
| (b::l) a := b :: concat l a

@[simp] def head' : list α → option α
| []       := none
| (a :: l) := some a

/-- Convert a list into an array (whose length is the length of `l`). -/
def to_array (l : list α) : array l.length α :=
{data := λ v, l.nth_le v.1 v.2}

/-- "inhabited" `nth` function: returns `default` instead of `none` in the case
  that the index is out of bounds. -/
@[simp] def inth [h : inhabited α] (l : list α) (n : nat) : α := (nth l n).iget

/-- Apply a function to the nth tail of `l`. Returns the input without
  using `f` if the index is larger than the length of the list.

     modify_nth_tail f 2 [a, b, c] = [a, b] ++ f [c] -/
@[simp] def modify_nth_tail (f : list α → list α) : ℕ → list α → list α
| 0     l      := f l
| (n+1) []     := []
| (n+1) (a::l) := a :: modify_nth_tail n l

/-- Apply `f` to the head of the list, if it exists. -/
@[simp] def modify_head (f : α → α) : list α → list α
| []     := []
| (a::l) := f a :: l

/-- Apply `f` to the nth element of the list, if it exists. -/
def modify_nth (f : α → α) : ℕ → list α → list α :=
modify_nth_tail (modify_head f)

def insert_nth (n : ℕ) (a : α) : list α → list α := modify_nth_tail (list.cons a) n

section take'
variable [inhabited α]

def take' : ∀ n, list α → list α
| 0     l := []
| (n+1) l := l.head :: take' n l.tail

end take'

/-- Get the longest initial segment of the list whose members all satisfy `p`.

     take_while (λ x, x < 3) [0, 2, 5, 1] = [0, 2] -/
def take_while (p : α → Prop) [decidable_pred p] : list α → list α
| []     := []
| (a::l) := if p a then a :: take_while l else []

/-- Fold a function `f` over the list from the left, returning the list
  of partial results.

     scanl (+) 0 [1, 2, 3] = [0, 1, 3, 6] -/
def scanl (f : α → β → α) : α → list β → list α
| a []     := [a]
| a (b::l) := a :: scanl (f a b) l

def scanr_aux (f : α → β → β) (b : β) : list α → β × list β
| []     := (b, [])
| (a::l) := let (b', l') := scanr_aux l in (f a b', b' :: l')

/-- Fold a function `f` over the list from the right, returning the list
  of partial results.

     scanr (+) 0 [1, 2, 3] = [6, 5, 3, 0] -/
def scanr (f : α → β → β) (b : β) (l : list α) : list β :=
let (b', l') := scanr_aux f b l in b' :: l'

/-- Product of a list.

     prod [a, b, c] = ((1 * a) * b) * c -/
def prod [has_mul α] [has_one α] : list α → α := foldl (*) 1

def partition_map (f : α → β ⊕ γ) : list α → list β × list γ
| [] := ([],[])
| (x::xs) :=
match f x with
| (sum.inr r) := prod.map id (cons r) $ partition_map xs
| (sum.inl l) := prod.map (cons l) id $ partition_map xs
end

/-- `find p l` is the first element of `l` satisfying `p`, or `none` if no such
  element exists. -/
def find (p : α → Prop) [decidable_pred p] : list α → option α
| []     := none
| (a::l) := if p a then some a else find l

def find_indexes_aux (p : α → Prop) [decidable_pred p] : list α → nat → list nat
| []     n := []
| (a::l) n := let t := find_indexes_aux l (succ n) in if p a then n :: t else t

/-- `find_indexes p l` is the list of indexes of elements of `l` that satisfy `p`. -/
def find_indexes (p : α → Prop) [decidable_pred p] (l : list α) : list nat :=
find_indexes_aux p l 0

/-- `lookmap` is a combination of `lookup` and `filter_map`.
  `lookmap f l` will apply `f : α → option α` to each element of the list,
  replacing `a -> b` at the first value `a` in the list such that `f a = some b`. -/
def lookmap (f : α → option α) : list α → list α
| []     := []
| (a::l) :=
  match f a with
  | some b := b :: l
  | none   := a :: lookmap l
  end

/-- `indexes_of a l` is the list of all indexes of `a` in `l`.

     indexes_of a [a, b, a, a] = [0, 2, 3] -/
def indexes_of [decidable_eq α] (a : α) : list α → list nat := find_indexes (eq a)

/-- `countp p l` is the number of elements of `l` that satisfy `p`. -/
def countp (p : α → Prop) [decidable_pred p] : list α → nat
| []      := 0
| (x::xs) := if p x then succ (countp xs) else countp xs

/-- `count a l` is the number of occurrences of `a` in `l`. -/
def count [decidable_eq α] (a : α) : list α → nat := countp (eq a)

/-- `is_prefix l₁ l₂`, or `l₁ <+: l₂`, means that `l₁` is a prefix of `l₂`,
  that is, `l₂` has the form `l₁ ++ t` for some `t`. -/
def is_prefix (l₁ : list α) (l₂ : list α) : Prop := ∃ t, l₁ ++ t = l₂

/-- `is_suffix l₁ l₂`, or `l₁ <:+ l₂`, means that `l₁` is a suffix of `l₂`,
  that is, `l₂` has the form `t ++ l₁` for some `t`. -/
def is_suffix (l₁ : list α) (l₂ : list α) : Prop := ∃ t, t ++ l₁ = l₂

/-- `is_infix l₁ l₂`, or `l₁ <:+: l₂`, means that `l₁` is a contiguous
  substring of `l₂`, that is, `l₂` has the form `s ++ l₁ ++ t` for some `s, t`. -/
def is_infix (l₁ : list α) (l₂ : list α) : Prop := ∃ s t, s ++ l₁ ++ t = l₂

infix ` <+: `:50 := is_prefix
infix ` <:+ `:50 := is_suffix
infix ` <:+: `:50 := is_infix

/-- `inits l` is the list of initial segments of `l`.

     inits [1, 2, 3] = [[], [1], [1, 2], [1, 2, 3]] -/
@[simp] def inits : list α → list (list α)
| []     := [[]]
| (a::l) := [] :: map (λt, a::t) (inits l)

/-- `tails l` is the list of terminal segments of `l`.

     tails [1, 2, 3] = [[1, 2, 3], [2, 3], [3], []] -/
@[simp] def tails : list α → list (list α)
| []     := [[]]
| (a::l) := (a::l) :: tails l

def sublists'_aux : list α → (list α → list β) → list (list β) → list (list β)
| []     f r := f [] :: r
| (a::l) f r := sublists'_aux l f (sublists'_aux l (f ∘ cons a) r)

/-- `sublists' l` is the list of all (non-contiguous) sublists of `l`.
  It differs from `sublists` only in the order of appearance of the sublists;
  `sublists'` uses the first element of the list as the MSB,
  `sublists` uses the first element of the list as the LSB.

     sublists' [1, 2, 3] = [[], [3], [2], [2, 3], [1], [1, 3], [1, 2], [1, 2, 3]] -/
def sublists' (l : list α) : list (list α) :=
sublists'_aux l id []

def sublists_aux : list α → (list α → list β → list β) → list β
| []     f := []
| (a::l) f := f [a] (sublists_aux l (λys r, f ys (f (a :: ys) r)))

/-- `sublists l` is the list of all (non-contiguous) sublists of `l`; cf. `sublists'`
  for a different ordering.

     sublists [1, 2, 3] = [[], [1], [2], [1, 2], [3], [1, 3], [2, 3], [1, 2, 3]] -/
def sublists (l : list α) : list (list α) :=
[] :: sublists_aux l cons

def sublists_aux₁ : list α → (list α → list β) → list β
| []     f := []
| (a::l) f := f [a] ++ sublists_aux₁ l (λys, f ys ++ f (a :: ys))

section forall₂
variables {r : α → β → Prop} {p : γ → δ → Prop}
open relator

inductive forall₂ (R : α → β → Prop) : list α → list β → Prop
| nil {} : forall₂ [] []
| cons {a b l₁ l₂} : R a b → forall₂ l₁ l₂ → forall₂ (a::l₁) (b::l₂)

attribute [simp] forall₂.nil

end forall₂

def transpose_aux : list α → list (list α) → list (list α)
| []     ls      := ls
| (a::i) []      := [a] :: transpose_aux i []
| (a::i) (l::ls) := (a::l) :: transpose_aux i ls

/-- transpose of a list of lists, treated as a matrix.

     transpose [[1, 2], [3, 4], [5, 6]] = [[1, 3, 5], [2, 4, 6]] -/
def transpose : list (list α) → list (list α)
| []      := []
| (l::ls) := transpose_aux l (transpose ls)

/-- List of all sections through a list of lists. A section
  of `[L₁, L₂, ..., Lₙ]` is a list whose first element comes from
  `L₁`, whose second element comes from `L₂`, and so on. -/
def sections : list (list α) → list (list α)
| []     := [[]]
| (l::L) := bind (sections L) $ λ s, map (λ a, a::s) l

section permutations

def permutations_aux2 (t : α) (ts : list α) (r : list β) : list α → (list α → β) → list α × list β
| []      f := (ts, r)
| (y::ys) f := let (us, zs) := permutations_aux2 ys (λx : list α, f (y::x)) in
               (y :: us, f (t :: y :: us) :: zs)

private def meas : (Σ'_:list α, list α) → ℕ × ℕ | ⟨l, i⟩ := (length l + length i, length l)

local infix ` ≺ `:50 := inv_image (prod.lex (<) (<)) meas

@[elab_as_eliminator] def permutations_aux.rec {C : list α → list α → Sort v}
  (H0 : ∀ is, C [] is)
  (H1 : ∀ t ts is, C ts (t::is) → C is [] → C (t::ts) is) : ∀ l₁ l₂, C l₁ l₂
| []      is := H0 is
| (t::ts) is :=
  have h1 : ⟨ts, t :: is⟩ ≺ ⟨t :: ts, is⟩, from
    show prod.lex _ _ (succ (length ts + length is), length ts) (succ (length ts) + length is, length (t :: ts)),
    by rw nat.succ_add; exact prod.lex.right _ _ (lt_succ_self _),
  have h2 : ⟨is, []⟩ ≺ ⟨t :: ts, is⟩, from prod.lex.left _ _ _ (lt_add_of_pos_left _ (succ_pos _)),
  H1 t ts is (permutations_aux.rec ts (t::is)) (permutations_aux.rec is [])
using_well_founded {
  dec_tac := tactic.assumption,
  rel_tac := λ _ _, `[exact ⟨(≺), @inv_image.wf _ _ _ meas (prod.lex_wf lt_wf lt_wf)⟩] }

def permutations_aux : list α → list α → list (list α) :=
@@permutations_aux.rec (λ _ _, list (list α)) (λ is, [])
  (λ t ts is IH1 IH2, foldr (λy r, (permutations_aux2 t ts r y id).2) IH1 (is :: IH2))

/-- List of all permutations of `l`.

     permutations [1, 2, 3] =
       [[1, 2, 3], [2, 1, 3], [3, 2, 1],
        [2, 3, 1], [3, 1, 2], [1, 3, 2]] -/
def permutations (l : list α) : list (list α) :=
l :: permutations_aux l []

end permutations

def erasep (p : α → Prop) [decidable_pred p] : list α → list α
| []     := []
| (a::l) := if p a then l else a :: erasep l

def extractp (p : α → Prop) [decidable_pred p] : list α → option α × list α
| []     := (none, [])
| (a::l) := if p a then (some a, l) else
  let (a', l') := extractp l in (a', a :: l')

def revzip (l : list α) : list (α × α) := zip l l.reverse

/-- `product l₁ l₂` is the list of pairs `(a, b)` where `a ∈ l₁` and `b ∈ l₂`.

     product [1, 2] [5, 6] = [(1, 5), (1, 6), (2, 5), (2, 6)] -/
def product (l₁ : list α) (l₂ : list β) : list (α × β) :=
l₁.bind $ λ a, l₂.map $ prod.mk a

/-- `sigma l₁ l₂` is the list of dependent pairs `(a, b)` where `a ∈ l₁` and `b ∈ l₂ a`.

     sigma [1, 2] (λ_, [(5 : ℕ), 6]) = [(1, 5), (1, 6), (2, 5), (2, 6)] -/
protected def sigma {σ : α → Type*} (l₁ : list α) (l₂ : Π a, list (σ a)) : list (Σ a, σ a) :=
l₁.bind $ λ a, (l₂ a).map $ sigma.mk a

def of_fn_aux {n} (f : fin n → α) : ∀ m, m ≤ n → list α → list α
| 0        h l := l
| (succ m) h l := of_fn_aux m (le_of_lt h) (f ⟨m, h⟩ :: l)

def of_fn {n} (f : fin n → α) : list α :=
of_fn_aux f n (le_refl _) []

def of_fn_nth_val {n} (f : fin n → α) (i : ℕ) : option α :=
if h : _ then some (f ⟨i, h⟩) else none

/-- `disjoint l₁ l₂` means that `l₁` and `l₂` have no elements in common. -/
def disjoint (l₁ l₂ : list α) : Prop := ∀ ⦃a⦄, a ∈ l₁ → a ∈ l₂ → false

section pairwise
variables (R : α → α → Prop)

/-- `pairwise R l` means that all the elements with earlier indexes are
  `R`-related to all the elements with later indexes.

     pairwise R [1, 2, 3] ↔ R 1 2 ∧ R 1 3 ∧ R 2 3

  For example if `R = (≠)` then it asserts `l` has no duplicates,
  and if `R = (<)` then it asserts that `l` is (strictly) sorted. -/
inductive pairwise : list α → Prop
| nil {} : pairwise []
| cons : ∀ {a : α} {l : list α}, (∀ a' ∈ l, R a a') → pairwise l → pairwise (a::l)

variables {R}
@[simp] theorem pairwise_cons {a : α} {l : list α} :
  pairwise R (a::l) ↔ (∀ a' ∈ l, R a a') ∧ pairwise R l :=
⟨λ p, by cases p with a l n p; exact ⟨n, p⟩, λ ⟨n, p⟩, p.cons n⟩

instance decidable_pairwise [decidable_rel R] (l : list α) : decidable (pairwise R l) :=
by induction l with hd tl ih; [exact is_true pairwise.nil,
  exactI decidable_of_iff' _ pairwise_cons]

end pairwise

/-- `pw_filter R l` is a maximal sublist of `l` which is `pairwise R`.
  `pw_filter (≠)` is the erase duplicates function (cf. `erase_dup`), and `pw_filter (<)` finds
  a maximal increasing subsequence in `l`. For example,

     pw_filter (<) [0, 1, 5, 2, 6, 3, 4] = [0, 1, 2, 3, 4] -/
def pw_filter (R : α → α → Prop) [decidable_rel R] : list α → list α
| []        := []
| (x :: xs) := let IH := pw_filter xs in if ∀ y ∈ IH, R x y then x :: IH else IH

section chain
variable (R : α → α → Prop)

/-- `chain R a l` means that `R` holds between adjacent elements of `a::l`.

     chain R a [b, c, d] ↔ R a b ∧ R b c ∧ R c d -/
inductive chain : α → list α → Prop
| nil {} {a : α} : chain a []
| cons : ∀ {a b : α} {l : list α}, R a b → chain b l → chain a (b::l)

/-- `chain' R l` means that `R` holds between adjacent elements of `l`.

     chain' R [a, b, c, d] ↔ R a b ∧ R b c ∧ R c d -/
def chain' : list α → Prop
| [] := true
| (a :: l) := chain R a l

variable {R}
@[simp] theorem chain_cons {a b : α} {l : list α} :
  chain R a (b::l) ↔ R a b ∧ chain R b l :=
⟨λ p, by cases p with _ a b l n p; exact ⟨n, p⟩, λ ⟨n, p⟩, p.cons n⟩

instance decidable_chain [decidable_rel R] (a : α) (l : list α) : decidable (chain R a l) :=
by induction l generalizing a; simp only [chain.nil, chain_cons]; resetI; apply_instance

instance decidable_chain' [decidable_rel R] (a : α) (l : list α) : decidable (chain' R l) :=
by cases l; dunfold chain'; apply_instance

end chain

/-- `nodup l` means that `l` has no duplicates, that is, any element appears at most
  once in the list. It is defined as `pairwise (≠)`. -/
def nodup : list α → Prop := pairwise (≠)

instance nodup_decidable [decidable_eq α] : ∀ l : list α, decidable (nodup l) :=
list.decidable_pairwise

/-- `erase_dup l` removes duplicates from `l` (taking only the first occurrence).
  Defined as `pw_filter (≠)`.

     erase_dup [1, 0, 2, 2, 1] = [0, 2, 1] -/
def erase_dup [decidable_eq α] : list α → list α := pw_filter (≠)

/-- `range' s n` is the list of numbers `[s, s+1, ..., s+n-1]`.
  It is intended mainly for proving properties of `range` and `iota`. -/
@[simp] def range' : ℕ → ℕ → list ℕ
| s 0     := []
| s (n+1) := s :: range' (s+1) n

def reduce_option {α} : list (option α) → list α :=
list.filter_map id

def map_head {α} (f : α → α) : list α → list α
| [] := []
| (x :: xs) := f x :: xs

def map_last {α} (f : α → α) : list α → list α
| [] := []
| [x] := [f x]
| (x :: xs) := x :: map_last xs

@[simp] def last' {α} : α → list α → α
| a []     := a
| a (b::l) := last' b l

/- tfae: The Following (propositions) Are Equivalent -/
def tfae (l : list Prop) : Prop := ∀ x ∈ l, ∀ y ∈ l, x ↔ y

/-- `rotate l n` rotates the elements of `l` to the left by `n`

     rotate [0, 1, 2, 3, 4, 5] 2 = [2, 3, 4, 5, 0, 1] -/
def rotate (l : list α) (n : ℕ) : list α :=
let (l₁, l₂) := list.split_at (n % l.length) l in l₂ ++ l₁

/-- rotate' is the same as `rotate`, but slower. Used for proofs about `rotate`-/
def rotate' : list α → ℕ → list α
| []     n     := []
| l      0     := l
| (a::l) (n+1) := rotate' (l ++ [a]) n

section choose
variables (p : α → Prop) [decidable_pred p] (l : list α)

def choose_x : Π l : list α, Π hp : (∃ a, a ∈ l ∧ p a), { a // a ∈ l ∧ p a }
| [] hp := false.elim (exists.elim hp (assume a h, not_mem_nil a h.left))
| (l :: ls) hp := if pl : p l then ⟨l, ⟨or.inl rfl, pl⟩⟩ else
let ⟨a, ⟨a_mem_ls, pa⟩⟩ := choose_x ls (hp.imp
  (λ b ⟨o, h₂⟩, ⟨o.resolve_left (λ e, pl $ e ▸ h₂), h₂⟩)) in
⟨a, ⟨or.inr a_mem_ls, pa⟩⟩

def choose (hp : ∃ a, a ∈ l ∧ p a) : α := choose_x p l hp

end choose

end list


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.sheaves.presheaf
import Mathlib.PostPort

universes v u l

namespace Mathlib

/-!
# Presheafed spaces

Introduces the category of topological spaces equipped with a presheaf (taking values in an
arbitrary target category `C`.)

We further describe how to apply functors and natural transformations to the values of the
presheaves.
-/

namespace algebraic_geometry

/-- A `PresheafedSpace C` is a topological space equipped with a presheaf of `C`s. -/
structure PresheafedSpace (C : Type u) [category_theory.category C]
where
  carrier : Top
  presheaf : Top.presheaf C carrier

namespace PresheafedSpace

protected instance coe_carrier {C : Type u} [category_theory.category C] : has_coe (PresheafedSpace C) Top :=
  has_coe.mk fun (X : PresheafedSpace C) => carrier X

@[simp] theorem as_coe {C : Type u} [category_theory.category C] (X : PresheafedSpace C) : carrier X = ↑X :=
  rfl

@[simp] theorem mk_coe {C : Type u} [category_theory.category C] (carrier : Top) (presheaf : Top.presheaf C carrier) : ↑(mk carrier presheaf) = carrier :=
  rfl

protected instance topological_space {C : Type u} [category_theory.category C] (X : PresheafedSpace C) : topological_space ↥X :=
  category_theory.bundled.str (carrier X)

/-- The constant presheaf on `X` with value `Z`. -/
def const {C : Type u} [category_theory.category C] (X : Top) (Z : C) : PresheafedSpace C :=
  mk X
    (category_theory.functor.mk (fun (U : topological_space.opens ↥Xᵒᵖ) => Z)
      fun (U V : topological_space.opens ↥Xᵒᵖ) (f : U ⟶ V) => 𝟙)

protected instance inhabited {C : Type u} [category_theory.category C] [Inhabited C] : Inhabited (PresheafedSpace C) :=
  { default := const (Top.of pempty) Inhabited.default }

/-- A morphism between presheafed spaces `X` and `Y` consists of a continuous map
    `f` between the underlying topological spaces, and a (notice contravariant!) map
    from the presheaf on `Y` to the pushforward of the presheaf on `X` via `f`. -/
structure hom {C : Type u} [category_theory.category C] (X : PresheafedSpace C) (Y : PresheafedSpace C)
where
  base : ↑X ⟶ ↑Y
  c : PresheafedSpace.presheaf Y ⟶ base _* PresheafedSpace.presheaf X

theorem ext {C : Type u} [category_theory.category C] {X : PresheafedSpace C} {Y : PresheafedSpace C} (α : hom X Y) (β : hom X Y) (w : hom.base α = hom.base β) (h : hom.c α ≫
    category_theory.whisker_right
      (category_theory.nat_trans.op
        (category_theory.iso.inv (topological_space.opens.map_iso (hom.base α) (hom.base β) w)))
      (PresheafedSpace.presheaf X) =
  hom.c β) : α = β := sorry

/-- The identity morphism of a `PresheafedSpace`. -/
def id {C : Type u} [category_theory.category C] (X : PresheafedSpace C) : hom X X :=
  hom.mk 𝟙
    (category_theory.iso.inv (category_theory.functor.left_unitor (PresheafedSpace.presheaf X)) ≫
      category_theory.whisker_right
        (category_theory.nat_trans.op (category_theory.iso.hom (topological_space.opens.map_id (carrier X))))
        (PresheafedSpace.presheaf X))

protected instance hom_inhabited {C : Type u} [category_theory.category C] (X : PresheafedSpace C) : Inhabited (hom X X) :=
  { default := id X }

/-- Composition of morphisms of `PresheafedSpace`s. -/
def comp {C : Type u} [category_theory.category C] {X : PresheafedSpace C} {Y : PresheafedSpace C} {Z : PresheafedSpace C} (α : hom X Y) (β : hom Y Z) : hom X Z :=
  hom.mk (hom.base α ≫ hom.base β)
    (hom.c β ≫
      category_theory.whisker_left (category_theory.functor.op (topological_space.opens.map (hom.base β))) (hom.c α) ≫
        category_theory.iso.inv (Top.presheaf.pushforward.comp (PresheafedSpace.presheaf X) (hom.base α) (hom.base β)))

/- The proofs below can be done by `tidy`, but it is too slow,
   and we don't have a tactic caching mechanism. -/

/-- The category of PresheafedSpaces. Morphisms are pairs, a continuous map and a presheaf map
    from the presheaf on the target to the pushforward of the presheaf on the source. -/
protected instance category_of_PresheafedSpaces (C : Type u) [category_theory.category C] : category_theory.category (PresheafedSpace C) :=
  category_theory.category.mk

@[simp] theorem id_base {C : Type u} [category_theory.category C] (X : PresheafedSpace C) : hom.base 𝟙 = 𝟙 :=
  rfl

theorem id_c {C : Type u} [category_theory.category C] (X : PresheafedSpace C) : hom.c 𝟙 =
  category_theory.iso.inv (category_theory.functor.left_unitor (PresheafedSpace.presheaf X)) ≫
    category_theory.whisker_right
      (category_theory.nat_trans.op (category_theory.iso.hom (topological_space.opens.map_id (carrier X))))
      (PresheafedSpace.presheaf X) :=
  rfl

@[simp] theorem id_c_app {C : Type u} [category_theory.category C] (X : PresheafedSpace C) (U : topological_space.opens ↥(carrier X)ᵒᵖ) : category_theory.nat_trans.app (hom.c 𝟙) U =
  category_theory.eq_to_hom
    (opposite.op_induction
      (fun (U : topological_space.opens ↥(carrier X)) =>
        subtype.cases_on U
          fun (U_val : set ↥(carrier X)) (U_property : is_open U_val) =>
            Eq.refl
              (category_theory.functor.obj (PresheafedSpace.presheaf X)
                (opposite.op { val := U_val, property := U_property })))
      U) := sorry

@[simp] theorem comp_base {C : Type u} [category_theory.category C] {X : PresheafedSpace C} {Y : PresheafedSpace C} {Z : PresheafedSpace C} (f : X ⟶ Y) (g : Y ⟶ Z) : hom.base (f ≫ g) = hom.base f ≫ hom.base g :=
  rfl

@[simp] theorem comp_c_app {C : Type u} [category_theory.category C] {X : PresheafedSpace C} {Y : PresheafedSpace C} {Z : PresheafedSpace C} (α : X ⟶ Y) (β : Y ⟶ Z) (U : topological_space.opens ↥(carrier Z)ᵒᵖ) : category_theory.nat_trans.app (hom.c (α ≫ β)) U =
  category_theory.nat_trans.app (hom.c β) U ≫
    category_theory.nat_trans.app (hom.c α)
        (opposite.op (category_theory.functor.obj (topological_space.opens.map (hom.base β)) (opposite.unop U))) ≫
      category_theory.nat_trans.app
        (category_theory.iso.inv (Top.presheaf.pushforward.comp (PresheafedSpace.presheaf X) (hom.base α) (hom.base β)))
        U :=
  rfl

theorem congr_app {C : Type u} [category_theory.category C] {X : PresheafedSpace C} {Y : PresheafedSpace C} {α : X ⟶ Y} {β : X ⟶ Y} (h : α = β) (U : topological_space.opens ↥(carrier Y)ᵒᵖ) : category_theory.nat_trans.app (hom.c α) U =
  category_theory.nat_trans.app (hom.c β) U ≫
    category_theory.functor.map (PresheafedSpace.presheaf X)
      (category_theory.eq_to_hom
        (Eq._oldrec
          (Eq.refl
            (category_theory.functor.obj (category_theory.functor.op (topological_space.opens.map (hom.base α))) U))
          h)) := sorry

/-- The forgetful functor from `PresheafedSpace` to `Top`. -/
def forget (C : Type u) [category_theory.category C] : PresheafedSpace C ⥤ Top :=
  category_theory.functor.mk (fun (X : PresheafedSpace C) => ↑X) fun (X Y : PresheafedSpace C) (f : X ⟶ Y) => hom.base f

/--
The restriction of a presheafed space along an open embedding into the space.
-/
@[simp] theorem restrict_carrier {C : Type u} [category_theory.category C] {U : Top} (X : PresheafedSpace C) (f : U ⟶ ↑X) (h : open_embedding ⇑f) : carrier (restrict X f h) = U :=
  Eq.refl (carrier (restrict X f h))

/--
The map from the restriction of a presheafed space.
-/
@[simp] theorem of_restrict_c_app {C : Type u} [category_theory.category C] (U : Top) (X : PresheafedSpace C) (f : U ⟶ ↑X) (h : open_embedding ⇑f) (V : topological_space.opens ↥(carrier X)ᵒᵖ) : category_theory.nat_trans.app (hom.c (of_restrict U X f h)) V =
  category_theory.functor.map (PresheafedSpace.presheaf X)
    (category_theory.has_hom.hom.op
      (coe_fn
        (equiv.symm
          (category_theory.adjunction.hom_equiv (is_open_map.adjunction (of_restrict._proof_2 U X f h))
            (category_theory.functor.obj (topological_space.opens.map f) (opposite.unop V)) (opposite.unop V)))
        𝟙)) :=
  Eq.refl (category_theory.nat_trans.app (hom.c (of_restrict U X f h)) V)

/--
The map to the restriction of a presheafed space along the canonical inclusion from the top
subspace.
-/
@[simp] theorem to_restrict_top_base_to_fun_coe {C : Type u} [category_theory.category C] (X : PresheafedSpace C) (x : ↥↑X) : ↑(coe_fn (hom.base (to_restrict_top X)) x) = x :=
  Eq.refl ↑(coe_fn (hom.base (to_restrict_top X)) x)

/--
The isomorphism from the restriction to the top subspace.
-/
def restrict_top_iso {C : Type u} [category_theory.category C] (X : PresheafedSpace C) : restrict X (topological_space.opens.inclusion ⊤) (restrict_top_iso._proof_1 X) ≅ X :=
  category_theory.iso.mk
    (of_restrict (category_theory.functor.obj (topological_space.opens.to_Top ↑X) ⊤) X
      (topological_space.opens.inclusion ⊤) sorry)
    (to_restrict_top X)

/--
The global sections, notated Gamma.
-/
@[simp] theorem Γ_obj {C : Type u} [category_theory.category C] (X : PresheafedSpace Cᵒᵖ) : category_theory.functor.obj Γ X =
  category_theory.functor.obj (PresheafedSpace.presheaf (opposite.unop X)) (opposite.op ⊤) :=
  Eq.refl (category_theory.functor.obj Γ X)

theorem Γ_obj_op {C : Type u} [category_theory.category C] (X : PresheafedSpace C) : category_theory.functor.obj Γ (opposite.op X) = category_theory.functor.obj (PresheafedSpace.presheaf X) (opposite.op ⊤) :=
  rfl

theorem Γ_map_op {C : Type u} [category_theory.category C] {X : PresheafedSpace C} {Y : PresheafedSpace C} (f : X ⟶ Y) : category_theory.functor.map Γ (category_theory.has_hom.hom.op f) =
  category_theory.nat_trans.app (hom.c f) (opposite.op ⊤) ≫
    category_theory.functor.map (PresheafedSpace.presheaf X)
      (category_theory.has_hom.hom.op (topological_space.opens.le_map_top (hom.base f) ⊤)) :=
  rfl

end PresheafedSpace

end algebraic_geometry

namespace category_theory

namespace functor

/-- We can apply a functor `F : C ⥤ D` to the values of the presheaf in any `PresheafedSpace C`,
    giving a functor `PresheafedSpace C ⥤ PresheafedSpace D` -/
def map_presheaf {C : Type u} [category C] {D : Type u} [category D] (F : C ⥤ D) : algebraic_geometry.PresheafedSpace C ⥤ algebraic_geometry.PresheafedSpace D :=
  mk
    (fun (X : algebraic_geometry.PresheafedSpace C) =>
      algebraic_geometry.PresheafedSpace.mk (algebraic_geometry.PresheafedSpace.carrier X)
        (algebraic_geometry.PresheafedSpace.presheaf X ⋙ F))
    fun (X Y : algebraic_geometry.PresheafedSpace C) (f : X ⟶ Y) =>
      algebraic_geometry.PresheafedSpace.hom.mk (algebraic_geometry.PresheafedSpace.hom.base f)
        (whisker_right (algebraic_geometry.PresheafedSpace.hom.c f) F)

@[simp] theorem map_presheaf_obj_X {C : Type u} [category C] {D : Type u} [category D] (F : C ⥤ D) (X : algebraic_geometry.PresheafedSpace C) : ↑(obj (map_presheaf F) X) = ↑X :=
  rfl

@[simp] theorem map_presheaf_obj_presheaf {C : Type u} [category C] {D : Type u} [category D] (F : C ⥤ D) (X : algebraic_geometry.PresheafedSpace C) : algebraic_geometry.PresheafedSpace.presheaf (obj (map_presheaf F) X) = algebraic_geometry.PresheafedSpace.presheaf X ⋙ F :=
  rfl

@[simp] theorem map_presheaf_map_f {C : Type u} [category C] {D : Type u} [category D] (F : C ⥤ D) {X : algebraic_geometry.PresheafedSpace C} {Y : algebraic_geometry.PresheafedSpace C} (f : X ⟶ Y) : algebraic_geometry.PresheafedSpace.hom.base (map (map_presheaf F) f) = algebraic_geometry.PresheafedSpace.hom.base f :=
  rfl

@[simp] theorem map_presheaf_map_c {C : Type u} [category C] {D : Type u} [category D] (F : C ⥤ D) {X : algebraic_geometry.PresheafedSpace C} {Y : algebraic_geometry.PresheafedSpace C} (f : X ⟶ Y) : algebraic_geometry.PresheafedSpace.hom.c (map (map_presheaf F) f) =
  whisker_right (algebraic_geometry.PresheafedSpace.hom.c f) F :=
  rfl

end functor

namespace nat_trans

/--
A natural transformation induces a natural transformation between the `map_presheaf` functors.
-/
def on_presheaf {C : Type u} [category C] {D : Type u} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ⟶ G) : functor.map_presheaf G ⟶ functor.map_presheaf F :=
  mk
    fun (X : algebraic_geometry.PresheafedSpace C) =>
      algebraic_geometry.PresheafedSpace.hom.mk 𝟙
        (whisker_left (algebraic_geometry.PresheafedSpace.presheaf X) α ≫
          iso.inv (functor.left_unitor (algebraic_geometry.PresheafedSpace.presheaf X ⋙ G)) ≫
            whisker_right
              (nat_trans.op (iso.hom (topological_space.opens.map_id (algebraic_geometry.PresheafedSpace.carrier X))))
              (algebraic_geometry.PresheafedSpace.presheaf X ⋙ G))


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis

! This file was ported from Lean 3 source module ring_theory.witt_vector.is_poly
! leanprover-community/mathlib commit 168ad7fc5d8173ad38be9767a22d50b8ecf1cd00
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Ring.Ulift
import Mathbin.RingTheory.WittVector.Basic
import Mathbin.Data.MvPolynomial.Funext

/-!
# The `is_poly` predicate

`witt_vector.is_poly` is a (type-valued) predicate on functions `f : Π R, 𝕎 R → 𝕎 R`.
It asserts that there is a family of polynomials `φ : ℕ → mv_polynomial ℕ ℤ`,
such that the `n`th coefficient of `f x` is equal to `φ n` evaluated on the coefficients of `x`.
Many operations on Witt vectors satisfy this predicate (or an analogue for higher arity functions).
We say that such a function `f` is a *polynomial function*.

The power of satisfying this predicate comes from `is_poly.ext`.
It shows that if `φ` and `ψ` witness that `f` and `g` are polynomial functions,
then `f = g` not merely when `φ = ψ`, but in fact it suffices to prove
```
∀ n, bind₁ φ (witt_polynomial p _ n) = bind₁ ψ (witt_polynomial p _ n)
```
(in other words, when evaluating the Witt polynomials on `φ` and `ψ`, we get the same values)
which will then imply `φ = ψ` and hence `f = g`.

Even though this sufficient condition looks somewhat intimidating,
it is rather pleasant to check in practice;
more so than direct checking of `φ = ψ`.

In practice, we apply this technique to show that the composition of `witt_vector.frobenius`
and `witt_vector.verschiebung` is equal to multiplication by `p`.

## Main declarations

* `witt_vector.is_poly`, `witt_vector.is_poly₂`:
  two predicates that assert that a unary/binary function on Witt vectors
  is polynomial in the coefficients of the input values.
* `witt_vector.is_poly.ext`, `witt_vector.is_poly₂.ext`:
  two polynomial functions are equal if their families of polynomials are equal
  after evaluating the Witt polynomials on them.
* `witt_vector.is_poly.comp` (+ many variants) show that unary/binary compositions
  of polynomial functions are polynomial.
* `witt_vector.id_is_poly`, `witt_vector.neg_is_poly`,
  `witt_vector.add_is_poly₂`, `witt_vector.mul_is_poly₂`:
  several well-known operations are polynomial functions
  (for Verschiebung, Frobenius, and multiplication by `p`, see their respective files).

## On higher arity analogues

Ideally, there should be a predicate `is_polyₙ` for functions of higher arity,
together with `is_polyₙ.comp` that shows how such functions compose.
Since mathlib does not have a library on composition of higher arity functions,
we have only implemented the unary and binary variants so far.
Nullary functions (a.k.a. constants) are treated
as constant functions and fall under the unary case.

## Tactics

There are important metaprograms defined in this file:
the tactics `ghost_simp` and `ghost_calc` and the attributes `@[is_poly]` and `@[ghost_simps]`.
These are used in combination to discharge proofs of identities between polynomial functions.

Any atomic proof of `is_poly` or `is_poly₂` (i.e. not taking additional `is_poly` arguments)
should be tagged as `@[is_poly]`.

Any lemma doing "ring equation rewriting" with polynomial functions should be tagged
`@[ghost_simps]`, e.g.
```lean
@[ghost_simps]
lemma bind₁_frobenius_poly_witt_polynomial (n : ℕ) :
  bind₁ (frobenius_poly p) (witt_polynomial p ℤ n) = (witt_polynomial p ℤ (n+1))
```

Proofs of identities between polynomial functions will often follow the pattern
```lean
begin
  ghost_calc _,
  <minor preprocessing>,
  ghost_simp
end
```

## References

* [Hazewinkel, *Witt Vectors*][Haze09]

* [Commelin and Lewis, *Formalizing the Ring of Witt Vectors*][CL21]
-/

/- failed to parenthesize: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
[PrettyPrinter.parenthesize.input] (Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr
     [(Command.docComment "/--" "Simplification rules for ghost equations -/")]
     "register_simp_attr"
     `ghost_simps)-/-- failed to format: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
/-- Simplification rules for ghost equations -/ register_simp_attr ghost_simps

namespace Tactic

namespace Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/-- A macro for a common simplification when rewriting with ghost component equations. -/
unsafe def ghost_simp (lems : parse simp_arg_list) : tactic Unit := do
  tactic.try tactic.intro1
  simp none none tt (lems ++ [simp_arg_type.symm_expr ``(sub_eq_add_neg)]) [`ghost_simps]
      (loc.ns [none])
#align tactic.interactive.ghost_simp tactic.interactive.ghost_simp

/-- `ghost_calc` is a tactic for proving identities between polynomial functions.
Typically, when faced with a goal like
```lean
∀ (x y : 𝕎 R), verschiebung (x * frobenius y) = verschiebung x * y
```
you can
1. call `ghost_calc`
2. do a small amount of manual work -- maybe nothing, maybe `rintro`, etc
3. call `ghost_simp`

and this will close the goal.

`ghost_calc` cannot detect whether you are dealing with unary or binary polynomial functions.
You must give it arguments to determine this.
If you are proving a universally quantified goal like the above,
call `ghost_calc _ _`.
If the variables are introduced already, call `ghost_calc x y`.
In the unary case, use `ghost_calc _` or `ghost_calc x`.

`ghost_calc` is a light wrapper around type class inference.
All it does is apply the appropriate extensionality lemma and try to infer the resulting goals.
This is subtle and Lean's elaborator doesn't like it because of the HO unification involved,
so it is easier (and prettier) to put it in a tactic script.
-/
unsafe def ghost_calc (ids' : parse ident_*) : tactic Unit := do
  let ids ← ids'.mapM fun n => get_local n <|> tactic.intro n
  let q(@Eq (WittVector _ $(R)) _ _) ← target
  match ids with
    | [x] => refine `(is_poly.ext _ _ _ _ $(x))
    | [x, y] => refine `(is_poly₂.ext _ _ _ _ $(x) $(y))
    | _ => fail "ghost_calc takes one or two arguments"
  let nm ←
    match R with
      | expr.local_const _ nm _ _ => return nm
      | _ => get_unused_name `R
  iterate_exactly 2 apply_instance
  unfreezingI (tactic.clear' tt [R])
  introsI <| [nm, .str nm "_inst"] ++ ids'
  skip
#align tactic.interactive.ghost_calc tactic.interactive.ghost_calc

end Interactive

end Tactic

namespace WittVector

universe u

variable {p : ℕ} {R S : Type u} {σ idx : Type _} [hp : Fact p.Prime] [CommRing R] [CommRing S]

-- mathport name: expr𝕎
local notation "𝕎" => WittVector p

-- type as `\bbW`
open MvPolynomial

open Function (uncurry)

include hp

variable (p)

noncomputable section

/-!
### The `is_poly` predicate
-/

theorem poly_eq_of_wittPolynomial_bind_eq' (f g : ℕ → MvPolynomial (idx × ℕ) ℤ)
    (h : ∀ n, bind₁ f (wittPolynomial p _ n) = bind₁ g (wittPolynomial p _ n)) : f = g :=
  by
  ext1 n
  apply MvPolynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective
  rw [← Function.funext_iff] at h
  replace h :=
    congr_arg (fun fam => bind₁ (MvPolynomial.map (Int.castRingHom ℚ) ∘ fam) (xInTermsOfW p ℚ n)) h
  simpa only [Function.comp, map_bind₁, map_wittPolynomial, ← bind₁_bind₁,
    bind₁_wittPolynomial_xInTermsOfW, bind₁_X_right] using h
#align witt_vector.poly_eq_of_witt_polynomial_bind_eq' WittVector.poly_eq_of_wittPolynomial_bind_eq'

theorem poly_eq_of_wittPolynomial_bind_eq (f g : ℕ → MvPolynomial ℕ ℤ)
    (h : ∀ n, bind₁ f (wittPolynomial p _ n) = bind₁ g (wittPolynomial p _ n)) : f = g :=
  by
  ext1 n
  apply MvPolynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective
  rw [← Function.funext_iff] at h
  replace h :=
    congr_arg (fun fam => bind₁ (MvPolynomial.map (Int.castRingHom ℚ) ∘ fam) (xInTermsOfW p ℚ n)) h
  simpa only [Function.comp, map_bind₁, map_wittPolynomial, ← bind₁_bind₁,
    bind₁_wittPolynomial_xInTermsOfW, bind₁_X_right] using h
#align witt_vector.poly_eq_of_witt_polynomial_bind_eq WittVector.poly_eq_of_wittPolynomial_bind_eq

omit hp

-- Ideally, we would generalise this to n-ary functions
-- But we don't have a good theory of n-ary compositions in mathlib
/-- A function `f : Π R, 𝕎 R → 𝕎 R` that maps Witt vectors to Witt vectors over arbitrary base rings
is said to be *polynomial* if there is a family of polynomials `φₙ` over `ℤ` such that the `n`th
coefficient of `f x` is given by evaluating `φₙ` at the coefficients of `x`.

See also `witt_vector.is_poly₂` for the binary variant.

The `ghost_calc` tactic treats `is_poly` as a type class,
and the `@[is_poly]` attribute derives certain specialized composition instances
for declarations of type `is_poly f`.
For the most part, users are not expected to treat `is_poly` as a class.
-/
class IsPoly (f : ∀ ⦃R⦄ [CommRing R], WittVector p R → 𝕎 R) : Prop where mk' ::
  poly :
    ∃ φ : ℕ → MvPolynomial ℕ ℤ,
      ∀ ⦃R⦄ [CommRing R] (x : 𝕎 R), (f x).coeff = fun n => aeval x.coeff (φ n)
#align witt_vector.is_poly WittVector.IsPoly

/-- The identity function on Witt vectors is a polynomial function. -/
instance idIsPoly : IsPoly p fun _ _ => id :=
  ⟨⟨X, by
      intros
      simp only [aeval_X, id]⟩⟩
#align witt_vector.id_is_poly WittVector.idIsPoly

instance idIsPolyI' : IsPoly p fun _ _ a => a :=
  WittVector.idIsPoly _
#align witt_vector.id_is_poly_i' WittVector.idIsPolyI'

namespace IsPoly

instance : Inhabited (IsPoly p fun _ _ => id) :=
  ⟨WittVector.idIsPoly p⟩

variable {p}

include hp

theorem ext {f g} (hf : IsPoly p f) (hg : IsPoly p g)
    (h :
      ∀ (R : Type u) [_Rcr : CommRing R] (x : 𝕎 R) (n : ℕ),
        ghost_component n (f x) = ghost_component n (g x)) :
    ∀ (R : Type u) [_Rcr : CommRing R] (x : 𝕎 R), f x = g x :=
  by
  obtain ⟨φ, hf⟩ := hf
  obtain ⟨ψ, hg⟩ := hg
  intros
  ext n
  rw [hf, hg, poly_eq_of_witt_polynomial_bind_eq p φ ψ]
  intro k
  apply MvPolynomial.funext
  intro x
  simp only [hom_bind₁]
  specialize h (ULift ℤ) (mk p fun i => ⟨x i⟩) k
  simp only [ghost_component_apply, aeval_eq_eval₂_hom] at h
  apply (ulift.ring_equiv.symm : ℤ ≃+* _).Injective
  simp only [← RingEquiv.coe_toRingHom, map_eval₂_hom]
  convert h using 1
  all_goals
    funext i
    simp only [hf, hg, MvPolynomial.eval, map_eval₂_hom]
    apply eval₂_hom_congr (RingHom.ext_int _ _) _ rfl
    ext1
    apply eval₂_hom_congr (RingHom.ext_int _ _) _ rfl
    simp only [coeff_mk]; rfl
#align witt_vector.is_poly.ext WittVector.IsPoly.ext

omit hp

/-- The composition of polynomial functions is polynomial. -/
theorem comp {g f} (hg : IsPoly p g) (hf : IsPoly p f) :
    IsPoly p fun R _Rcr => @g R _Rcr ∘ @f R _Rcr :=
  by
  obtain ⟨φ, hf⟩ := hf
  obtain ⟨ψ, hg⟩ := hg
  use fun n => bind₁ φ (ψ n)
  intros
  simp only [aeval_bind₁, Function.comp, hg, hf]
#align witt_vector.is_poly.comp WittVector.IsPoly.comp

end IsPoly

/-- A binary function `f : Π R, 𝕎 R → 𝕎 R → 𝕎 R` on Witt vectors
is said to be *polynomial* if there is a family of polynomials `φₙ` over `ℤ` such that the `n`th
coefficient of `f x y` is given by evaluating `φₙ` at the coefficients of `x` and `y`.

See also `witt_vector.is_poly` for the unary variant.

The `ghost_calc` tactic treats `is_poly₂` as a type class,
and the `@[is_poly]` attribute derives certain specialized composition instances
for declarations of type `is_poly₂ f`.
For the most part, users are not expected to treat `is_poly₂` as a class.
-/
class IsPoly₂ (f : ∀ ⦃R⦄ [CommRing R], WittVector p R → 𝕎 R → 𝕎 R) : Prop where mk' ::
  poly :
    ∃ φ : ℕ → MvPolynomial (Fin 2 × ℕ) ℤ,
      ∀ ⦃R⦄ [CommRing R] (x y : 𝕎 R), (f x y).coeff = fun n => peval (φ n) ![x.coeff, y.coeff]
#align witt_vector.is_poly₂ WittVector.IsPoly₂

variable {p}

/-- The composition of polynomial functions is polynomial. -/
theorem IsPoly₂.comp {h f g} (hh : IsPoly₂ p h) (hf : IsPoly p f) (hg : IsPoly p g) :
    IsPoly₂ p fun R _Rcr x y => h (f x) (g y) :=
  by
  obtain ⟨φ, hf⟩ := hf
  obtain ⟨ψ, hg⟩ := hg
  obtain ⟨χ, hh⟩ := hh
  refine'
    ⟨⟨fun n =>
        bind₁
          (uncurry <|
            ![fun k => rename (Prod.mk (0 : Fin 2)) (φ k), fun k =>
              rename (Prod.mk (1 : Fin 2)) (ψ k)])
          (χ n),
        _⟩⟩
  intros
  funext n
  simp only [peval, aeval_bind₁, Function.comp, hh, hf, hg, uncurry]
  apply eval₂_hom_congr rfl _ rfl
  ext ⟨i, n⟩
  fin_cases i <;>
    simp only [aeval_eq_eval₂_hom, eval₂_hom_rename, Function.comp, Matrix.cons_val_zero,
      Matrix.head_cons, Matrix.cons_val_one]
#align witt_vector.is_poly₂.comp WittVector.IsPoly₂.comp

/-- The composition of a polynomial function with a binary polynomial function is polynomial. -/
theorem IsPoly.comp₂ {g f} (hg : IsPoly p g) (hf : IsPoly₂ p f) :
    IsPoly₂ p fun R _Rcr x y => g (f x y) :=
  by
  obtain ⟨φ, hf⟩ := hf
  obtain ⟨ψ, hg⟩ := hg
  use fun n => bind₁ φ (ψ n)
  intros
  simp only [peval, aeval_bind₁, Function.comp, hg, hf]
#align witt_vector.is_poly.comp₂ WittVector.IsPoly.comp₂

/-- The diagonal `λ x, f x x` of a polynomial function `f` is polynomial. -/
theorem IsPoly₂.diag {f} (hf : IsPoly₂ p f) : IsPoly p fun R _Rcr x => f x x :=
  by
  obtain ⟨φ, hf⟩ := hf
  refine' ⟨⟨fun n => bind₁ (uncurry ![X, X]) (φ n), _⟩⟩
  intros ; funext n
  simp only [hf, peval, uncurry, aeval_bind₁]
  apply eval₂_hom_congr rfl _ rfl
  ext ⟨i, k⟩;
  fin_cases i <;> simp only [Matrix.head_cons, aeval_X, Matrix.cons_val_zero, Matrix.cons_val_one]
#align witt_vector.is_poly₂.diag WittVector.IsPoly₂.diag

open Tactic

namespace Tactic

/-!
### The `@[is_poly]` attribute

This attribute is used to derive specialized composition instances
for `is_poly` and `is_poly₂` declarations.
-/

/-- If `n` is the name of a lemma with opened type `∀ vars, is_poly p _`,
`mk_poly_comp_lemmas n vars p` adds composition instances to the environment
`n.comp_i` and `n.comp₂_i`.
-/
unsafe def mk_poly_comp_lemmas (n : Name) (vars : List expr) (p : expr) : tactic Unit := do
  let c ← mk_const n
  let appd := vars.foldl expr.app c
  let tgt_bod ←
    to_expr ``(fun f [hf : IsPoly $(p) f] => IsPoly.comp $(appd) hf) >>=
        replace_univ_metas_with_univ_params
  let tgt_bod ← lambdas vars tgt_bod
  let tgt_tp ← infer_type tgt_bod
  let nm := .str n "comp_i"
  add_decl <| mk_definition nm tgt_tp tgt_tp tgt_bod
  set_attribute `instance nm
  let tgt_bod ←
    to_expr ``(fun f [hf : IsPoly₂ $(p) f] => IsPoly.comp₂ $(appd) hf) >>=
        replace_univ_metas_with_univ_params
  let tgt_bod ← lambdas vars tgt_bod
  let tgt_tp ← infer_type tgt_bod
  let nm := .str n "comp₂_i"
  add_decl <| mk_definition nm tgt_tp tgt_tp tgt_bod
  set_attribute `instance nm
#align witt_vector.tactic.mk_poly_comp_lemmas witt_vector.tactic.mk_poly_comp_lemmas

/-- If `n` is the name of a lemma with opened type `∀ vars, is_poly₂ p _`,
`mk_poly₂_comp_lemmas n vars p` adds composition instances to the environment
`n.comp₂_i` and `n.comp_diag`.
-/
unsafe def mk_poly₂_comp_lemmas (n : Name) (vars : List expr) (p : expr) : tactic Unit := do
  let c ← mk_const n
  let appd := vars.foldl expr.app c
  let tgt_bod ←
    to_expr
          ``(fun {f g} [hf : IsPoly $(p) f] [hg : IsPoly $(p) g] => IsPoly₂.comp $(appd) hf hg) >>=
        replace_univ_metas_with_univ_params
  let tgt_bod ← lambdas vars tgt_bod
  let tgt_tp ← infer_type tgt_bod >>= simp_lemmas.mk.dsimplify
  let nm := .str n "comp₂_i"
  add_decl <| mk_definition nm tgt_tp tgt_tp tgt_bod
  set_attribute `instance nm
  let tgt_bod ←
    to_expr
          ``(fun {f g} [hf : IsPoly $(p) f] [hg : IsPoly $(p) g] =>
            (IsPoly₂.comp $(appd) hf hg).diag) >>=
        replace_univ_metas_with_univ_params
  let tgt_bod ← lambdas vars tgt_bod
  let tgt_tp ← infer_type tgt_bod >>= simp_lemmas.mk.dsimplify
  let nm := .str n "comp_diag"
  add_decl <| mk_definition nm tgt_tp tgt_tp tgt_bod
  set_attribute `instance nm
#align witt_vector.tactic.mk_poly₂_comp_lemmas witt_vector.tactic.mk_poly₂_comp_lemmas

/-- The `after_set` function for `@[is_poly]`. Calls `mk_poly(₂)_comp_lemmas`.
-/
unsafe def mk_comp_lemmas (n : Name) : tactic Unit := do
  let d ← get_decl n
  let (vars, tp) ← open_pis d.type
  match tp with
    | q(IsPoly $(p) _) => mk_poly_comp_lemmas n vars p
    | q(IsPoly₂ $(p) _) => mk_poly₂_comp_lemmas n vars p
    | _ => fail "@[is_poly] should only be applied to terms of type `is_poly _ _` or `is_poly₂ _ _`"
#align witt_vector.tactic.mk_comp_lemmas witt_vector.tactic.mk_comp_lemmas

/-- `@[is_poly]` is applied to lemmas of the form `is_poly f φ` or `is_poly₂ f φ`.
These lemmas should *not* be tagged as instances, and only atomic `is_poly` defs should be tagged:
composition lemmas should not. Roughly speaking, lemmas that take `is_poly` proofs as arguments
should not be tagged.

Type class inference struggles with function composition, and the higher order unification problems
involved in inferring `is_poly` proofs are complex. The standard style writing these proofs by hand
doesn't work very well. Instead, we construct the type class hierarchy "under the hood", with
limited forms of composition.

Applying `@[is_poly]` to a lemma creates a number of instances. Roughly, if the tagged lemma is a
proof of `is_poly f φ`, the instances added have the form
```lean
∀ g ψ, [is_poly g ψ] → is_poly (f ∘ g) _
```
Since `f` is fixed in this instance, it restricts the HO unification needed when the instance is
applied. Composition lemmas relating `is_poly` with `is_poly₂` are also added.
`id_is_poly` is an atomic instance.

The user-written lemmas are not instances. Users should be able to assemble `is_poly` proofs by hand
"as normal" if the tactic fails.
-/
@[user_attribute]
unsafe def is_poly_attr : user_attribute
    where
  Name := `is_poly
  descr := "Lemmas with this attribute describe the polynomial structure of functions"
  after_set := some fun n _ _ => mk_comp_lemmas n
#align witt_vector.tactic.is_poly_attr witt_vector.tactic.is_poly_attr

end Tactic

include hp

/-!
### `is_poly` instances

These are not declared as instances at the top level,
but the `@[is_poly]` attribute adds instances based on each one.
Users are expected to use the non-instance versions manually.
-/

/-- The additive negation is a polynomial function on Witt vectors. -/
@[is_poly]
theorem negIsPoly : IsPoly p fun R _ => @Neg.neg (𝕎 R) _ :=
  ⟨⟨fun n => rename Prod.snd (wittNeg p n), by
      intros ; funext n
      rw [neg_coeff, aeval_eq_eval₂_hom, eval₂_hom_rename]
      apply eval₂_hom_congr rfl _ rfl
      ext ⟨i, k⟩; fin_cases i; rfl⟩⟩
#align witt_vector.neg_is_poly WittVector.negIsPoly

section ZeroOne

/- To avoid a theory of 0-ary functions (a.k.a. constants)
we model them as constant unary functions. -/
/-- The function that is constantly zero on Witt vectors is a polynomial function. -/
instance zeroIsPoly : IsPoly p fun _ _ _ => 0 :=
  ⟨⟨0, by
      intros
      funext n
      simp only [Pi.zero_apply, AlgHom.map_zero, zero_coeff]⟩⟩
#align witt_vector.zero_is_poly WittVector.zeroIsPoly

@[simp]
theorem bind₁_zero_wittPolynomial (n : ℕ) :
    bind₁ (0 : ℕ → MvPolynomial ℕ R) (wittPolynomial p R n) = 0 := by
  rw [← aeval_eq_bind₁, aeval_zero, constantCoeff_wittPolynomial, RingHom.map_zero]
#align witt_vector.bind₁_zero_witt_polynomial WittVector.bind₁_zero_wittPolynomial

omit hp

/-- The coefficients of `1 : 𝕎 R` as polynomials. -/
def onePoly (n : ℕ) : MvPolynomial ℕ ℤ :=
  if n = 0 then 1 else 0
#align witt_vector.one_poly WittVector.onePoly

include hp

@[simp]
theorem bind₁_onePoly_wittPolynomial (n : ℕ) : bind₁ onePoly (wittPolynomial p ℤ n) = 1 :=
  by
  rw [wittPolynomial_eq_sum_c_mul_x_pow, AlgHom.map_sum, Finset.sum_eq_single 0]
  ·
    simp only [one_poly, one_pow, one_mul, AlgHom.map_pow, C_1, pow_zero, bind₁_X_right, if_true,
      eq_self_iff_true]
  · intro i hi hi0
    simp only [one_poly, if_neg hi0, zero_pow (pow_pos hp.1.Pos _), MulZeroClass.mul_zero,
      AlgHom.map_pow, bind₁_X_right, AlgHom.map_mul]
  · rw [Finset.mem_range]
    decide
#align witt_vector.bind₁_one_poly_witt_polynomial WittVector.bind₁_onePoly_wittPolynomial

/-- The function that is constantly one on Witt vectors is a polynomial function. -/
instance oneIsPoly : IsPoly p fun _ _ _ => 1 :=
  ⟨⟨onePoly, by
      intros ; funext n; cases n
      · simp only [one_poly, if_true, eq_self_iff_true, one_coeff_zero, AlgHom.map_one]
      ·
        simp only [one_poly, Nat.succ_pos', one_coeff_eq_of_pos, if_neg n.succ_ne_zero,
          AlgHom.map_zero]⟩⟩
#align witt_vector.one_is_poly WittVector.oneIsPoly

end ZeroOne

omit hp

/-- Addition of Witt vectors is a polynomial function. -/
@[is_poly]
theorem add_isPoly₂ [Fact p.Prime] : IsPoly₂ p fun _ _ => (· + ·) :=
  ⟨⟨wittAdd p, by
      intros
      dsimp only [WittVector.hasAdd]
      simp [eval]⟩⟩
#align witt_vector.add_is_poly₂ WittVector.add_isPoly₂

/-- Multiplication of Witt vectors is a polynomial function. -/
@[is_poly]
theorem mul_isPoly₂ [Fact p.Prime] : IsPoly₂ p fun _ _ => (· * ·) :=
  ⟨⟨wittMul p, by
      intros
      dsimp only [WittVector.hasMul]
      simp [eval]⟩⟩
#align witt_vector.mul_is_poly₂ WittVector.mul_isPoly₂

include hp

-- unfortunately this is not universe polymorphic, merely because `f` isn't
theorem IsPoly.map {f} (hf : IsPoly p f) (g : R →+* S) (x : 𝕎 R) : map g (f x) = f (map g x) :=
  by
  -- this could be turned into a tactic “macro” (taking `hf` as parameter)
  -- so that applications do not have to worry about the universe issue
  -- see `is_poly₂.map` for a slightly more general proof strategy
  obtain ⟨φ, hf⟩ := hf
  ext n
  simp only [map_coeff, hf, map_aeval]
  apply eval₂_hom_congr (RingHom.ext_int _ _) _ rfl
  simp only [map_coeff]
#align witt_vector.is_poly.map WittVector.IsPoly.map

namespace IsPoly₂

omit hp

instance [Fact p.Prime] : Inhabited (IsPoly₂ p _) :=
  ⟨add_isPoly₂⟩

variable {p}

/-- The composition of a binary polynomial function
 with a unary polynomial function in the first argument is polynomial. -/
theorem comp_left {g f} (hg : IsPoly₂ p g) (hf : IsPoly p f) :
    IsPoly₂ p fun R _Rcr x y => g (f x) y :=
  hg.comp hf (WittVector.idIsPoly _)
#align witt_vector.is_poly₂.comp_left WittVector.IsPoly₂.comp_left

/-- The composition of a binary polynomial function
 with a unary polynomial function in the second argument is polynomial. -/
theorem comp_right {g f} (hg : IsPoly₂ p g) (hf : IsPoly p f) :
    IsPoly₂ p fun R _Rcr x y => g x (f y) :=
  hg.comp (WittVector.idIsPoly p) hf
#align witt_vector.is_poly₂.comp_right WittVector.IsPoly₂.comp_right

include hp

theorem ext {f g} (hf : IsPoly₂ p f) (hg : IsPoly₂ p g)
    (h :
      ∀ (R : Type u) [_Rcr : CommRing R] (x y : 𝕎 R) (n : ℕ),
        ghost_component n (f x y) = ghost_component n (g x y)) :
    ∀ (R) [_Rcr : CommRing R] (x y : 𝕎 R), f x y = g x y :=
  by
  obtain ⟨φ, hf⟩ := hf
  obtain ⟨ψ, hg⟩ := hg
  intros
  ext n
  rw [hf, hg, poly_eq_of_witt_polynomial_bind_eq' p φ ψ]
  clear x y
  intro k
  apply MvPolynomial.funext
  intro x
  simp only [hom_bind₁]
  specialize h (ULift ℤ) (mk p fun i => ⟨x (0, i)⟩) (mk p fun i => ⟨x (1, i)⟩) k
  simp only [ghost_component_apply, aeval_eq_eval₂_hom] at h
  apply (ulift.ring_equiv.symm : ℤ ≃+* _).Injective
  simp only [← RingEquiv.coe_toRingHom, map_eval₂_hom]
  convert h using 1
  all_goals
    funext i
    simp only [hf, hg, MvPolynomial.eval, map_eval₂_hom]
    apply eval₂_hom_congr (RingHom.ext_int _ _) _ rfl
    ext1
    apply eval₂_hom_congr (RingHom.ext_int _ _) _ rfl
    ext ⟨b, _⟩
    fin_cases b <;> simp only [coeff_mk, uncurry] <;> rfl
#align witt_vector.is_poly₂.ext WittVector.IsPoly₂.ext

-- unfortunately this is not universe polymorphic, merely because `f` isn't
theorem map {f} (hf : IsPoly₂ p f) (g : R →+* S) (x y : 𝕎 R) :
    map g (f x y) = f (map g x) (map g y) :=
  by
  -- this could be turned into a tactic “macro” (taking `hf` as parameter)
  -- so that applications do not have to worry about the universe issue
  obtain ⟨φ, hf⟩ := hf
  ext n
  simp only [map_coeff, hf, map_aeval, peval, uncurry]
  apply eval₂_hom_congr (RingHom.ext_int _ _) _ rfl
  try ext ⟨i, k⟩; fin_cases i
  all_goals simp only [map_coeff, Matrix.cons_val_zero, Matrix.head_cons, Matrix.cons_val_one]
#align witt_vector.is_poly₂.map WittVector.IsPoly₂.map

end IsPoly₂

attribute [ghost_simps]
  AlgHom.map_zero AlgHom.map_one AlgHom.map_add AlgHom.map_mul AlgHom.map_sub AlgHom.map_neg AlgHom.id_apply map_natCast RingHom.map_zero RingHom.map_one RingHom.map_mul RingHom.map_add RingHom.map_sub RingHom.map_neg RingHom.id_apply mul_add add_mul add_zero zero_add mul_one one_mul MulZeroClass.mul_zero MulZeroClass.zero_mul Nat.succ_ne_zero add_tsub_cancel_right Nat.succ_eq_add_one if_true eq_self_iff_true if_false forall_true_iff forall₂_true_iff forall₃_true_iff

end WittVector