/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jeremy Avigad, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.filter.cofinite
import Mathlib.PostPort

universes u_1 l u v

namespace Mathlib

/-!
# Ultrafilters

An ultrafilter is a minimal (maximal in the set order) proper filter.
In this file we define

* `ultrafilter.of`: an ultrafilter that is less than or equal to a given filter;
* `ultrafilter`: subtype of ultrafilters;
* `ultrafilter.pure`: `pure x` as an `ultrafiler`;
* `ultrafilter.map`, `ultrafilter.bind`, `ultrafilter.comap` : operations on ultrafilters;
* `hyperfilter`: the ultrafilter extending the cofinite filter.
-/

/-- An ultrafilter is a minimal (maximal in the set order) proper filter. -/
structure ultrafilter (α : Type u_1)
extends filter α
where
  ne_bot' : filter.ne_bot _to_filter
  le_of_le : ∀ (g : filter α), filter.ne_bot g → g ≤ _to_filter → _to_filter ≤ g

namespace ultrafilter

protected instance filter.has_coe_t {α : Type u} : has_coe_t (ultrafilter α) (filter α) :=
  has_coe_t.mk ultrafilter.to_filter

protected instance has_mem {α : Type u} : has_mem (set α) (ultrafilter α) :=
  has_mem.mk fun (s : set α) (f : ultrafilter α) => s ∈ ↑f

theorem unique {α : Type u} (f : ultrafilter α) {g : filter α} (h : g ≤ ↑f) (hne : autoParam (filter.ne_bot g)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "apply_instance") [])) : g = ↑f :=
  le_antisymm h (ultrafilter.le_of_le f g hne h)

protected instance ne_bot {α : Type u} (f : ultrafilter α) : filter.ne_bot ↑f :=
  ultrafilter.ne_bot' f

@[simp] theorem mem_coe {α : Type u} {f : ultrafilter α} {s : set α} : s ∈ ↑f ↔ s ∈ f :=
  iff.rfl

theorem coe_injective {α : Type u} : function.injective coe := sorry

@[simp] theorem coe_le_coe {α : Type u} {f : ultrafilter α} {g : ultrafilter α} : ↑f ≤ ↑g ↔ f = g :=
  { mp := fun (h : ↑f ≤ ↑g) => coe_injective (unique g h), mpr := fun (h : f = g) => h ▸ le_rfl }

@[simp] theorem coe_inj {α : Type u} {f : ultrafilter α} {g : ultrafilter α} : ↑f = ↑g ↔ f = g :=
  function.injective.eq_iff coe_injective

theorem ext {α : Type u} {f : ultrafilter α} {g : ultrafilter α} (h : ∀ (s : set α), s ∈ f ↔ s ∈ g) : f = g :=
  coe_injective (filter.ext h)

theorem le_of_inf_ne_bot {α : Type u} (f : ultrafilter α) {g : filter α} (hg : filter.ne_bot (↑f ⊓ g)) : ↑f ≤ g :=
  le_of_inf_eq (unique f inf_le_left)

theorem le_of_inf_ne_bot' {α : Type u} (f : ultrafilter α) {g : filter α} (hg : filter.ne_bot (g ⊓ ↑f)) : ↑f ≤ g :=
  le_of_inf_ne_bot f (eq.mpr (id (Eq._oldrec (Eq.refl (filter.ne_bot (↑f ⊓ g))) inf_comm)) hg)

@[simp] theorem compl_not_mem_iff {α : Type u} {f : ultrafilter α} {s : set α} : ¬sᶜ ∈ f ↔ s ∈ f := sorry

@[simp] theorem frequently_iff_eventually {α : Type u} {f : ultrafilter α} {p : α → Prop} : filter.frequently (fun (x : α) => p x) ↑f ↔ filter.eventually (fun (x : α) => p x) ↑f :=
  compl_not_mem_iff

theorem Mathlib.filter.frequently.eventually {α : Type u} {f : ultrafilter α} {p : α → Prop} : filter.frequently (fun (x : α) => p x) ↑f → filter.eventually (fun (x : α) => p x) ↑f :=
  iff.mp frequently_iff_eventually

theorem compl_mem_iff_not_mem {α : Type u} {f : ultrafilter α} {s : set α} : sᶜ ∈ f ↔ ¬s ∈ f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (sᶜ ∈ f ↔ ¬s ∈ f)) (Eq.symm (propext compl_not_mem_iff))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (¬sᶜᶜ ∈ f ↔ ¬s ∈ f)) (compl_compl s))) (iff.refl (¬s ∈ f)))

/-- If `sᶜ ∉ f ↔ s ∈ f`, then `f` is an ultrafilter. The other implication is given by
`ultrafilter.compl_not_mem_iff`.  -/
def of_compl_not_mem_iff {α : Type u} (f : filter α) (h : ∀ (s : set α), ¬sᶜ ∈ f ↔ s ∈ f) : ultrafilter α :=
  mk f sorry sorry

theorem nonempty_of_mem {α : Type u} {f : ultrafilter α} {s : set α} (hs : s ∈ f) : set.nonempty s :=
  filter.nonempty_of_mem_sets hs

theorem ne_empty_of_mem {α : Type u} {f : ultrafilter α} {s : set α} (hs : s ∈ f) : s ≠ ∅ :=
  set.nonempty.ne_empty (nonempty_of_mem hs)

@[simp] theorem empty_not_mem {α : Type u} {f : ultrafilter α} : ¬∅ ∈ f :=
  filter.empty_nmem_sets ↑f

theorem mem_or_compl_mem {α : Type u} (f : ultrafilter α) (s : set α) : s ∈ f ∨ sᶜ ∈ f :=
  iff.mpr or_iff_not_imp_left (iff.mpr compl_mem_iff_not_mem)

protected theorem em {α : Type u} (f : ultrafilter α) (p : α → Prop) : filter.eventually (fun (x : α) => p x) ↑f ∨ filter.eventually (fun (x : α) => ¬p x) ↑f :=
  mem_or_compl_mem f (set_of fun (x : α) => p x)

theorem eventually_or {α : Type u} {f : ultrafilter α} {p : α → Prop} {q : α → Prop} : filter.eventually (fun (x : α) => p x ∨ q x) ↑f ↔
  filter.eventually (fun (x : α) => p x) ↑f ∨ filter.eventually (fun (x : α) => q x) ↑f := sorry

theorem union_mem_iff {α : Type u} {f : ultrafilter α} {s : set α} {t : set α} : s ∪ t ∈ f ↔ s ∈ f ∨ t ∈ f :=
  eventually_or

theorem eventually_not {α : Type u} {f : ultrafilter α} {p : α → Prop} : filter.eventually (fun (x : α) => ¬p x) ↑f ↔ ¬filter.eventually (fun (x : α) => p x) ↑f :=
  compl_mem_iff_not_mem

theorem eventually_imp {α : Type u} {f : ultrafilter α} {p : α → Prop} {q : α → Prop} : filter.eventually (fun (x : α) => p x → q x) ↑f ↔
  filter.eventually (fun (x : α) => p x) ↑f → filter.eventually (fun (x : α) => q x) ↑f := sorry

theorem finite_sUnion_mem_iff {α : Type u} {f : ultrafilter α} {s : set (set α)} (hs : set.finite s) : ⋃₀s ∈ f ↔ ∃ (t : set α), ∃ (H : t ∈ s), t ∈ f := sorry

theorem finite_bUnion_mem_iff {α : Type u} {β : Type v} {f : ultrafilter α} {is : set β} {s : β → set α} (his : set.finite is) : (set.Union fun (i : β) => set.Union fun (H : i ∈ is) => s i) ∈ f ↔ ∃ (i : β), ∃ (H : i ∈ is), s i ∈ f := sorry

/-- Pushforward for ultrafilters. -/
def map {α : Type u} {β : Type v} (m : α → β) (f : ultrafilter α) : ultrafilter β :=
  of_compl_not_mem_iff (filter.map m ↑f) sorry

@[simp] theorem coe_map {α : Type u} {β : Type v} (m : α → β) (f : ultrafilter α) : ↑(map m f) = filter.map m ↑f :=
  rfl

@[simp] theorem mem_map {α : Type u} {β : Type v} {m : α → β} {f : ultrafilter α} {s : set β} : s ∈ map m f ↔ m ⁻¹' s ∈ f :=
  iff.rfl

/-- The pullback of an ultrafilter along an injection whose range is large with respect to the given
ultrafilter. -/
def comap {α : Type u} {β : Type v} {m : α → β} (u : ultrafilter β) (inj : function.injective m) (large : set.range m ∈ u) : ultrafilter α :=
  mk (filter.comap m ↑u) sorry sorry

/-- The principal ultrafilter associated to a point `x`. -/
protected instance has_pure : Pure ultrafilter :=
  { pure := fun (α : Type u_1) (a : α) => of_compl_not_mem_iff (pure a) sorry }

@[simp] theorem mem_pure_sets {α : Type u} {a : α} {s : set α} : s ∈ pure a ↔ a ∈ s :=
  iff.rfl

protected instance inhabited {α : Type u} [Inhabited α] : Inhabited (ultrafilter α) :=
  { default := pure Inhabited.default }

/-- Monadic bind for ultrafilters, coming from the one on filters
defined in terms of map and join.-/
def bind {α : Type u} {β : Type v} (f : ultrafilter α) (m : α → ultrafilter β) : ultrafilter β :=
  of_compl_not_mem_iff (filter.bind ↑f fun (x : α) => ↑(m x)) sorry

protected instance ultrafilter.has_bind : Bind ultrafilter :=
  { bind := bind }

protected instance ultrafilter.functor : Functor ultrafilter :=
  { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β }

protected instance ultrafilter.monad : Monad ultrafilter := sorry

protected instance ultrafilter.is_lawful_monad : is_lawful_monad ultrafilter :=
  is_lawful_monad.mk
    (fun (α β : Type u_1) (a : α) (f : α → ultrafilter β) => coe_injective (filter.pure_bind a (coe ∘ f)))
    fun (α β γ : Type u_1) (f : ultrafilter α) (m₁ : α → ultrafilter β) (m₂ : β → ultrafilter γ) =>
      coe_injective (filter.filter_eq rfl)

/-- The ultrafilter lemma: Any proper filter is contained in an ultrafilter. -/
theorem exists_le {α : Type u} (f : filter α) [h : filter.ne_bot f] : ∃ (u : ultrafilter α), ↑u ≤ f := sorry

theorem Mathlib.filter.exists_ultrafilter_le {α : Type u} (f : filter α) [h : filter.ne_bot f] : ∃ (u : ultrafilter α), ↑u ≤ f :=
  exists_le

/-- Construct an ultrafilter extending a given filter.
  The ultrafilter lemma is the assertion that such a filter exists;
  we use the axiom of choice to pick one. -/
def of {α : Type u} (f : filter α) [filter.ne_bot f] : ultrafilter α :=
  classical.some (exists_le f)

theorem of_le {α : Type u} (f : filter α) [filter.ne_bot f] : ↑(of f) ≤ f :=
  classical.some_spec (exists_le f)

theorem of_coe {α : Type u} (f : ultrafilter α) : of ↑f = f :=
  iff.mp coe_inj (unique f (of_le ↑f))

theorem exists_ultrafilter_of_finite_inter_nonempty {α : Type u} (S : set (set α)) (cond : ∀ (T : finset (set α)), ↑T ⊆ S → set.nonempty (⋂₀↑T)) : ∃ (F : ultrafilter α), S ⊆ filter.sets (ultrafilter.to_filter F) := sorry

end ultrafilter

namespace filter

theorem mem_iff_ultrafilter {α : Type u} {s : set α} {f : filter α} : s ∈ f ↔ ∀ (g : ultrafilter α), ↑g ≤ f → s ∈ g := sorry

theorem le_iff_ultrafilter {α : Type u} {f₁ : filter α} {f₂ : filter α} : f₁ ≤ f₂ ↔ ∀ (g : ultrafilter α), ↑g ≤ f₁ → ↑g ≤ f₂ := sorry

/-- A filter equals the intersection of all the ultrafilters which contain it. -/
theorem supr_ultrafilter_le_eq {α : Type u} (f : filter α) : (supr fun (g : ultrafilter α) => supr fun (hg : ↑g ≤ f) => ↑g) = f := sorry

/-- The `tendsto` relation can be checked on ultrafilters. -/
theorem tendsto_iff_ultrafilter {α : Type u} {β : Type v} (f : α → β) (l₁ : filter α) (l₂ : filter β) : tendsto f l₁ l₂ ↔ ∀ (g : ultrafilter α), ↑g ≤ l₁ → tendsto f (↑g) l₂ := sorry

theorem exists_ultrafilter_iff {α : Type u} {f : filter α} : (∃ (u : ultrafilter α), ↑u ≤ f) ↔ ne_bot f := sorry

theorem forall_ne_bot_le_iff {α : Type u} {g : filter α} {p : filter α → Prop} (hp : monotone p) : (∀ (f : filter α), ne_bot f → f ≤ g → p f) ↔ ∀ (f : ultrafilter α), ↑f ≤ g → p ↑f := sorry

/-- The ultrafilter extending the cofinite filter. -/
def hyperfilter (α : Type u) [infinite α] : ultrafilter α :=
  ultrafilter.of cofinite

theorem hyperfilter_le_cofinite {α : Type u} [infinite α] : ↑(hyperfilter α) ≤ cofinite :=
  ultrafilter.of_le cofinite

