import data.mv_polynomial.comm_ring
import linear_algebra.finsupp
import linear_algebra.clifford_algebra.basic
import data.zmod.basic
import data.matrix.notation
import field_theory.mv_polynomial
import tactic.induction
import algebra.char_p.quotient
import data.nat.prime
import algebra.char_p.pi
import algebra.char_p.two
import ring_theory.mv_polynomial.ideal
import ring_theory.mv_polynomial.basic
import algebra.char_p.algebra
import tactic.norm_fin
/-!
A formalization of https://mathoverflow.net/questions/60596/clifford-pbw-theorem-for-quadratic-form/87958#87958

Some Zulip discussion at https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/.F0.9D.94.BD.E2.82.82.5B.CE.B1.2C.20.CE.B2.2C.20.CE.B3.5D.20.2F.20.28.CE.B1.C2.B2.2C.20.CE.B2.C2.B2.2C.20.CE.B3.C2.B2.29/near/222716333.
-/

noncomputable theory

open_locale big_operators

section for_mathlib

lemma ideal.comap_span_le {R : Type*} {S : Type*} [semiring R] [semiring S] (f : S →+* R)
  (g : R →+* S) (h : function.left_inverse g f) (s : set R) :
  ideal.comap f (ideal.span s) ≤ ideal.span (g '' s) :=
begin
  rintros x (hx : f x ∈ ideal.span s),
  have := ideal.apply_coe_mem_map g _ ⟨_, hx⟩,
  rw [ideal.map_span, subtype.coe_mk, h x] at this,
  exact this,
end

/-- `char_p.quotient'` as an `iff`. -/
lemma char_p.quotient_iff' (R : Type*) [comm_ring R] (n : ℕ) [char_p R n] (I : ideal R) :
  char_p (R ⧸ I) n ↔ ∀ x : ℕ, ↑x ∈ I → (x : R) = 0 :=
begin
  refine ⟨λ (i : char_p (R ⧸ I) n) x hx, _, char_p.quotient' n I⟩,
  resetI,
  have := char_p.cast_eq_zero_iff (R ⧸ I) n,
  rw char_p.cast_eq_zero_iff R n,
  refine (this _).mp _,
  exact (submodule.quotient.mk_eq_zero I).mpr hx,
end

lemma ideal.span_le_bot {R : Type*} [semiring R] (s : set R) : ideal.span s ≤ ⊥ ↔ s ≤ {0} :=
submodule.span_le

/-- `char_p.quotient'` as an `iff`. -/
lemma char_p.quotient_iff'' (R : Type*) [comm_ring R] (n : ℕ) [char_p R n] (I : ideal R) :
  char_p (R ⧸ I) n ↔ I.comap (nat.cast_ring_hom R) ≤ (nat.cast_ring_hom R).ker :=