@[simp] theorem bot_ne_hyperfilter {α : Type u} [infinite α] : ⊥ ≠ ↑(hyperfilter α) :=
  ne.symm ((fun (this : ne_bot ↑(hyperfilter α)) => this) (ultrafilter.ne_bot (hyperfilter α)))

theorem nmem_hyperfilter_of_finite {α : Type u} [infinite α] {s : set α} (hf : set.finite s) : ¬s ∈ hyperfilter α :=
  fun (hy : s ∈ hyperfilter α) => compl_not_mem_sets hy (hyperfilter_le_cofinite (set.finite.compl_mem_cofinite hf))

theorem Mathlib.set.finite.nmem_hyperfilter {α : Type u} [infinite α] {s : set α} (hf : set.finite s) : ¬s ∈ hyperfilter α :=
  nmem_hyperfilter_of_finite

theorem compl_mem_hyperfilter_of_finite {α : Type u} [infinite α] {s : set α} (hf : set.finite s) : sᶜ ∈ hyperfilter α :=
  iff.mpr ultrafilter.compl_mem_iff_not_mem (set.finite.nmem_hyperfilter hf)

theorem Mathlib.set.finite.compl_mem_hyperfilter {α : Type u} [infinite α] {s : set α} (hf : set.finite s) : sᶜ ∈ hyperfilter α :=
  compl_mem_hyperfilter_of_finite

theorem mem_hyperfilter_of_finite_compl {α : Type u} [infinite α] {s : set α} (hf : set.finite (sᶜ)) : s ∈ hyperfilter α :=
  compl_compl s ▸ set.finite.compl_mem_hyperfilter hf


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module data.multiset.antidiagonal
! leanprover-community/mathlib commit e04043d6bf7264a3c84bc69711dc354958ca4516
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Multiset.Powerset

/-!
# The antidiagonal on a multiset.

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

The antidiagonal of a multiset `s` consists of all pairs `(t₁, t₂)`
such that `t₁ + t₂ = s`. These pairs are counted with multiplicities.
-/

namespace Multiset

open List

variable {α β : Type _}

#print Multiset.antidiagonal /-
/-- The antidiagonal of a multiset `s` consists of all pairs `(t₁, t₂)`
    such that `t₁ + t₂ = s`. These pairs are counted with multiplicities. -/
def antidiagonal (s : Multiset α) : Multiset (Multiset α × Multiset α) :=
  Quot.liftOn s (fun l => (revzip (powersetAux l) : Multiset (Multiset α × Multiset α)))
    fun l₁ l₂ h => Quot.sound (revzip_powersetAux_perm h)
#align multiset.antidiagonal Multiset.antidiagonal
-/

#print Multiset.antidiagonal_coe /-
theorem antidiagonal_coe (l : List α) : @antidiagonal α l = revzip (powersetAux l) :=
  rfl
#align multiset.antidiagonal_coe Multiset.antidiagonal_coe
-/

#print Multiset.antidiagonal_coe' /-
@[simp]
theorem antidiagonal_coe' (l : List α) : @antidiagonal α l = revzip (powersetAux' l) :=
  Quot.sound revzip_powersetAux_perm_aux'
#align multiset.antidiagonal_coe' Multiset.antidiagonal_coe'
-/

#print Multiset.mem_antidiagonal /-
/-- A pair `(t₁, t₂)` of multisets is contained in `antidiagonal s`
    if and only if `t₁ + t₂ = s`. -/
@[simp]
theorem mem_antidiagonal {s : Multiset α} {x : Multiset α × Multiset α} :
    x ∈ antidiagonal s ↔ x.1 + x.2 = s :=
  Quotient.inductionOn s fun l => by
    simp [antidiagonal_coe]; refine' ⟨fun h => revzip_powerset_aux h, fun h => _⟩
    haveI := Classical.decEq α
    simp [revzip_powerset_aux_lemma l revzip_powerset_aux, h.symm]
    cases' x with x₁ x₂
    dsimp only
    exact ⟨x₁, le_add_right _ _, by rw [add_tsub_cancel_left x₁ x₂]⟩
#align multiset.mem_antidiagonal Multiset.mem_antidiagonal
-/

#print Multiset.antidiagonal_map_fst /-
@[simp]
theorem antidiagonal_map_fst (s : Multiset α) : (antidiagonal s).map Prod.fst = powerset s :=
  Quotient.inductionOn s fun l => by simp [powerset_aux']
#align multiset.antidiagonal_map_fst Multiset.antidiagonal_map_fst
-/

#print Multiset.antidiagonal_map_snd /-
@[simp]
theorem antidiagonal_map_snd (s : Multiset α) : (antidiagonal s).map Prod.snd = powerset s :=
  Quotient.inductionOn s fun l => by simp [powerset_aux']
#align multiset.antidiagonal_map_snd Multiset.antidiagonal_map_snd
-/

#print Multiset.antidiagonal_zero /-
@[simp]
theorem antidiagonal_zero : @antidiagonal α 0 = {(0, 0)} :=
  rfl
#align multiset.antidiagonal_zero Multiset.antidiagonal_zero
-/

#print Multiset.antidiagonal_cons /-
@[simp]
theorem antidiagonal_cons (a : α) (s) :
    antidiagonal (a ::ₘ s) =
      map (Prod.map id (cons a)) (antidiagonal s) + map (Prod.map (cons a) id) (antidiagonal s) :=
  Quotient.inductionOn s fun l =>
    by
    simp only [revzip, reverse_append, quot_mk_to_coe, coe_eq_coe, powerset_aux'_cons, cons_coe,
      coe_map, antidiagonal_coe', coe_add]
    rw [← zip_map, ← zip_map, zip_append, (_ : _ ++ _ = _)]
    · congr <;> simp; · simp
#align multiset.antidiagonal_cons Multiset.antidiagonal_cons
-/

#print Multiset.antidiagonal_eq_map_powerset /-
theorem antidiagonal_eq_map_powerset [DecidableEq α] (s : Multiset α) :
    s.antidiagonal = s.powerset.map fun t => (s - t, t) :=
  by
  induction' s using Multiset.induction_on with a s hs
  · simp only [antidiagonal_zero, powerset_zero, zero_tsub, map_singleton]
  · simp_rw [antidiagonal_cons, powerset_cons, map_add, hs, map_map, Function.comp, Prod.map_mk,
      id.def, sub_cons, erase_cons_head]
    rw [add_comm]
    congr 1
    refine' Multiset.map_congr rfl fun x hx => _
    rw [cons_sub_of_le _ (mem_powerset.mp hx)]
#align multiset.antidiagonal_eq_map_powerset Multiset.antidiagonal_eq_map_powerset
-/

/- warning: multiset.card_antidiagonal -> Multiset.card_antidiagonal is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} (s : Multiset.{u1} α), Eq.{1} Nat (coeFn.{succ u1, succ u1} (AddMonoidHom.{u1, 0} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.orderedCancelAddCommMonoid.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)))))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (fun (_x : AddMonoidHom.{u1, 0} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.orderedCancelAddCommMonoid.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)))))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) => (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) -> Nat) (AddMonoidHom.hasCoeToFun.{u1, 0} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.orderedCancelAddCommMonoid.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)))))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (Multiset.card.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.antidiagonal.{u1} α s)) (HPow.hPow.{0, 0, 0} Nat Nat Nat (instHPow.{0, 0} Nat Nat (Monoid.Pow.{0} Nat Nat.monoid)) (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))) (coeFn.{succ u1, succ u1} (AddMonoidHom.{u1, 0} (Multiset.{u1} α) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} α) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} α) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} α) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} α) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} α) (Multiset.orderedCancelAddCommMonoid.{u1} α)))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (fun (_x : AddMonoidHom.{u1, 0} (Multiset.{u1} α) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} α) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} α) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} α) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} α) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} α) (Multiset.orderedCancelAddCommMonoid.{u1} α)))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) => (Multiset.{u1} α) -> Nat) (AddMonoidHom.hasCoeToFun.{u1, 0} (Multiset.{u1} α) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} α) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} α) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} α) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} α) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} α) (Multiset.orderedCancelAddCommMonoid.{u1} α)))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (Multiset.card.{u1} α) s))
but is expected to have type
  forall {α : Type.{u1}} (s : Multiset.{u1} α), Eq.{1} ((fun (x._@.Mathlib.Algebra.Hom.Group._hyg.403 : Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) => Nat) (Multiset.antidiagonal.{u1} α s)) (FunLike.coe.{succ u1, succ u1, 1} (AddMonoidHom.{u1, 0} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)))))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (fun (_x : Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.403 : Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) => Nat) _x) (AddHomClass.toFunLike.{u1, u1, 0} (AddMonoidHom.{u1, 0} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)))))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) Nat (AddZeroClass.toAdd.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))))))))) (AddZeroClass.toAdd.{0} Nat (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (AddMonoidHomClass.toAddHomClass.{u1, u1, 0} (AddMonoidHom.{u1, 0} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)))))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)))))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid) (AddMonoidHom.addMonoidHomClass.{u1, 0} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)))))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)))) (Multiset.card.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) (Multiset.antidiagonal.{u1} α s)) (HPow.hPow.{0, 0, 0} ((fun (x._@.Mathlib.Algebra.Hom.Group._hyg.403 : Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) => Nat) (Multiset.antidiagonal.{u1} α s)) ((fun (x._@.Mathlib.Algebra.Hom.Group._hyg.403 : Multiset.{u1} α) => Nat) s) ((fun (x._@.Mathlib.Algebra.Hom.Group._hyg.403 : Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) => Nat) (Multiset.antidiagonal.{u1} α s)) (instHPow.{0, 0} ((fun (x._@.Mathlib.Algebra.Hom.Group._hyg.403 : Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) => Nat) (Multiset.antidiagonal.{u1} α s)) ((fun (x._@.Mathlib.Algebra.Hom.Group._hyg.403 : Multiset.{u1} α) => Nat) s) instPowNat) (OfNat.ofNat.{0} ((fun (x._@.Mathlib.Algebra.Hom.Group._hyg.403 : Multiset.{u1} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α))) => Nat) (Multiset.antidiagonal.{u1} α s)) 2 (instOfNatNat 2)) (FunLike.coe.{succ u1, succ u1, 1} (AddMonoidHom.{u1, 0} (Multiset.{u1} α) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} α) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} α) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} α) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} α) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} α) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} α)))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (Multiset.{u1} α) (fun (_x : Multiset.{u1} α) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.403 : Multiset.{u1} α) => Nat) _x) (AddHomClass.toFunLike.{u1, u1, 0} (AddMonoidHom.{u1, 0} (Multiset.{u1} α) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} α) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} α) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} α) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} α) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} α) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} α)))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (Multiset.{u1} α) Nat (AddZeroClass.toAdd.{u1} (Multiset.{u1} α) (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} α) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} α) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} α) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} α) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} α) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} α))))))) (AddZeroClass.toAdd.{0} Nat (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (AddMonoidHomClass.toAddHomClass.{u1, u1, 0} (AddMonoidHom.{u1, 0} (Multiset.{u1} α) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} α) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} α) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} α) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} α) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} α) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} α)))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)) (Multiset.{u1} α) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} α) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} α) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} α) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} α) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} α) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} α)))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid) (AddMonoidHom.addMonoidHomClass.{u1, 0} (Multiset.{u1} α) Nat (AddMonoid.toAddZeroClass.{u1} (Multiset.{u1} α) (AddRightCancelMonoid.toAddMonoid.{u1} (Multiset.{u1} α) (AddCancelMonoid.toAddRightCancelMonoid.{u1} (Multiset.{u1} α) (AddCancelCommMonoid.toAddCancelMonoid.{u1} (Multiset.{u1} α) (OrderedCancelAddCommMonoid.toCancelAddCommMonoid.{u1} (Multiset.{u1} α) (Multiset.instOrderedCancelAddCommMonoidMultiset.{u1} α)))))) (AddMonoid.toAddZeroClass.{0} Nat Nat.addMonoid)))) (Multiset.card.{u1} α) s))
Case conversion may be inaccurate. Consider using '#align multiset.card_antidiagonal Multiset.card_antidiagonalₓ'. -/
@[simp]
theorem card_antidiagonal (s : Multiset α) : card (antidiagonal s) = 2 ^ card s := by
  have := card_powerset s <;> rwa [← antidiagonal_map_fst, card_map] at this
#align multiset.card_antidiagonal Multiset.card_antidiagonal

/- warning: multiset.prod_map_add -> Multiset.prod_map_add is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : CommSemiring.{u2} β] {s : Multiset.{u1} α} {f : α -> β} {g : α -> β}, Eq.{succ u2} β (Multiset.prod.{u2} β (CommSemiring.toCommMonoid.{u2} β _inst_1) (Multiset.map.{u1, u2} α β (fun (a : α) => HAdd.hAdd.{u2, u2, u2} β β β (instHAdd.{u2} β (Distrib.toHasAdd.{u2} β (NonUnitalNonAssocSemiring.toDistrib.{u2} β (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} β (Semiring.toNonAssocSemiring.{u2} β (CommSemiring.toSemiring.{u2} β _inst_1)))))) (f a) (g a)) s)) (Multiset.sum.{u2} β (NonUnitalNonAssocSemiring.toAddCommMonoid.{u2} β (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} β (Semiring.toNonAssocSemiring.{u2} β (CommSemiring.toSemiring.{u2} β _inst_1)))) (Multiset.map.{u1, u2} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)) β (fun (p : Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)) => HMul.hMul.{u2, u2, u2} β β β (instHMul.{u2} β (Distrib.toHasMul.{u2} β (NonUnitalNonAssocSemiring.toDistrib.{u2} β (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} β (Semiring.toNonAssocSemiring.{u2} β (CommSemiring.toSemiring.{u2} β _inst_1)))))) (Multiset.prod.{u2} β (CommSemiring.toCommMonoid.{u2} β _inst_1) (Multiset.map.{u1, u2} α β f (Prod.fst.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α) p))) (Multiset.prod.{u2} β (CommSemiring.toCommMonoid.{u2} β _inst_1) (Multiset.map.{u1, u2} α β g (Prod.snd.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α) p)))) (Multiset.antidiagonal.{u1} α s)))
but is expected to have type
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : CommSemiring.{u2} β] {s : Multiset.{u1} α} {f : α -> β} {g : α -> β}, Eq.{succ u2} β (Multiset.prod.{u2} β (CommSemiring.toCommMonoid.{u2} β _inst_1) (Multiset.map.{u1, u2} α β (fun (a : α) => HAdd.hAdd.{u2, u2, u2} β β β (instHAdd.{u2} β (Distrib.toAdd.{u2} β (NonUnitalNonAssocSemiring.toDistrib.{u2} β (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} β (Semiring.toNonAssocSemiring.{u2} β (CommSemiring.toSemiring.{u2} β _inst_1)))))) (f a) (g a)) s)) (Multiset.sum.{u2} β (NonUnitalNonAssocSemiring.toAddCommMonoid.{u2} β (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} β (Semiring.toNonAssocSemiring.{u2} β (CommSemiring.toSemiring.{u2} β _inst_1)))) (Multiset.map.{u1, u2} (Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)) β (fun (p : Prod.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α)) => HMul.hMul.{u2, u2, u2} β β β (instHMul.{u2} β (NonUnitalNonAssocSemiring.toMul.{u2} β (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} β (Semiring.toNonAssocSemiring.{u2} β (CommSemiring.toSemiring.{u2} β _inst_1))))) (Multiset.prod.{u2} β (CommSemiring.toCommMonoid.{u2} β _inst_1) (Multiset.map.{u1, u2} α β f (Prod.fst.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α) p))) (Multiset.prod.{u2} β (CommSemiring.toCommMonoid.{u2} β _inst_1) (Multiset.map.{u1, u2} α β g (Prod.snd.{u1, u1} (Multiset.{u1} α) (Multiset.{u1} α) p)))) (Multiset.antidiagonal.{u1} α s)))
Case conversion may be inaccurate. Consider using '#align multiset.prod_map_add Multiset.prod_map_addₓ'. -/
theorem prod_map_add [CommSemiring β] {s : Multiset α} {f g : α → β} :
    prod (s.map fun a => f a + g a) =
      sum ((antidiagonal s).map fun p => (p.1.map f).Prod * (p.2.map g).Prod) :=
  by
  refine' s.induction_on _ _
  · simp
  · intro a s ih
    have := @sum_map_mul_left α β _
    simp [ih, add_mul, mul_comm, mul_left_comm (f a), mul_left_comm (g a), mul_assoc,
      sum_map_mul_left.symm]
    cc
#align multiset.prod_map_add Multiset.prod_map_add

end Multiset


/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang
-/
import algebraic_geometry.projective_spectrum.topology
import topology.sheaves.local_predicate
import ring_theory.graded_algebra.homogeneous_localization
import algebraic_geometry.locally_ringed_space

/-!
# The structure sheaf on `projective_spectrum 𝒜`.

In `src/algebraic_geometry/topology.lean`, we have given a topology on `projective_spectrum 𝒜`; in
this file we will construct a sheaf on `projective_spectrum 𝒜`.

## Notation
- `R` is a commutative semiring;
- `A` is a commutative ring and an `R`-algebra;
- `𝒜 : ℕ → submodule R A` is the grading of `A`;
- `U` is opposite object of some open subset of `projective_spectrum.Top`.

## Main definitions and results
We define the structure sheaf as the subsheaf of all dependent function
`f : Π x : U, homogeneous_localization 𝒜 x` such that `f` is locally expressible as ratio of two
elements of the *same grading*, i.e. `∀ y ∈ U, ∃ (V ⊆ U) (i : ℕ) (a b ∈ 𝒜 i), ∀ z ∈ V, f z = a / b`.

* `algebraic_geometry.projective_spectrum.structure_sheaf.is_locally_fraction`: the predicate that
  a dependent function is locally expressible as a ratio of two elements of the same grading.
* `algebraic_geometry.projective_spectrum.structure_sheaf.sections_subring`: the dependent functions
  satisfying the above local property forms a subring of all dependent functions
  `Π x : U, homogeneous_localization 𝒜 x`.
* `algebraic_geometry.Proj.structure_sheaf`: the sheaf with `U ↦ sections_subring U` and natural
  restriction map.

Then we establish that `Proj 𝒜` is a `LocallyRingedSpace`:
* `algebraic_geometry.Proj.stalk_iso'`: for any `x : projective_spectrum 𝒜`, the stalk of
  `Proj.structure_sheaf` at `x` is isomorphic to `homogeneous_localization 𝒜 x`.
* `algebraic_geometry.Proj.to_LocallyRingedSpace`: `Proj` as a locally ringed space.

## References

* [Robin Hartshorne, *Algebraic Geometry*][Har77]

-/

noncomputable theory

namespace algebraic_geometry

open_locale direct_sum big_operators pointwise
open direct_sum set_like localization Top topological_space category_theory opposite

variables {R A: Type*}
variables [comm_ring R] [comm_ring A] [algebra R A]
variables (𝒜 : ℕ → submodule R A) [graded_algebra 𝒜]

local notation `at ` x := homogeneous_localization.at_prime 𝒜 x.as_homogeneous_ideal.to_ideal

namespace projective_spectrum.structure_sheaf

variables {𝒜}

/--
The predicate saying that a dependent function on an open `U` is realised as a fixed fraction
`r / s` of *same grading* in each of the stalks (which are localizations at various prime ideals).
-/
def is_fraction {U : opens (projective_spectrum.Top 𝒜)} (f : Π x : U, at x.1) : Prop :=
∃ (i : ℕ) (r s : 𝒜 i),
  ∀ x : U, ∃ (s_nin : s.1 ∉ x.1.as_homogeneous_ideal),
  (f x) = quotient.mk' ⟨i, r, s, s_nin⟩

variables (𝒜)

/--
The predicate `is_fraction` is "prelocal", in the sense that if it holds on `U` it holds on any open
subset `V` of `U`.
-/
def is_fraction_prelocal : prelocal_predicate (λ (x : projective_spectrum.Top 𝒜), at x) :=
{ pred := λ U f, is_fraction f,
  res := by rintros V U i f ⟨j, r, s, w⟩; exact ⟨j, r, s, λ y, w (i y)⟩ }

/--
We will define the structure sheaf as the subsheaf of all dependent functions in
`Π x : U, homogeneous_localization 𝒜 x` consisting of those functions which can locally be expressed
as a ratio of `A` of same grading.-/
def is_locally_fraction : local_predicate (λ (x : projective_spectrum.Top 𝒜), at x) :=
(is_fraction_prelocal 𝒜).sheafify

namespace section_subring
variable {𝒜}

open submodule set_like.graded_monoid homogeneous_localization

lemma zero_mem' (U : (opens (projective_spectrum.Top 𝒜))ᵒᵖ) :
  (is_locally_fraction 𝒜).pred (0 : Π x : unop U, at x.1) :=
λ x, ⟨unop U, x.2, 𝟙 (unop U), ⟨0, ⟨0, zero_mem _⟩, ⟨1, one_mem⟩, λ y, ⟨_, rfl⟩⟩⟩

lemma one_mem' (U : (opens (projective_spectrum.Top 𝒜))ᵒᵖ) :
  (is_locally_fraction 𝒜).pred (1 : Π x : unop U, at x.1) :=
λ x, ⟨unop U, x.2, 𝟙 (unop U), ⟨0, ⟨1, one_mem⟩, ⟨1, one_mem⟩, λ y, ⟨_, rfl⟩⟩⟩

lemma add_mem' (U : (opens (projective_spectrum.Top 𝒜))ᵒᵖ)
  (a b : Π x : unop U, at x.1)
  (ha : (is_locally_fraction 𝒜).pred a) (hb : (is_locally_fraction 𝒜).pred b) :
  (is_locally_fraction 𝒜).pred (a + b) := λ x,