(char_p.quotient_iff' _ _ _).trans begin
  rw ring_hom.ker_eq_comap_bot,
  exact iff.rfl,
end

lemma finsupp.equiv_fun_on_finite_const {α β} [fintype α] [add_comm_monoid β] (b : β):
  finsupp.equiv_fun_on_finite.symm (λ _, b : α → β) = ∑ i : α, finsupp.single i b :=
by { ext, simp [finsupp.finset_sum_apply] }

-- note; more general than `mv_polynomial.support_smul`
lemma _root_.mv_polynomial.support_smul' {S R σ} [comm_semiring R] [monoid S] [distrib_mul_action S R]
  {r : S} {p : mv_polynomial σ R} :
  (r • p).support ⊆ p.support := finsupp.support_smul

lemma finsupp.to_multiset_sup {α} [decidable_eq α] (f g : α →₀ ℕ) :
  (f ⊔ g).to_multiset = f.to_multiset ∪ g.to_multiset :=
begin
  ext,
  simp_rw [multiset.count_union, finsupp.count_to_multiset, finsupp.sup_apply, sup_eq_max],
end

lemma finsupp.to_multiset_inf {α} [decidable_eq α] (f g : α →₀ ℕ) :
  (f ⊓ g).to_multiset = f.to_multiset ∩ g.to_multiset :=
begin
  ext,
  simp_rw [multiset.count_inter, finsupp.count_to_multiset, finsupp.inf_apply, inf_eq_min],
end

/-- `equiv.ulift` as a `linear_equiv`. -/
@[simps]
def {w u v} linear_equiv.ulift
  (R : Type u) (M : Type v) [semiring R] [add_comm_monoid M] [module R M]: ulift.{w} M ≃ₗ[R] M :=
{ map_add' := λ x y, rfl,
  map_smul' := λ c x, rfl,
  .. equiv.ulift }

lemma ideal.mem_span_range_iff_exists_fun {ι R} [fintype ι] [comm_semiring R] (g : ι → R) (x : R) :
  x ∈ ideal.span (set.range g) ↔ ∃ f : ι → R, ∑ i, f i * g i = x :=
mem_span_range_iff_exists_fun _

end for_mathlib

namespace q60596

open mv_polynomial

/-- The monomial ideal generated by terms of the form $x_ix_i$. -/
def k_ideal : ideal (mv_polynomial (fin 3) (zmod 2)) :=
ideal.span (set.range (λ i, (X i * X i : mv_polynomial (fin 3) (zmod 2))))

lemma mem_k_ideal_iff (x : mv_polynomial (fin 3) (zmod 2)) :
  x ∈ k_ideal ↔ ∀ (m : fin 3 →₀ ℕ), m ∈ x.support → ∃ i, 2 ≤ m i :=
begin
  have : k_ideal =
    ideal.span ((λ i, monomial i (1 : zmod 2)) '' set.range (λ i, finsupp.single i 2)),
  { simp_rw [k_ideal, X, monomial_mul, one_mul, ←finsupp.single_add, ←set.range_comp] },
  rw [this, mem_ideal_span_monomial_image],
  simp,
end

lemma X0_X1_X2_nmem_k_ideal : (X 0 * X 1 * X 2 : mv_polynomial (fin 3) (zmod 2)) ∉ k_ideal :=
begin
  intro h,
  simp_rw [mem_k_ideal_iff, support_mul_X, support_X, finset.map_singleton,
    add_right_embedding_apply, finset.mem_singleton, forall_eq,
    ←fin.sum_univ_three (λ i, finsupp.single i 1), ←finsupp.equiv_fun_on_finite_const,
    finsupp.equiv_fun_on_finite_symm_apply_to_fun] at h,
  obtain ⟨i, hi⟩ := h,
  revert hi,
  dec_trivial,
end

lemma mul_self_mem_k_ideal_of_X0_X1_X2_mul_mem {x : mv_polynomial (fin 3) (zmod 2)}
  (h : X 0 * X 1 * X 2 * x ∈ k_ideal) : x * x ∈ k_ideal :=
begin
  rw mem_k_ideal_iff at h,
  have : x ∈ ideal.span ((X : fin 3 → mv_polynomial _ (zmod 2)) '' set.univ),
  { rw [mem_ideal_span_X_image],
    intros m hm,
    simp_rw [mul_assoc, support_X_mul, finset.map_map, finset.mem_map,
        function.embedding.trans_apply, add_left_embedding_apply, exists_prop,
        forall_exists_index, and_imp, forall_apply_eq_imp_iff₂, ←add_assoc,
        ←fin.sum_univ_three (λ i, finsupp.single i 1), ←finsupp.equiv_fun_on_finite_const,
        finsupp.add_apply, finsupp.equiv_fun_on_finite_symm_apply_to_fun] at h,
    refine (h _ hm).imp (λ i hi, ⟨set.mem_univ _, _⟩),
    rintro hmi,
    rw hmi at hi,
    cases nat.le_of_add_le_add_left hi },
  rw [as_sum x, char_two.sum_mul_self],
  refine sum_mem (λ m hm, _),
  rw [mem_k_ideal_iff, monomial_mul],
  intros m' hm',
  obtain rfl := finset.mem_singleton.1 (support_monomial_subset hm'),
  rw mem_ideal_span_X_image at this,
  obtain ⟨i, _, hi⟩ := this m hm,
  refine ⟨i, nat.add_le_add _ _⟩; rwa nat.one_le_iff_ne_zero,
end

-- 𝔽₂[α, β, γ] / (α², β², γ²)
@[derive [comm_ring, comm_semiring, ring, semiring, add_comm_group, add_comm_monoid]]
def k := _ ⧸ k_ideal

lemma comap_C_span_le_bot :
  k_ideal.comap (C : zmod 2 →+* (mv_polynomial (fin 3) (zmod 2))) ≤ ⊥ :=
begin
  refine (ideal.comap_span_le _ _ (constant_coeff_C _) _).trans _,
  refine (ideal.span_le_bot _).2 _,
  rintro x ⟨_, ⟨i, rfl⟩, rfl⟩,
  rw [ring_hom.map_mul, constant_coeff_X, mul_zero, set.mem_singleton_iff],
end

/-- `k` has characteristic 2. -/
instance k.char_p : char_p k 2 :=
begin
  dunfold k,
  rw char_p.quotient_iff'',
  have : (nat.cast_ring_hom (mv_polynomial (fin 3) (zmod 2))) = C.comp (nat.cast_ring_hom _),
  { ext1 r, refl },
  rw [this, ←ideal.comap_comap, ←ring_hom.comap_ker],
  exact ideal.comap_mono (comap_C_span_le_bot.trans bot_le),
end

abbreviation α : k := ideal.quotient.mk _ (mv_polynomial.X 0)
abbreviation β : k := ideal.quotient.mk _ (mv_polynomial.X 1)
abbreviation γ : k := ideal.quotient.mk _ (mv_polynomial.X 2)

/-- The elements above square to zero -/
@[simp] lemma X_sq (i : fin 3) :
  ideal.quotient.mk _ (mv_polynomial.X i) * ideal.quotient.mk _ (mv_polynomial.X i) = (0 : k) :=
begin
  change ideal.quotient.mk _ _ = _,
  rw [ideal.quotient.eq_zero_iff_mem],
  exact ideal.subset_span ⟨i, rfl⟩,
end

/-- If an element multiplied by `αβγ` is zero then it squares to zero. -/
lemma sq_zero_of_αβγ_mul {x : k} : α * β * γ * x = 0 → x * x = 0 :=
begin
  induction x using quotient.induction_on',
  change ideal.quotient.mk _ _ = 0 → ideal.quotient.mk _ _ = 0,
  rw [ideal.quotient.eq_zero_iff_mem, ideal.quotient.eq_zero_iff_mem],
  exact mul_self_mem_k_ideal_of_X0_X1_X2_mul_mem,
end

/-- Though `αβγ` is not itself zero-/
lemma αβγ_ne_zero : α * β * γ ≠ 0 :=
λ h, X0_X1_X2_nmem_k_ideal $ ideal.quotient.eq_zero_iff_mem.1 h

@[simps]
def L_func : (fin 3 → k) →ₗ[k] k :=
α • linear_map.proj 0 - β • linear_map.proj 1 - γ • linear_map.proj 2

/-- The quotient of k^3 by the specified relation-/
@[derive [add_comm_group, module k]]
def L := _ ⧸ L_func.ker

def sq {ι R : Type*} [comm_ring R] (i : ι) : quadratic_form R (ι → R) :=
quadratic_form.sq.comp $ linear_map.proj i

lemma sq_map_add_char_two {ι R : Type*} [comm_ring R] [char_p R 2] (i : ι) (a b : ι → R) :
  sq i (a + b) = sq i a + sq i b :=
char_two.add_mul_self _ _

lemma sq_map_sub_char_two {ι R : Type*} [comm_ring R] [char_p R 2] (i : ι) (a b : ι → R) :
  sq i (a - b) = sq i a - sq i b :=
begin
  haveI : nonempty ι := ⟨i⟩,
  rw [char_two.sub_eq_add, char_two.sub_eq_add, sq_map_add_char_two]
end

open_locale big_operators

/-- The quadratic form (metric) is just euclidean -/
def Q' : quadratic_form k (fin 3 → k) :=
∑ i, sq i

def Q'_add (x y : fin 3 → k) : Q' (x + y) = Q' x + Q' y :=
by simp only [Q', quadratic_form.sum_apply, sq_map_add_char_two, finset.sum_add_distrib]

def Q'_sub (x y : fin 3 → k) : Q' (x - y) = Q' x - Q' y :=
by simp only [Q', quadratic_form.sum_apply, sq_map_sub_char_two, finset.sum_sub_distrib]

lemma Q'_apply (a : fin 3 → k) : Q' a = a 0 * a 0 + a 1 * a 1 + a 2 * a 2 :=
calc Q' a = a 0 * a 0 + (a 1 * a 1 + (a 2 * a 2 + 0)) : rfl
      ... = _ : by ring

lemma Q'_apply_single (i : fin 3) (x : k) : Q' (pi.single i x) = x * x :=
calc Q' (pi.single i x)
    = ∑ j : fin 3, (pi.single i x * pi.single i x : fin 3 → k) j : by simp [Q', sq]
... = _ : by simp_rw [←pi.single_mul, finset.sum_pi_single', finset.mem_univ, if_pos]

lemma Q'_zero_under_ideal (v : fin 3 → k) (hv : v ∈ L_func.ker) : Q' v = 0 :=
begin
  rw [linear_map.mem_ker, L_func_apply] at hv,
  have h0 : α * β * γ * v 0 = 0,
  { have := congr_arg ((*) (β * γ)) hv,
    simp only [mul_zero, mul_add, ←mul_assoc] at this,
    rw [mul_comm (β * γ) α, ←mul_assoc, mul_right_comm β γ β, mul_assoc β γ γ, X_sq, X_sq] at this,
    simpa only [mul_zero, zero_mul, add_zero, zero_add] using this },
  have h1 : α * β * γ * v 1 = 0,
  { have := congr_arg ((*) (α * γ)) hv,
    simp only [mul_zero, mul_add, ←mul_assoc] at this,
    rw [mul_right_comm α γ α, mul_assoc α γ γ, mul_right_comm α γ β, X_sq, X_sq] at this,
    simpa only [mul_zero, zero_mul, add_zero, zero_add] using this },
  have h2 : α * β * γ * v 2 = 0,
  { have := congr_arg ((*) (α * β)) hv,
    simp only [mul_zero, mul_add, ←mul_assoc] at this,
    rw [mul_right_comm α β α, mul_assoc α β β, X_sq, X_sq] at this,
    simpa only [mul_zero, zero_mul, add_zero, zero_add] using this },
  rw [Q'_apply, sq_zero_of_αβγ_mul h0, sq_zero_of_αβγ_mul h1, sq_zero_of_αβγ_mul h2,
    add_zero, add_zero],
end

/-- `Q'`, lifted to operate on the quotient space `L`. -/
@[simps]
def Q : quadratic_form k L :=
quadratic_form.of_polar
  (λ x, quotient.lift_on' x Q' $ λ a b h, begin
    rw submodule.quotient_rel_r_def at h,
    suffices : Q' (a - b) = 0,
    { rwa [Q'_sub, sub_eq_zero] at this, },
    apply Q'_zero_under_ideal (a - b) h,
  end)
  (λ a x, begin
    induction x using quotient.induction_on,
    exact Q'.to_fun_smul a x,
  end)
  (by { rintros ⟨x⟩ ⟨x'⟩ ⟨y⟩, exact Q'.polar_add_left x x' y })
  (by { rintros c ⟨x⟩ ⟨y⟩, exact Q'.polar_smul_left c x y })

open clifford_algebra

/-! Shorthand for basis vectors in the Clifford algebra -/
abbreviation x' : clifford_algebra Q := ι Q $ submodule.quotient.mk (pi.single 0 1)
abbreviation y' : clifford_algebra Q := ι Q $ submodule.quotient.mk (pi.single 1 1)
abbreviation z' : clifford_algebra Q := ι Q $ submodule.quotient.mk (pi.single 2 1)

/-- The basis vectors square to one -/
@[simp] lemma x_mul_x : x' * x' = 1 :=
begin
  dunfold x',
  simp_rw [clifford_algebra.ι_sq_scalar, Q_apply, ←submodule.quotient.mk'_eq_mk,
    quotient.lift_on'_mk', Q'_apply_single, mul_one, map_one],
end

/-- By virtue of the quotient, terms of this form are zero -/
lemma quot_obv : α • x' - β • y' - γ • z' = 0 :=
begin
  dunfold x' y' z',
  simp only [←linear_map.map_smul, ←linear_map.map_sub, ←submodule.quotient.mk_smul,
    ←submodule.quotient.mk_sub],
  convert linear_map.map_zero _ using 2,
  rw submodule.quotient.mk_eq_zero,
  norm_num [sub_zero, ideal.span, pi.single_apply],
end

/-- The core of the proof - scaling `1` by `α * β * γ` gives zero -/
lemma αβγ_smul_eq_zero : (α * β * γ) • (1 : clifford_algebra Q) = 0 :=
begin
  suffices : α • 1 - β • (y' * x') - γ • (z' * x') = 0,
  { have := congr_arg (λ x, (β * γ) • x) this,
    simpa [smul_sub, smul_smul, mul_assoc β γ γ, mul_right_comm β γ β, mul_right_comm β γ α,
      mul_comm β α] using this },
  have : (α • x' - β • y' - γ • z') * x' = α • 1 - β • (y' * x') - γ • (z' * x'),
  { simp [sub_mul], },
  rw ← this,
  rw [quot_obv, zero_mul],
end

/-- Our final result -/
lemma algebra_map_not_injective : ¬function.injective (algebra_map k $ clifford_algebra Q) :=
λ h, αβγ_ne_zero $ h begin
  rw [algebra.algebra_map_eq_smul_one, ring_hom.map_zero, αβγ_smul_eq_zero],
end

end q60596

/- The generate statement: not every Clifford algebra has an injective algebra map -/
-- TODO: https://github.com/leanprover-community/mathlib/pull/18644/files
lemma {v} clifford_algebra.not_forall_algebra_map_injective :
  ¬∀ (R : Type) (M : Type v) [comm_ring R] [add_comm_group M], by exactI
   ∀ [module R M], by exactI
   ∀ (Q : quadratic_form R M),
    function.injective (algebra_map R $ clifford_algebra Q) :=
λ h, q60596.algebra_map_not_injective $ λ x y hxy, begin
  let uQ := q60596.Q.comp (linear_equiv.ulift q60596.k _).to_linear_map,
  refine h q60596.k (ulift q60596.L)
    (q60596.Q.comp $ (linear_equiv.ulift q60596.k _).to_linear_map) _,
  let uC := clifford_algebra.map q60596.Q uQ
    (linear_equiv.ulift q60596.k q60596.L).symm.to_linear_map (λ _, rfl),
  simpa using uC.congr_arg hxy,
end


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

import category_theory.category
import category_theory.graphs

open category_theory
open category_theory.graphs

namespace category_theory.examples.graphs

universe u₁

def Graph := Σ α : Type u₁, graph.{u₁} α

instance graph_from_Graph (G : Graph) : graph G.1 := G.2

structure Graph_hom (G H : Graph.{u₁}) : Type u₁ :=
(map : @graph_hom G.1 G.2 H.1 H.2)

@[extensionality] lemma graph_homomorphisms_pointwise_equal
  {G H : Graph.{u₁}}
  {p q : Graph_hom G H}
  (vertexWitness : ∀ X : G.1, p.map.onVertices X = q.map.onVertices X)
  (edgeWitness : ∀ X Y : G.1, ∀ f : edges X Y, ⟬ p.map.onEdges f ⟭ = q.map.onEdges f ) : p = q :=
begin
  induction p,
  induction q,
  tidy,
end

instance CategoryOfGraphs : large_category Graph :=
{ hom := Graph_hom,
  id := λ G,
  ⟨{ onVertices   := id,
     onEdges := λ _ _ f, f }⟩,
  comp := λ G H K f g,
  ⟨{ onVertices := λ v, g.map.onVertices (f.map.onVertices v),
     onEdges    := λ v w e, g.map.onEdges (f.map.onEdges e) }⟩ }

end category_theory.examples.graphs


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit : ∀ α : ℝ, α ∉ ℚ → ∀ ε > 0, ∃ n : ℤ, ∀ m : ℤ, |n * α - m| < ε :=
begin
  assume α h1 ε h2,
  sorry,
end

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (hα : ¬ is_rat α) : ∀ ε > 0, ∃ x : ℤ, 0 ≤ x ∧ x < 1 ∧ ∀ y : ℤ, 0 ≤ y ∧ y < 1 → |y - x| < ε :=
begin
  assume (ε : ℝ) (hε : ε > 0),
  -- Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$.
  have h1 : ∀ i j : ℤ, i ≠ j → frac (i * α) ≠ frac (j * α), from sorry,
  -- If this were not true, then $i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor$, which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$.
  have h2 : ∀ i j : ℤ, i ≠ j → ¬ is_rat α, from sorry,
  -- Hence, $S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}$ is an infinite subset of $\left[0,1\right]$.
  have h3 : ∀ i : ℤ, frac (i * α) ∈ Icc (0 : ℝ) 1, from sorry,
  have h4 : ∀ i : ℤ, ∃ x : ℤ, 0 ≤ x ∧ x < 1 ∧ ∀ y : ℤ, 0 ≤ y ∧ y < 1 → |y - x| < ε, from sorry,
  show ∃ x : ℤ, 0 ≤ x ∧ x < 1 ∧ ∀ y : ℤ, 0 ≤ y ∧ y < 1 → |y - x| < ε, from sorry,
end

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (hα : α ∉ ℚ) : ∀ y ∈ Icc 0 1, ∃ x ∈ Icc 0 1, x ∈ (ℤ : set ℝ) ∧ |y - x| < 1 :=
begin
  -- Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
  assume (y : ℝ) (h1 : y ∈ Icc 0 1),
  have h2 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α ≠ (j : ℝ) * α, from sorry,
  have h3 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h4 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h5 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h6 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h7 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h8 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h9 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h10 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h11 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h12 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h13 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h14 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h15 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h16 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h17 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h18 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h19 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h20 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h21 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h22 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h23 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h24 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h25 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h26 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h27 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h28 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h29 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h30 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h31 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h32 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ) ≠ (j : ℝ) * α - (j : ℝ), from sorry,
  have h33 : ∀ i j : ℤ, i ≠ j → (i : ℝ) * α - (i : ℝ
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from sorry,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from sorry,
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from sorry,
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by sorry
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by sorry
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  --From Negative of Absolute Value: $\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$
  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from sorry,

  --Let $\epsilon > 0$.
  assume (h7 : ε > 0),

  --As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that $\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$
  cases h2 ε h7 with N1 h8,

  --As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that $\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$
  cases h3 ε h7 with N2 h9,

  --Let $N = \max \set {N_1, N_2}$.
  let N := max N1 N2,
  use N,

  --Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.
  have h10 : ∀ n > N, n > N1 ∧ n > N2 := sorry,

  --$\forall n > N: l - \epsilon < y_n < l + \epsilon$
  --$\forall n > N: l - \epsilon < z_n < l + \epsilon$
  --$\forall n \in \N: y_n \le x_n \le z_n$
  --So $\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$
  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from sorry,

  --$\forall n > N: l - \epsilon < x_n < l + \epsilon$
  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from sorry,

  --So $\forall n > N: \size {x_n - l} < \epsilon$
  --Hence the result
  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from sorry,
end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

QED
-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.category_theory.limits.lattice
import Mathlib.PostPort

universes v l

namespace Mathlib

/-!
# The category of "pairwise intersections".

Given `ι : Type v`, we build the diagram category `pairwise ι`
with objects `single i` and `pair i j`, for `i j : ι`,
whose only non-identity morphisms are
`left : pair i j ⟶ single i` and `right : pair i j ⟶ single j`.

We use this later in describing (one formulation of) the sheaf condition.

Given any function `U : ι → α`, where `α` is some complete lattice (e.g. `(opens X)ᵒᵖ`),
we produce a functor `pairwise ι ⥤ α` in the obvious way,
and show that `supr U` provides a colimit cocone over this functor.
-/

namespace category_theory

/--
An inductive type representing either a single term of a type `ι`, or a pair of terms.
We use this as the objects of a category to describe the sheaf condition.
-/
inductive pairwise (ι : Type v)
where
| single : ι → pairwise ι
| pair : ι → ι → pairwise ι

namespace pairwise

protected instance pairwise_inhabited {ι : Type v} [Inhabited ι] : Inhabited (pairwise ι) :=
  { default := single Inhabited.default }

/--
Morphisms in the category `pairwise ι`. The only non-identity morphisms are
`left i j : single i ⟶ pair i j` and `right i j : single j ⟶ pair i j`.
-/
inductive hom {ι : Type v} : pairwise ι → pairwise ι → Type v
where
| id_single : (i : ι) → hom (single i) (single i)
| id_pair : (i j : ι) → hom (pair i j) (pair i j)
| left : (i j : ι) → hom (pair i j) (single i)
| right : (i j : ι) → hom (pair i j) (single j)

protected instance hom_inhabited {ι : Type v} [Inhabited ι] : Inhabited (hom (single Inhabited.default) (single Inhabited.default)) :=
  { default := hom.id_single Inhabited.default }

/--
The identity morphism in `pairwise ι`.
-/
def id {ι : Type v} (o : pairwise ι) : hom o o :=
  sorry

/-- Composition of morphisms in `pairwise ι`. -/
def comp {ι : Type v} {o₁ : pairwise ι} {o₂ : pairwise ι} {o₃ : pairwise ι} (f : hom o₁ o₂) (g : hom o₂ o₃) : hom o₁ o₃ :=
  sorry

protected instance category_theory.category {ι : Type v} : category (pairwise ι) :=
  category.mk

/-- Auxilliary definition for `diagram`. -/
@[simp] def diagram_obj {ι : Type v} {α : Type v} (U : ι → α) [semilattice_inf α] : pairwise ι → α :=
  sorry

/-- Auxilliary definition for `diagram`. -/
@[simp] def diagram_map {ι : Type v} {α : Type v} (U : ι → α) [semilattice_inf α] {o₁ : pairwise ι} {o₂ : pairwise ι} (f : o₁ ⟶ o₂) : diagram_obj U o₁ ⟶ diagram_obj U o₂ :=
  sorry

/--
Given a function `U : ι → α` for `[semilattice_inf α]`, we obtain a functor `pairwise ι ⥤ α`,
sending `single i` to `U i` and `pair i j` to `U i ⊓ U j`,
and the morphisms to the obvious inequalities.
-/
def diagram {ι : Type v} {α : Type v} (U : ι → α) [semilattice_inf α] : pairwise ι ⥤ α :=
  functor.mk (diagram_obj U) fun (X Y : pairwise ι) (f : X ⟶ Y) => diagram_map U f

-- `complete_lattice` is not really needed, as we only ever use `inf`,

-- but the appropriate structure has not been defined.

/-- Auxilliary definition for `cocone`. -/
def cocone_ι_app {ι : Type v} {α : Type v} (U : ι → α) [complete_lattice α] (o : pairwise ι) : diagram_obj U o ⟶ supr U :=
  sorry

/--
Given a function `U : ι → α` for `[complete_lattice α]`,
`supr U` provides a cocone over `diagram U`.
-/
@[simp] theorem cocone_X {ι : Type v} {α : Type v} (U : ι → α) [complete_lattice α] : limits.cocone.X (cocone U) = supr U :=
  Eq.refl (limits.cocone.X (cocone U))

/--
Given a function `U : ι → α` for `[complete_lattice α]`,
`infi U` provides a limit cone over `diagram U`.
-/
def cocone_is_colimit {ι : Type v} {α : Type v} (U : ι → α) [complete_lattice α] : limits.is_colimit (cocone U) :=
  limits.is_colimit.mk fun (s : limits.cocone (diagram U)) => hom_of_le sorry


import logic.equiv.transfer_instance
import ring_theory.valuation.valuation_subring
import algebraic_geometry.prime_spectrum_more
import for_mathlib.local_ring
import for_mathlib.ideal

variables {K: Type*} [field K] (A : valuation_subring K)

open local_ring

def local_subring (K : Type*) [comm_ring K] : Type* :=
{ s : subring K // local_ring s }

instance : partial_order (local_subring K) :=
{ le := λ A B, ∃ h : A.1 ≤ B.1, is_local_ring_hom (subring.inclusion h),
  le_refl := λ A, ⟨rfl.le, ⟨λ a ha, by { cases a, exact ha }⟩⟩,
  le_trans := λ A B C ⟨hAB, hAB'⟩ ⟨hBC, hBC'⟩,
    ⟨hAB.trans hBC, @@is_local_ring_hom_comp _ _ _ _ _ hBC' hAB'⟩,
  le_antisymm := λ A B ⟨hAB, hAB'⟩ ⟨hBA, hBA'⟩, subtype.ext (hAB.antisymm hBA) }

instance : has_coe_to_sort (local_subring K) Type* := ⟨λ s, s.1⟩
instance local_subring.local_ring (A : local_subring K) : local_ring A := A.2

def valuation_subring.to_local_subring (A : valuation_subring K) : local_subring K :=
⟨A.to_subring, show local_ring A, by apply_instance⟩

lemma valuation_subring.to_local_subring_injective :
  function.injective (valuation_subring.to_local_subring : _ → local_subring K) :=
λ A B e, by { ext, change x ∈ A.to_local_subring.1 ↔ _, rw e, refl }

def maximal_local_subrings (K : Type*) [field K] : set (local_subring K) :=
maximals (≤) (set.univ : set $ local_subring K)

open_locale polynomial

lemma maximal_ideal_map_eq_top_of_mem_maximal_local_subrings {R : local_subring K}
  (hR : R ∈ maximal_local_subrings K) {S : subring K} (hS : R.1 < S) :
    (local_ring.maximal_ideal R).map (subring.inclusion hS.le) = ⊤ :=
begin
  replace hR := hR.2,
  refine (not_not.mp $ λ h, _),
  obtain ⟨m, hm, hm'⟩ := ideal.exists_le_maximal _ h,
  haveI hm'' : m.comap (subring.inclusion hS.le) = local_ring.maximal_ideal R,
  { symmetry, apply (local_ring.maximal_ideal.is_maximal _).eq_of_le,
    { introI e, exact (ideal.is_prime.comap (subring.inclusion hS.le)).1 e },
    { rwa ← ideal.map_le_iff_le_comap } },
  let f := @is_localization.lift _ _ m.prime_compl (localization.at_prime m) _ _ _ _ _
    S.subtype (λ ⟨y, hy⟩, is_unit_iff_ne_zero.mpr $ λ e, hy $ by
    { obtain rfl : y = 0 := subtype.ext (e.trans S.subtype.map_zero.symm), exact m.zero_mem }),
  have hf : function.injective f,
  { rw injective_iff_map_eq_zero, intros x hx,
    obtain ⟨x, s, rfl⟩ := is_localization.mk'_surjective m.prime_compl x,
    rw [is_localization.lift_mk', eq_comm, units.eq_mul_inv_iff_mul_eq, zero_mul] at hx,
    obtain rfl : x = 0 := subtype.ext (hx.symm.trans S.subtype.map_zero.symm),
    rw is_localization.mk'_zero },
  let f' := ring_equiv.of_left_inverse hf.has_left_inverse.some_spec,
  have : S ≤ f.range,
  { intros x hx, refine ⟨is_localization.mk' _ (⟨x, hx⟩ : S) (1 : m.prime_compl), _⟩,
    rw [is_localization.lift_mk', map_one, inv_one, units.coe_one, mul_one], refl },
  have hS' := set_like.le_def.not.mp (not_le_of_lt hS),
  push_neg at hS',
  obtain ⟨x, hx, hx'⟩ := hS',
  refine hx' ((@hR ⟨f.range, _⟩ trivial ⟨hS.le.trans this, _⟩).some (this hx)),
  { exact f'.local_ring },
  { constructor, rintros y hy,
    have : subring.inclusion (hS.le.trans this) y =
      f' (algebra_map _ _ (subring.inclusion hS.le y)),
    { ext1, change _ = f _, rw is_localization.lift_eq, refl },
    rw [this, ← ring_equiv.coe_to_ring_hom, is_unit_map_iff ↑f',
      is_localization.at_prime.is_unit_to_map_iff _ m] at hy,
    apply not_not.mp,
    change y ∉ local_ring.maximal_ideal R,
    rw ← hm'',
    exact hy,
    all_goals { apply_instance } }
end

lemma algebra.mem_ideal_map_adjoin {R S : Type*} [comm_ring R] [comm_ring S] [algebra R S]
  (x : S) (I : ideal R) {y : algebra.adjoin R ({x} : set S)} :
  y ∈ I.map (algebra_map R $ algebra.adjoin R ({x} : set S)) ↔
    ∃ p : R[X], (∀ i, p.coeff i ∈ I) ∧ polynomial.aeval x p = y :=
begin
  let f : R[X] →ₐ[R] algebra.adjoin R ({x} : set S) :=
    polynomial.aeval ⟨x, algebra.self_mem_adjoin_singleton R x⟩,
  have hf : f.to_ring_hom.comp polynomial.C = algebra_map _ _ := f.comp_algebra_map,
  have : ∀ p, (f p : S) = polynomial.aeval x p,
  { intro p, change _ = polynomial.aeval ((algebra_map (algebra.adjoin R ({x} : set S))) S
      ⟨x, algebra.self_mem_adjoin_singleton R x⟩) p, rw polynomial.aeval_algebra_map_apply, refl },
  rw [← hf, ideal.map_comp, ideal.mem_map_iff_of_surjective],
  simp_rw [ideal.mem_map_C_iff, subtype.ext_iff, alg_hom.to_ring_hom_eq_coe,
    alg_hom.coe_to_ring_hom, this],
  rintro ⟨y, hy⟩,
  obtain ⟨p, rfl⟩ : y ∈ (polynomial.aeval x : R[X] →ₐ[R] S).range :=
    by rwa ← algebra.adjoin_singleton_eq_range_aeval,
  exact ⟨p, subtype.ext (this _)⟩
end

instance : has_mem K (local_subring K) := ⟨λ x K, x ∈ K.1⟩

lemma mem_of_mem_maximal_local_subrings_of_is_integral {R : local_subring K}
  (hR : R ∈ maximal_local_subrings K) {x : K} (hx : is_integral R x) : x ∈ R :=
begin
  by_contra hx',
  have H : R.1 < (algebra.adjoin R {x}).to_subring,
  { rw set_like.lt_iff_le_and_exists,
    exact ⟨λ y hy, (algebra.adjoin R {x}).algebra_map_mem ⟨y, hy⟩, x,
      algebra.subset_adjoin (set.mem_singleton x), hx'⟩ },
  have h₁ := maximal_ideal_map_eq_top_of_mem_maximal_local_subrings hR H,
  have h₂ : algebra.is_integral R (algebra.adjoin R ({x} : set K)),
  { rwa [← le_integral_closure_iff_is_integral, algebra.adjoin_le_iff,
      set.singleton_subset_iff] },
  obtain ⟨p, hp⟩ := prime_spectrum.surjective_of_is_integral_of_injective _ h₂
    (λ x y e, by { ext, injection e }) (local_ring.closed_point _),
  apply p.2.ne_top,
  rw [eq_top_iff, ← h₁, ideal.map_le_iff_le_comap],
  exact le_of_eq (by injection hp.symm)
end

lemma local_subring.range_valuation_subring :
  set.range valuation_subring.to_local_subring = maximal_local_subrings K :=
begin
  ext A, split,
  { rintro ⟨A, rfl⟩,
    refine ⟨trivial, _⟩,
    rintro B - ⟨hB, hB'⟩,
    apply eq.le,
    refine subtype.ext (hB.antisymm _).symm,
    intros x hx,
    cases A.2 x, { assumption },
    by_cases hx : x⁻¹ = 0, { rw inv_eq_zero.mp hx, exact zero_mem _ },
    have := hB'.1 ⟨_, h⟩,
    rw [subring.is_unit_iff, subring.is_unit_iff, subtype.coe_mk, inv_inv] at this,
    { apply this, show x⁻¹⁻¹ ∈ B.1, rwa inv_inv },
    { contrapose! hx, injection hx },
    { contrapose! hx, injection hx } },
  { rintros hA, refine ⟨⟨A.1, λ x, or_iff_not_imp_left.mpr $ λ hx, _⟩, subtype.ext rfl⟩,
    apply mem_of_mem_maximal_local_subrings_of_is_integral hA,
    let A' := algebra.adjoin A ({x} : set K),
    have hA' : A.1 ≤ A'.to_subring := λ x hx, A'.algebra_map_mem ⟨x, hx⟩,
    have hx' : x ∈ A' := algebra.subset_adjoin (set.mem_singleton x),
    have hx'' : x ≠ 0 := λ e, hx (e.symm ▸ A.1.zero_mem),
    have : (local_ring.maximal_ideal A).map (algebra_map A A') = ⊤,
    { refine maximal_ideal_map_eq_top_of_mem_maximal_local_subrings hA (lt_of_le_not_le hA' _),
      exact λ e, hx (e hx') },
    rw [ideal.eq_top_iff_one, algebra.mem_ideal_map_adjoin x (maximal_ideal A)] at this,
    obtain ⟨p, hp₁, hp₂⟩ := this,
    have hp₃ : polynomial.aeval x (p - 1) = 0,
    { rw [map_sub, polynomial.aeval_one, hp₂], exact sub_self 1 },
    haveI : invertible x := invertible_of_nonzero hx'',
    rw [polynomial.aeval_def, ← polynomial.eval₂_reverse_eq_zero_iff, inv_of_eq_inv] at hp₃,
    suffices hp₄ : is_unit (p - 1).reverse.leading_coeff,
    { have := is_integral_leading_coeff_smul _ _ hp₃,
      rw [algebra.smul_def, mul_comm] at this,
      refine is_integral_of_is_integral_mul_unit _ this,
      swap, rw [← map_mul, ← (algebra_map A K).map_one], congr' 1, exact hp₄.coe_inv_mul },
    have : (p - 1).nat_trailing_degree = 0,
    { rw ← le_zero_iff,
      apply polynomial.nat_trailing_degree_le_of_ne_zero _,
      rw [polynomial.coeff_sub, polynomial.coeff_one_zero, sub_ne_zero],
      intro e,
      apply (maximal_ideal.is_maximal A).ne_top,
      rw [ideal.eq_top_iff_one, ← e],
      apply hp₁ },
    rw [polynomial.reverse_leading_coeff, polynomial.trailing_coeff,
      this, polynomial.coeff_sub, polynomial.coeff_one_zero, ← is_unit.neg_iff, neg_sub],
    exact (local_ring.is_unit_or_is_unit_of_add_one
      $ sub_add_cancel 1 (p.coeff 0)).resolve_right (hp₁ 0) }
end

lemma exists_valuation_subring_dominates (A : local_subring K) :
  ∃ (B : valuation_subring K), A ≤ B.to_local_subring :=
begin
  let S := { B : local_subring K | A ≤ B },
  suffices : ∃ B ∈ S, A ≤ B ∧ ∀ B' ∈ S, B ≤ B' → B' = B,
  { obtain ⟨B, -, hB, hB'⟩ := this,
    obtain ⟨B, rfl⟩ : B ∈ (set.range valuation_subring.to_local_subring : set (local_subring K)),
    { rw local_subring.range_valuation_subring,
      exact ⟨trivial, λ B' _ h, (hB' B' (le_trans hB h) h).le⟩ },
    exact ⟨B, hB⟩ },
  apply zorn_nonempty_partial_order₀, swap, { exact le_refl _ },
  intros c hc hc' B hB,
  haveI : nonempty c := ⟨⟨B, hB⟩⟩,
  have hdir : directed has_le.le (λ (i : c), i.1.1),
  { apply is_chain.directed, intros i hi j hj e, apply or_of_or_of_imp_of_imp (hc' hi hj e),
    all_goals { exact λ x, x.some } },
  let X : local_subring K := ⟨⨆ i : c, i.1.1, ⟨_⟩⟩,
  swap,
  { rintros ⟨a, ha⟩ ⟨b, hb⟩ hab,
    rw subring.mem_supr_of_directed hdir at ha hb,
    obtain ⟨⟨i, hi⟩, ⟨j, hj⟩⟩ := ⟨ha, hb⟩,
    obtain ⟨k, hak, hbk⟩ := hdir i j,
    have : k.1.1 ≤ ⨆ i : c, i.1.1 := le_supr (λ i : c, i.1.1) k,
    apply or_of_or_of_imp_of_imp (@@local_ring.is_unit_or_is_unit_of_add_one _ k.1.2
      (show (⟨a, hak hi⟩ + ⟨b, hbk hj⟩ : k.1.1) = 1, by { ext, injection hab })),
    all_goals { exact (subring.inclusion this).is_unit_map } },
  have : ∀ (C : c), C.1 ≤ X,
  { intro C,
    refine ⟨le_supr _ C, ⟨λ x hx, _⟩⟩,
    obtain ⟨D, hD⟩ := (subring.mem_supr_of_directed hdir).mp (hx.unit⁻¹).1.prop,
    obtain ⟨E, hCE, hDE⟩ := hc'.directed C D,
    apply hCE.some_spec.1,
    refine is_unit_of_mul_eq_one _ ⟨_, hDE.some hD⟩ _,
    ext, injection hx.mul_coe_inv },
  exact ⟨X, le_trans (hc hB) (this ⟨B, hB⟩), λ C hC, this ⟨C, hC⟩⟩
end

lemma bijective_range_restrict_comp_of_valuation_ring {R S K : Type*} [comm_ring R]
  [is_domain R] [valuation_ring R]
  [comm_ring S] [local_ring S] [field K] [algebra R K] [is_fraction_ring R K]
  (f : R →+* S) (g : S →+* K) (h : g.comp f = algebra_map R K) [is_local_ring_hom f] :
  function.bijective (g.range_restrict.comp f) :=
begin
  haveI := local_ring.of_surjective' _ g.range_restrict_surjective,
  haveI H := local_ring.of_surjective' _ (algebra_map R K).range_restrict_surjective,
  have : (⟨(algebra_map R K).range, H⟩ : local_subring K) ∈ maximal_local_subrings K,
  { rw ← @local_subring.range_valuation_subring K,
    exact ⟨⟨_, λ x, valuation_ring.is_integer_or_is_integer R x⟩, subtype.ext rfl⟩ },
  refine ⟨λ x y e, is_fraction_ring.injective R K _, _⟩,
  { rw ← h, exact (congr_arg subtype.val e : _) },
  suffices : (show local_subring K, from ⟨g.range, infer_instance⟩) ≤ ⟨(algebra_map R K).range, H⟩,
  { intro x, obtain ⟨y, e⟩ := this.some x.prop, use y, rw ← h at e, ext1, exact e },
  refine this.2 trivial ⟨_, _⟩,
  { rintro _ ⟨x, rfl⟩, rw ← h, exact ⟨_, rfl⟩ },
  { generalize_proofs h',
    let e := ring_equiv.of_left_inverse (is_fraction_ring.injective R K).has_left_inverse.some_spec,
    have : (subring.inclusion h') = (g.range_restrict.comp f).comp e.symm.to_ring_hom,
    { ext x, obtain ⟨x, rfl⟩ := e.surjective x, change _ = (g.comp f) (e.symm _),
      rw [h, e.symm_apply_apply], refl },
    rw this,
    apply_with is_local_ring_hom_comp { instances := ff },
    apply_with is_local_ring_hom_comp { instances := ff },
    { exact is_local_ring_hom_of_surjective _ g.range_restrict_surjective },
    { assumption },
    { exact is_local_ring_hom_equiv e.symm } },
end

lemma exists_factor_valuation_ring {R : Type*} [comm_ring R] [local_ring R] {K : Type*} [field K]
  (f : R →+* K) :
    ∃ (A : valuation_subring K) h, is_local_ring_hom (f.cod_restrict A.to_subring h) :=
begin
  obtain ⟨B, hB, hB'⟩ := exists_valuation_subring_dominates ⟨f.range,
    local_ring.of_surjective' _ f.range_restrict_surjective⟩,
  haveI := is_local_ring_hom_of_surjective _ f.range_restrict_surjective,
  exact ⟨B, λ x, hB ⟨x, rfl⟩, is_local_ring_hom_comp (subring.inclusion hB) f.range_restrict⟩
end


import phase1.A_map
import phase2.basic

/-!
# Constraints
Support conditions can be said to *constrain* each other in a number of ways.
This is detailed below. The `constrains` relation is well-founded.
-/

open quiver set sum with_bot
open_locale classical

universe u

namespace con_nf
variables [params.{u}]

section extended_index
variable {α : type_index}

/-!
We construct a well-order on the type of extended indices.
The details are unimportant, we probably don't actually need AC here.
-/

instance : has_lt (extended_index α) := ⟨well_ordering_rel⟩
instance : is_well_order (extended_index α) (<) := well_ordering_rel.is_well_order
instance : has_well_founded (extended_index α) := is_well_order.to_has_well_founded
noncomputable instance : linear_order (extended_index α) := linear_order_of_STO (<)

end extended_index

variables {α : Λ} [position_data.{}] [phase_2_assumptions α] {β : Λ}

lemma coe_ne' {γ : Iio α} {β : Iio α} : γ ≠ β → (γ : Λ) ≠ (β : Λ) :=
by contrapose!; simp only [subtype.coe_inj, imp_self]

lemma coe_lt {γ : Iio α} {β : Iic α} : (γ : Λ) < β → (γ : type_index) < (β : type_index) :=
begin
  intro h,
  cases β,
  cases γ,
  exact coe_lt_coe.mpr h,
end

variables (α) (β)

/--
Support conditions can be said to *constrain* each other in a number of ways. This is discussed
in the "freedom of action discussion".
1. `⟨L, A⟩ ≺ ⟨a, A⟩` when `a ∈ L` and `L` is a litter. We can say that an atom is constrained by the
    litter it belongs to.
2. `⟨N°, A⟩ ≺ ⟨N, A⟩` when `N` is a near-litter not equal to its corresponding litter `N°`.
3. `⟨a, A⟩ ≺ ⟨N, A⟩` for all `a ∈ N ∆ N°`.
4. `⟨x, A ≫ (γ ⟶ δ) ≫ B⟩ ≺ ⟨f_{γ,δ}(t), A ≫ (γ ⟶ ε) ≫ (ε ⟶ ⊥)⟩` for all paths `A : β ⟶ γ` and
    `δ, ε < γ` with `δ ≠ ε`, `t ∈ τ_γ`, where `⟨x, B⟩` lies in the designated `δ`-support of `t`.
TODO: Refactor `near_litter` to use `¬N.is_litter`.
-/
@[mk_iff] inductive constrains : support_condition β → support_condition β → Prop
| atom (a : atom) (A : extended_index β) :
    constrains ⟨inr a.1.to_near_litter, A⟩ ⟨inl a, A⟩
| near_litter (N : near_litter) (hN : litter_set N.fst ≠ N.snd) (A : extended_index β) :
    constrains ⟨inr N.fst.to_near_litter, A⟩ ⟨inr N, A⟩
| symm_diff (N : near_litter) (a ∈ litter_set N.fst ∆ N.snd) (A : extended_index β) :
    constrains ⟨inl a, A⟩ ⟨inr N, A⟩
| f_map ⦃γ : Iic α⦄ ⦃δ : Iio α⦄ ⦃ε : Iio α⦄ (hδ : (δ : Λ) < γ) (hε : (ε : Λ) < γ) (hδε : δ ≠ ε)
    (A : path (β : type_index) γ) (t : tangle δ) (c ∈ (designated_support t).carrier) :
    constrains
      ⟨c.fst, (A.cons (coe_lt hδ)).comp c.snd⟩
      ⟨inr (f_map (coe_ne_coe.mpr $ coe_ne' hδε) t).to_near_litter,
        (A.cons (coe_lt hε)).cons (bot_lt_coe _)⟩
| f_map_bot ⦃γ : Iic α⦄ ⦃ε : Iio α⦄ (hε : (ε : Λ) < γ)
    (A : path (β : type_index) γ) (a : atom) :
    constrains
      ⟨inl a, A.cons (bot_lt_coe _)⟩
      ⟨inr (f_map (show (⊥ : type_index) ≠ (ε : Λ), from bot_ne_coe) a).to_near_litter,
        (A.cons (coe_lt hε)).cons (bot_lt_coe _)⟩

/-! We declare new notation for the "constrains" relation on support conditions. -/
notation c ` ≺[`:50 α `] ` d:50 := constrains α _ c d

instance : has_lt (support_condition β) :=
⟨prod.lex (inv_image (<) (λ c, c.elim typed_atom_position typed_near_litter_position)) (<)⟩

instance : is_well_founded (support_condition β) (<) :=
prod.lex.is_well_founded

lemma constrains_subrelation : subrelation (constrains α β) (<) :=
begin
  rintros c d h,
  obtain (⟨a, A⟩ | ⟨N, hN, A⟩ | ⟨N, a, ha, A⟩ | ⟨hδ, hε, hδε, A, t, c, hc⟩ | ⟨hδ, A, a⟩) := h;
  left,
  { exact litter_lt a.1 a rfl, },
  { refine litter_lt_near_litter N _,
    contrapose! hN,
    rw ← hN,
    refl, },
  { exact symm_diff_lt_near_litter N a ha, },
  { have := f_map_position (coe_ne_coe.mpr $ coe_ne' hδε) t _ (is_near_litter_litter_set _),
    rw tangle_data.typed_near_litter_position_eq at this,
    refine lt_of_le_of_lt _ this,
    convert tangle_data.support_le (show tangle (h_δ : Λ), from t) _ hc, },
  { simp only [inv_image, elim_inr],
    convert typed_atom_position_lt_f_map a,
    rw tangle_data.typed_near_litter_position_eq (f_map bot_ne_coe a).to_near_litter,
    apply_instance, },
end

/-- The `≺` relation is well-founded. By the conditions on orderings, if we have `⟨x, A⟩ ≺ ⟨y, B⟩`,
then `x < y` in `µ`, under the `typed_near_litter` or `typed_atom` maps. -/
lemma constrains_wf : well_founded (constrains α β) :=
subrelation.wf (constrains_subrelation α β) (is_well_founded.to_has_well_founded _).wf

instance : has_well_founded (support_condition β) := ⟨constrains α β, constrains_wf α β⟩

variable {α}

@[simp] lemma constrains_atom {c : support_condition β} {a : atom} {A : extended_index β} :
  c ≺[α] ⟨inl a, A⟩ ↔ c = ⟨inr a.1.to_near_litter, A⟩ :=
begin
  split,
  { rintro ⟨⟩, refl, },
  { rintro rfl, exact constrains.atom a A, },
end

/-- The constrains relation is stable under composition of paths. -/
lemma constrains_comp {β γ : Λ} {c d : support_condition γ} (h : c ≺[α] d)
  (B : path (β : type_index) γ) : ⟨c.fst, B.comp c.snd⟩ ≺[α] ⟨d.fst, B.comp d.snd⟩ :=
begin
  obtain (⟨a, A⟩ | ⟨N, hN, A⟩ | ⟨N, a, ha, A⟩ | ⟨hδ, hε, hδε, A, t, c, hc⟩ | ⟨hδ, A, a⟩) := h,
  { exact constrains.atom _ _, },
  { exact constrains.near_litter _ hN _, },
  { exact constrains.symm_diff _ _ ha _, },
  { rw [path.comp_cons, ← path.comp_assoc, path.comp_cons],
    exact constrains.f_map hδ hε hδε (B.comp A) t c hc, },
  { rw path.comp_cons,
    exact constrains.f_map_bot hδ (B.comp A) a, },
end

lemma refl_trans_gen_constrains_comp {β γ : Λ} {c d : support_condition γ}
  (h : relation.refl_trans_gen (constrains α γ) c d) (B : path (β : type_index) γ) :
  relation.refl_trans_gen (constrains α β) ⟨c.fst, B.comp c.snd⟩ ⟨d.fst, B.comp d.snd⟩ :=
begin
  induction h with e f hce hef ih,
  exact relation.refl_trans_gen.refl,
  exact relation.refl_trans_gen.tail ih (constrains_comp hef B),
end

lemma trans_gen_constrains_comp {β γ : Λ} {c d : support_condition γ}
  (h : relation.trans_gen (constrains α γ) c d) (B : path (β : type_index) γ) :
  relation.trans_gen (constrains α β) ⟨c.fst, B.comp c.snd⟩ ⟨d.fst, B.comp d.snd⟩ :=
begin
  induction h with e hce e f hce hef ih,
  exact relation.trans_gen.single (constrains_comp hce B),
  exact relation.trans_gen.tail ih (constrains_comp hef B),
end

lemma refl_trans_gen_near_litter {β : Λ} {N : near_litter} {B : extended_index β}
  {c : support_condition β}
  (h : relation.refl_trans_gen (constrains α β) (inr N, B) c) :
  relation.refl_trans_gen (constrains α β) (inr N.1.to_near_litter, B) c :=
begin
  by_cases h' : N.is_litter,
  { obtain ⟨L, rfl⟩ := h'.exists_litter_eq,
    exact h, },
  { exact relation.refl_trans_gen.head
      (constrains.near_litter N (near_litter.not_is_litter h') B) h, },
end

lemma trans_gen_near_litter {β : Λ} {N : near_litter} {B : extended_index β}
  {c : support_condition β}
  (h : relation.trans_gen (constrains α β) c (inr N.1.to_near_litter, B)) :
  relation.trans_gen (constrains α β) c (inr N, B) :=
begin
  by_cases h' : N.is_litter,
  { obtain ⟨L, rfl⟩ := h'.exists_litter_eq,
    exact h, },
  { exact relation.trans_gen.tail h
      (constrains.near_litter N (near_litter.not_is_litter h') B), },
end

lemma trans_gen_near_litter' {β : Λ} {N : near_litter} {B : extended_index β}
  {c : support_condition β}
  (h : relation.trans_gen (constrains α β) (inr N, B) c) :
  relation.trans_gen (constrains α β) (inr N.1.to_near_litter, B) c :=
begin
  by_cases h' : N.is_litter,
  { obtain ⟨L, rfl⟩ := h'.exists_litter_eq,
    exact h, },
  { exact relation.trans_gen.head
      (constrains.near_litter N (near_litter.not_is_litter h') B) h, },
end

end con_nf


/-
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.constructions.tracking_oracle
import computational_monads.simulation_semantics.simulate.subsingleton

/-!
# Stateless Oracles

This file defines a specific version of `tracking_oracle`, where the tracking isn't used.
This allows a specified function for responding to queries,
while making no use of the internal state (which is left as a `unit` type).
This is used for example in coercing from a computation with one set of oracles
to one with some superset of those oracles, using the simulation function to pass upwards.
-/

open oracle_comp oracle_spec

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

/-- Simulate a computation without making use of the internal state.
  We use the `unit` type as the state in this case, so all possible states are equal.
  Implemented as a `tracking_oracle` where the state isn't actually tracking anything -/
def stateless_oracle (spec spec' : oracle_spec)
  (o : Π (i : spec.ι), spec.domain i → oracle_comp spec' (spec.range i)) :
  sim_oracle spec spec' unit :=
⟪o | λ _ _ _ _, (), ()⟫

notation `⟪` o `⟫` := stateless_oracle _ _ o

namespace stateless_oracle

variables (oa : oracle_comp spec α)
  (o : Π (i : spec.ι), spec.domain i → oracle_comp spec' (spec.range i))
  (o' : Π (i : spec.ι), spec.domain i → oracle_comp spec'' (spec.range i))
  (i : spec.ι) (t : spec.domain i) (s s' : unit) (u : spec.range i)
  (x : spec.domain i × unit) (y : spec.range i × unit)

@[simp] lemma apply_eq : ⟪o⟫ i x = o i x.1 >>= λ u, return (u, ()) := by {cases x, refl}

instance decidable [∀ i x, (o i x).decidable] (x : spec.domain i × unit) : (⟪o⟫ i x).decidable :=
tracking_oracle.decidable o _ _ i x

lemma simulate_eq_default_simulate : simulate ⟪o⟫ oa s = default_simulate ⟪o⟫ oa :=
simulate_eq_default_simulate ⟪o⟫ oa s

lemma simulate'_eq_default_simulate' : simulate' ⟪o⟫ oa s = default_simulate' ⟪o⟫ oa :=
simulate'_eq_default_simulate' ⟪o⟫ oa s

section support

lemma support_apply : (⟪o⟫ i x).support = prod.fst ⁻¹' (o i x.1).support :=
by simp only [apply_eq, support_bind_prod_mk_of_snd_subsingleton, set.image_id']

lemma mem_support_apply_iff : y ∈ (⟪o⟫ i (t, s)).support ↔ y.1 ∈ (o i t).support :=
by cases y; simp only [apply_eq, support_bind, support_return, set.mem_Union, prod.mk.inj_iff,
  set.mem_singleton_iff, eq_iff_true_of_subsingleton, and_true, exists_prop, exists_eq_right']

/-- The `support` of `simulate` is the preimage of the support of `simulate'`,
as there is only one possible internal state for the oracle. -/
lemma support_simulate_eq_preimage_support_simulate' :
  (simulate ⟪o⟫ oa s).support = prod.fst ⁻¹' (simulate' ⟪o⟫ oa ()).support :=
support_simulate_eq_preimage_support_simulate' ⟪o⟫ oa s

/-- If the oracle function can take on any possible output, simulation doesn't affect `support`. -/
lemma support_simulate'_eq_support (h : ∀ i t, (o i t).support = ⊤) :
  (simulate' ⟪o⟫ oa s).support = oa.support :=
tracking_oracle.support_simulate'_eq_support o _ _ oa s h

lemma support_simulate_eq_preimage_support (h : ∀ i t, (o i t).support = ⊤) :
  (simulate ⟪o⟫ oa s).support = prod.fst ⁻¹' oa.support :=
tracking_oracle.support_simulate_eq_preimage_support_of_subsingleton o _ _ oa s h

lemma support_simulate'_eq_support_simulate' (h : ∀ i t, (o i t).support = (o' i t).support) :
  (simulate' ⟪o⟫ oa s).support = (simulate' ⟪o'⟫ oa s').support :=
tracking_oracle.support_simulate'_eq_support_simulate' o o' _ _ () () oa s s' h

lemma support_simulate_eq_support_simulate (h : ∀ i t, (o i t).support = (o' i t).support) :
  (simulate ⟪o⟫ oa s).support = (simulate ⟪o'⟫ oa s').support :=
support_simulate_eq_support_simulate_of_subsingleton oa ⟪o⟫ ⟪o'⟫ s s'
  (λ i t, by rw [support_apply, support_apply, h])

@[simp] lemma mem_support_simulate_iff (y : α × unit) :
  y ∈ (simulate ⟪o⟫ oa s).support ↔ y.1 ∈ (simulate' ⟪o⟫ oa ()).support :=
by rw [support_simulate_eq_preimage_support_simulate', set.mem_preimage]

end support

section fin_support

variable [∀ i x, (o i x).decidable]

-- TODO: this should generalize I think?
lemma fin_support_apply : (⟪o⟫ i x).fin_support = finset.preimage (o i t).fin_support prod.fst
  (λ y hy z hz h, prod.eq_iff_fst_eq_snd_eq.2 ⟨h, punit_eq _ _⟩) :=
sorry

lemma mem_fin_support_apply : y ∈ (⟪o⟫ i x).fin_support ↔ y.1 ∈ (o i x.1).fin_support :=
sorry

end fin_support

section eval_dist

lemma eval_dist_apply : ⁅⟪o⟫ i x⁆ = ⁅o i x.1⁆.map (λ u, (u, ())) :=
by rw [apply_eq, eval_dist_bind_return]

/-- If the oracle responds uniformly to queries, then simulation doesn't affect `eval_dist`. -/
lemma eval_dist_simulate'_eq_eval_dist
  (h : ∀ i t, ⁅o i t⁆ = pmf.uniform_of_fintype (spec.range i)) : ⁅simulate' ⟪o⟫ oa s⁆ = ⁅oa⁆ :=
tracking_oracle.eval_dist_simulate'_eq_eval_dist o _ _ oa s h

lemma eval_dist_simulate'_eq_eval_dist_simulate' (h : ∀ i t, ⁅o i t⁆ = ⁅o' i t⁆) :
  ⁅simulate' ⟪o⟫ oa s⁆ = ⁅simulate' ⟪o'⟫ oa s'⁆ :=
tracking_oracle.eval_dist_simulate'_eq_eval_dist_simulate' o o' _ _ _ _ oa s s' h

/-- The `eval_dist` of `simulate` is the result of mapping the `eval_dist` of `simulate'`
under the map adding on a default `()` value for the internal state. -/
lemma eval_dist_simulate_eq_map_eval_dist_simulate' :
  ⁅simulate ⟪o⟫ oa s⁆ = ⁅simulate' ⟪o⟫ oa s⁆.map (λ x, (x, ())) :=
by simp only [eval_dist_simulate_eq_map_eval_dist_simulate'_of_subsingleton, punit_eq s ()]

lemma eval_dist_simulate_eq_eval_dist_simulate (h : ∀ i t, ⁅o i t⁆ = ⁅o' i t⁆) :
  ⁅simulate ⟪o⟫ oa s⁆ = ⁅simulate ⟪o'⟫ oa s'⁆ :=
by simp only [eval_dist_simulate_eq_map_eval_dist_simulate',
  eval_dist_simulate'_eq_eval_dist_simulate' oa o o' s s' h]

lemma eval_dist_simulate_apply_eq_eval_dist_simulate'_apply (x : α × unit) :
  ⁅simulate ⟪o⟫ oa s⁆ x = ⁅simulate' ⟪o⟫ oa s⁆ x.1 :=
eval_dist_simulate_apply_eq_eval_dist_simulate'_apply_of_subsingleton ⟪o⟫ oa s x

end eval_dist

section prob_event

lemma prob_event_apply (e : set $ spec.range i × unit) :
  ⁅e | ⟪o⟫ i x⁆ = ⁅(λ x, (x, ())) ⁻¹' e | o i x.1⁆ :=
by rw [apply_eq, prob_event_bind_return]

/-- If the oracle function responds uniformly, then simulation doesn't affect `prob_event`. -/
lemma prob_event_simulate'_eq_prob_event
  (h : ∀ i t, ⁅o i t⁆ = pmf.uniform_of_fintype (spec.range i)) (e : set α) :
  ⁅e | simulate' ⟪o⟫ oa s⁆ = ⁅e | oa⁆ :=
prob_event_eq_of_eval_dist_eq (eval_dist_simulate'_eq_eval_dist oa o s h) e

lemma prob_event_simulate'_eq_prob_event_simulate' (h : ∀ i t, ⁅o i t⁆ = ⁅o' i t⁆) (e : set α) :
  ⁅e | simulate' ⟪o⟫ oa s⁆ = ⁅e | simulate' ⟪o'⟫ oa s'⁆ :=
prob_event_eq_of_eval_dist_eq (eval_dist_simulate'_eq_eval_dist_simulate' oa o o' s s' h) e

lemma prob_event_simulate (e : set $ α × unit) :
  ⁅e | simulate ⟪o⟫ oa s⁆ = ⁅prod.fst '' e | simulate' ⟪o⟫ oa s⁆ :=
begin
  sorry
end

end prob_event

end stateless_oracle

-- More lemmas we can prove about `tracking_oracle` with the definition of the `stateless_oracle`
namespace tracking_oracle

variables {S S' : Type} (o o' : Π (i : spec.ι), spec.domain i → oracle_comp spec' (spec.range i))
  (update_state update_state': Π (s : S) (i : spec.ι), spec.domain i → spec.range i → S)
  (default_state default_state' s s' : S) (oa : oracle_comp spec α)

section support

/-- The first output with a tracking oracle is independent of any of the tracking state -/
lemma support_simulate'_eq_support_simulate'_stateless_oracle :
  (simulate' ⟪o | update_state, default_state⟫ oa s).support = (simulate' ⟪o⟫ oa ()).support :=
begin
  sorry
  -- unfold stateless_oracle,
  -- refine support_simulate'_eq_of_oracle_eq o update_state (λ _ _ _ _, ()) default_state _ oa s _
end

end support

section distribution_semantics

/-- The first output of a tracking oracle is equivalent to using just the stateless oracle -/
theorem simulate'_equiv_stateless_oracle :
  simulate' ⟪o | update_state, default_state⟫ oa s ≃ₚ simulate' ⟪o⟫ oa () :=
begin
  sorry
  -- induction oa using oracle_comp.induction_on with α a α β oa ob hoa hob i t generalizing s,
  -- { simp },
  -- { let so := ⟪o|update_state, default_state⟫,
  --   calc simulate' so (oa >>= ob) s
  --     ≃ₚ (simulate so oa s) >>= (λ x, simulate' so (ob x.1) x.2) :
              --simulate'_bind_equiv so oa ob s
  --     ... ≃ₚ (simulate so oa s) >>= (λ x, simulate' ⟪o⟫ (ob x.1) ()) :
  --       bind_equiv_of_equiv_second _ (λ a, (hob a.1 a.2))
  --     ... ≃ₚ (simulate' so oa s) >>= (λ x, simulate' ⟪o⟫ (ob x) ()) : by erw [bind_map_equiv]
  --     ... ≃ₚ (simulate' ⟪o⟫ oa ()) >>= (λ x, simulate' ⟪o⟫ (ob x) ()) :
  --       bind_equiv_of_equiv_first _ (hoa _)
  --     ... ≃ₚ (simulate ⟪o⟫ oa ()) >>= (λ x, simulate' ⟪o⟫ (ob x.1) ()) : by erw [bind_map_equiv]
  --     ... ≃ₚ (simulate ⟪o⟫ oa ()) >>= (λ x, simulate' ⟪o⟫ (ob x.1) x.2) :
  --       by { congr, ext x, rw [punit_eq () x.2] }
  --     ... ≃ₚ simulate' ⟪o⟫ (oa >>= ob) () : by rw [simulate'_bind_equiv] },
  -- { simp_rw [simulate'_query_equiv, apply_eq, stateless_oracle.apply_eq, map_bind_equiv],
  --   refine bind_equiv_of_equiv_second (o i t) _,
  --   simp only [map_pure_equiv, eq_self_iff_true, forall_const] }
end

/-- The first ouptput of a tracking oracle is indepenedent of the actual tracking functions -/
lemma simulate'_equiv_of_equiv (h : ∀ i t, o i t ≃ₚ o' i t) :
  simulate' ⟪o | update_state, default_state⟫ oa s ≃ₚ
    simulate' ⟪o' | update_state', default_state'⟫ oa s' :=
calc simulate' ⟪o | update_state, default_state⟫ oa s
  ≃ₚ simulate' ⟪o⟫ oa () : simulate'_equiv_stateless_oracle o update_state default_state s oa
  ... ≃ₚ simulate' ⟪o'⟫ oa () :
    stateless_oracle.eval_dist_simulate'_eq_eval_dist_simulate' _ _ _ _ _ h
  ... ≃ₚ simulate' ⟪o' | update_state', default_state'⟫ oa s' :
    symm (simulate'_equiv_stateless_oracle o' update_state' default_state' _ _)

end distribution_semantics

end tracking_oracle


/-
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

Binder elimination

! This file was ported from Lean 3 source module tactic.converter.binders
! leanprover-community/mathlib commit d6814c584384ddf2825ff038e868451a7c956f31
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.CompleteLattice

namespace OldConv

open Tactic Monad

unsafe instance : MonadFail old_conv :=
  { old_conv.monad with fail := fun α s => (fun r e => tactic.fail (to_fmt s) : old_conv α) }

unsafe instance : HasMonadLift tactic old_conv :=
  ⟨fun α => lift_tactic⟩

unsafe instance (α : Type) : Coe (tactic α) (old_conv α) :=
  ⟨monadLift⟩

unsafe def current_relation : old_conv Name := fun r lhs => return ⟨r, lhs, none⟩
#align old_conv.current_relation old_conv.current_relation

unsafe def head_beta : old_conv Unit := fun r e => do
  let n ← tactic.head_beta e
  return ⟨(), n, none⟩
#align old_conv.head_beta old_conv.head_beta

-- congr should forward data!
unsafe def congr_arg : old_conv Unit → old_conv Unit :=
  congr_core (return ())
#align old_conv.congr_arg old_conv.congr_arg

unsafe def congr_fun : old_conv Unit → old_conv Unit := fun c => congr_core c (return ())
#align old_conv.congr_fun old_conv.congr_fun

unsafe def congr_rule (congr : expr) (cs : List (List expr → old_conv Unit)) : old_conv Unit :=
  fun r lhs => do
  let meta_rhs ← infer_type lhs >>= mk_meta_var
  let t
    ←-- is maybe overly restricted for `heq`
        mk_app
        r [lhs, meta_rhs]
  let ((), meta_pr) ←
    solve_aux t do
        apply congr
        focus <|
            cs fun c => do
              let xs ← intros
              conversion (head_beta >> c xs)
        done
  let rhs ← instantiate_mvars meta_rhs
  let pr ← instantiate_mvars meta_pr
  return ⟨(), rhs, some pr⟩
#align old_conv.congr_rule old_conv.congr_rule

unsafe def congr_binder (congr : Name) (cs : expr → old_conv Unit) : old_conv Unit := do
  let e ← mk_const congr
  congr_rule e
      [fun bs => do
        let [b] ← return bs
        cs b]
#align old_conv.congr_binder old_conv.congr_binder

unsafe def funext' : (expr → old_conv Unit) → old_conv Unit :=
  congr_binder `` _root_.funext
#align old_conv.funext' old_conv.funext'

unsafe def propext' {α : Type} (c : old_conv α) : old_conv α := fun r lhs =>
  (do
      guard (r = `iff)
      c r lhs) <|>
    do
    guard (r = `eq)
    let ⟨res, rhs, pr⟩ ← c `iff lhs
    match pr with
      | some pr => return ⟨res, rhs, (expr.const `propext [] : expr) lhs rhs pr⟩
      | none => return ⟨res, rhs, none⟩
#align old_conv.propext' old_conv.propext'

unsafe def apply (pr : expr) : old_conv Unit := fun r e => do
  let sl ← simp_lemmas.mk.add pr
  apply_lemmas sl r e
#align old_conv.apply old_conv.apply

unsafe def applyc (n : Name) : old_conv Unit := fun r e => do
  let sl ← simp_lemmas.mk.add_simp n
  apply_lemmas sl r e
#align old_conv.applyc old_conv.applyc

unsafe def apply' (n : Name) : old_conv Unit := do
  let e ← mk_const n
  congr_rule e []
#align old_conv.apply' old_conv.apply'

end OldConv

open Expr Tactic OldConv

/- Binder elimination:

We assume a binder `B : p → Π (α : Sort u), (α → t) → t`, where `t` is a type depending on `p`.
Examples:
  ∃: there is no `p` and `t` is `Prop`.
  ⨅, ⨆: here p is `β` and `[complete_lattice β]`, `p` is `β`

Problem: ∀x, _ should be a binder, but is not a constant!

Provide a mechanism to rewrite:

  B (x : α) ..x.. (h : x = t), p x  =  B ..x/t.., p t

Here ..x.. are binders, maybe also some constants which provide commutativity rules with `B`.

-/
unsafe structure binder_eq_elim where
  match_binder : expr → tactic (expr × expr)
  -- returns the bound type and body
  adapt_rel : old_conv Unit → old_conv Unit
  -- optionally adapt `eq` to `iff`
  apply_comm : old_conv Unit
  -- apply commutativity rule
  applyCongr : (expr → old_conv Unit) → old_conv Unit
  -- apply congruence rule
  apply_elim_eq : old_conv Unit
#align binder_eq_elim binder_eq_elim

-- (B (x : β) (h : x = t), s x) = s t
unsafe def binder_eq_elim.check_eq (b : binder_eq_elim) (x : expr) : expr → tactic Unit
  | q(@Eq $(β) $(l) $(r)) => guard (l = x ∧ ¬x.occurs r ∨ r = x ∧ ¬x.occurs l)
  | _ => fail "no match"
#align binder_eq_elim.check_eq binder_eq_elim.check_eq

unsafe def binder_eq_elim.pull (b : binder_eq_elim) (x : expr) : old_conv Unit := do
  let (β, f) ← lhs >>= lift_tactic ∘ b.match_binder
  guard ¬x β <|>
      b x β <|> do
        b fun x => binder_eq_elim.pull
        b
#align binder_eq_elim.pull binder_eq_elim.pull

unsafe def binder_eq_elim.push (b : binder_eq_elim) : old_conv Unit :=
  b.apply_elim_eq <|>
    (do
        b
        b fun x => binder_eq_elim.push) <|>
      do
      b <| b
      binder_eq_elim.push
#align binder_eq_elim.push binder_eq_elim.push

unsafe def binder_eq_elim.check (b : binder_eq_elim) (x : expr) : expr → tactic Unit
  | e => do
    let (β, f) ← b.match_binder e
    b x β <|> do
        let lam n bi d bd ← return f
        let x ← mk_local' n bi d
        binder_eq_elim.check <| bd x
#align binder_eq_elim.check binder_eq_elim.check

unsafe def binder_eq_elim.old_conv (b : binder_eq_elim) : old_conv Unit := do
  let (β, f) ← lhs >>= lift_tactic ∘ b.match_binder
  let lam n bi d bd ← return f
  let x ← mk_local' n bi d
  b x (bd x)
  b b
#align binder_eq_elim.old_conv binder_eq_elim.old_conv

theorem exists_elim_eq_left.{u, v} {α : Sort u} (a : α) (p : ∀ a' : α, a' = a → Prop) :
    (∃ (a' : α)(h : a' = a), p a' h) ↔ p a rfl :=
  ⟨fun ⟨a', ⟨h, p_h⟩⟩ =>
    match a', h, p_h with
    | _, rfl, h => h,
    fun h => ⟨a, rfl, h⟩⟩
#align exists_elim_eq_left exists_elim_eq_left

theorem exists_elim_eq_right.{u, v} {α : Sort u} (a : α) (p : ∀ a' : α, a = a' → Prop) :
    (∃ (a' : α)(h : a = a'), p a' h) ↔ p a rfl :=
  ⟨fun ⟨a', ⟨h, p_h⟩⟩ =>
    match a', h, p_h with
    | _, rfl, h => h,
    fun h => ⟨a, rfl, h⟩⟩
#align exists_elim_eq_right exists_elim_eq_right

unsafe def exists_eq_elim : binder_eq_elim
    where
  match_binder e := do
    let q(@Exists $(β) $(f)) ← return e
    return (β, f)
  adapt_rel := propext'
  apply_comm := applyc `` exists_comm
  applyCongr := congr_binder `` exists_congr
  apply_elim_eq := apply' `` exists_elim_eq_left <|> apply' `` exists_elim_eq_right
#align exists_eq_elim exists_eq_elim

theorem forall_comm.{u, v} {α : Sort u} {β : Sort v} (p : α → β → Prop) :
    (∀ a b, p a b) ↔ ∀ b a, p a b :=
  ⟨fun h b a => h a b, fun h b a => h a b⟩
#align forall_comm forall_comm

theorem forall_elim_eq_left.{u, v} {α : Sort u} (a : α) (p : ∀ a' : α, a' = a → Prop) :
    (∀ (a' : α) (h : a' = a), p a' h) ↔ p a rfl :=
  ⟨fun h => h a rfl, fun h a' h_eq =>
    match a', h_eq with
    | _, rfl => h⟩
#align forall_elim_eq_left forall_elim_eq_left

theorem forall_elim_eq_right.{u, v} {α : Sort u} (a : α) (p : ∀ a' : α, a = a' → Prop) :
    (∀ (a' : α) (h : a = a'), p a' h) ↔ p a rfl :=
  ⟨fun h => h a rfl, fun h a' h_eq =>
    match a', h_eq with
    | _, rfl => h⟩
#align forall_elim_eq_right forall_elim_eq_right

unsafe def forall_eq_elim : binder_eq_elim
    where
  match_binder e := do
    let expr.pi n bi d bd ← return e
    return (d, expr.lam n bi d bd)
  adapt_rel := propext'
  apply_comm := applyc `` forall_comm
  applyCongr := congr_binder `` forall_congr'
  apply_elim_eq := apply' `` forall_elim_eq_left <|> apply' `` forall_elim_eq_right
#align forall_eq_elim forall_eq_elim

unsafe def supr_eq_elim : binder_eq_elim
    where
  match_binder e := do
    let q(@supᵢ $(α) $(cl) $(β) $(f)) ← return e
    return (β, f)
  adapt_rel c := do
    let r ← current_relation
    guard (r = `eq)
    c
  apply_comm := applyc `` supᵢ_comm
  applyCongr := congr_arg ∘ funext'
  apply_elim_eq := applyc `` supᵢ_supᵢ_eq_left <|> applyc `` supᵢ_supᵢ_eq_right
#align supr_eq_elim supr_eq_elim

unsafe def infi_eq_elim : binder_eq_elim
    where
  match_binder e := do
    let q(@infᵢ $(α) $(cl) $(β) $(f)) ← return e
    return (β, f)
  adapt_rel c := do
    let r ← current_relation
    guard (r = `eq)
    c
  apply_comm := applyc `` infᵢ_comm
  applyCongr := congr_arg ∘ funext'
  apply_elim_eq := applyc `` infᵢ_infᵢ_eq_left <|> applyc `` infᵢ_infᵢ_eq_right
#align infi_eq_elim infi_eq_elim

universe u v w w₂

variable {α : Type u} {β : Type v} {ι : Sort w} {ι₂ : Sort w₂} {s t : Set α} {a : α}

section

variable [CompleteLattice α]

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic old_conv.conversion -/
example {s : Set β} {f : β → α} : infₛ (Set.image f s) = ⨅ a ∈ s, f a :=
  by
  simp [infₛ_eq_infᵢ, infᵢ_and]
  run_tac
    conversion infi_eq_elim.old_conv

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic old_conv.conversion -/
example {s : Set β} {f : β → α} : supₛ (Set.image f s) = ⨆ a ∈ s, f a :=
  by
  simp [supₛ_eq_supᵢ, supᵢ_and]
  run_tac
    conversion supr_eq_elim.old_conv

end


import topology.category.Profinite.as_limit
import topology.continuous_function.algebra
import locally_constant.SemiNormedGroup
import locally_constant.completion
import analysis.special_functions.pow
import topology.algebra.module.weak_dual
import analysis.mean_inequalities_pow
import real_measures.condensed
import for_mathlib.is_locally_constant

open_locale nnreal big_operators classical

noncomputable theory

open category_theory
open category_theory.limits
open topological_space

local attribute [instance]
  locally_constant.seminormed_add_comm_group
  locally_constant.pseudo_metric_space

lemma real.pow_nnnorm_sum_le
  {ι : Type*} (S : finset ι) (r : ι → ℝ)
  (p : ℝ≥0) [fact (0 < p)] [fact (p ≤ 1)] :
  ∥ ∑ i in S, r i ∥₊^(p : ℝ) ≤ ∑ i in S, ∥ r i ∥₊^(p : ℝ) :=
begin
  refine finset.le_sum_of_subadditive (λ x : ℝ, ∥ x ∥₊^(p : ℝ)) _ _
    S r,
  { simp only [nnnorm_zero, nnreal.rpow_eq_zero_iff, eq_self_iff_true, ne.def,
      nnreal.coe_eq_zero, true_and],
    exact ne_of_gt (fact.out _) },
  { intros x y,
    dsimp,
    refine le_trans _ (nnreal.rpow_add_le_add_rpow _ _ (nnreal.coe_pos.mpr (fact.out _)).le _),
    rw nnreal.rpow_le_rpow_iff (nnreal.coe_pos.mpr (fact.out _) : 0 < ↑p),
    apply nnnorm_add_le,
    exact (nnreal.coe_le_coe.mpr (fact.out _)).trans nnreal.coe_one.le }
end

namespace locally_constant

instance normed_space (X : Type*)
  [topological_space X] [compact_space X] :
  normed_space ℝ (locally_constant X ℝ) :=
{ norm_smul_le := λ a f, by simpa only [norm_def, coe_smul, pi.smul_apply, algebra.id.smul_eq_mul,
    real.norm_eq_abs, abs_mul, mul_comm (abs a)] using
      (real.supr_mul_of_nonneg (abs_nonneg _) _).symm.le,
  ..(infer_instance : module ℝ _) }

lemma nnnorm_apply_le_nnnorm (X : Type*)
  [topological_space X] [compact_space X]
  (e : locally_constant X ℝ) (x : X) :
  ∥ e x ∥₊ ≤ ∥ e ∥₊ :=
begin
  change _ ≤ Sup _,
  apply le_cSup,
  let S := _, change bdd_above S, suffices : is_compact S, apply is_compact.bdd_above this,
  apply is_compact_range, refine continuous.comp _ e.continuous, exact continuous_norm,
  use x, refl,
end

/--  The evaluation map at a point of a topological space, bundled as a linear map from
locally constant functions to the real numbers. -/
def linear_eval (X : Type*)
  [topological_space X] (x : X) :
  locally_constant X ℝ →ₗ[ℝ] ℝ :=
{ to_fun := λ e, e x,
  map_add' := λ f g, rfl,
  map_smul' := λ r f, rfl }

lemma continuous_eval (X : Type*)
  [topological_space X] [compact_space X] (x : X) :
  continuous (λ e : locally_constant X ℝ, e x) :=
begin
  change continuous (linear_eval X x),
  let E := linear_map.mk_continuous_of_exists_bound (linear_eval X x) _,
  swap,
  use 1, intros e, rw one_mul, apply nnnorm_apply_le_nnnorm,
  exact E.continuous
end

end locally_constant

namespace topological_space.clopens

lemma indicator_continuous {X Y : Type*} [topological_space X] [topological_space Y] [has_zero Y]
  (U : clopens X) (f : X → Y) (hf : continuous f) :
  continuous (set.indicator (U : set X) f) :=
begin
  constructor, intros V hV,
  set W : set X := (U : set X).indicator f ⁻¹' V,
  by_cases h0 : (0:Y) ∈ V,
  { suffices : W = f ⁻¹' V ∪ Uᶜ,
    { rw this, exact (hV.preimage hf).union U.clopen.compl.is_open },
    classical, ext x,
    simp only [set.mem_preimage, set.mem_union, set.mem_compl_iff, set_like.mem_coe,
      set.indicator_apply],
    split_ifs with hxU,
    { simp only [hxU, not_true, or_false] },
    { simp only [h0, hxU, true_iff, not_false_iff, or_true], }, },
  { suffices : W = f ⁻¹' V ∩ U,
    { rw this, exact (hV.preimage hf).inter U.clopen.is_open },
    classical, ext x,
    simp only [set.mem_preimage, set.mem_union, set.mem_compl_iff, set_like.mem_coe,
      set.indicator_apply],
    split_ifs with hxU,
    { simp only [hxU, set.mem_inter_iff, set.mem_preimage, set_like.mem_coe, and_true] },
    { simp only [h0, false_iff, set.mem_inter_iff, set.mem_preimage, set_like.mem_coe, not_and],
      intro, assumption, } }
end

/--  The indicator function on clopen sets are continuous functions. -/
def indicator {X : Type*} [topological_space X] (U : clopens X) :
  C(X,ℝ) :=
{ to_fun := set.indicator U 1,
  continuous_to_fun := indicator_continuous _ _ continuous_one }

lemma indicator_one_inverse_image {X : Type*} (U : set X) (s : set ℝ) :
  (U.indicator 1 ⁻¹' s) = set.univ ∨ (U.indicator 1 ⁻¹' s) = U ∨
  (U.indicator 1 ⁻¹' s) = Uᶜ ∨ (U.indicator 1 ⁻¹' s) = ∅ :=
begin
  by_cases s1 : (1 : ℝ) ∈ s;
  by_cases s0 : (0 : ℝ) ∈ s,
  work_on_goal 1 { refine or.inl _},
  work_on_goal 2 { refine or.inr (or.inl _) },
  work_on_goal 3 { refine or.inr (or.inr (or.inl _)) },
  work_on_goal 4 { refine or.inr (or.inr (or.inr _)) },
  all_goals
  { ext x,
    by_cases xU : x ∈ U,
    { simp only [xU, s1, set.mem_preimage, set.indicator_of_mem, pi.one_apply, set.mem_compl_iff,
        not_true, set.mem_univ, set.mem_empty_iff_false] },
    { simp only [xU, s0, set.mem_preimage, set.indicator_of_not_mem, not_false_iff,
        set.mem_compl_iff, set.mem_univ, set.mem_empty_iff_false] } }
end

/--  The indicator function of a clopen set, bundled as a locally constant function. -/
def indicator_LC {X : Type*} [topological_space X] (U : clopens X) :
  locally_constant X ℝ :=
{ to_fun := set.indicator U 1,
  is_locally_constant := λ s, begin
    rcases indicator_one_inverse_image ↑U s with h | h | h | h;
    rw h,
    exacts [is_open_univ, U.clopen.is_open, (Uᶜ).clopen.is_open, is_open_empty]
  end }

lemma indicator_apply {X : Type*} [topological_space X] (U : clopens X) (x) :
  U.indicator x = if x ∈ U then 1 else 0 := rfl

lemma indicator_LC_apply {X : Type*} [topological_space X] (U : clopens X) (x) :
  U.indicator_LC x = if x ∈ U then 1 else 0 := rfl

end topological_space.clopens

namespace discrete_quotient

/--  Given a discrete topological space `T` that is a quotient of a topological space `X`, and
an element `t : T`, `fiber T t` is the clopen subset of `X` that is the inverse image of `t` under
the quotient map `X → T`. -/
def fibre {X : Type*} [topological_space X] (T : discrete_quotient X)
  (t : T) : clopens X :=
{ carrier := T.proj ⁻¹' {t},
  clopen' := fiber_clopen T {t} }

/--  When the topological space `X` is discrete, `equiv_bot` is the equivalence between `X` and the
bottom element of the discrete quotients of `X`.  In other words, the identity map from `X` to
itself *is*  a discrete quotient and `equiv_bot` is this bijection. -/
def equiv_bot {X : Type*} [topological_space X] [discrete_topology X] :
  X ≃ (⊥ : discrete_quotient X) :=
equiv.of_bijective (discrete_quotient.proj _)
⟨λ x y h, quotient.exact' h, discrete_quotient.proj_surjective _⟩

lemma mem_fibre_iff {X : Type*} [topological_space X]
  (T : discrete_quotient X) (a : T) (b : X) :
  T.proj b ∈ discrete_quotient.fibre _ (equiv_bot a) ↔
  b ∈ discrete_quotient.fibre T a :=
begin
  obtain ⟨a,rfl⟩ := discrete_quotient.proj_surjective _ a,
  dsimp [fibre, equiv_bot],
  let TT : discrete_quotient T := ⊥,
  change T.proj b ∈ equiv_bot ⁻¹' {equiv_bot (T.proj a)} ↔ T.proj b ∈ {T.proj a},
  simp,
end

lemma mem_fibre_iff' {X : Type*} [topological_space X]
  (T : discrete_quotient X) (a : (⊥ : discrete_quotient T)) (b : X) :
  T.proj b ∈ discrete_quotient.fibre _ a ↔
  b ∈ discrete_quotient.fibre T (equiv_bot.symm a) :=
begin
  rw [← equiv_bot.apply_symm_apply a, mem_fibre_iff],
  simp,
end

/--  Given a continuous (`hf`), surjective (`hf'`) function `f : X → Y` between topological spaces
`X` and `Y`, and a discrete quotient `T` of `Y`, `comap_equiv f hf hf' T` is the bijection between
between the  comap of `T` along `f` and `T` itself.
-/
def comap_equiv {X Y : Type*} [topological_space X] [topological_space Y]
  (f : X → Y) (hf : continuous f) (hf' : function.surjective f)
  (T : discrete_quotient Y) :
  T.comap hf ≃ T :=
equiv.of_bijective (discrete_quotient.map $ le_refl _)
begin
  split,
  { rintros ⟨x⟩ ⟨y⟩ h,
    apply quotient.sound',
    apply quotient.exact' h },
  { rintros ⟨x⟩,
    obtain ⟨x,rfl⟩ := hf' x,
    use discrete_quotient.proj _ x, refl }
end

lemma comap_mem_fibre_iff {X Y : Type*} [topological_space X] [topological_space Y]
  (f : X → Y) (hf : continuous f)
  (T : discrete_quotient Y) (a : T.comap hf) (b : X) :
  b ∈ discrete_quotient.fibre (T.comap hf) a ↔
  f b ∈ discrete_quotient.fibre T (discrete_quotient.map (le_refl _) a) :=
begin
  dsimp [fibre],
  change b ∈ (T.comap hf).proj ⁻¹' {a} ↔
    f b ∈ T.proj ⁻¹' {_},
  obtain ⟨a,rfl⟩ := discrete_quotient.proj_surjective _ a,
  simp only [set.mem_preimage, set.mem_singleton_iff, map_proj_apply],
  split,
  { intros h, apply quotient.sound', apply quotient.exact' h, },
  { intros h, apply quotient.sound', apply quotient.exact' h, },
end

end discrete_quotient

lemma locally_constant.sum_apply {ι X Y : Type*} [topological_space X] [add_comm_monoid Y]
  (f : ι → locally_constant X Y) (S : finset ι) (t : X) :
  (∑ i in S, f i) t = ∑ i in S, (f i t) :=
begin
  let ee : locally_constant X Y →+ X → Y := locally_constant.coe_fn_add_monoid_hom,
  change (ee (∑ i in S, f i)) t = ∑ i in S, (ee (f i) t),
  rw [ee.map_sum, finset.sum_apply],
end

lemma locally_constant.eq_sum {X : Type*} [topological_space X] [compact_space X]
  (e : locally_constant X ℝ) :
  e = ∑ t : e.discrete_quotient,
    e.locally_constant_lift t • (e.discrete_quotient.fibre t).indicator_LC :=
begin
  ext t,
  simp_rw [locally_constant.sum_apply, locally_constant.smul_apply],
  suffices :
    ∑ (x : ↥(e.discrete_quotient)),
      (e.locally_constant_lift) x • ((e.discrete_quotient.fibre x).indicator_LC) t =
    ∑ x in { e.discrete_quotient.proj t },
      (e.locally_constant_lift) x • ((e.discrete_quotient.fibre x).indicator_LC) t,
  { simp_rw [this, algebra.id.smul_eq_mul, finset.sum_singleton],
    convert (mul_one _).symm,
    rw [topological_space.clopens.indicator_LC_apply, if_pos],
    change e.discrete_quotient.proj t ∈ _, simp, -- clopens is missing some `mem_mk` lemma...
  },
  symmetry,
  apply finset.sum_subset, simp only [finset.subset_univ],
  intros s _ ht,
  convert smul_zero _,
  rw [topological_space.clopens.indicator_LC_apply, if_neg],
  contrapose! ht,
  change e.discrete_quotient.proj t ∈ _ at ht,
  exact finset.mem_singleton.mpr (set.mem_singleton_iff.mp ht).symm,
end

/--  Given a point `x : X` is a discrete topological space `X`,
`topological_space.clopens.singleton x` is the point `x`, bundled as a clopen subset of `X`. -/
def topological_space.clopens.singleton {X : Type*}
  [topological_space X] [discrete_topology X] (x : X) :
  clopens X :=
{ carrier := {x},
  clopen' := is_clopen_discrete {x} }

lemma locally_constant.eq_sum_of_fintype {X : Type*} [fintype X]
  [topological_space X] [discrete_topology X]
  (e : locally_constant X ℝ) :
  e =
  ∑ t : X, e t • (topological_space.clopens.singleton t).indicator_LC :=
begin
  ext t,
  rw locally_constant.sum_apply,
  rw finset.sum_eq_single t,
  { change _ = _ • ite _ _ _,
    rw [if_pos, smul_eq_mul], erw mul_one,
    change _ = _, refl },
  { intros x _ hx,
    change _ • ite _ _ _ = _,
    rw [if_neg, smul_zero], change _ ≠ _, exact hx.symm },
  { intros h, exfalso, apply h, exact finset.mem_univ _ }
end

/--  Given a continuous function `f : X → Y` between topological spaces `X` and `Y`,
`continuous_map.comap f` is the `ℝ`-linear pre-composition with `f` as a function from
the `ℝ`-valued continuous functions on `Y` to the `ℝ`-valued continuous functions on `X`. -/
def continuous_map.comap {X Y : Type*} [topological_space X] [topological_space Y]
  (f : C(X,Y)) : C(Y,ℝ) →L[ℝ] C(X,ℝ) :=
{ to_fun := λ g, g.comp f,
  map_add' := λ _ _, rfl,
  map_smul' := λ _ _, rfl,
  cont := by refine continuous_map.continuous_comp_left f }

/--  Given a continuous function `f : X → Y` between topological spaces `X` and `Y`,
`continuous_map.comap_LC_linear_map f` is the `ℝ`-linear pre-composition with `f` as a function from
the locally constant `ℝ`-valued continuous functions on `Y` to the locally constant `ℝ`-valued
continuous functions on `X`.

`continuous_map.comap_LC` is similar, except that it also bundles continuity of the resulting
function among spaces of continuous maps. -/
def continuous_map.comap_LC_linear_map {X Y : Type*} [topological_space X] [topological_space Y]
  (f : C(X,Y)) : locally_constant Y ℝ →ₗ[ℝ] locally_constant X ℝ :=
{ to_fun := λ g,
  { to_fun := g ∘ f,
    is_locally_constant := λ S,
      by { rw set.preimage_comp, apply is_open.preimage f.2, apply g.2, } },
  map_add' := λ _ _, rfl,
  map_smul' := λ _ _, rfl }

/--  Given a continuous function `f : X → Y` between topological spaces `X` and `Y`,
`continuous_map.comap_LC_linear_map f` is the `ℝ`-linear pre-composition with `f` as a *continuous*
function from the locally constant `ℝ`-valued continuous functions on `Y` to the locally constant
`ℝ`-valued continuous functions on `X`.

`continuous_map.comap_LC_linear_map` is similar, but does not bundle continuity of the resulting
function among spaces of continuous maps. -/
def continuous_map.comap_LC {X Y : Type*} [topological_space X] [compact_space X]
  [topological_space Y] [compact_space Y]
  (f : C(X,Y)) : locally_constant Y ℝ →L[ℝ] locally_constant X ℝ :=
{ to_fun := λ g,
  { to_fun := g ∘ f,
    is_locally_constant := λ S,
      by { rw set.preimage_comp, apply is_open.preimage f.2, apply g.2, } },
  map_add' := λ _ _, rfl,
  map_smul' := λ _ _, rfl,
  cont := begin
    apply (f.comap_LC_linear_map.mk_continuous_of_exists_bound _).continuous,
    use 1, intros e, rw one_mul,
    by_cases (is_empty X),
    { have : (f.comap_LC_linear_map) e = 0, ext x, exact h.elim x, rw this,
      simp },
    change Sup _ ≤ _,
    apply cSup_le,
    simp only [not_is_empty_iff] at h, obtain ⟨x⟩ := h,
    use ∥ e (f x) ∥, use x, refl,
    rintros b ⟨x,rfl⟩, dsimp,
    exact_mod_cast locally_constant.nnnorm_apply_le_nnnorm _ e (f x),
  end }

/--  Given a compact topological space `X`, the inclusion of locally constant functions on `X` into
the space of all continuous functions is a continuous `ℝ`-linear map. -/
def lc_to_c (X : Type*) [topological_space X] [compact_space X] :
  locally_constant X ℝ →L[ℝ] C(X,ℝ) :=
{ to_fun := λ f, f.to_continuous_map,
  map_add' := λ _ _, rfl,
  map_smul' := λ _ _, rfl,
  cont := begin
    apply isometry.continuous,
    intros f g,
    simp only [edist_dist, dist_eq_norm, continuous_map.norm_eq_supr_norm,
      locally_constant.norm_def, locally_constant.to_continuous_map_eq_coe,
      continuous_map.coe_sub, locally_constant.coe_continuous_map, pi.sub_apply],
    refl,
  end }

namespace weak_dual

/--  Given topological `ℝ`-vector spaces `A` and `B` and a continuous, `ℝ`-linear map `f : A → B`
between them, `comap f` is the pre-composition with `f` as a continuous, `ℝ`-linear map between
the weak `ℝ`-linear dual of `B` to the weak `ℝ`-linear dual of `A`. -/
def comap {A B : Type*}
  [add_comm_group A] [module ℝ A] [topological_space A]
  [add_comm_group B] [module ℝ B] [topological_space B]
  (f : A →L[ℝ] B) :
  weak_dual ℝ B →L[ℝ] weak_dual ℝ A :=
{ to_fun := λ g, g.comp f,
  map_add' := λ _ _, rfl,
  map_smul' := λ _ _, rfl,
  cont := begin
    apply weak_dual.continuous_of_continuous_eval,
    intros a,
    apply weak_dual.eval_continuous,
  end }

/--  Given a compact topological space `X`, an element `μ` in the weak, `ℝ`-linear dual of the
continuous functions on `X`, and two non-negative real numbers `p` and `c`, `bdd μ p c` is the
statement that the sum of the `p`-th powers of the absolute values of the measures of all the
clopen subsets of `X` is bounded above by `c`.

See the actual definition for what "all the clopen subsets" really means!

`bdd_LC` is similar, but uses the dual of locally constant functions.  -/
def bdd {X : Type*} [topological_space X] [compact_space X]
  (μ : weak_dual ℝ C(X,ℝ)) (p c : ℝ≥0) : Prop :=
∀ (T : discrete_quotient X),
  ∑ t : T, ∥ μ (T.fibre t).indicator ∥₊^(p : ℝ) ≤ c

/--  Given a compact topological space `X`, an element `μ` in the weak, `ℝ`-linear dual of the
locally constant functions on `X`, and two non-negative real numbers `p` and `c`, `bdd μ p c` is the
statement that the sum of the `p`-th powers of the absolute values of the measures of all the
clopen subsets of `X` is bounded above by `c`.

See the actual definition for what "all the clopen subsets" really means!

`bdd` is similar, but uses the dual of continuous functions.  -/
def bdd_LC {X : Type*} [topological_space X] [compact_space X]
  (μ : weak_dual ℝ (locally_constant X ℝ)) (p c : ℝ≥0) : Prop :=
∀ (T : discrete_quotient X),
  ∑ t : T, ∥ μ (T.fibre t).indicator_LC ∥₊^(p : ℝ) ≤ c

lemma bdd_LC_comap {X Y : Type*} {p c : ℝ≥0} [fact (0 < p)]
  [topological_space X] [compact_space X]
  [topological_space Y] [compact_space Y]
  (μ : weak_dual ℝ (locally_constant X ℝ)) (hμ : μ.bdd_LC p c) (f : C(X,Y)) :
  (weak_dual.comap f.comap_LC μ).bdd_LC p c :=
begin
  intros T,
  convert hμ (T.comap f.2) using 1,
  let ι : T.comap f.2 → T := discrete_quotient.map (le_refl _),
  have hι : function.injective ι,
  { rintros ⟨⟩ ⟨⟩ h,
    apply quotient.sound',
    apply quotient.exact' h },
  let S₁ := _, change S₁ = _,
  have : S₁ = ∑ t in finset.univ.image ι,
    ∥ ((comap f.comap_LC) μ) (T.fibre t).indicator_LC ∥₊ ^ (p : ℝ),
  { symmetry, apply finset.sum_subset, simp only [finset.subset_univ],
    intros x _ hx,
    --simp only [finset.mem_image, finset.mem_univ, exists_true_left, not_exists] at hx,
    suffices : ((comap f.comap_LC) μ) (T.fibre x).indicator_LC = 0,
    { simp only [this, nnnorm_zero, nnreal.rpow_eq_zero_iff, eq_self_iff_true,
        ne.def, nnreal.coe_eq_zero, true_and],
      exact ne_of_gt (fact.out (0 < p)) },
    -- the `change` below is faster than `dsimp [comap]`
    change μ ((f.comap_LC) (T.fibre x).indicator_LC) = 0,
    convert μ.map_zero,
    refine locally_constant.ext (λ t, _),
    dsimp only [continuous_map.comap_LC, topological_space.clopens.indicator_LC_apply],
    apply if_neg,
    contrapose! hx,
    rw finset.mem_image,
    refine ⟨discrete_quotient.proj _ t, finset.mem_univ _, hx⟩ },
  rw this, clear this, symmetry,
  fapply finset.sum_bij,
  { intros a _, exact ι a },
  { intros, dsimp, erw finset.mem_image, refine ⟨a, finset.mem_univ _, rfl⟩ },
  { intros a ha,
    congrm ∥ μ ⟨(λ t, ite _ _ _), _⟩ ∥₊ ^ ↑p,
    rw [set_like.mem_coe, set_like.mem_coe, ← discrete_quotient.comap_mem_fibre_iff] },
  { intros a₁ a₂ h₁ h₂ hh, apply hι, exact hh },
  { rintros b hb,
    rw finset.mem_image at hb,
    obtain ⟨b,hh,hb⟩ := hb,
    use [b,hh,hb.symm] },
end

lemma bdd_comap {X Y : Type*} {p c : ℝ≥0} [fact (0 < p)]
  [topological_space X] [compact_space X]
  [topological_space Y] [compact_space Y]
  (μ : weak_dual ℝ C(X,ℝ)) (hμ : μ.bdd p c) (f : C(X,Y)) :
  (weak_dual.comap f.comap μ).bdd p c :=
λ t, by apply bdd_LC_comap (comap (lc_to_c X) μ) hμ f t

lemma bdd_iff_indexed_parition (S : Profinite.{0}) (μ : weak_dual ℝ C(S,ℝ)) (p c : ℝ≥0) :
  μ.bdd p c ↔
  ∀ (ι : Fintype.{0}) (e : ι → set S)
    (I : indexed_partition e) (he : ∀ i, is_clopen (e i)),
    ∑ i : ι, ∥ μ.1 (topological_space.clopens.indicator ⟨e i, he i⟩) ∥₊^(p : ℝ) ≤ c :=
begin
  split,
  { intros hμ ι e I he,
    let T : discrete_quotient S := indexed_partition.discrete_quotient I he,
    let ee : ι ≃ T := indexed_partition.discrete_quotient_equiv he I,
    specialize hμ T,
    convert hμ using 1,
    fapply finset.sum_bij',
    { intros i _, exact ee i, },
    { intros, exact finset.mem_univ _ },
    { intros a ha, congr' 4,
      ext1, change _ = T.proj ⁻¹' _,
      rw indexed_partition.discrete_quotient_fiber,
      erw ee.symm_apply_apply,
      refl },
    { intros t ht, exact ee.symm t },
    { intros, exact finset.mem_univ _ },
    { intros, exact ee.symm_apply_apply _ },
    { intros, exact ee.apply_symm_apply _ } },
  { intros hμ T,
    refine hμ (Fintype.of T) (λ t, T.proj ⁻¹' {t}) _ (λ t, (T.fibre t).2),
    fapply indexed_partition.mk',
    { intros i j hij a ha, simp only [set.bot_eq_empty, set.mem_empty_iff_false], apply hij,
      simp only [set.inf_eq_inter, set.mem_inter_iff, set.mem_preimage,
        set.mem_singleton_iff] at ha,
      rw [← ha.1, ha.2] },
    { rintros (t : T), obtain ⟨t,rfl⟩ := T.proj_surjective t, use t, change _ = _, refl, },
    { intros s, use T.proj s, change _ = _, refl } }
end

end weak_dual


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

universes u_1

namespace Mathlib

theorem punit_eq (a : PUnit) (b : PUnit) : a = b :=
  punit.rec_on a (punit.rec_on b rfl)

theorem punit_eq_star (a : PUnit) : a = PUnit.unit :=
  punit_eq a PUnit.unit

protected instance punit.subsingleton : subsingleton PUnit :=
  subsingleton.intro punit_eq

protected instance punit.inhabited : Inhabited PUnit :=
  { default := PUnit.unit }

protected instance punit.decidable_eq : DecidableEq PUnit :=
  fun (a b : PUnit) => is_true (punit_eq a b)


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

Functors with two arguments
-/
import logic.function.basic
import control.functor
import tactic.core

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

open function

class bifunctor (F : Type u₀ → Type u₁ → Type u₂) :=
(bimap : Π {α α' β β'}, (α → α') → (β → β') → F α β → F α' β')
export bifunctor ( bimap )

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

@[reducible]
def fst {α α' β} (f : α → α') : F α β → F α' β :=
bimap f id

@[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 for_mathlib.derived.les_facts

noncomputable theory

universes v u

open category_theory category_theory.limits

namespace bounded_homotopy_category

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐] [enough_projectives 𝓐]

lemma Ext_map_is_iso_of_quasi_iso
  (A₁ A₂ B : bounded_homotopy_category 𝓐) (f : A₁ ⟶ A₂)
  [homotopy_category.is_quasi_iso f] (i : ℤ) :
  is_iso $ ((Ext i).map f.op).app B :=
begin
  let e := replacement_iso A₁.replace A₂.replace A₂ (A₁.π ≫ f) A₂.π,
  let e' := ((preadditive_yoneda.obj (B⟦i⟧)).map_iso e.op),
  show is_iso e'.hom,
  apply_instance
end

end bounded_homotopy_category