begin
  rcases ha x with ⟨Va, ma, ia, ja, ⟨ra, ra_mem⟩, ⟨sa, sa_mem⟩, wa⟩,
  rcases hb x with ⟨Vb, mb, ib, jb, ⟨rb, rb_mem⟩, ⟨sb, sb_mem⟩, wb⟩,
  refine ⟨Va ⊓ Vb, ⟨ma, mb⟩, opens.inf_le_left _ _ ≫ ia, ja + jb,
    ⟨sb * ra + sa * rb, add_mem (add_comm jb ja ▸ mul_mem sb_mem ra_mem : sb * ra ∈ 𝒜 (ja + jb))
      (mul_mem sa_mem rb_mem)⟩,
    ⟨sa * sb, mul_mem sa_mem sb_mem⟩, λ y, ⟨λ h, _, _⟩⟩,
  { cases (y : projective_spectrum.Top 𝒜).is_prime.mem_or_mem h with h h,
    { obtain ⟨nin, -⟩ := (wa ⟨y, (opens.inf_le_left Va Vb y).2⟩), exact nin h },
    { obtain ⟨nin, -⟩ := (wb ⟨y, (opens.inf_le_right Va Vb y).2⟩), exact nin h } },
  { simp only [add_mul, map_add, pi.add_apply, ring_hom.map_mul, ext_iff_val, add_val],
    obtain ⟨nin1, hy1⟩ := (wa (opens.inf_le_left Va Vb y)),
    obtain ⟨nin2, hy2⟩ := (wb (opens.inf_le_right Va Vb y)),
    dsimp only at hy1 hy2,
    erw [hy1, hy2],
    simpa only [val_mk', add_mk, ← subtype.val_eq_coe, add_comm, mul_comm sa sb], }
end

lemma mul_mem' (U : (opens (projective_spectrum.Top 𝒜))ᵒᵖ)
  (a b : Π x : unop U, at x.1)
  (ha : (is_locally_fraction 𝒜).pred a) (hb : (is_locally_fraction 𝒜).pred b) :
  (is_locally_fraction 𝒜).pred (a * b) := λ x,
begin
  rcases ha x with ⟨Va, ma, ia, ja, ⟨ra, ra_mem⟩, ⟨sa, sa_mem⟩, wa⟩,
  rcases hb x with ⟨Vb, mb, ib, jb, ⟨rb, rb_mem⟩, ⟨sb, sb_mem⟩, wb⟩,
  refine ⟨Va ⊓ Vb, ⟨ma, mb⟩, opens.inf_le_left _ _ ≫ ia, ja + jb,
    ⟨ra * rb, set_like.mul_mem_graded ra_mem rb_mem⟩,
    ⟨sa * sb, set_like.mul_mem_graded sa_mem sb_mem⟩, λ y, ⟨λ h, _, _⟩⟩,
  { cases (y : projective_spectrum.Top 𝒜).is_prime.mem_or_mem h with h h,
    { choose nin hy using wa ⟨y, (opens.inf_le_left Va Vb y).2⟩, exact nin h },
    { choose nin hy using wb ⟨y, (opens.inf_le_right Va Vb y).2⟩, exact nin h }, },
  { simp only [pi.mul_apply, ring_hom.map_mul],
    choose nin1 hy1 using wa (opens.inf_le_left Va Vb y),
    choose nin2 hy2 using wb (opens.inf_le_right Va Vb y),
    rw ext_iff_val at hy1 hy2 ⊢,
    erw [mul_val, hy1, hy2],
    simpa only [val_mk', mk_mul, ← subtype.val_eq_coe] }
end

end section_subring

section

open section_subring

variable {𝒜}
/--The functions satisfying `is_locally_fraction` form a subring of all dependent functions
`Π x : U, homogeneous_localization 𝒜 x`.-/
def sections_subring (U : (opens (projective_spectrum.Top 𝒜))ᵒᵖ) : subring (Π x : unop U, at x.1) :=
{ carrier := { f | (is_locally_fraction 𝒜).pred f },
  zero_mem' := zero_mem' U,
  one_mem' := one_mem' U,
  add_mem' := add_mem' U,
  neg_mem' := neg_mem' U,
  mul_mem' := mul_mem' U }

end

/--The structure sheaf (valued in `Type`, not yet `CommRing`) is the subsheaf consisting of
functions satisfying `is_locally_fraction`.-/
def structure_sheaf_in_Type : sheaf Type* (projective_spectrum.Top 𝒜):=
subsheaf_to_Types (is_locally_fraction 𝒜)

instance comm_ring_structure_sheaf_in_Type_obj (U : (opens (projective_spectrum.Top 𝒜))ᵒᵖ) :
  comm_ring ((structure_sheaf_in_Type 𝒜).1.obj U) := (sections_subring U).to_comm_ring

/--The structure presheaf, valued in `CommRing`, constructed by dressing up the `Type` valued
structure presheaf.-/
@[simps] def structure_presheaf_in_CommRing : presheaf CommRing (projective_spectrum.Top 𝒜) :=
{ obj := λ U, CommRing.of ((structure_sheaf_in_Type 𝒜).1.obj U),
  map := λ U V i,
  { to_fun := ((structure_sheaf_in_Type 𝒜).1.map i),
    map_zero' := rfl,
    map_add' := λ x y, rfl,
    map_one' := rfl,
    map_mul' := λ x y, rfl, }, }

/--Some glue, verifying that that structure presheaf valued in `CommRing` agrees with the `Type`
valued structure presheaf.-/
def structure_presheaf_comp_forget :
  structure_presheaf_in_CommRing 𝒜 ⋙ (forget CommRing) ≅ (structure_sheaf_in_Type 𝒜).1 :=
nat_iso.of_components (λ U, iso.refl _) (by tidy)

end projective_spectrum.structure_sheaf

namespace projective_spectrum

open Top.presheaf projective_spectrum.structure_sheaf opens

/--The structure sheaf on `Proj` 𝒜, valued in `CommRing`.-/
def Proj.structure_sheaf : sheaf CommRing (projective_spectrum.Top 𝒜) :=
⟨structure_presheaf_in_CommRing 𝒜,
  -- We check the sheaf condition under `forget CommRing`.
  (is_sheaf_iff_is_sheaf_comp _ _).mpr
    (is_sheaf_of_iso (structure_presheaf_comp_forget 𝒜).symm
      (structure_sheaf_in_Type 𝒜).cond)⟩

end projective_spectrum

section

open projective_spectrum projective_spectrum.structure_sheaf opens

@[simp] lemma res_apply (U V : opens (projective_spectrum.Top 𝒜)) (i : V ⟶ U)
  (s : (Proj.structure_sheaf 𝒜).1.obj (op U)) (x : V) :
  ((Proj.structure_sheaf 𝒜).1.map i.op s).1 x = (s.1 (i x) : _) :=
rfl

/--`Proj` of a graded ring as a `SheafedSpace`-/
def Proj.to_SheafedSpace : SheafedSpace CommRing :=
{ carrier := Top.of (projective_spectrum 𝒜),
  presheaf := (Proj.structure_sheaf 𝒜).1,
  is_sheaf := (Proj.structure_sheaf 𝒜).2 }

/-- The ring homomorphism that takes a section of the structure sheaf of `Proj` on the open set `U`,
implemented as a subtype of dependent functions to localizations at homogeneous prime ideals, and
evaluates the section on the point corresponding to a given homogeneous prime ideal. -/
def open_to_localization (U : opens (projective_spectrum.Top 𝒜)) (x : projective_spectrum.Top 𝒜)
  (hx : x ∈ U) :
  (Proj.structure_sheaf 𝒜).1.obj (op U) ⟶ CommRing.of (at x) :=
{ to_fun := λ s, (s.1 ⟨x, hx⟩ : _),
  map_one' := rfl,
  map_mul' := λ _ _, rfl,
  map_zero' := rfl,
  map_add' := λ _ _, rfl }

/-- The ring homomorphism from the stalk of the structure sheaf of `Proj` at a point corresponding
to a homogeneous prime ideal `x` to the *homogeneous localization* at `x`,
formed by gluing the `open_to_localization` maps. -/
def stalk_to_fiber_ring_hom (x : projective_spectrum.Top 𝒜) :
  (Proj.structure_sheaf 𝒜).presheaf.stalk x ⟶ CommRing.of (at x) :=
limits.colimit.desc (((open_nhds.inclusion x).op) ⋙ (Proj.structure_sheaf 𝒜).1)
  { X := _,
    ι :=
    { app := λ U, open_to_localization 𝒜 ((open_nhds.inclusion _).obj (unop U)) x (unop U).2, } }

@[simp] lemma germ_comp_stalk_to_fiber_ring_hom (U : opens (projective_spectrum.Top 𝒜)) (x : U) :
  (Proj.structure_sheaf 𝒜).presheaf.germ x ≫ stalk_to_fiber_ring_hom 𝒜 x =
  open_to_localization 𝒜 U x x.2 :=
limits.colimit.ι_desc _ _

@[simp] lemma stalk_to_fiber_ring_hom_germ' (U : opens (projective_spectrum.Top 𝒜))
  (x : projective_spectrum.Top 𝒜) (hx : x ∈ U) (s : (Proj.structure_sheaf 𝒜).1.obj (op U)) :
  stalk_to_fiber_ring_hom 𝒜 x
    ((Proj.structure_sheaf 𝒜).presheaf.germ ⟨x, hx⟩ s) = (s.1 ⟨x, hx⟩ : _) :=
ring_hom.ext_iff.1 (germ_comp_stalk_to_fiber_ring_hom 𝒜 U ⟨x, hx⟩ : _) s

@[simp] lemma stalk_to_fiber_ring_hom_germ (U : opens (projective_spectrum.Top 𝒜)) (x : U)
  (s : (Proj.structure_sheaf 𝒜).1.obj (op U)) :
  stalk_to_fiber_ring_hom 𝒜 x ((Proj.structure_sheaf 𝒜).presheaf.germ x s) = s.1 x :=
by { cases x, exact stalk_to_fiber_ring_hom_germ' 𝒜 U _ _ _ }

lemma homogeneous_localization.mem_basic_open (x : projective_spectrum.Top 𝒜) (f : at x) :
  x ∈ projective_spectrum.basic_open 𝒜 f.denom :=
by { rw projective_spectrum.mem_basic_open, exact f.denom_mem }

variable (𝒜)

/--Given a point `x` corresponding to a homogeneous prime ideal, there is a (dependent) function
such that, for any `f` in the homogeneous localization at `x`, it returns the obvious section in the
basic open set `D(f.denom)`-/
def section_in_basic_open (x : projective_spectrum.Top 𝒜) :
  Π (f : at x),
    (Proj.structure_sheaf 𝒜).1.obj (op (projective_spectrum.basic_open 𝒜 f.denom)) :=
λ f, ⟨λ y, quotient.mk' ⟨f.deg, ⟨f.num, f.num_mem_deg⟩, ⟨f.denom, f.denom_mem_deg⟩, y.2⟩,
  λ y, ⟨projective_spectrum.basic_open 𝒜 f.denom, y.2,
    ⟨𝟙 _, ⟨f.deg, ⟨⟨f.num, f.num_mem_deg⟩, ⟨f.denom, f.denom_mem_deg⟩,
      λ z, ⟨z.2, rfl⟩⟩⟩⟩⟩⟩

/--Given any point `x` and `f` in the homogeneous localization at `x`, there is an element in the
stalk at `x` obtained by `section_in_basic_open`. This is the inverse of `stalk_to_fiber_ring_hom`.
-/
def homogeneous_localization_to_stalk (x : projective_spectrum.Top 𝒜) :
  (at x) → (Proj.structure_sheaf 𝒜).presheaf.stalk x :=
λ f, (Proj.structure_sheaf 𝒜).presheaf.germ
  (⟨x, homogeneous_localization.mem_basic_open _ x f⟩ : projective_spectrum.basic_open _ f.denom)
  (section_in_basic_open _ x f)

/--Using `homogeneous_localization_to_stalk`, we construct a ring isomorphism between stalk at `x`
and homogeneous localization at `x` for any point `x` in `Proj`.-/
def Proj.stalk_iso' (x : projective_spectrum.Top 𝒜) :
  (Proj.structure_sheaf 𝒜).presheaf.stalk x ≃+* CommRing.of (at x)  :=
ring_equiv.of_bijective (stalk_to_fiber_ring_hom _ x)
⟨λ z1 z2 eq1, begin
  obtain ⟨u1, memu1, s1, rfl⟩ := (Proj.structure_sheaf 𝒜).presheaf.germ_exist x z1,
  obtain ⟨u2, memu2, s2, rfl⟩ := (Proj.structure_sheaf 𝒜).presheaf.germ_exist x z2,
  obtain ⟨v1, memv1, i1, ⟨j1, ⟨a1, a1_mem⟩, ⟨b1, b1_mem⟩, hs1⟩⟩ := s1.2 ⟨x, memu1⟩,
  obtain ⟨v2, memv2, i2, ⟨j2, ⟨a2, a2_mem⟩, ⟨b2, b2_mem⟩, hs2⟩⟩ := s2.2 ⟨x, memu2⟩,
  obtain ⟨b1_nin_x, eq2⟩ := hs1 ⟨x, memv1⟩,
  obtain ⟨b2_nin_x, eq3⟩ := hs2 ⟨x, memv2⟩,
  dsimp only at eq1 eq2 eq3,
  erw [stalk_to_fiber_ring_hom_germ 𝒜 u1 ⟨x, memu1⟩ s1,
    stalk_to_fiber_ring_hom_germ 𝒜 u2 ⟨x, memu2⟩ s2] at eq1,
  erw eq1 at eq2,
  erw [eq2, quotient.eq] at eq3,
  change localization.mk _ _ = localization.mk _ _ at eq3,
  rw [localization.mk_eq_mk', is_localization.eq] at eq3,
  obtain ⟨⟨c, hc⟩, eq3⟩ := eq3,
  simp only [← subtype.val_eq_coe] at eq3,
  have eq3' : ∀ (y : projective_spectrum.Top 𝒜)
    (hy : y ∈ projective_spectrum.basic_open 𝒜 b1 ⊓
      projective_spectrum.basic_open 𝒜 b2 ⊓
      projective_spectrum.basic_open 𝒜 c),
    (localization.mk a1
      ⟨b1, show b1 ∉ y.as_homogeneous_ideal,
        by rw ←projective_spectrum.mem_basic_open;
          exact le_of_hom (opens.inf_le_left _ _ ≫ opens.inf_le_left _ _) hy⟩ :
            localization.at_prime y.1.to_ideal) =
    localization.mk a2
      ⟨b2, show b2 ∉ y.as_homogeneous_ideal,
        by rw ←projective_spectrum.mem_basic_open;
        exact le_of_hom (opens.inf_le_left _ _ ≫ opens.inf_le_right _ _) hy⟩,
  { intros y hy,
    rw [localization.mk_eq_mk', is_localization.eq],
    exact ⟨⟨c, show c ∉ y.as_homogeneous_ideal, by rw ←projective_spectrum.mem_basic_open;
      exact le_of_hom (opens.inf_le_right _ _) hy⟩, eq3⟩ },
  refine presheaf.germ_ext (Proj.structure_sheaf 𝒜).1
    (projective_spectrum.basic_open _ b1 ⊓
      projective_spectrum.basic_open _ b2 ⊓
      projective_spectrum.basic_open _ c ⊓ v1 ⊓ v2)
    ⟨⟨⟨⟨b1_nin_x, b2_nin_x⟩, hc⟩, memv1⟩, memv2⟩
    (opens.inf_le_left _ _ ≫ opens.inf_le_right _ _ ≫ i1) (opens.inf_le_right _ _ ≫ i2) _,
  rw subtype.ext_iff_val,
  ext1 y,
  simp only [res_apply],
  obtain ⟨b1_nin_y, eq6⟩ := hs1 ⟨_, le_of_hom (opens.inf_le_left _ _ ≫ opens.inf_le_right _ _) y.2⟩,
  obtain ⟨b2_nin_y, eq7⟩ := hs2 ⟨_, le_of_hom (opens.inf_le_right _ _) y.2⟩,
  simp only at eq6 eq7,
  erw [eq6, eq7, quotient.eq],
  change localization.mk _ _ = localization.mk _ _,
  exact eq3' _ ⟨⟨le_of_hom (opens.inf_le_left _ _ ≫ opens.inf_le_left _ _ ≫
      opens.inf_le_left _ _ ≫ opens.inf_le_left _ _) y.2,
    le_of_hom (opens.inf_le_left _ _ ≫ opens.inf_le_left _ _ ≫
      opens.inf_le_left _ _ ≫ opens.inf_le_right _ _) y.2⟩,
    le_of_hom (opens.inf_le_left _ _ ≫ opens.inf_le_left _ _ ≫
      opens.inf_le_right _ _) y.2⟩,
end, function.surjective_iff_has_right_inverse.mpr ⟨homogeneous_localization_to_stalk 𝒜 x,
  λ f, begin
    rw homogeneous_localization_to_stalk,
    erw stalk_to_fiber_ring_hom_germ 𝒜
      (projective_spectrum.basic_open 𝒜 f.denom) ⟨x, _⟩ (section_in_basic_open _ x f),
    simp only [section_in_basic_open, subtype.ext_iff_val, homogeneous_localization.ext_iff_val,
      homogeneous_localization.val_mk', f.eq_num_div_denom],
    refl,
  end⟩⟩

/--`Proj` of a graded ring as a `LocallyRingedSpace`-/
def Proj.to_LocallyRingedSpace : LocallyRingedSpace :=
{ local_ring := λ x, @@ring_equiv.local_ring _
    (show local_ring (at x), from infer_instance) _
    (Proj.stalk_iso' 𝒜 x).symm,
  ..(Proj.to_SheafedSpace 𝒜) }

end

end algebraic_geometry


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.functor
import data.sum.basic

/-!
# Functors with two arguments

This file defines bifunctors.

A bifunctor is a function `F : Type* → Type* → Type*` along with a bimap which turns `F α β` into
`F α' β'` given two functions `α → α'` and `β → β'`. It further
* respects the identity: `bimap id id = id`
* composes in the obvious way: `(bimap f' g') ∘ (bimap f g) = bimap (f' ∘ f) (g' ∘ g)`

## Main declarations

* `bifunctor`: A typeclass for the bare bimap of a bifunctor.
* `is_lawful_bifunctor`: A typeclass asserting this bimap respects the bifunctor laws.
-/

universes u₀ u₁ u₂ v₀ v₁ v₂

open function

/-- Lawless bifunctor. This typeclass only holds the data for the bimap. -/
class bifunctor (F : Type u₀ → Type u₁ → Type u₂) :=
(bimap : Π {α α' β β'}, (α → α') → (β → β') → F α β → F α' β')
export bifunctor ( bimap )

/-- Bifunctor. This typeclass asserts that a lawless `bifunctor` is lawful. -/
class is_lawful_bifunctor (F : Type u₀ → Type u₁ → Type u₂) [bifunctor F] :=
(id_bimap : Π {α β} (x : F α β), bimap id id x = x)
(bimap_bimap : Π {α₀ α₁ α₂ β₀ β₁ β₂} (f : α₀ → α₁) (f' : α₁ → α₂)
  (g : β₀ → β₁) (g' : β₁ → β₂) (x : F α₀ β₀),
  bimap f' g' (bimap f g x) = bimap (f' ∘ f) (g' ∘ g) x)

export is_lawful_bifunctor (id_bimap bimap_bimap)

attribute [higher_order bimap_id_id] id_bimap
attribute [higher_order bimap_comp_bimap] bimap_bimap

export is_lawful_bifunctor (bimap_id_id bimap_comp_bimap)
variables {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F]

namespace bifunctor

/-- Left map of a bifunctor. -/
@[reducible] def fst {α α' β} (f : α → α') : F α β → F α' β := bimap f id

/-- Right map of a bifunctor. -/
@[reducible] def snd {α β β'} (f : β → β') : F α β → F α β' := bimap id f

variable [is_lawful_bifunctor F]

@[higher_order fst_id]
lemma id_fst : Π {α β} (x : F α β), fst id x = x :=
@id_bimap _ _ _

@[higher_order snd_id]
lemma id_snd : Π {α β} (x : F α β), snd id x = x :=
@id_bimap _ _ _

@[higher_order fst_comp_fst]

@[higher_order fst_comp_snd]
lemma fst_snd {α₀ α₁ β₀ β₁}
  (f : α₀ → α₁) (f' : β₀ → β₁) (x : F α₀ β₀) :
  fst f (snd f' x) = bimap f f' x :=
by simp [fst,bimap_bimap]

@[higher_order snd_comp_fst]
lemma snd_fst {α₀ α₁ β₀ β₁}
  (f : α₀ → α₁) (f' : β₀ → β₁) (x : F α₀ β₀) :
  snd f' (fst f x) = bimap f f' x :=
by simp [snd,bimap_bimap]

@[higher_order snd_comp_snd]
lemma comp_snd {α β₀ β₁ β₂}
  (g : β₀ → β₁) (g' : β₁ → β₂) (x : F α β₀) :
  snd g' (snd g x) = snd (g' ∘ g) x :=
by simp [snd,bimap_bimap]

attribute [functor_norm] bimap_bimap comp_snd comp_fst
  snd_comp_snd snd_comp_fst fst_comp_snd fst_comp_fst bimap_comp_bimap
  bimap_id_id fst_id snd_id

end bifunctor
open functor
instance : bifunctor prod :=
{ bimap := @prod.map }

instance : is_lawful_bifunctor prod :=
by refine { .. }; intros; cases x; refl

instance bifunctor.const : bifunctor const :=
{ bimap := (λ α α' β β f _, f) }

instance is_lawful_bifunctor.const : is_lawful_bifunctor const  :=
by refine { .. }; intros; refl

instance bifunctor.flip : bifunctor (flip F) :=
{ bimap := (λ α α' β β' f f' x, (bimap f' f x : F β' α')) }

instance is_lawful_bifunctor.flip [is_lawful_bifunctor F] : is_lawful_bifunctor (flip F)  :=
by refine { .. }; intros; simp [bimap] with functor_norm

instance : bifunctor sum :=
{ bimap := @sum.map }

instance : is_lawful_bifunctor sum :=
by refine { .. }; intros; cases x; refl

open bifunctor functor

@[priority 10]
instance bifunctor.functor {α} : functor (F α) :=
{ map := λ _ _, snd }

@[priority 10]
instance bifunctor.is_lawful_functor [is_lawful_bifunctor F] {α} : is_lawful_functor (F α) :=
by refine {..}; intros; simp [functor.map] with functor_norm

section bicompl

variables (G : Type* → Type u₀) (H : Type* → Type u₁) [functor G] [functor H]

instance : bifunctor (bicompl F G H) :=
{ bimap := λ α α' β β' f f' x, (bimap (map f) (map f') x : F (G α') (H β')) }

instance [is_lawful_functor G]  [is_lawful_functor H] [is_lawful_bifunctor F] :
  is_lawful_bifunctor (bicompl F G H) :=
by constructor; intros; simp [bimap,map_id,map_comp_map] with functor_norm

end bicompl
section bicompr

variables (G : Type u₂ → Type*) [functor G]

instance : bifunctor (bicompr G F) :=
{ bimap := λ α α' β β' f f' x, (map (bimap f f') x : G (F α' β')) }

instance [is_lawful_functor G] [is_lawful_bifunctor F] :
  is_lawful_bifunctor (bicompr G F) :=
by constructor; intros; simp [bimap] with functor_norm

end bicompr


import ftype.basic ftype.embed
import .rankfun .dual

namespace ftype
noncomputable theory

@[simp] def restrict_subset {B : ftype} (R : set B) (rfun : rankfun B)  : rankfun (subftype R) :=
{
  r := λ X, rfun.r X,
  R0 := λ X, rfun.R0 X,
  R1 := λ X, by {simp only [subftype_coe_size], from rfun.R1 X},
  R2 := λ X Y, by {intros H, simp, apply rfun.R2, simp at H, apply H,},
  R3 := λ X Y, by {simp, from rfun.R3 X Y}
}
-- simp [-has_univ.univ]
-- #check has_univ.univ

-- def image (f : α → β) (s : set α) : set β :=
-- {b | ∃ a, a ∈ s ∧ f a = b}

--let f := (embed.from_subftype R).f in
--⟨λ X, rfun.r X, λ X, rfun.R0 X, λ X, rfun.R1 X, λ X Y, rfun.R2 X Y, λ X Y, rfun.R3 X Y⟩

@[simp] def restrict_nested_pair {B : ftype} {R₀ R : set B} (h : R₀ ⊆ R) (rfun : rankfun (subftype R)) : rankfun (subftype R₀)  :=
let f := embed.from_nested_pair h in
{
  r := λ X, rfun.r (f.img X),
  R0 := λ X, rfun.R0 (f.img X),
  R1 := λ X, by {rw ←f.on_size, from rfun.R1 (f.img X)},
  R2 := λ X Y hXY, rfun.R2 _ _ (f.on_subset hXY),
  R3 := λ X Y, by {have := rfun.R3 (f.img X) (f.img Y), rw [←f.on_union, ←f.on_inter] at this, from this},
}

--⟨λ X, rfun.r (f X), λ X, rfun.R0 (f X), λ X, rfun.R1 (f X), λ X Y, rfun.R2 (f X) (f Y), λ X Y, rfun.R3 (f X) (f Y)⟩
@[simp] def corestrict_subset {U : ftype} (R : set U) (M : rankfun U)  : rankfun (subftype R) :=
let C := Rᶜ, f := embed.from_subftype R in
⟨
  λ X_foo, M.r ((X_foo : set U) ∪ C) - M.r C,
  λ X, by {rw sub_nonneg, exact M.R2 C (X ∪ C) (subset_union_right X C)},
  λ X, by {simp only, linarith [M.R0 (X ∩ C), M.R3 X C, M.R1 X, subftype_coe_size X]},
  λ X Y hXY, by {simp only, linarith [M.R2 (X ∪ C) (Y ∪ C) (subset_union_subset_left _ _ C (f.on_subset hXY))]},
  λ X Y, by
  {
    suffices : M.r (coe (X ∪ Y) ∪ C) + M.r (coe (X ∩ Y) ∪ C) ≤ M.r (X ∪ C) + M.r (Y ∪ C),
      by {simp only, linarith},
    simp only [subftype_coe_inter, subftype_coe_union],
    have h := M.R3 (X ∪ C) (Y ∪ C),
    rw [←union_distrib_right, ←union_distrib_union_left] at h,
    assumption,
  },
⟩

@[simp] def corestrict_nested_pair {B : ftype} {R₀ R₁ : set B} (h : R₀ ⊆ R₁) (M : rankfun (subftype R₁)) : rankfun (subftype R₀)  :=
let
  r := M.r,
  f := (embed.from_nested_pair h),
  φ := f.img,
  C := (φ (set.univ))ᶜ in
⟨
  λ X, r (φ X ∪ C) - r C,
  λ X, by {rw sub_nonneg, exact M.R2 C (φ X ∪ C) (subset_union_right (φ X) C)},
  λ X, by {simp only, linarith [f.on_size X, M.R0 ((φ X) ∩ C), M.R3 (φ X) C, M.R1 (φ X)]},
  λ X Y hXY, by {simp only, linarith [M.R2 ((φ X) ∪ C) ((φ Y) ∪ C) (subset_union_subset_left _ _ C (f.on_subset hXY))]},
  λ X Y, by
  {
    simp only,
    suffices : M.r (φ (X ∪ Y) ∪ C) + M.r (φ (X ∩ Y) ∪ C) ≤ M.r ((φ X) ∪ C) + M.r ((φ Y) ∪ C), by linarith,
    have h := M.R3 ((f.img X) ∪ C) ((f.img Y) ∪ C),
    rw [←union_distrib_right, ←union_distrib_union_left, ←f.on_inter, ←f.on_union] at h,
    from h,
  },
⟩

--- Below here still needs refactor

def matroid_on {U : ftype} (E : set U) := rankfun (subftype E)

section minor

variables {U : ftype}

inductive minor_on : set U → Type
| self                       : minor_on univ
| restrict   (X : set U) {E : set U} : (X ⊆ E) → minor_on E → minor_on X
| corestrict (X : set U) {E : set U} : (X ⊆ E) → minor_on E → minor_on X
open minor_on

def to_minor : Π {E : set U}, minor_on E → rankfun U → matroid_on E
| _ self r := restrict_subset _ r
| _ (restrict _ hE' expr) r := restrict_nested_pair hE' (to_minor expr r)
| _ (corestrict _ hE' expr) r := corestrict_nested_pair hE' (to_minor expr r)

/--simplified minor expression \ corestrict to Z, then restrict to A -/

lemma restrict_rank {M : rankfun U} (A : set U) (X : set (subftype A)) :
  (to_minor (restrict A (subset_univ A) self) M).r X = M.r X :=
by simp [to_minor]

lemma corestrict_rank {M : rankfun U} (A : set U) (X : set (subftype A)) :
  (to_minor (corestrict A (subset_univ A) self) M).r X = M.r (X ∪ (univ \ A)) - M.r (univ \ A) :=
by simp [to_minor]

lemma switch_restrict_corestrict {M : rankfun U} (A Z : set U) (hAZ : A ⊆ Z) :
  to_minor (restrict A hAZ ((corestrict Z (subset_univ Z)) self)) M = to_minor (corestrict A (subset_union_left A Zᶜ) ((restrict (A ∪ Zᶜ) (subset_univ (A ∪ Zᶜ))) self)) M :=
  let f := (embed.from_subftype A).f, hAZc := subset_union_left A Zᶜ, hAZc_univ := subset_univ (A ∪ Zᶜ) in
  begin

    ext X,
    have set_eq : (A ∪ Zᶜ) \ A = univ \ Z
      := by {rw [diff_eq, inter_distrib_right, ←compl_union, union_comm Z,
                subset_iff_union_eq_left.mp hAZ], simp},
    set M' := (to_minor (corestrict A hAZc (restrict (A ∪ Zᶜ) hAZc_univ self)) M) with hM',

    have RHS : M'.r X = M.r (X ∪ ((A ∪ Zᶜ) \ A)) - M.r ((A ∪ Zᶜ) \ A) :=
      by {rw hM',convert rfl; simp,},

    rw set_eq at RHS,
    convert RHS.symm,
    simp [to_minor],
  end

lemma dual_restrict_corestrict {M : rankfun U} (A Z : set U) (hAZ : A ⊆ Z) :
  dual (to_minor (restrict A hAZ (corestrict Z (subset_univ Z) self)) M) = to_minor (corestrict A hAZ (restrict Z (subset_univ Z) self)) (dual M) :=
  let emb := embed.from_subftype A in
  begin
    rw switch_restrict_corestrict, ext X, apply eq.symm,
    have hJ : ∀ (J : set U) (hJ : J ⊆ A), (J ∪ (Z\A))ᶜ = (A \ J) ∪ (univ \ Z) :=
      λ J hJ, by rw [compl_union, univ_diff, compl_diff, diff_eq, inter_distrib_left, ←compl_union, subset_iff_union_eq_left.mp (subset.trans hJ hAZ), inter_comm, union_comm],
    have hset : size ((X:set U) ∩ (Z \ A)) = 0 := by
    {
      suffices : ((X:set U) ∩ (Z \ A)) = ∅,
      rw this, exact size_empty U,
      have := coe_set_is_subset X,
      tidy,
    },
    have hempty : (Z\A)ᶜ = A ∪ (univ \ Z) :=
      by {rw [←empty_union (Z\A), hJ ∅ (empty_subset _), diff_empty]},

    have := calc (to_minor (corestrict A hAZ (restrict Z (subset_univ Z) self)) (dual M)).r X
           = (size ((X:set U) ∪ (Z\A)) + M.r ((X ∪ (Z\A))ᶜ) - M.r univ) - (size (Z\A) + M.r (Z\A)ᶜ - M.r univ )
            : by {simp [to_minor, dual], }
       ... = size (X:set U) + M.r ((X ∪ (Z\A))ᶜ) - M.r  (Z\A)ᶜ
            : by linarith [size_modular (X :set U) (Z\A), hset, emb.on_size X]
       ... = size (X:set U) + M.r ((A \ X) ∪ (univ \ Z)) - M.r (A ∪ (univ \ Z))
            : by {congr', finish}
       ... = size (X:set U) + (M.r ((A \ X) ∪ (univ \ Z)) - M.r (univ \ Z)) - (M.r (A ∪ (univ \ Z)) - M.r (univ \ Z))
            : by linarith
       ... = (dual (to_minor (restrict A hAZ (corestrict Z (subset_univ Z) self)) M)).r X
            : by {simp [dual, to_minor],} ,

    rw ←switch_restrict_corestrict, assumption,
  end

lemma dual_corestrict_restrict {M : rankfun U} (A Z : set U) (hAZ : A ⊆ Z) :
  dual (to_minor (corestrict A hAZ (restrict Z (subset_univ Z) self)) M) = to_minor (restrict A hAZ (corestrict Z (subset_univ Z) self)) (dual M) :=
  by {nth_rewrite 0 ←(dual_dual M), rw [←dual_restrict_corestrict, dual_dual]}

lemma restrict_univ (M : rankfun U){A : set U} (expr: minor_on A) :
  to_minor (restrict A (subset_refl A) expr) M = to_minor expr M :=
  by {ext X, simp [to_minor], congr',    }-- cases X,refl}

lemma corestrict_univ (M : rankfun U){A : set U} (expr: minor_on A) :
  to_minor (corestrict A (subset_refl A) expr) M = to_minor expr M :=
begin
  simp [to_minor],
  set M' := to_minor expr M,
  apply rankfun.ext, ext X,
  simp only,
  set f := (embed.from_nested_pair (subset_refl A)).f,
  have : (embed.to_subftype A A _) = univ := rfl,
  rw [this,  ftype.compl_univ, union_empty, rank_empty M'],
  rw [(by cases X; refl: f X = X)],
  linarith,
end

lemma dual_restrict (M: rankfun U) (A : set U) :
  dual (to_minor (restrict A (subset_univ A) self) M) = to_minor (corestrict A (subset_univ A) self) (dual M) :=
    by rw [←(corestrict_univ _ (restrict A (subset_univ A) self)), dual_corestrict_restrict, restrict_univ]

lemma dual_corestrict (M: rankfun U) (A : set U) :
  dual (to_minor (corestrict A (subset_univ A) self) M) = to_minor (restrict A (subset_univ A) self) (dual M) :=
    by rw [←(restrict_univ _ (corestrict A (subset_univ A) self)), dual_restrict_corestrict, corestrict_univ]

lemma switch_corestrict_restrict (M : rankfun U) (A Z : set U) (hAZ : A ⊆ Z) :
  to_minor (corestrict A hAZ ((restrict Z (subset_univ Z)) self)) M = to_minor (restrict A (subset_union_left A Zᶜ) ((corestrict (A ∪ Zᶜ) (subset_univ (A ∪ Zᶜ))) self)) M :=
  by {nth_rewrite 0 ←(dual_dual M), rw [←dual_restrict_corestrict, switch_restrict_corestrict, dual_corestrict_restrict, dual_dual]}

lemma restrict_restrict (M : rankfun U) (A Z : set U) (hAZ : A ⊆ Z) :
  to_minor (restrict A hAZ (restrict Z (subset_univ Z) self)) M = to_minor (restrict A (subset_univ A) self) M :=
  let f := (embed.from_subftype A).f in
  by {ext X,calc _ = M.r (f X) : rfl ...= _ : rfl}

#check minor_on

/-lemma corestrict_corestrict {M : rankfun U} (A Z : set U) (hAZ : A ⊆ Z) :
  to_minor (corestrict A hAZ (corestrict Z (subset_univ Z) self)) M = to_minor (corestrict A (subset_univ A) self) M :=
  begin
    nth_rewrite 0 ←(dual_dual M),
    have := dual_restrict (dual M) A,

    --unfold to_minor at *,

    --←dual_restrict,
    /-let U' := subftype Z,
    let expr := ((corestrict univ (subset_refl univ) self) : minor_on (univ : set U')),
    let M₀ := to_minor expr,
    have := corestrict_univ M₀ expr-/
    --have := @corestrict_univ (subftype Z) M₀ univ expr,
    --nth_rewrite 0 ←(dual_dual M),

    --have :=
    --calc
    sorry,
  end-/

@[simp] def reduced_expr  (A Z : set U) (hAZ : A ⊆ Z) : minor_on A :=
  restrict A hAZ ((corestrict Z (subset_univ Z)) self)

lemma restriction_of_reduced  {M : rankfun U} (A Z A' : set U) (hA'A : A' ⊆ A) (hAZ : A ⊆ Z) :
  to_minor (restrict A' hA'A (reduced_expr A Z hAZ)) M = to_minor (reduced_expr A' Z (subset.trans hA'A hAZ)) M := rfl

lemma corestriction_of_reduced {M : rankfun U} (A Z Z' : set U) (hZ'A : Z' ⊆ A) (hAZ : A ⊆ Z) :
  to_minor (corestrict Z' hZ'A (reduced_expr A Z hAZ) ) M = to_minor (reduced_expr Z' (Z' ∪ (Z \ A)) (subset_union_left Z' _)) M :=
  let  J  := Z' ∪ (Z \ A),
       M' := to_minor (reduced_expr A Z hAZ) M,
       N  := (to_minor (reduced_expr Z' J (subset_union_left _ _)) M) in
  begin
    ext, rename x X,
    have equiv : (A \ Z') ∪ (univ \ Z) = (univ \ J) := by
    {
      simp only [univ_diff, J, diff_eq, univ_inter],
      rw [compl_union, compl_inter, inter_distrib_left, ←compl_union Z',
          (subset_iff_union_eq_left.mp (subset.trans hZ'A hAZ)), compl_compl, union_comm Zᶜ, inter_comm A],
    },
    have LHS :=
    calc     (to_minor (corestrict Z' hZ'A (reduced_expr A Z hAZ)) M).r X
           = (corestrict_nested_pair hZ'A M').r X                                                   : rfl
      ...  = M.r (X ∪ (A \ Z') ∪ (univ \ Z)) - M.r (univ \ Z) - (M.r ((A \ Z') ∪ (univ \ Z)) - M.r (univ \ Z)) : rfl
      ...  = M.r (X ∪ (A \ Z') ∪ (univ \ Z)) - M.r ((A \ Z') ∪ (univ \ Z))                                : by linarith
      ...  = M.r (X ∪ (univ \ J)) - M.r (univ \ J)                                                        : by rw [union_assoc, equiv],

    rw LHS, apply eq.symm, clear LHS, calc N.r X = _ : rfl,
  end

-- Every minor expression is equivalent to a reduced one.

lemma has_reduced_expr {M : rankfun U} {E : set U} (expr : minor_on E) :
  ∃ (Z : set U) (hZ : E ⊆ Z),
  to_minor (reduced_expr E Z hZ) M = to_minor expr M :=
begin
  induction expr with X₁ E₁ hX₁E₁ minor_expr IH
                    X₁ A₁ hX₁A₁ minor_expr IH,
  /- self -/
  { use univ,  use subset_refl univ, simp [reduced_expr], rw [restrict_univ, corestrict_univ] },
  /-restrict-/
  {
    rcases IH with ⟨Z, ⟨hE₁Z, h⟩⟩,
    use Z, use subset.trans hX₁E₁ hE₁Z,
    rw ← restriction_of_reduced,
    dunfold to_minor,
    rw h,
  },
  /-corestrict-/
  {
    rcases IH with ⟨Z, ⟨hA₁Z, h⟩⟩,
    use X₁ ∪ (Z \ A₁), use subset_union_left X₁ _,
    rw ←corestriction_of_reduced _ _ _ hX₁A₁ hA₁Z,
    dunfold to_minor,
    rw h,
  }
end

/-lemma has_representation {M : rankfun U} {E : set U} (expr : minor_on E) :
  (∃ (C D : set U) (hCD : C ∩ D = ∅),
    (C ∪ D)ᶜ = E
    ∧ ((to_minor (contract_delete C D hCD) M) ≅ (to_minor expr M))) :=
begin
  sorry,
end-/

/-lemma has_good_representation {M : rankfun U} {E : set U} (expr : minor_on E) :
  (∃ (C D : set U) (hCD : C ∩ D = ∅),
    (C ∪ D)ᶜ = E ∧
    is_indep M C ∧ is_coindep M D
    ∧ ((to_minor (contract_delete C D hCD) M) ≅ (to_minor expr M))) := sorry-/

end minor
end ftype

-- A larger-rank set can be used to add a smaller-rank one. Old proof that takes a minor

/-lemma rank_augment {M : rankfun U} {X Z : set U} : (M.r X < M.r Z) →
  ∃ z, z ∈ Z ∧ M.r X < M.r (X ∪ z) :=
let
    hcr    : Z \ X ⊆ X ∪ Z         := subset.trans (diff_subset Z X) (subset_union_right X Z),
    hr     : X ∪ Z ⊆ univ             :=  subset_univ (X ∪ Z),
    hdiff  : (X ∪ Z) \ (Z \ X) = X := union_diff_diff _ _,
    hunion : (Z \ X) ∪ X = X ∪ Z   := by rw [union_comm _ X, union_diff]
in
begin
  intros hrXrZ, by_contradiction h, push_neg at h,
  --pertinent minor M' : restrict to X ∪ Z then corestrict to Z-X
  let M' := to_minor (corestrict (Z \ X) hcr (restrict (X ∪ Z) hr self)) M,
  -- simplified rank function of M'
  have hrM' : ∀ (J : subftype (Z \ X)), M'.r J = M.r (J ∪ X) - M.r (X) :=
    by {intros J, calc _  = M.r (J ∪ ((X ∪ Z) \ (Z \ X))) - M.r ((X ∪ Z) \ (Z \ X)) : rfl ... = _ : by rw hdiff},

  have hr'univ := hrM' univ,
  rw [coe_univ (Z \ X), hunion] at hr'univ,

  have : M'.r univ ≠ 0 := by linarith [by calc M'.r univ = _ : hr'univ ... ≥ M.r Z - M.r X : by linarith [M.R2 Z (X ∪ Z) (subset_union_right X Z)]],

  apply this, apply loopy_rank_zero, intros e he,
  specialize h e (subset.trans ((e: subftype (Z \ X)).property) (diff_subset _ _ )),
  rw coe_single_subftype_compose at h,
  rw [hrM' e, union_comm, coe_subftype_single_compose],
  linarith [M.R2 _ _ (subset_union_left X e)],
end
-/


universes u

def f {α : Type u} [BEq α] (xs : List α) (y : α) : α := do
for x in xs do
  if x == y then
    return x
return y

structure S :=
(key val : Nat)

instance : BEq S :=
⟨fun a b => a.key == b.key⟩

theorem ex1 : f (α := S) [⟨1, 2⟩, ⟨3, 4⟩, ⟨5, 6⟩] ⟨3, 0⟩ = ⟨3, 4⟩ :=
rfl

theorem ex2 : f (α := S) [⟨1, 2⟩, ⟨3, 4⟩, ⟨5, 6⟩] ⟨4, 10⟩ = ⟨4, 10⟩ :=
rfl


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

! This file was ported from Lean 3 source module category_theory.limits.shapes.finite_limits
! leanprover-community/mathlib commit c3019c79074b0619edb4b27553a91b2e82242395
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.FinCategory
import Mathlib.CategoryTheory.Limits.Shapes.BinaryProducts
import Mathlib.CategoryTheory.Limits.Shapes.Equalizers
import Mathlib.CategoryTheory.Limits.Shapes.WidePullbacks
import Mathlib.CategoryTheory.Limits.Shapes.Pullbacks
import Mathlib.Data.Fintype.Option

/-!
# Categories with finite limits.

A typeclass for categories with all finite (co)limits.
-/

universe w' w v' u' v u

noncomputable section

open CategoryTheory

namespace CategoryTheory.Limits

variable (C : Type u) [Category.{v} C]

-- We can't just made this an `abbreviation`
-- because of https://github.com/leanprover-community/lean/issues/429
/-- A category has all finite limits if every functor `J ⥤ C` with a `FinCategory J`
instance and `J : Type` has a limit.

This is often called 'finitely complete'.
-/
class HasFiniteLimits : Prop where
  /-- `C` has all limits over any type `J` whose objects and morphisms lie in the same universe
  and which has `FinType` objects and morphisms-/
  out (J : Type) [𝒥 : SmallCategory J] [@FinCategory J 𝒥] : @HasLimitsOfShape J 𝒥 C _
#align category_theory.limits.has_finite_limits CategoryTheory.Limits.HasFiniteLimits

instance (priority := 100) hasLimitsOfShape_of_hasFiniteLimits (J : Type w) [SmallCategory J]
    [FinCategory J] [HasFiniteLimits C] : HasLimitsOfShape J C := by
  apply @hasLimitsOfShape_of_equivalence _ _ _ _ _ _ (FinCategory.equivAsType J) ?_
  apply HasFiniteLimits.out
#align category_theory.limits.has_limits_of_shape_of_has_finite_limits CategoryTheory.Limits.hasLimitsOfShape_of_hasFiniteLimits

instance (priority := 100) hasFiniteLimits_of_hasLimitsOfSize [HasLimitsOfSize.{v', u'} C] :
    HasFiniteLimits C where
  out := fun J hJ hJ' =>
    haveI := hasLimitsOfSizeShrink.{0, 0} C
    let F := @FinCategory.equivAsType J (@FinCategory.fintypeObj J hJ hJ') hJ hJ'
    @hasLimitsOfShape_of_equivalence (@FinCategory.AsType J (@FinCategory.fintypeObj J hJ hJ'))
    (@FinCategory.categoryAsType J (@FinCategory.fintypeObj J hJ hJ') hJ hJ') _ _ J hJ F _
#align category_theory.limits.has_finite_limits_of_has_limits_of_size CategoryTheory.Limits.hasFiniteLimits_of_hasLimitsOfSize

/-- If `C` has all limits, it has finite limits. -/
instance (priority := 100) hasFiniteLimits_of_hasLimits [HasLimits C] : HasFiniteLimits C :=
  inferInstance
#align category_theory.limits.has_finite_limits_of_has_limits CategoryTheory.Limits.hasFiniteLimits_of_hasLimits

/-- We can always derive `HasFiniteLimits C` by providing limits at an
arbitrary universe. -/
theorem hasFiniteLimits_of_hasFiniteLimits_of_size
    (h : ∀ (J : Type w) {𝒥 : SmallCategory J} (_ : @FinCategory J 𝒥), HasLimitsOfShape J C) :
    HasFiniteLimits C where
  out := fun J hJ hhJ => by
    haveI := h (ULiftHom.{w} (ULift.{w} J)) <| @CategoryTheory.finCategoryUlift J hJ hhJ
    have l :
      @Equivalence J (ULiftHom (ULift J)) hJ (@ULiftHom.category (ULift J) (@uliftCategory J hJ))
      := @ULiftHomULiftCategory.equiv J hJ
    apply @hasLimitsOfShape_of_equivalence (ULiftHom (ULift J))
      (@ULiftHom.category (ULift J) (@uliftCategory J hJ)) C _ J hJ
      (@Equivalence.symm J hJ (ULiftHom (ULift J))
      (@ULiftHom.category (ULift J) (@uliftCategory J hJ)) l) _
    /- Porting note: tried to factor out (@instCategoryULiftHom (ULift J) (@uliftCategory J hJ)
    but when doing that would then find the instance and say it was not definitionally equal to
    to the provide one (the same thing factored out) -/
#align category_theory.limits.has_finite_limits_of_has_finite_limits_of_size CategoryTheory.Limits.hasFiniteLimits_of_hasFiniteLimits_of_size

/-- A category has all finite colimits if every functor `J ⥤ C` with a `FinCategory J`
instance and `J : Type` has a colimit.

This is often called 'finitely cocomplete'.
-/
class HasFiniteColimits : Prop where
  /-- `C` has all colimits over any type `J` whose objects and morphisms lie in the same universe
  and which has `FinType` objects and morphisms-/
  out (J : Type) [𝒥 : SmallCategory J] [@FinCategory J 𝒥] : @HasColimitsOfShape J 𝒥 C _
#align category_theory.limits.has_finite_colimits CategoryTheory.Limits.HasFiniteColimits

instance (priority := 100) hasColimitsOfShape_of_hasFiniteColimits (J : Type w) [SmallCategory J]
    [FinCategory J] [HasFiniteColimits C] : HasColimitsOfShape J C := by
  refine @hasColimitsOfShape_of_equivalence _ _ _ _ _ _ (FinCategory.equivAsType J) ?_
  apply HasFiniteColimits.out
#align category_theory.limits.has_colimits_of_shape_of_has_finite_colimits CategoryTheory.Limits.hasColimitsOfShape_of_hasFiniteColimits

instance (priority := 100) hasFiniteColimits_of_hasColimitsOfSize [HasColimitsOfSize.{v', u'} C] :
    HasFiniteColimits C where
  out := fun J hJ hJ' =>
    haveI := hasColimitsOfSize_shrink.{0, 0} C
    let F := @FinCategory.equivAsType J (@FinCategory.fintypeObj J hJ hJ') hJ hJ'
    @hasColimitsOfShape_of_equivalence (@FinCategory.AsType J (@FinCategory.fintypeObj J hJ hJ'))
    (@FinCategory.categoryAsType J (@FinCategory.fintypeObj J hJ hJ') hJ hJ') _ _ J hJ F _
#align category_theory.limits.has_finite_colimits_of_has_colimits_of_size CategoryTheory.Limits.hasFiniteColimits_of_hasColimitsOfSize

/-- We can always derive `HasFiniteColimits C` by providing colimits at an
arbitrary universe. -/
theorem hasFiniteColimits_of_hasFiniteColimits_of_size
    (h : ∀ (J : Type w) {𝒥 : SmallCategory J} (_ : @FinCategory J 𝒥), HasColimitsOfShape J C) :
    HasFiniteColimits C where
  out := fun J hJ hhJ => by
    haveI := h (ULiftHom.{w} (ULift.{w} J)) <| @CategoryTheory.finCategoryUlift J hJ hhJ
    have l :
      @Equivalence J (ULiftHom (ULift J)) hJ (@ULiftHom.category (ULift J) (@uliftCategory J hJ))
      := @ULiftHomULiftCategory.equiv J hJ
    apply @hasColimitsOfShape_of_equivalence (ULiftHom (ULift J))
      (@ULiftHom.category (ULift J) (@uliftCategory J hJ)) C _ J hJ
      (@Equivalence.symm J hJ (ULiftHom (ULift J))
      (@ULiftHom.category (ULift J) (@uliftCategory J hJ)) l) _
#align category_theory.limits.has_finite_colimits_of_has_finite_colimits_of_size CategoryTheory.Limits.hasFiniteColimits_of_hasFiniteColimits_of_size

section

open WalkingParallelPair WalkingParallelPairHom

instance fintypeWalkingParallelPair : Fintype WalkingParallelPair where
  elems := [WalkingParallelPair.zero, WalkingParallelPair.one].toFinset
  complete x := by cases x <;> simp
#align category_theory.limits.fintype_walking_parallel_pair CategoryTheory.Limits.fintypeWalkingParallelPair

-- attribute [local tidy] tactic.case_bash Porting note: no tidy; no case_bash

instance (j j' : WalkingParallelPair) : Fintype (WalkingParallelPairHom j j') where
  elems :=
    WalkingParallelPair.recOn j
      (WalkingParallelPair.recOn j' [WalkingParallelPairHom.id zero].toFinset
        [left, right].toFinset)
      (WalkingParallelPair.recOn j' ∅ [WalkingParallelPairHom.id one].toFinset)
  complete := by
    rintro (_|_) <;> simp
    · cases j <;> simp
end

instance : FinCategory WalkingParallelPair where
  fintypeObj := fintypeWalkingParallelPair
  fintypeHom := instFintypeWalkingParallelPairHom -- Porting note: could not be inferred

/-- Equalizers are finite limits, so if `C` has all finite limits, it also has all equalizers -/
example [HasFiniteLimits C] : HasEqualizers C := by infer_instance

/-- Coequalizers are finite colimits, of if `C` has all finite colimits, it also has all
    coequalizers -/
example [HasFiniteColimits C] : HasCoequalizers C := by infer_instance

variable {J : Type v}

-- attribute [local tidy] tactic.case_bash Porting note: no tidy; no case_bash

namespace WidePullbackShape

instance fintypeObj [Fintype J] : Fintype (WidePullbackShape J) := by
  rw [WidePullbackShape]
  infer_instance
#align category_theory.limits.wide_pullback_shape.fintype_obj CategoryTheory.Limits.WidePullbackShape.fintypeObj

instance fintypeHom (j j' : WidePullbackShape J) : Fintype (j ⟶ j')
    where
  elems := by
    cases' j' with j'
    · cases' j with j
      · exact {Hom.id none}
      · exact {Hom.term j}
    · by_cases some j' = j
      · rw [h]
        exact {Hom.id j}
      · exact ∅
  complete := by
    rintro (_|_)
    · cases j <;> simp
    · simp
#align category_theory.limits.wide_pullback_shape.fintype_hom CategoryTheory.Limits.WidePullbackShape.fintypeHom

end WidePullbackShape

namespace WidePushoutShape

instance fintypeObj [Fintype J] : Fintype (WidePushoutShape J) := by
  rw [WidePushoutShape]; infer_instance
#align category_theory.limits.wide_pushout_shape.fintype_obj CategoryTheory.Limits.WidePushoutShape.fintypeObj

instance fintypeHom (j j' : WidePushoutShape J) : Fintype (j ⟶ j') where
  elems := by
    cases' j with j
    · cases' j' with j'
      · exact {Hom.id none}
      · exact {Hom.init j'}
    · by_cases some j = j'
      · rw [h]
        exact {Hom.id j'}
      · exact ∅
  complete := by
    rintro (_|_)
    · cases j <;> simp
    · simp
#align category_theory.limits.wide_pushout_shape.fintype_hom CategoryTheory.Limits.WidePushoutShape.fintypeHom

end WidePushoutShape

instance finCategoryWidePullback [Fintype J] : FinCategory (WidePullbackShape J)
    where fintypeHom := WidePullbackShape.fintypeHom
#align category_theory.limits.fin_category_wide_pullback CategoryTheory.Limits.finCategoryWidePullback

instance finCategoryWidePushout [Fintype J] : FinCategory (WidePushoutShape J)
    where fintypeHom := WidePushoutShape.fintypeHom
#align category_theory.limits.fin_category_wide_pushout CategoryTheory.Limits.finCategoryWidePushout

-- We can't just made this an `abbreviation`
-- because of https://github.com/leanprover-community/lean/issues/429
/-- `HasFiniteWidePullbacks` represents a choice of wide pullback
for every finite collection of morphisms
-/
class HasFiniteWidePullbacks : Prop where
  /-- `C` has all wide pullbacks any Fintype `J`-/
  out (J : Type) [Fintype J] : HasLimitsOfShape (WidePullbackShape J) C
#align category_theory.limits.has_finite_wide_pullbacks CategoryTheory.Limits.HasFiniteWidePullbacks

instance hasLimitsOfShape_widePullbackShape (J : Type) [Finite J] [HasFiniteWidePullbacks C] :
    HasLimitsOfShape (WidePullbackShape J) C := by
  cases nonempty_fintype J
  haveI := @HasFiniteWidePullbacks.out C _ _ J
  infer_instance
#align category_theory.limits.has_limits_of_shape_wide_pullback_shape CategoryTheory.Limits.hasLimitsOfShape_widePullbackShape

/-- `HasFiniteWidePushouts` represents a choice of wide pushout
for every finite collection of morphisms
-/
class HasFiniteWidePushouts : Prop where
  /-- `C` has all wide pushouts any Fintype `J`-/
  out (J : Type) [Fintype J] : HasColimitsOfShape (WidePushoutShape J) C
#align category_theory.limits.has_finite_wide_pushouts CategoryTheory.Limits.HasFiniteWidePushouts

instance hasColimitsOfShape_widePushoutShape (J : Type) [Finite J] [HasFiniteWidePushouts C] :
    HasColimitsOfShape (WidePushoutShape J) C := by
  cases nonempty_fintype J
  haveI := @HasFiniteWidePushouts.out C _ _ J
  infer_instance
#align category_theory.limits.has_colimits_of_shape_wide_pushout_shape CategoryTheory.Limits.hasColimitsOfShape_widePushoutShape

/-- Finite wide pullbacks are finite limits, so if `C` has all finite limits,
it also has finite wide pullbacks
-/
theorem hasFiniteWidePullbacks_of_hasFiniteLimits [HasFiniteLimits C] : HasFiniteWidePullbacks C :=
  ⟨fun _ _ => HasFiniteLimits.out _⟩
#align category_theory.limits.has_finite_wide_pullbacks_of_has_finite_limits CategoryTheory.Limits.hasFiniteWidePullbacks_of_hasFiniteLimits

/-- Finite wide pushouts are finite colimits, so if `C` has all finite colimits,
it also has finite wide pushouts
-/
theorem hasFiniteWidePushouts_of_has_finite_limits [HasFiniteColimits C] :
    HasFiniteWidePushouts C :=
  ⟨fun _ _ => HasFiniteColimits.out _⟩
#align category_theory.limits.has_finite_wide_pushouts_of_has_finite_limits CategoryTheory.Limits.hasFiniteWidePushouts_of_has_finite_limits

instance fintypeWalkingPair : Fintype WalkingPair where
  elems := {WalkingPair.left, WalkingPair.right}
  complete x := by cases x <;> simp
#align category_theory.limits.fintype_walking_pair CategoryTheory.Limits.fintypeWalkingPair

/-- Pullbacks are finite limits, so if `C` has all finite limits, it also has all pullbacks -/
example [HasFiniteWidePullbacks C] : HasPullbacks C := by infer_instance

/-- Pushouts are finite colimits, so if `C` has all finite colimits, it also has all pushouts -/
example [HasFiniteWidePushouts C] : HasPushouts C := by infer_instance

end CategoryTheory.Limits


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.simulation_semantics.simulate.basic

/-!
# Support of Simulations

This file contains more complex lemmas about the support of `simulate` and `simulate'`.
In particular it relates the `support` after `simulate` and `simulate'` to the original `support`,
and gives lemmas for proving equalities between or properties of these `supports`.
-/

variables {α β γ : Type} {spec spec' spec'' : oracle_spec} {S S' : Type}

namespace oracle_comp

open oracle_spec

variables (so : sim_oracle spec spec' S) (so' : sim_oracle spec spec'' S')
  (a : α) (i : spec.ι) (t : spec.domain i) (oa oa' : oracle_comp spec α)
  (ob ob' : α → oracle_comp spec β) (oc : β → oracle_comp spec γ) (s : S) (f : α → β)

section monad

lemma support_simulate_map_bind (g : β → γ) : (simulate so (g <$> (oa >>= ob)) s).support =
  ⋃ x ∈ (simulate so oa s).support, prod.map g id '' (simulate so (ob $ prod.fst x) x.2).support :=
by simp only [support_simulate_map, support_simulate_bind, set.image_Union]

-- TODO: can't be a simp lemma unless simulate doesn't auto unfold?
lemma support_simulate_bind_map : (simulate so ((f <$> oa) >>= oc) s).support
  = ⋃ x ∈ (simulate so oa s).support, (simulate so (oc (f $ prod.fst x)) x.2).support :=
begin
  refine set.ext (λ z, _),
  simp only [support_simulate_bind, support_simulate_map, set.mem_image, set.Union_exists,
    set.Union_and, set.mem_Union],
  exact ⟨λ h, let ⟨x, y, hy, hxy, hx⟩ := h in ⟨y, hy, by simpa only [← hxy] using hx⟩,
    λ h, let ⟨x, hx, hz⟩ := h in ⟨(f x.1, x.2), x, hx, rfl, hz⟩⟩,
end

end monad

section induction

/-- Lemma for inductively proving the support of a simulation is a specific function of the input.
Often this is simpler than induction on the computation itself, especially the case of `bind`. -/
lemma support_simulate_eq_induction {supp : Π (α : Type), oracle_comp spec α → S → set (α × S)}
  (so : sim_oracle spec spec' S) (oa : oracle_comp spec α) (s : S)
  (h_ret : ∀ α a s, supp α (return a) s = {(a, s)})
  (h_bind : ∀ α β (oa : oracle_comp spec α) (ob : α → oracle_comp spec β) s,
    supp β (oa >>= ob) s = ⋃ x ∈ (supp α oa s), supp β (ob $ prod.fst x) $ prod.snd x)
  (h_query : ∀ i t s, supp (spec.range i) (query i t) s = (so i (t, s)).support) :
  (simulate so oa s).support = supp α oa s :=
begin
  induction oa using oracle_comp.induction_on with α a α β oa ob hoa hob i t generalizing s,
  { simp only [h_ret, simulate_return, support_return] },
  { simp only [simulate_bind, support_bind, hoa, hob, h_bind] },
  { simp only [h_query, simulate_query] }
end

/-- Slightly weaker version of `support_simulate_eq_induction` for `simulate'`. -/
lemma support_simulate'_eq_induction {supp : Π (α : Type), oracle_comp spec α → S → set α}
  (so : sim_oracle spec spec' S) (oa : oracle_comp spec α) (s : S)
  (h_ret : ∀ α a s, supp α (return a) s = {a})
  (h_bind : ∀ α β (oa : oracle_comp spec α) (ob : α → oracle_comp spec β) s,
    supp β (oa >>= ob) s = ⋃ x ∈ (simulate so oa s).support, supp β (ob $ prod.fst x) $ prod.snd x)
  (h_query : ∀ i t s, supp (spec.range i) (query i t) s = prod.fst '' (so i (t, s)).support) :
  (simulate' so oa s).support = supp α oa s :=
begin
  induction oa using oracle_comp.induction_on with α a α β oa ob hoa hob i t generalizing s,
  { simp only [h_ret, simulate'_return, support_map, support_return, set.image_singleton] },
  { simp only [h_bind, ←hob, simulate'_bind, support_map_bind, support_simulate'] },
  { simp only [h_query, simulate'_query, support_map] }
end

/-- Given a property `P` of oracle states, if any query call to the oracle preserves it,
then simulation of an entire computation with that oracle will also preserve it. -/
theorem support_state_simulate_induction (so : sim_oracle spec spec' S) (P : S → Prop)
  (s : S) (hs : P s) (oa : oracle_comp spec α) (x : α × S) (hx : x ∈ (simulate so oa s).support)
  (hso : ∀ i t s, ∀ x ∈ (so i (t, s)).support, P s → P (prod.snd x)) : P x.2 :=
begin
  induction oa using oracle_comp.induction_on with α a α β oa ob hoa hob i' t' generalizing s,
  { rw [support_simulate_return, set.mem_singleton_iff] at hx,
    exact hx.symm ▸ hs },
  { rw [mem_support_simulate_bind_iff] at hx,
    obtain ⟨a, s', ha, ha'⟩ := hx,
    exact hob a x s' (hoa (a, s') s hs ha) ha' },
  { exact hso i' t' s x hx hs }
end

end induction

/-- Since `support` assumes any possible query result, `simulate` will never reduce the support.
In particular the support of a simulation lies in the pullback of the original support. -/
theorem support_simulate_subset_preimage_support :
  (simulate so oa s).support ⊆ prod.fst ⁻¹' oa.support :=
begin
  rw [set.preimage],
  induction oa using oracle_comp.induction_on with α a α β oa ob hoa hob i t generalizing s,
  { simp only [simulate_return, support_return, set.mem_singleton_iff,
      set.singleton_subset_iff, set.mem_set_of_eq] },
  { rw [support_simulate_bind],
    refine set.Union_subset (λ x, set.Union_subset (λ hx, _)),
    simp only [support_bind, set.mem_Union, exists_prop],
    refine λ b hb, ⟨x.1, hoa s hx, hob x.1 x.2 hb⟩ },
  { simp only [support_query, set.top_eq_univ, set.mem_univ, set.set_of_true, set.subset_univ] }
end

/-- Simulation only reduces the possible oracle outputs, so can't reduce the support. In particular
the first output of a simulation has support at most that of the original computation -/
lemma support_simulate'_subset_support : (simulate' so oa s).support ⊆ oa.support :=
begin
  refine (support_simulate' so oa s).symm ▸ λ x hx, _,
  obtain ⟨y, hy, rfl⟩ := (set.mem_image prod.fst _ _).1 hx,
  exact support_simulate_subset_preimage_support so oa s hy,
end

lemma mem_support_of_mem_support_simulate (x : α × S) (hx : x ∈ (simulate so oa s).support) :
  x.1 ∈ oa.support := by simpa using (support_simulate_subset_preimage_support so oa s hx)

lemma mem_support_of_mem_support_simulate' (x : α)
  (hx : x ∈ (simulate' so oa s).support) : x ∈ oa.support :=
support_simulate'_subset_support so oa s hx

/-- If the first output of an oracle can take on any value (although the state might not),
then the first value of simulation has the same support as the original computation.
For example simulation with the identity oracle `idₛ` doesn't change the support,
  and this also holds for something like a logging oracle that just records queries -/
theorem support_simulate'_eq_support (h : ∀ i t s, prod.fst '' (so i (t, s)).support = ⊤) :
  (simulate' so oa s).support = oa.support :=
begin
  refine set.eq_of_subset_of_subset (support_simulate'_subset_support so oa s) (λ x hx, _),
  induction oa using oracle_comp.induction_on with α a α β oa ob hoa hob i t generalizing s,
  { simpa only [simulate'_return, support_map, support_return, set.image_singleton] using hx },
  { simp only [support_simulate'_bind, support_bind, set.mem_Union] at hx ⊢,
    obtain ⟨a, ha, hx⟩ := hx,
    specialize hoa a ha s,
    rw [support_simulate', set.mem_image] at hoa,
    obtain ⟨⟨a', s'⟩, ha', ha''⟩ := hoa,
    exact ⟨(a', s'), ha', hob a' x (let this : a = a' := ha''.symm in this ▸ hx) s'⟩ },
  { simp only [support_simulate'_query, h i t s] }
end

/-- If the possible outputs of two oracles are the same for any inputs  regardless of their
internal states, then the `support` of `simulate'` with either oracle is the same.
Intuitively the simulations *could* take the same branch at each oracle query, and while the
probabilities of divergence may vary, this doesn't affect the set of possible results. -/
theorem support_simulate'_eq_support_simulate'
  {so : sim_oracle spec spec' S} {so' : sim_oracle spec spec'' S'}
  (h : ∀ i t s s', prod.fst '' (so i (t, s)).support = prod.fst '' (so' i (t, s')).support)
  (oa : oracle_comp spec α) (s : S) (s' : S') :
  (simulate' so oa s).support = (simulate' so' oa s').support :=
begin
  induction oa using oracle_comp.induction_on with α a α β oa ob hoa hob i t generalizing s s',
  { simp only [simulate'_return, support_map, support_return, set.image_singleton] },
  { ext x,
    simp_rw [support_simulate'_bind, set.mem_Union],
    refine ⟨λ h, _, λ h, _⟩,
    { obtain ⟨⟨a, t⟩, hoa', hob'⟩ := h,
      have : ∃ u, (a, u) ∈ (simulate so oa s).support := ⟨t, hoa'⟩,
      rw [← mem_support_simulate'_iff_exists_state, hoa s s',
        mem_support_simulate'_iff_exists_state] at this,
      obtain ⟨t', ht'⟩ := this,
      exact ⟨(a, t'), ht', hob a t t' ▸ hob'⟩ },
    { obtain ⟨⟨a, t⟩, hoa', hob'⟩ := h,
      have : ∃ u, (a, u) ∈ (simulate so' oa s').support := ⟨t, hoa'⟩,
      rw [← mem_support_simulate'_iff_exists_state, ← hoa s s',
        mem_support_simulate'_iff_exists_state] at this,
      obtain ⟨t', ht'⟩ := this,
      exact ⟨(a, t'), ht', (hob a t' t).symm ▸ hob'⟩ } },
  { simpa only [support_simulate'_query] using h i t s s' }
end

lemma support_simulate_eq_support_simulate
  (so : sim_oracle spec spec' S) (so' : sim_oracle spec spec'' S)
  (h : ∀ i t s s', (so i (t, s)).support = (so' i (t, s')).support) :
  (simulate so oa s).support = (simulate so' oa s).support :=
begin
  refine support_simulate_eq_induction so oa s _ (λ _ _ _ _ _, _) (λ _ _ _, _),
  { simp only [simulate_return, support_return, eq_self_iff_true, forall_3_true_iff] },
  { simp only [simulate_bind, support_bind, eq_self_iff_true] },
  { rw [simulate_query, h]  }
end

theorem support_simulate_simulate_eq_support_simulate (so so' : sim_oracle spec spec' S)
  (h : ∀ i t s, (⋃ x ∈ (so i (t, s)).support, (so' i (t, prod.snd x)).support) =
    (so i (t, s)).support) (s : S) (oa : oracle_comp spec α) :
  (simulate so oa s >>= λ x, simulate so' oa x.2).support = (simulate so oa s).support :=
begin
  refine symm (support_simulate_eq_induction so oa s (λ α a s, _) _ _),
  { simp only [simulate_return, support_bind_return, support_return, set.image_singleton] },
  { intros α β oa ob s,
    ext x,

    sorry },
  { exact h }
end

end oracle_comp


import norm.norm_prime
import number_theory.cyclotomic.gal
import number_theory.cyclotomic.rat

variables {K : Type*} [field K] {ζ : K}

open_locale number_field

open polynomial algebra

local notation `R` := 𝓞 K

namespace is_cyclotomic_extension.rat

variables {p : ℕ+} {k : ℕ} [hp : fact (p : ℕ).prime] [char_zero K]

include hp

lemma zeta_sub_one_prime [is_cyclotomic_extension {p ^ (k + 1)} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ (k + 1))) (hodd : p ≠ 2) :
  prime (⟨ζ - 1, subalgebra.sub_mem _ (hζ.is_integral (p ^ _).pos) (subalgebra.one_mem _)⟩ : R) :=
begin
  letI := is_cyclotomic_extension.number_field {p ^ (k + 1)} ℚ K,
  letI := is_cyclotomic_extension.is_galois (p ^ (k + 1)) ℚ K,
  rw [← hζ.sub_one_integral_power_basis_gen],
  refine prime_of_norm_prime _,
  rw [hζ.sub_one_integral_power_basis_gen],
  simp only [ring_of_integers.norm, monoid_hom.restrict_apply, set_like.coe_mk,
    monoid_hom.cod_restrict_apply, hζ.sub_one_norm_prime_ne_two
    (cyclotomic.irreducible_rat (p ^ (k + 1)).pos) hodd],
  rw [mul_equiv.prime_iff rat.ring_of_integers_equiv.to_mul_equiv],
  simp only [coe_coe, ring_equiv.to_mul_equiv_eq_coe, ring_equiv.coe_to_mul_equiv],
  convert nat.prime_iff_prime_int.1 hp.1,
  refine equiv_like.injective rat.ring_of_integers_equiv.symm (subtype.ext _),
  simp only [set_like.coe_mk, ring_equiv.symm_apply_apply],
  norm_cast,
  simp [← ring_equiv.coe_to_ring_hom]
end

lemma zeta_sub_one_prime' [h : is_cyclotomic_extension {p} ℚ K] (hζ : is_primitive_root ζ p)
  (hodd : p ≠ 2) :
  prime (⟨ζ - 1, subalgebra.sub_mem _ (hζ.is_integral p.pos) (subalgebra.one_mem _)⟩ : R) :=
begin
  convert @zeta_sub_one_prime K _ _ p 0 _ _ (by { convert h, rw [zero_add, pow_one] }) _ hodd,
  simpa,
end

end is_cyclotomic_extension.rat


lemma contrapositive (P Q : Prop) : (P → Q) → (¬ Q → ¬ P) :=
begin
repeat {rw not_iff_imp_false},
intros f g p,
apply g,
exact f p,
end