import data.int.interval
import data.finset.nat_antidiagonal
import laurent_measures.aux_lemmas
import laurent_measures.basic
import laurent_measures.theta
import linear_algebra.basic
import order.filter.at_top_bot tactic.linarith
import for_mathlib.nnreal

/-!
This file introduces the maps
* `θ`, which is the specialization of evaluation-at-ξ map `ϑ` from `laurent_measures.theta`
  at `ξ=2⁻¹`.
* `ϕ` which corresponds to multiplying a Laurent series in `ℒ S = (laurent_measures r S)`
  for `r = 2^(1/p)` by `T⁻¹-2`.
* `ψ` corresponds to dividing a Laurent series by `(T⁻¹-2)`. It is defined only on series
  vanishing at `2⁻¹`, so that it again takes values in `ℒ S`
* The maps `Θ`, `Φ` and `Ψ` are the "measurifications" of `θ`, `ϕ` and `ψ`,
  so they are morphisms in the right category (**[FAE]** Not here any more!)

The main results are
* `injective_ϕ` stating that `ϕ` is injective;
* `θ_ϕ_complex` stating that `ϕ ∘ θ = 0`; and
* `θ_ϕ_exact` stating that the kernel of `θ` coincides with the image of `ϕ`.
Together with `ϑ_surjective` from `laurent_measures.theta` (specialized at `ξ=2⁻¹`, so that `ϑ` is
`θ`) this is the statement of Theorem 6.9 of `Analytic.pdf` of interest to us, although only "on
elements" and not yet as a Short Exact Sequence in the right category.
-/

noncomputable theory

open nnreal theta laurent_measures aux_thm69 finset
open_locale nnreal classical big_operators topological_space

section phi

parameter {r : ℝ≥0}

local notation `ℒ` := laurent_measures r
variables [fact (0 < r)]
variable {S : Fintype}

def ϕ : ℒ S → ℒ S :=
λ F, shift (1) F - 2 • F

lemma ϕ_apply (F : ℒ S) (s : S) (n : ℤ) : ϕ F s n = F s (n+1) - 2 * F s n :=
by simp only [ϕ, sub_apply, nsmul_apply, shift_to_fun_to_fun, nsmul_eq_mul]; refl

lemma ϕ_natural (S T : Fintype) (f : S ⟶ T) : --[fact (0 < p)] [fact ( p ≤ 1)] :
  ϕ ∘ laurent_measures.map_hom f = laurent_measures.map_hom f ∘ ϕ :=
begin
  ext F t n,
  simp only [ϕ, sum_sub_distrib, mul_sum, function.comp_app, map_hom_to_fun, sub_apply,
    nsmul_apply, shift_to_fun_to_fun,
    map_apply, nsmul_eq_mul, mul_ite, mul_zero], -- squeezed for time
end

-- #check @ϕ

-- lemma tsum_reindex (F : ℒ S) (N : ℤ) (s : S) : ∑' (l : ℕ), (F s (N + l) : ℝ) * (2 ^ l)⁻¹ =
--  2 ^ N * ∑' (m : {m : ℤ // N ≤ m}), (F s m : ℝ) * (2 ^ m.1)⁻¹ :=
-- begin
--   have h_shift := int_tsum_shift (λ n, (F s n : ℝ) * (2 ^ (-n))) N,
--   simp only at h_shift,
--   simp_rw [subtype.val_eq_coe, ← zpow_neg],
--   rw [← h_shift, ← _root_.tsum_mul_left, tsum_congr],
--   intro n,
--   rw [mul_comm (_ ^ N), mul_assoc, ← (zpow_add₀ (@two_ne_zero ℝ _ _)), neg_add_rev,
--     neg_add_cancel_comm, zpow_neg, zpow_coe_nat, add_comm],
-- end

variable [fact (r < 1)]

lemma injective_ϕ (F : ℒ S) (H : ϕ F = 0) : F = 0 :=
begin
  dsimp only [ϕ] at H, rw [sub_eq_zero] at H,
  replace H : ∀ n : ℤ, ∀ s : S, 2 * F s (n - 1) = F s n,
  { intros n s,
    rw laurent_measures.ext_iff at H,
    convert (H s (n-1)).symm using 1,
    { rw [two_smul, two_mul], refl, },
    { simp [shift] } },
  ext s n,
  apply int.induction_on' n (F.d - 1),
  { refine lt_d_eq_zero _ _ (F.d - 1) _,
    simp only [sub_lt_self_iff, zero_lt_one], },
  { intros k h hk₀,
    simp [← H (k + 1) s, add_sub_cancel, hk₀, mul_zero] },
  { intros k h hk₀,
    simpa only [hk₀, mul_eq_zero, bit0_eq_zero, one_ne_zero, false_or, zero_apply] using H k s }
end

lemma injective_ϕ' : function.injective (ϕ : ℒ S → ℒ S) :=
begin
  let PHI : comphaus_filtered_pseudo_normed_group_hom (ℒ S) (ℒ S) :=
    shift (1) - 2 • comphaus_filtered_pseudo_normed_group_hom.id,
  apply (injective_iff_map_eq_zero (PHI.to_add_monoid_hom)).mpr,
  exact injective_ϕ
end

end phi

section mem_exact

parameter {p : ℝ≥0}

/-- `r`, or `r(p)`, is `2⁻ᵖ`. -/
def r : ℝ≥0 := 2⁻¹ ^ (p : ℝ)

lemma r_pos : 0 < r :=
suffices 0 < (2 : ℝ≥0)⁻¹ ^ (p : ℝ), by simpa [r],
rpow_pos (nnreal.inv_pos.mpr zero_lt_two)

instance r_pos' : fact (0 < r) := ⟨r_pos⟩

lemma r_coe : (2⁻¹ : ℝ) ^ (p : ℝ) = r :=
begin
  have : (2⁻¹ : ℝ) = ((2⁻¹ : ℝ≥0) : ℝ),
  simp only [one_div, nonneg.coe_inv, nnreal.coe_bit0, nonneg.coe_one],
  rw [this, ← nnreal.coe_rpow, nnreal.coe_eq],
  refl,
end

variable [fact(0 < p)]

lemma r_lt_one : r < 1 :=
begin
  refine rpow_lt_one nnreal.two_inv_lt_one _,
  rw nnreal.coe_pos,
  exact fact.out _
end

instance r_lt_one' : fact (r < 1) := ⟨r_lt_one⟩

variable {S : Fintype}

local notation `ℒ` := laurent_measures r
local notation `ℳ` := real_measures p

theorem nnreal.rpow_int_cast (x : nnreal) (n : ℤ) : x ^ (n : ℝ) = x ^ n :=
begin
  apply subtype.ext,
  simp,
end

def θ : ℒ S → ℳ S := ϑ 2⁻¹ r p S

lemma θ_natural [fact (0 < p)] [fact (p ≤ 1)] (S T : Fintype) (f : S ⟶ T) (F : ℒ S) (t : T) :
  θ (map f F) t = real_measures.map f (θ F) t :=
begin
  simp only [θ, ϑ, one_div, map_apply, int.cast_sum, inv_zpow', zpow_neg, real_measures.map_apply],
  rw ← tsum_sum,
  { congr', ext n, exact sum_mul, },
  intros,
  rw mem_filter at H,
  rcases H with ⟨-, rfl⟩,
  have := F.summable i,
  refine summable.add_compl (_ : summable (_ ∘ (coe : {n : ℤ | 0 ≤ n} → ℤ))) _,
  { have moo := summable.comp_injective this
      (subtype.coe_injective : function.injective (coe : {n : ℤ | 0 ≤ n} → ℤ)),
    refine summable_of_norm_bounded _ (moo) _, clear moo this,
    rintro ⟨n, (hn : 0 ≤ n)⟩,
    simp only [function.comp_app, subtype.coe_mk, norm_mul, norm_inv, norm_zpow, real.norm_two],
    rw (F i n).norm_cast_real,
    apply mul_le_mul_of_nonneg_left _ (norm_nonneg _),
    delta r,
    delta r,
    rw (by push_cast : ((2 : ℝ) ^ n)⁻¹ = ((2 ^ n)⁻¹ : nnreal)),
    norm_cast,
    rw [← nnreal.rpow_int_cast, ← inv_rpow],
    rw nnreal.rpow_int_cast,
    set m := n.nat_abs with hm,
    have hmn : n = m := by { rw hm, exact int.eq_nat_abs_of_zero_le hn },
    rw hmn,
    norm_cast,
    apply pow_le_pow_of_le_left', clear hn hmn hm m n,
    apply nnreal.le_self_rpow' (nnreal.two_inv_lt_one.le),
    norm_cast,
    exact fact.out _,
  },
  {
    obtain ⟨d, hd⟩ := exists_bdd_filtration (r_pos) (r_lt_one) F,
    apply summable_of_ne_finset_zero, -- missing finset
    swap, exact (finset.subtype _ (finset.Ico d 0)),
    rintros ⟨z, (hz : ¬ (0 ≤ z))⟩ hz2,
    simp only [subtype.coe_mk, mul_eq_zero, int.cast_eq_zero, inv_eq_zero],
    left,
    apply hd,
    simp only [mem_subtype, subtype.coe_mk, mem_Ico, not_and, not_le] at hz2,
    by_contra h,
    push_neg at h,
    apply hz,
    specialize hz2 h,
    push_neg at hz2,
    exact hz2 },
end

variables [fact (p < 1)]

lemma half_lt_r : 2⁻¹ < r :=
calc (2⁻¹:ℝ≥0)
    = 2⁻¹ ^ (1:ℝ) : (rpow_one (2⁻¹:ℝ≥0)).symm
... < r : rpow_lt_rpow_of_exponent_gt (begin rw nnreal.inv_pos, norm_num, end)
  (begin apply nnreal.inv_lt_one, norm_num end) $
(nnreal.coe_lt_coe.mpr (fact.out _)).trans_le (nnreal.coe_one).le

lemma one_lt_two_r : 1 < 2 * r :=
begin
  have := half_lt_r,
  have this2 : (2⁻¹ : ℝ) < r,
    assumption_mod_cast,
  rw inv_pos_lt_iff_one_lt_mul' at this2, assumption_mod_cast,
  norm_num,
end

lemma r_inv_lt_2 : r⁻¹ < 2 :=
begin
  rw ← inv_inv (2 : ℝ≥0),
  exact nnreal.inv_lt_inv (by norm_num) half_lt_r,
end

lemma laurent_measures.summable_half (F : ℒ S) (s : S) :
  summable (λ n, ((F s n) : ℝ) * 2⁻¹ ^ n) :=
aux_thm69.summable_smaller_radius F.d (F.summable s) (λ n hn, lt_d_eq_zero _ _ _ hn) half_lt_r

lemma θ_ϕ_complex (F : ℒ S) : (θ ∘ ϕ) F = 0 :=
begin
  have t0 : (2 : ℝ)⁻¹ ≠ 0 := inv_ne_zero two_ne_zero,
  funext s,
  convert_to ∑' (n : ℤ), ((F s (n + 1) - 2 * F s n) : ℝ) * 2⁻¹ ^ n = 0,
  { apply tsum_congr,
    intro b,
    field_simp [ϕ] },
  simp_rw [sub_mul],
  rw [tsum_sub, sub_eq_zero],
  -- old proof was slicker :-(
  { refine tsum_eq_tsum_of_ne_zero_bij (λ i, (i.val : ℤ) - 1) _ _ _,
    { rintros ⟨x, _⟩ ⟨y, _⟩ h, dsimp at *, linarith },
    { rintros x hx,
      refine ⟨⟨x + 1, _⟩, _⟩,
      { rw function.mem_support at ⊢ hx,
        convert hx using 1,
        simp [zpow_add₀],
        ring },
      { simp } },
    { rintro ⟨i, hi⟩,
      simp [zpow_sub₀],
      ring } },
  { rw ← (equiv.add_group_add (-1 : ℤ)).summable_iff,
    simp only [function.comp, one_div, inv_zpow', equiv.add_group_add_apply,
      neg_add_cancel_comm],
    convert summable.mul_right 2 (F.summable_half s),
    ext x,
    simp [zpow_add₀], ring },
  { simp_rw [mul_assoc],
    convert (F.summable_half s).mul_left 2 },
end
.

/-!

### Definition of ψ

This involves dividing by T⁻¹ - 2 and we have to check that this process converges.
The proof below is pretty icky. It's "do some trivial rearrangements and it boils
down to the fact that you can interchange the order of summation in a ℝ≥0-valued
sum of sums"

-/

lemma nnreal.summable_mul_left_iff {X : Type*} {f : X → ℝ≥0} {a : ℝ≥0} (ha : a ≠ 0) :
summable f ↔ summable (λ (x : X), a * f x) :=
begin
  rw [← nnreal.summable_coe, ← nnreal.summable_coe],
  rw summable_mul_left_iff (by exact_mod_cast ha : (a : ℝ) ≠ 0),
  apply summable_congr,
  intro b,
  norm_cast,
end

lemma psi_def_summable {S : Fintype} (n : ℕ)
  (F : ℒ S)
  (s : S) :
  summable
    (λ (k : ℕ),
       r ^ (F.d + ↑n) *
         (2⁻¹ ^ (k : ℤ) * ∥F s (F.d + ↑n + ↑k)∥₊)) :=
begin
  have := F.summable_half s,
  apply summable.mul_left,
  have h : (2⁻¹ : ℝ≥0) ≠ 0 := by norm_num,
  rw nnreal.summable_mul_left_iff (show ((2⁻¹ : ℝ≥0) ^ (F.d + n) ≠ 0), from zpow_ne_zero _ h),
  simp only [← mul_assoc, ← zpow_add₀ h],
  have this2 := lt_d_eq_zero F s,
  rw ← summable_norm_iff at this,
  simp_rw ← _root_.coe_nnnorm at this,
  rw summable_coe at this,
  rw nnreal.summable_iff_on_nat_less_shift F.d _ (F.d + n) at this,
  { convert this,
    ext1 k,
    rw mul_comm,
    simp only [inv_zpow', neg_add_rev, nnnorm_mul, nnnorm_zpow, real.nnnorm_two],
    congr' },
  { intros n hn,
    simp [this2 n hn] },
end

lemma psi_def_summable2 {S : Fintype}
  [fact (0 < p)]
  [fact (p < 1)]
  (F : ℒ S)
  (s : ↥S) :
  ∀ (k : ℕ),
    summable
      (λ (n : ℕ),
         r ^ (F.d + ↑n) *
           ((2⁻¹ : ℝ≥0) ^ (k : ℤ) * ∥F s (F.d + ↑n + ↑k)∥₊)) :=
begin
  intro k,
  have hhalf : (2⁻¹ : ℝ≥0) ≠ 0, by norm_num,
  have hhalf' : (2⁻¹ : ℝ≥0) ≠ 0, by norm_num,
  have hr : r ≠ 0 := r_pos.ne.symm,
  rw nnreal.summable_mul_left_iff
    (show (2⁻¹ : ℝ≥0) ^ (-(k : ℤ)) * r ^ (k : ℤ) ≠ 0, from mul_ne_zero (zpow_ne_zero _ hhalf') (zpow_ne_zero _ hr)),
  have : ∀ x : ℕ, 2⁻¹ ^ -(k : ℤ) * r ^ (k : ℤ) * (r ^ (F.d + ↑x) * (2⁻¹ ^ (k : ℤ) * ∥F s (F.d + ↑x + ↑k)∥₊))
    = r ^ (F.d + x + k) * ∥F s (F.d + ↑x + ↑k)∥₊,
  { intro x,
    rw (show (2⁻¹ : ℝ≥0) ^ -(k : ℤ) * r ^ (k : ℤ) * (r ^ (F.d + ↑x) * (2⁻¹ ^ (k : ℤ) * ∥F s (F.d + ↑x + ↑k)∥₊))
      = (2⁻¹ : ℝ≥0) ^ -(k : ℤ) * 2⁻¹ ^ (k : ℤ) * r ^ (k : ℤ) * r ^ (F.d + ↑x) *  ∥F s (F.d + ↑x + ↑k)∥₊, by ring),
    simp only [zpow_add₀ hr, ← zpow_add₀ hhalf'],
    simp,
    left,
    ring,
    },
  rw summable_congr this, clear this,
  have := F.summable' s,
  rw nnreal.summable_iff_on_nat_less_shift F.d _ (F.d + k) at this,
  { convert this,
    ext n,
    rw [mul_comm, add_right_comm],
    refl },
  { intros n hn,
    convert zero_mul _,
    convert nnnorm_zero,
    exact lt_d_eq_zero F s n hn },
end

lemma psi_def_summable3 {S : Fintype}
  [fact (0 < p)]
  [fact (p < 1)]
  (F : ℒ S)
  (s : ↥S) :
  summable
    (λ (k : ℕ),
       ∑' (n : ℕ),
         r ^ (F.d + ↑n) *
           (2⁻¹ ^ (k : ℤ) * ∥F s (F.d + ↑n + ↑k)∥₊)) :=
begin
  -- take 2⁻¹^k out the tsum,
  -- put r^k into the tsum,
  -- bounded by sum of GP,
  have bdd : ∀ k : ℕ, ∑' (n : ℕ),
         r ^ (F.d + ↑n + k) * ∥F s (F.d + ↑n + ↑k)∥₊ ≤
           ∑' (t : ℤ),
         r ^ t * ∥F s t∥₊,
  { intro k,
    simp_rw add_right_comm,
    have hinj : function.injective (λ (m : ℕ), F.d + k + m),
    { rintros a b (h2 : F.d + k + a = F.d + k + b),
      simpa using h2 },
      refine tsum_le_tsum_of_inj _ hinj _ _ _ _,
      { intros, apply zero_le' },
      { intro, refl },
      { rw ← @nnreal.summable_iff_on_nat_less_shift (λ (z : ℤ), r ^ z * ∥F s z∥₊) F.d _ (F.d + k),
        { convert F.summable' s,
          ext z,
          rw mul_comm,
          refl },
        { intros n hn,
          simp [lt_d_eq_zero F s n hn] } },
      { convert F.summable' s,
        ext z,
        rw mul_comm,
        refl } },
  have : ∀ k : ℕ, ∑' (n : ℕ), r ^ (F.d + ↑n) * (2⁻¹ ^ (k : ℤ) * ∥F s (F.d + ↑n + ↑k)∥₊) =
   (∑' (n : ℕ), r ^ (F.d + ↑n + k) * (∥F s (F.d + ↑n + ↑k)∥₊)) * (2⁻¹ * r⁻¹) ^ (k : ℤ),
  { intro k,
    rw ← nnreal.tsum_mul_right,
    apply tsum_congr,
    intro n,
    simp only [zpow_add₀ r_pos.ne.symm, zpow_coe_nat, one_div, inv_pow, div_zpow],
    have foo : (2 * r) ^ k ≠ 0,
    { apply pow_ne_zero, apply mul_ne_zero,
      { norm_num },
      { exact r_pos.ne.symm },

    },
    field_simp [foo],
    rw mul_pow,
    ring, },
  rw summable_congr this, clear this,
  suffices : summable (λ k : ℕ, (∑' (t : ℤ), r ^ t * ∥F s t∥₊) * (2⁻¹ * r⁻¹) ^ k),
  { refine summable_of_le _ this,
    intro k,
    rw zpow_coe_nat,
    apply nnreal.mul_le_mul_right (bdd k),
  },
  apply summable.mul_left,
  apply summable_geometric,
  exact div_lt_one_of_lt half_lt_r,
end

lemma psi_def_aux_4 {S : Fintype} [fact (0 < p)] [fact (p < 1)] (F : ℒ S) (s : ↥S) : summable
  (λ (m : ℕ),
     ∥(2 : ℝ) ^ (F.d + ↑m)∥₊ *
       ((∑' (k : ℕ), ∥F s (F.d + ↑m + ↑k)∥₊ * 2⁻¹ ^ (F.d + ↑m + ↑k)) * r ^ (F.d + ↑m))) :=
begin
  -- tidy up
  simp_rw [nnnorm_zpow, real.nnnorm_two],
  have : ∀ m : ℕ, (2 : ℝ≥0) ^ (F.d + ↑m) *
  ((∑' (k : ℕ), ∥F s (F.d + ↑m + ↑k)∥₊ * 2⁻¹ ^ (F.d + ↑m + ↑k)) * r ^ (F.d + ↑m)) =
  ∑' (k : ℕ), (2 : ℝ≥0) ^ (F.d + ↑m) * ∥F s (F.d + ↑m + ↑k)∥₊ * 2⁻¹ ^ (F.d + ↑m + ↑k) * r ^ (F.d + ↑m),
  { intro m,
    rw [← nnreal.tsum_mul_right, ← nnreal.tsum_mul_left],
    apply tsum_congr,
    intro b,
    ring },
  rw summable_congr this, clear this,
  -- TODO : maybe now is the time to tidy up a bit (e.g. cancel the 2^x and 2⁻¹^x)
  suffices : summable
  (λ (m : ℕ), ∑' (k : ℕ),
       ∥F s (F.d + ↑m + ↑k)∥₊ *
       2⁻¹ ^ (k : ℤ) * r ^ (F.d + ↑m)),
  { refine (summable_congr _).2 this,
    intro m,
    apply tsum_congr,
    intro b,
    rw [inv_zpow , inv_zpow],
    rw [← zpow_neg, ←zpow_neg],
    have h2 : (2 : ℝ≥0) ≠ 0 := two_ne_zero,
    simp only [zpow_add₀, ne.def, bit0_eq_zero, one_ne_zero, not_false_iff, zpow_coe_nat, neg_add_rev, zpow_neg,
  mul_eq_mul_right_iff],
    field_simp [zpow_ne_zero _ h2], left,
    ring,
  },
  simp_rw [mul_comm],
  -- change order of summation
  apply nnreal.summable_symm,
  -- check various things are summable
  have := F.summable_half s,
  { intro n,
    apply psi_def_summable },
  { apply psi_def_summable2 },
  -- sum is then bounded above by a GP.
  { apply psi_def_summable3, },
end

lemma psi_def_aux_3 {S : Fintype} [fact (0 < p)] [fact (p < 1)] (F : ℒ S) (s : ↥S) : summable
  (λ (n : ℤ),
     ∥-(2 : ℝ) ^ (n - 1)∥₊ *
       ite (F.d ≤ n) ((∑' (k : ℕ), ∥F s (n + ↑k)∥₊ * 2⁻¹ ^ (n + ↑k)) * r ^ n) 0) :=
begin
  -- get rid of factor of -2⁻¹
  simp_rw [_root_.nnnorm_neg, zpow_sub₀ (two_ne_zero : (2 : ℝ) ≠ 0), nnnorm_div, zpow_one,
    div_eq_mul_inv _ ∥(2 : ℝ)∥₊, mul_comm _ ∥(2 : ℝ)∥₊⁻¹, mul_assoc],
  apply summable.mul_left,
  have hinj : function.injective (λ (m : ℕ), F.d + m),
  { rintros a b (h2 : F.d + a = F.d + b),
    simpa using h2 },
  -- change outer sum to m : ℕ with n : ℤ = F.d + m
  suffices : summable (λ (m : ℕ),
     ∥(2 : ℝ) ^ (F.d + m)∥₊ *
       ((∑' (k : ℕ), ∥F s (F.d + m + ↑k)∥₊ * 2⁻¹ ^ (F.d + m + ↑k)) * r ^ (F.d + m))),
  refine nnreal.summable_of_comp_injective hinj _ _,
  { intros a ha,
    rw [if_neg], simp,
    intro hda, apply ha,
    use (a - F.d).to_nat,
    simp, rw int.to_nat_of_nonneg, ring, linarith },
  { refine (summable_congr _).1 this,
    simp },
  exact psi_def_aux_4 F s,
end

lemma psi_def_aux_2 {S : Fintype} [fact (0 < p)] [fact (p < 1)] (F : ℒ S) (s : ↥S) : summable
  (λ (n : ℤ),
     ite (F.d ≤ n) ∥-(2 : ℝ) ^ (n - 1) * ∑' (k : ℕ), ↑(F s (n + ↑k)) * 2⁻¹ ^ (n + ↑k) * r ^ n∥₊ 0) :=
begin
  simp_rw [nnnorm_mul],
  -- next : put norm inside inner tsum (a one way implication)
  suffices : summable
  (λ (n : ℤ), ∥-(2 : ℝ) ^ (n - 1)∥₊ *
     ite (F.d ≤ n)
     ((∑' (k : ℕ), ∥F s (n + ↑k)∥₊ * 2⁻¹ ^ (n + ↑k)) * r ^ n)
       0),
  refine summable_of_le _ this,
  { intro n,
    split_ifs,
    { simp only [_root_.nnnorm_neg, nnnorm_zpow, real.nnnorm_two, one_div, inv_zpow', neg_add_rev],
      refine mul_le_mul_of_nonneg_left _ _,
      { refine le_trans (nnnorm_tsum_le _) _,
        { clear this, have := F.summable_half s,
          simp_rw nnnorm_mul,
          apply summable.mul_right,
          rw ← summable_norm_iff at this,
          simp_rw ← _root_.coe_nnnorm at this,
          rw nnreal.summable_coe at this,
          have hinj : function.injective (λ (b : ℕ), n + b),
          { rintros a b (h2 : n + a = n + b),
            simpa using h2 },
            convert summable_comp_injective this hinj,
            ext1 k,
            simp [← zpow_neg] },
        { rw ← nnreal.tsum_mul_right,
          apply le_of_eq,
          apply tsum_congr,
          { intro k,
            simp only [nnnorm_mul, nnnorm_zpow, real.nnnorm_two, nnnorm_eq, mul_eq_mul_right_iff],
            left, left,
            congr } } },
      { simp } },
    { simp } },
  exact psi_def_aux_3 _ _,
end

lemma psi_def_aux {S : Fintype} [fact (0 < p)] [fact (p < 1)] (F : ℒ S) (s : ↥S) :
  summable (λ (n : ℤ), ∥ite (F.d ≤ n) (-(2 : ℝ) ^ (n - 1) *
    ∑' (k : ℕ), ↑(F s (n + ↑k)) * 2⁻¹ ^ (n + ↑k)) 0∥₊ * r ^ n) :=
begin
  suffices :  summable (λ (n : ℤ), ite (F.d ≤ n) ∥-(2 : ℝ) ^ (n - 1) *
    ∑' (k : ℕ), ↑(F s (n + ↑k)) * 2⁻¹ ^ (n + ↑k) * r ^ n∥₊ 0),
  refine summable_of_le _ this,
  { intro n,
    split_ifs,
    { apply le_of_eq,
      simp_rw _root_.tsum_mul_right,
      rw [ ← mul_assoc, nnnorm_mul _ ((r : ℝ) ^ n)],
      simp },
    { simp } },
  exact psi_def_aux_2 _ _,
end

def ψ (F : ℒ S) (hF : θ F = 0) : ℒ S :=
{ to_fun := λ s n, if F.d ≤ n then
    ∑ l in range (n - F.d).nat_abs.succ, F s (n - 1 - l) * (2 ^ l)
    else 0,
  summable' := λ s, begin
    -- make everything real
    change summable (λ (n : ℤ),
     ∥((ite (F.d ≤ n)
       (∑ (l : ℕ) in range (n - F.d).nat_abs.succ, F s (n - 1 - ↑l) * 2 ^ l) 0 : ℤ) : ℝ)∥₊
     * r ^ n),
    push_cast,
    -- hypothesis that infinite sum converges at r>2⁻¹
    -- get hypothesis that infinite sum is 0 at 2⁻¹
    simp only [θ, ϑ] at hF,
    replace hF := congr_fun hF s, dsimp at hF,
    -- change sum from ℤ to ℕ
    --rw nnreal.summable_iff_on_nat_less F.d, swap,
    --{ intros n hn, simp [if_neg hn.not_le] },
    have h1 : ∀ (n : ℤ),
      ite (F.d ≤ n) (∑ (l : ℕ) in range (n - F.d).nat_abs.succ, (F s (n - 1 - ↑l) : ℝ) * 2 ^ l) 0 =
      ite (F.d ≤ n) (-(2 : ℝ)^(n-1)*∑' (k : ℕ), F s (n + k) * 2⁻¹ ^ (n + k)) 0,
    { intro n,
      split_ifs with hn, swap, refl,
      rw [← inv_mul_eq_iff_eq_mul₀, ← neg_inv, neg_mul, mul_sum, neg_eq_iff_add_eq_zero, ← hF],
        swap, exact neg_ne_zero.2 (zpow_ne_zero _ two_ne_zero),
      convert @tsum_add_tsum_compl ℝ ℤ _ _ _ _ _ {x : ℤ | x < n}
        (summable.subtype (F.summable_half s) _) (summable.subtype (F.summable_half s) _) using 2,
      { simp_rw [← inv_zpow, mul_comm ((2⁻¹ : ℝ)^(n-1)), mul_assoc],
        simp_rw (show ∀ (x : ℕ), (2 : ℝ)^x = 2⁻¹^(-(x : ℤ)), by {intros, simp}),
        simp_rw [← zpow_add₀ (by norm_num : (2⁻¹ : ℝ) ≠ 0), add_comm, ← sub_eq_add_neg],
        rw ← tsum_eq_sum,
        convert @equiv.tsum_eq ℝ _ _ _ _ _
          (⟨λ m, ⟨n - 1 - m, lt_of_le_of_lt (sub_le_self _ (int.coe_zero_le m)) (sub_one_lt n)⟩,
           (λ z, (n - 1 - z.1).nat_abs), λ m, by simp, λ ⟨z, hz⟩, subtype.ext begin
--             squeeze_simp,
             change n - 1 - (n - 1 - z).nat_abs = z,
             rw ← int.eq_nat_abs_of_zero_le (sub_nonneg_of_le (int.le_sub_one_of_lt hz)),
             ring, end⟩ : ℕ ≃ {z : ℤ // z < n}) _,
        { ext, refl },
        { intros b hb,
          rw mul_eq_zero, left,
          norm_cast,
          apply lt_d_eq_zero,
          by_contra h, push_neg at h, apply hb,
          rw [mem_range, nat.succ_eq_add_one, ← int.coe_nat_lt, int.coe_nat_add,
            ← int.eq_nat_abs_of_zero_le]; linarith } },
      { convert @equiv.tsum_eq ℝ _ _ _ _ _
          (⟨λ x, ⟨n + x, (int.le.intro rfl).not_lt⟩, (λ z, (z.1 - n).nat_abs),
            λ x, by simp, λ ⟨x, hx⟩, subtype.ext begin
              change n + _ = x,
              rw ← int.eq_nat_abs_of_zero_le (sub_nonneg.2 (le_of_not_lt hx)),
              exact add_eq_of_eq_sub' rfl,
            end⟩ : ℕ ≃ {z : ℤ // ¬ z < n}) _,
        ext, refl },
    },
    suffices : summable (λ (n : ℤ),
     ∥ite (F.d ≤ n) (-(2 : ℝ)^(n-1)*∑' (k : ℕ), ↑(F s (n + k)) * 2⁻¹ ^ (n + k)) 0∥₊ *
       r ^ n),
    { refine (summable_congr _).2 this,
      intro n,
      congr' 2,
      apply h1 n,
    }, clear h1,
    clear hF,
    exact psi_def_aux F s,
  end }

theorem θ_ϕ_split_exact (F : ℒ S) (hF : θ F = 0) : ϕ (ψ F hF) = F :=
begin
  ext s n,
  simp only [ϕ, ψ, sub_apply, shift_to_fun_to_fun, laurent_measures.coe_mk, nsmul_apply,
    nsmul_eq_mul, int.coe_nat_succ, int.coe_nat_zero, zero_add],
  split_ifs with h1 h2,
  { rw [sum_range_succ', (by norm_num : (1 : ℤ) + 1 = 2), mul_sum],
    convert add_sub_cancel' _ _,
    { rw [nat.succ_eq_add_one, (by ring : n + 1 - F.d = n - F.d + 1)],
      obtain ⟨m, hm⟩ := (int.eq_coe_of_zero_le (sub_nonneg.mpr h2)),
      rw hm,
      norm_cast },
    { ext,
      push_cast,
      ring_exp,
      congr' 2,
      ring },
    { simp } },
  { have hF : F.d = n + 1, linarith,
    simp [hF] },
  { linarith },
  { exact (lt_d_eq_zero F s n (not_le.mp h)).symm },
end

theorem θ_ϕ_exact (F : ℒ S) (hF : θ F = 0) : ∃ G, ϕ G = F :=
⟨ψ F hF, θ_ϕ_split_exact F hF⟩

end mem_exact


/-
Copyright (c) 2020 Bhavik Mehta, Edward Ayers, Thomas Read. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Edward Ayers, Thomas Read
-/

import category_theory.limits.shapes.finite_products
import category_theory.limits.preserves.shapes.binary_products
import category_theory.closed.monoidal
import category_theory.monoidal.of_has_finite_products
import category_theory.adjunction
import category_theory.adjunction.mates
import category_theory.epi_mono

/-!
# Cartesian closed categories

Given a category with finite products, the cartesian monoidal structure is provided by the local
instance `monoidal_of_has_finite_products`.

We define exponentiable objects to be closed objects with respect to this monoidal structure,
i.e. `(X × -)` is a left adjoint.

We say a category is cartesian closed if every object is exponentiable
(equivalently, that the category equipped with the cartesian monoidal structure is closed monoidal).

Show that exponential forms a difunctor and define the exponential comparison morphisms.

## TODO
Some of the results here are true more generally for closed objects and
for closed monoidal categories, and these could be generalised.
-/
universes v u u₂

noncomputable theory

namespace category_theory

open category_theory category_theory.category category_theory.limits

local attribute [instance] monoidal_of_has_finite_products

/--
An object `X` is *exponentiable* if `(X × -)` is a left adjoint.
We define this as being `closed` in the cartesian monoidal structure.
-/
abbreviation exponentiable {C : Type u} [category.{v} C] [has_finite_products C] (X : C) :=
closed X

/--
If `X` and `Y` are exponentiable then `X ⨯ Y` is.
This isn't an instance because it's not usually how we want to construct exponentials, we'll usually
prove all objects are exponential uniformly.
-/
def binary_product_exponentiable {C : Type u} [category.{v} C] [has_finite_products C] {X Y : C}
  (hX : exponentiable X) (hY : exponentiable Y) : exponentiable (X ⨯ Y) :=
{ is_adj :=
  begin
    haveI := hX.is_adj,
    haveI := hY.is_adj,
    exact adjunction.left_adjoint_of_nat_iso (monoidal_category.tensor_left_tensor _ _).symm
  end }

/--
The terminal object is always exponentiable.
This isn't an instance because most of the time we'll prove cartesian closed for all objects
at once, rather than just for this one.
-/
def terminal_exponentiable {C : Type u} [category.{v} C] [has_finite_products C] :
  exponentiable ⊤_C :=
unit_closed

/--
A category `C` is cartesian closed if it has finite products and every object is exponentiable.
We define this as `monoidal_closed` with respect to the cartesian monoidal structure.
-/
abbreviation cartesian_closed (C : Type u) [category.{v} C] [has_finite_products C] :=
monoidal_closed C

variables {C : Type u} [category.{v} C] (A B : C) {X X' Y Y' Z : C}

section exp
variables [has_finite_products C] [exponentiable A]

/-- This is (-)^A. -/
def exp : C ⥤ C :=
(@closed.is_adj _ _ _ A _).right

/-- The adjunction between A ⨯ - and (-)^A. -/
def exp.adjunction : prod.functor.obj A ⊣ exp A :=
closed.is_adj.adj

/-- The evaluation natural transformation. -/
def ev : exp A ⋙ prod.functor.obj A ⟶ 𝟭 C :=
(exp.adjunction A).counit

/-- The coevaluation natural transformation. -/
def coev : 𝟭 C ⟶ prod.functor.obj A ⋙ exp A :=
(exp.adjunction A).unit

@[simp] lemma exp_adjunction_counit : (exp.adjunction A).counit = ev A := rfl
@[simp] lemma exp_adjunction_unit : (exp.adjunction A).unit = coev A := rfl

@[simp, reassoc]
lemma ev_naturality {X Y : C} (f : X ⟶ Y) :
  limits.prod.map (𝟙 A) ((exp A).map f) ≫ (ev A).app Y = (ev A).app X ≫ f :=
(ev A).naturality f

@[simp, reassoc]
lemma coev_naturality {X Y : C} (f : X ⟶ Y) :
  f ≫ (coev A).app Y = (coev A).app X ≫ (exp A).map (limits.prod.map (𝟙 A) f) :=
(coev A).naturality f

notation A ` ⟹ `:20 B:20 := (exp A).obj B
notation B ` ^^ `:30 A:30 := (exp A).obj B

@[simp, reassoc] lemma ev_coev :
  limits.prod.map (𝟙 A) ((coev A).app B) ≫ (ev A).app (A ⨯ B) = 𝟙 (A ⨯ B) :=
adjunction.left_triangle_components (exp.adjunction A)

@[simp, reassoc] lemma coev_ev : (coev A).app (A⟹B) ≫ (exp A).map ((ev A).app B) = 𝟙 (A⟹B) :=
adjunction.right_triangle_components (exp.adjunction A)

instance : preserves_colimits (prod.functor.obj A) :=
(exp.adjunction A).left_adjoint_preserves_colimits

end exp

variables {A}

-- Wrap these in a namespace so we don't clash with the core versions.
namespace cartesian_closed

variables [has_finite_products C] [exponentiable A]

/-- Currying in a cartesian closed category. -/
def curry : (A ⨯ Y ⟶ X) → (Y ⟶ A ⟹ X) :=
(exp.adjunction A).hom_equiv _ _
/-- Uncurrying in a cartesian closed category. -/
def uncurry : (Y ⟶ A ⟹ X) → (A ⨯ Y ⟶ X) :=
((exp.adjunction A).hom_equiv _ _).symm

@[simp] lemma hom_equiv_apply_eq (f : A ⨯ Y ⟶ X) :
  (exp.adjunction A).hom_equiv _ _ f = curry f := rfl
@[simp] lemma hom_equiv_symm_apply_eq (f : Y ⟶ A ⟹ X) :
  ((exp.adjunction A).hom_equiv _ _).symm f = uncurry f := rfl

end cartesian_closed

open cartesian_closed

variables [has_finite_products C] [exponentiable A]

@[reassoc]
lemma curry_natural_left (f : X ⟶ X') (g : A ⨯ X' ⟶ Y) :
  curry (limits.prod.map (𝟙 _) f ≫ g) = f ≫ curry g :=
adjunction.hom_equiv_naturality_left _ _ _

@[reassoc]
lemma curry_natural_right (f : A ⨯ X ⟶ Y) (g : Y ⟶ Y') :
  curry (f ≫ g) = curry f ≫ (exp _).map g :=
adjunction.hom_equiv_naturality_right _ _ _

@[reassoc]
lemma uncurry_natural_right  (f : X ⟶ A⟹Y) (g : Y ⟶ Y') :
  uncurry (f ≫ (exp _).map g) = uncurry f ≫ g :=
adjunction.hom_equiv_naturality_right_symm _ _ _

@[reassoc]
lemma uncurry_natural_left  (f : X ⟶ X') (g : X' ⟶ A⟹Y) :
  uncurry (f ≫ g) = limits.prod.map (𝟙 _) f ≫ uncurry g :=
adjunction.hom_equiv_naturality_left_symm _ _ _

@[simp]
lemma uncurry_curry (f : A ⨯ X ⟶ Y) : uncurry (curry f) = f :=
(closed.is_adj.adj.hom_equiv _ _).left_inv f

@[simp]
lemma curry_uncurry (f : X ⟶ A⟹Y) : curry (uncurry f) = f :=
(closed.is_adj.adj.hom_equiv _ _).right_inv f

lemma curry_eq_iff (f : A ⨯ Y ⟶ X) (g : Y ⟶ A ⟹ X) :
  curry f = g ↔ f = uncurry g :=
adjunction.hom_equiv_apply_eq _ f g

lemma eq_curry_iff (f : A ⨯ Y ⟶ X) (g : Y ⟶ A ⟹ X) :
  g = curry f ↔ uncurry g = f :=
adjunction.eq_hom_equiv_apply _ f g

-- I don't think these two should be simp.
lemma uncurry_eq (g : Y ⟶ A ⟹ X) : uncurry g = limits.prod.map (𝟙 A) g ≫ (ev A).app X :=
adjunction.hom_equiv_counit _

lemma curry_eq (g : A ⨯ Y ⟶ X) : curry g = (coev A).app Y ≫ (exp A).map g :=
adjunction.hom_equiv_unit _

lemma uncurry_id_eq_ev (A X : C) [exponentiable A] : uncurry (𝟙 (A ⟹ X)) = (ev A).app X :=
by rw [uncurry_eq, prod.map_id_id, id_comp]

lemma curry_id_eq_coev (A X : C) [exponentiable A] : curry (𝟙 _) = (coev A).app X :=
by { rw [curry_eq, (exp A).map_id (A ⨯ _)], apply comp_id }

lemma curry_injective : function.injective (curry : (A ⨯ Y ⟶ X) → (Y ⟶ A ⟹ X)) :=
(closed.is_adj.adj.hom_equiv _ _).injective

lemma uncurry_injective : function.injective (uncurry : (Y ⟶ A ⟹ X) → (A ⨯ Y ⟶ X)) :=
(closed.is_adj.adj.hom_equiv _ _).symm.injective

/--
Show that the exponential of the terminal object is isomorphic to itself, i.e. `X^1 ≅ X`.

The typeclass argument is explicit: any instance can be used.
-/
def exp_terminal_iso_self [exponentiable ⊤_C] : (⊤_C ⟹ X) ≅ X :=
yoneda.ext (⊤_ C ⟹ X) X
  (λ Y f, (prod.left_unitor Y).inv ≫ uncurry f)
  (λ Y f, curry ((prod.left_unitor Y).hom ≫ f))
  (λ Z g, by rw [curry_eq_iff, iso.hom_inv_id_assoc] )
  (λ Z g, by simp)
  (λ Z W f g, by rw [uncurry_natural_left, prod.left_unitor_inv_naturality_assoc f] )

/-- The internal element which points at the given morphism. -/
def internalize_hom (f : A ⟶ Y) : ⊤_C ⟶ (A ⟹ Y) :=
curry (limits.prod.fst ≫ f)

section pre

variables {B}

/-- Pre-compose an internal hom with an external hom. -/
def pre (f : B ⟶ A) [exponentiable B] : exp A ⟶ exp B :=
transfer_nat_trans_self (exp.adjunction _) (exp.adjunction _) (prod.functor.map f)

lemma prod_map_pre_app_comp_ev (f : B ⟶ A) [exponentiable B] (X : C) :
  limits.prod.map (𝟙 B) ((pre f).app X) ≫ (ev B).app X =
    limits.prod.map f (𝟙 (A ⟹ X)) ≫ (ev A).app X :=
transfer_nat_trans_self_counit _ _ (prod.functor.map f) X

lemma uncurry_pre (f : B ⟶ A) [exponentiable B] (X : C) :
  uncurry ((pre f).app X) = limits.prod.map f (𝟙 _) ≫ (ev A).app X :=
begin
  rw [uncurry_eq, prod_map_pre_app_comp_ev]
end

lemma coev_app_comp_pre_app (f : B ⟶ A) [exponentiable B] :
  (coev A).app X ≫ (pre f).app (A ⨯ X) = (coev B).app X ≫ (exp B).map (limits.prod.map f (𝟙 _)) :=
unit_transfer_nat_trans_self _ _ (prod.functor.map f) X

@[simp]
lemma pre_id (A : C) [exponentiable A] : pre (𝟙 A) = 𝟙 _ :=
by simp [pre]

@[simp]
lemma pre_map {A₁ A₂ A₃ : C} [exponentiable A₁] [exponentiable A₂] [exponentiable A₃]
  (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃) :
  pre (f ≫ g) = pre g ≫ pre f :=
by rw [pre, pre, pre, transfer_nat_trans_self_comp, prod.functor.map_comp]

end pre

/-- The internal hom functor given by the cartesian closed structure. -/
def internal_hom [cartesian_closed C] : Cᵒᵖ ⥤ C ⥤ C :=
{ obj := λ X, exp X.unop,
  map := λ X Y f, pre f.unop }

/-- If an initial object `I` exists in a CCC, then `A ⨯ I ≅ I`. -/
@[simps]
def zero_mul {I : C} (t : is_initial I) : A ⨯ I ≅ I :=
{ hom := limits.prod.snd,
  inv := t.to _,
  hom_inv_id' :=
  begin
    have: (limits.prod.snd : A ⨯ I ⟶ I) = uncurry (t.to _),
      rw ← curry_eq_iff,
      apply t.hom_ext,
    rw [this, ← uncurry_natural_right, ← eq_curry_iff],
    apply t.hom_ext,
  end,
  inv_hom_id' := t.hom_ext _ _ }

/-- If an initial object `0` exists in a CCC, then `0 ⨯ A ≅ 0`. -/
def mul_zero {I : C} (t : is_initial I) : I ⨯ A ≅ I :=
limits.prod.braiding _ _ ≪≫ zero_mul t

/-- If an initial object `0` exists in a CCC then `0^B ≅ 1` for any `B`. -/
def pow_zero {I : C} (t : is_initial I) [cartesian_closed C] : I ⟹ B ≅ ⊤_ C :=
{ hom := default _,
  inv := curry ((mul_zero t).hom ≫ t.to _),
  hom_inv_id' :=
  begin
    rw [← curry_natural_left, curry_eq_iff, ← cancel_epi (mul_zero t).inv],
    { apply t.hom_ext },
    { apply_instance },
    { apply_instance }
  end }

-- TODO: Generalise the below to its commutated variants.
-- TODO: Define a distributive category, so that zero_mul and friends can be derived from this.
/-- In a CCC with binary coproducts, the distribution morphism is an isomorphism. -/
def prod_coprod_distrib [has_binary_coproducts C] [cartesian_closed C] (X Y Z : C) :
  (Z ⨯ X) ⨿ (Z ⨯ Y) ≅ Z ⨯ (X ⨿ Y) :=
{ hom := coprod.desc (limits.prod.map (𝟙 _) coprod.inl) (limits.prod.map (𝟙 _) coprod.inr),
  inv := uncurry (coprod.desc (curry coprod.inl) (curry coprod.inr)),
  hom_inv_id' :=
  begin
    apply coprod.hom_ext,
    rw [coprod.inl_desc_assoc, comp_id, ←uncurry_natural_left, coprod.inl_desc, uncurry_curry],
    rw [coprod.inr_desc_assoc, comp_id, ←uncurry_natural_left, coprod.inr_desc, uncurry_curry],
  end,
  inv_hom_id' :=
  begin
    rw [← uncurry_natural_right, ←eq_curry_iff],
    apply coprod.hom_ext,
    rw [coprod.inl_desc_assoc, ←curry_natural_right, coprod.inl_desc, ←curry_natural_left, comp_id],
    rw [coprod.inr_desc_assoc, ←curry_natural_right, coprod.inr_desc, ←curry_natural_left, comp_id],
  end }

/--
If an initial object `I` exists in a CCC then it is a strict initial object,
i.e. any morphism to `I` is an iso.
This actually shows a slightly stronger version: any morphism to an initial object from an
exponentiable object is an isomorphism.
-/
lemma strict_initial {I : C} (t : is_initial I) (f : A ⟶ I) : is_iso f :=
begin
  haveI : mono (limits.prod.lift (𝟙 A) f ≫ (zero_mul t).hom) := mono_comp _ _,
  rw [zero_mul_hom, prod.lift_snd] at _inst,
  haveI: split_epi f := ⟨t.to _, t.hom_ext _ _⟩,
  apply is_iso_of_mono_of_split_epi
end

instance to_initial_is_iso [has_initial C] (f : A ⟶ ⊥_ C) : is_iso f :=
strict_initial initial_is_initial _

/-- If an initial object `0` exists in a CCC then every morphism from it is monic. -/
lemma initial_mono {I : C} (B : C) (t : is_initial I) [cartesian_closed C] : mono (t.to B) :=
⟨λ B g h _,
begin
  haveI := strict_initial t g,
  haveI := strict_initial t h,
  exact eq_of_inv_eq_inv (t.hom_ext _ _)
end⟩

instance initial.mono_to [has_initial C] (B : C) [cartesian_closed C] : mono (initial.to B) :=
initial_mono B initial_is_initial

variables {D : Type u₂} [category.{v} D]
section functor

variables [has_finite_products D]

/--
Transport the property of being cartesian closed across an equivalence of categories.

Note we didn't require any coherence between the choice of finite products here, since we transport
along the `prod_comparison` isomorphism.
-/
def cartesian_closed_of_equiv (e : C ≌ D) [h : cartesian_closed C] : cartesian_closed D :=
{ closed := λ X,
  { is_adj :=
    begin
      haveI q : exponentiable (e.inverse.obj X) := infer_instance,
      have : is_left_adjoint (prod.functor.obj (e.inverse.obj X)) := q.is_adj,
      have : e.functor ⋙ prod.functor.obj X ⋙ e.inverse ≅ prod.functor.obj (e.inverse.obj X),
      apply nat_iso.of_components _ _,
      intro Y,
      { apply as_iso (prod_comparison e.inverse X (e.functor.obj Y)) ≪≫ _,
        apply prod.map_iso (iso.refl _) (e.unit_iso.app Y).symm },
      { intros Y Z g,
        dsimp [prod_comparison],
        simp [prod.comp_lift, ← e.inverse.map_comp, ← e.inverse.map_comp_assoc],
          -- I wonder if it would be a good idea to make `map_comp` a simp lemma the other way round
        dsimp, simp -- See note [dsimp, simp]
        },
      { have : is_left_adjoint (e.functor ⋙ prod.functor.obj X ⋙ e.inverse) :=
          by exactI adjunction.left_adjoint_of_nat_iso this.symm,
        have : is_left_adjoint (e.inverse ⋙ e.functor ⋙ prod.functor.obj X ⋙ e.inverse) :=
          by exactI adjunction.left_adjoint_of_comp e.inverse _,
        have : (e.inverse ⋙ e.functor ⋙ prod.functor.obj X ⋙ e.inverse) ⋙ e.functor ≅
          prod.functor.obj X,
        { apply iso_whisker_right e.counit_iso (prod.functor.obj X ⋙ e.inverse ⋙ e.functor) ≪≫ _,
          change prod.functor.obj X ⋙ e.inverse ⋙ e.functor ≅ prod.functor.obj X,
          apply iso_whisker_left (prod.functor.obj X) e.counit_iso, },
        resetI,
        apply adjunction.left_adjoint_of_nat_iso this },
    end } }

end functor

end category_theory


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

! This file was ported from Lean 3 source module dynamics.minimal
! leanprover-community/mathlib commit 4c19a16e4b705bf135cf9a80ac18fcc99c438514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.GroupAction.Basic
import Mathlib.Topology.Algebra.ConstMulAction

/-!
# Minimal action of a group

In this file we define an action of a monoid `M` on a topological space `α` to be *minimal* if the
`M`-orbit of every point `x : α` is dense. We also provide an additive version of this definition
and prove some basic facts about minimal actions.

## TODO

* Define a minimal set of an action.

## Tags

group action, minimal
-/

open Pointwise

/-- An action of an additive monoid `M` on a topological space is called *minimal* if the `M`-orbit
of every point `x : α` is dense. -/
class AddAction.IsMinimal (M α : Type _) [AddMonoid M] [TopologicalSpace α] [AddAction M α] :
    Prop where
  dense_orbit : ∀ x : α, Dense (AddAction.orbit M x)
#align add_action.is_minimal AddAction.IsMinimal

/-- An action of a monoid `M` on a topological space is called *minimal* if the `M`-orbit of every
point `x : α` is dense. -/
@[to_additive]
class MulAction.IsMinimal (M α : Type _) [Monoid M] [TopologicalSpace α] [MulAction M α] :
    Prop where
  dense_orbit : ∀ x : α, Dense (MulAction.orbit M x)
#align mul_action.is_minimal MulAction.IsMinimal

open MulAction Set

variable (M G : Type _) {α : Type _} [Monoid M] [Group G] [TopologicalSpace α] [MulAction M α]
  [MulAction G α]

@[to_additive]
theorem MulAction.dense_orbit [IsMinimal M α] (x : α) : Dense (orbit M x) :=
  MulAction.IsMinimal.dense_orbit x
#align mul_action.dense_orbit MulAction.dense_orbit
#align add_action.dense_orbit AddAction.dense_orbit

@[to_additive]
theorem denseRange_smul [IsMinimal M α] (x : α) : DenseRange fun c : M ↦ c • x :=
  MulAction.dense_orbit M x
#align dense_range_smul denseRange_smul
#align dense_range_vadd denseRange_vadd

@[to_additive]
instance (priority := 100) MulAction.isMinimal_of_pretransitive [IsPretransitive M α] :
    IsMinimal M α :=
  ⟨fun x ↦ (surjective_smul M x).denseRange⟩
#align mul_action.is_minimal_of_pretransitive MulAction.isMinimal_of_pretransitive
#align add_action.is_minimal_of_pretransitive AddAction.isMinimal_of_pretransitive

@[to_additive]
theorem IsOpen.exists_smul_mem [IsMinimal M α] (x : α) {U : Set α} (hUo : IsOpen U)
    (hne : U.Nonempty) : ∃ c : M, c • x ∈ U :=
  (denseRange_smul M x).exists_mem_open hUo hne
#align is_open.exists_smul_mem IsOpen.exists_smul_mem
#align is_open.exists_vadd_mem IsOpen.exists_vadd_mem

@[to_additive]
theorem IsOpen.unionᵢ_preimage_smul [IsMinimal M α] {U : Set α} (hUo : IsOpen U)
    (hne : U.Nonempty) : (⋃ c : M, (· • ·) c ⁻¹' U) = univ :=
  unionᵢ_eq_univ_iff.2 fun x ↦ hUo.exists_smul_mem M x hne
#align is_open.Union_preimage_smul IsOpen.unionᵢ_preimage_smul
#align is_open.Union_preimage_vadd IsOpen.unionᵢ_preimage_vadd

@[to_additive]
theorem IsOpen.unionᵢ_smul [IsMinimal G α] {U : Set α} (hUo : IsOpen U) (hne : U.Nonempty) :
    (⋃ g : G, g • U) = univ :=
  unionᵢ_eq_univ_iff.2 fun x ↦
    let ⟨g, hg⟩ := hUo.exists_smul_mem G x hne
    ⟨g⁻¹, _, hg, inv_smul_smul _ _⟩
#align is_open.Union_smul IsOpen.unionᵢ_smul
#align is_open.Union_vadd IsOpen.unionᵢ_vadd

@[to_additive]
theorem IsCompact.exists_finite_cover_smul [IsMinimal G α] [ContinuousConstSMul G α]
    {K U : Set α} (hK : IsCompact K) (hUo : IsOpen U) (hne : U.Nonempty) :
    ∃ I : Finset G, K ⊆ ⋃ g ∈ I, g • U :=
  (hK.elim_finite_subcover (fun g ↦ g • U) fun _ ↦ hUo.smul _) <| calc
    K ⊆ univ := subset_univ K
    _ = ⋃ g : G, g • U := (hUo.unionᵢ_smul G hne).symm
#align is_compact.exists_finite_cover_smul IsCompact.exists_finite_cover_smul
#align is_compact.exists_finite_cover_vadd IsCompact.exists_finite_cover_vadd

@[to_additive]
theorem dense_of_nonempty_smul_invariant [IsMinimal M α] {s : Set α} (hne : s.Nonempty)
    (hsmul : ∀ c : M, c • s ⊆ s) : Dense s :=
  let ⟨x, hx⟩ := hne
  (MulAction.dense_orbit M x).mono (range_subset_iff.2 fun c ↦ hsmul c ⟨x, hx, rfl⟩)
#align dense_of_nonempty_smul_invariant dense_of_nonempty_smul_invariant
#align dense_of_nonempty_vadd_invariant dense_of_nonempty_vadd_invariant

@[to_additive]
theorem eq_empty_or_univ_of_smul_invariant_closed [IsMinimal M α] {s : Set α} (hs : IsClosed s)
    (hsmul : ∀ c : M, c • s ⊆ s) : s = ∅ ∨ s = univ :=
  s.eq_empty_or_nonempty.imp_right fun hne ↦
    hs.closure_eq ▸ (dense_of_nonempty_smul_invariant M hne hsmul).closure_eq
#align eq_empty_or_univ_of_smul_invariant_closed eq_empty_or_univ_of_smul_invariant_closed
#align eq_empty_or_univ_of_vadd_invariant_closed eq_empty_or_univ_of_vadd_invariant_closed

@[to_additive]
theorem isMinimal_iff_closed_smul_invariant [ContinuousConstSMul M α] :
    IsMinimal M α ↔ ∀ s : Set α, IsClosed s → (∀ c : M, c • s ⊆ s) → s = ∅ ∨ s = univ := by
  constructor
  · intro _ _
    exact eq_empty_or_univ_of_smul_invariant_closed M
  refine' fun H ↦ ⟨fun _ ↦ dense_iff_closure_eq.2 <| (H _ _ _).resolve_left _⟩
  exacts[isClosed_closure, fun _ ↦ smul_closure_orbit_subset _ _,
    (orbit_nonempty _).closure.ne_empty]
#align is_minimal_iff_closed_smul_invariant isMinimal_iff_closed_smul_invariant
#align is_minimal_iff_closed_vadd_invariant isMinimal_iff_closed_vadd_invariant


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen

! This file was ported from Lean 3 source module linear_algebra.matrix.reindex
! leanprover-community/mathlib commit 1cfdf5f34e1044ecb65d10be753008baaf118edf
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Matrix.Determinant

/-!
# Changing the index type of a matrix

This file concerns the map `matrix.reindex`, mapping a `m` by `n` matrix
to an `m'` by `n'` matrix, as long as `m ≃ m'` and `n ≃ n'`.

## Main definitions

* `matrix.reindex_linear_equiv R A`: `matrix.reindex` is an `R`-linear equivalence between
  `A`-matrices.
* `matrix.reindex_alg_equiv R`: `matrix.reindex` is an `R`-algebra equivalence between `R`-matrices.

## Tags

matrix, reindex

-/

namespace Matrix

open Equiv

open Matrix

variable {l m n o : Type _} {l' m' n' o' : Type _} {m'' n'' : Type _}

variable (R A : Type _)

section AddCommMonoid

variable [Semiring R] [AddCommMonoid A] [Module R A]

/-- The natural map that reindexes a matrix's rows and columns with equivalent types,
`matrix.reindex`, is a linear equivalence. -/
def reindexLinearEquiv (eₘ : m ≃ m') (eₙ : n ≃ n') : Matrix m n A ≃ₗ[R] Matrix m' n' A :=
  { reindex eₘ eₙ with
    map_add' := fun _ _ => rfl
    map_smul' := fun _ _ => rfl }
#align matrix.reindex_linear_equiv Matrix.reindexLinearEquiv

@[simp]
theorem reindexLinearEquiv_apply (eₘ : m ≃ m') (eₙ : n ≃ n') (M : Matrix m n A) :
    reindexLinearEquiv R A eₘ eₙ M = reindex eₘ eₙ M :=
  rfl
#align matrix.reindex_linear_equiv_apply Matrix.reindexLinearEquiv_apply

@[simp]
theorem reindexLinearEquiv_symm (eₘ : m ≃ m') (eₙ : n ≃ n') :
    (reindexLinearEquiv R A eₘ eₙ).symm = reindexLinearEquiv R A eₘ.symm eₙ.symm :=
  rfl
#align matrix.reindex_linear_equiv_symm Matrix.reindexLinearEquiv_symm

@[simp]
theorem reindexLinearEquiv_refl_refl :
    reindexLinearEquiv R A (Equiv.refl m) (Equiv.refl n) = LinearEquiv.refl R _ :=
  LinearEquiv.ext fun _ => rfl
#align matrix.reindex_linear_equiv_refl_refl Matrix.reindexLinearEquiv_refl_refl

theorem reindexLinearEquiv_trans (e₁ : m ≃ m') (e₂ : n ≃ n') (e₁' : m' ≃ m'') (e₂' : n' ≃ n'') :
    (reindexLinearEquiv R A e₁ e₂).trans (reindexLinearEquiv R A e₁' e₂') =
      (reindexLinearEquiv R A (e₁.trans e₁') (e₂.trans e₂') : _ ≃ₗ[R] _) :=
  by
  ext
  rfl
#align matrix.reindex_linear_equiv_trans Matrix.reindexLinearEquiv_trans

theorem reindexLinearEquiv_comp (e₁ : m ≃ m') (e₂ : n ≃ n') (e₁' : m' ≃ m'') (e₂' : n' ≃ n'') :
    reindexLinearEquiv R A e₁' e₂' ∘ reindexLinearEquiv R A e₁ e₂ =
      reindexLinearEquiv R A (e₁.trans e₁') (e₂.trans e₂') :=
  by
  rw [← reindex_linear_equiv_trans]
  rfl
#align matrix.reindex_linear_equiv_comp Matrix.reindexLinearEquiv_comp

theorem reindexLinearEquiv_comp_apply (e₁ : m ≃ m') (e₂ : n ≃ n') (e₁' : m' ≃ m'') (e₂' : n' ≃ n'')
    (M : Matrix m n A) :
    (reindexLinearEquiv R A e₁' e₂') (reindexLinearEquiv R A e₁ e₂ M) =
      reindexLinearEquiv R A (e₁.trans e₁') (e₂.trans e₂') M :=
  submatrix_submatrix _ _ _ _ _
#align matrix.reindex_linear_equiv_comp_apply Matrix.reindexLinearEquiv_comp_apply

theorem reindexLinearEquiv_one [DecidableEq m] [DecidableEq m'] [One A] (e : m ≃ m') :
    reindexLinearEquiv R A e e (1 : Matrix m m A) = 1 :=
  submatrix_one_equiv e.symm
#align matrix.reindex_linear_equiv_one Matrix.reindexLinearEquiv_one

end AddCommMonoid

section Semiring

variable [Semiring R] [Semiring A] [Module R A]

theorem reindexLinearEquiv_mul [Fintype n] [Fintype n'] (eₘ : m ≃ m') (eₙ : n ≃ n') (eₒ : o ≃ o')
    (M : Matrix m n A) (N : Matrix n o A) :
    reindexLinearEquiv R A eₘ eₙ M ⬝ reindexLinearEquiv R A eₙ eₒ N =
      reindexLinearEquiv R A eₘ eₒ (M ⬝ N) :=
  submatrix_mul_equiv M N _ _ _
#align matrix.reindex_linear_equiv_mul Matrix.reindexLinearEquiv_mul

theorem mul_reindexLinearEquiv_one [Fintype n] [DecidableEq o] (e₁ : o ≃ n) (e₂ : o ≃ n')
    (M : Matrix m n A) :
    M.mul (reindexLinearEquiv R A e₁ e₂ 1) =
      reindexLinearEquiv R A (Equiv.refl m) (e₁.symm.trans e₂) M :=
  haveI := Fintype.ofEquiv _ e₁.symm
  mul_submatrix_one _ _ _
#align matrix.mul_reindex_linear_equiv_one Matrix.mul_reindexLinearEquiv_one

end Semiring

section Algebra

variable [CommSemiring R] [Fintype n] [Fintype m] [DecidableEq m] [DecidableEq n]

/-- For square matrices with coefficients in commutative semirings, the natural map that reindexes
a matrix's rows and columns with equivalent types, `matrix.reindex`, is an equivalence of algebras.
-/
def reindexAlgEquiv (e : m ≃ n) : Matrix m m R ≃ₐ[R] Matrix n n R :=
  { reindexLinearEquiv R R e e with
    toFun := reindex e e
    map_mul' := fun a b => (reindexLinearEquiv_mul R R e e e a b).symm
    commutes' := fun r => by simp [algebraMap, Algebra.toRingHom, submatrix_smul] }
#align matrix.reindex_alg_equiv Matrix.reindexAlgEquiv

@[simp]
theorem reindexAlgEquiv_apply (e : m ≃ n) (M : Matrix m m R) :
    reindexAlgEquiv R e M = reindex e e M :=
  rfl
#align matrix.reindex_alg_equiv_apply Matrix.reindexAlgEquiv_apply

@[simp]
theorem reindexAlgEquiv_symm (e : m ≃ n) : (reindexAlgEquiv R e).symm = reindexAlgEquiv R e.symm :=
  rfl
#align matrix.reindex_alg_equiv_symm Matrix.reindexAlgEquiv_symm

@[simp]
theorem reindexAlgEquiv_refl : reindexAlgEquiv R (Equiv.refl m) = AlgEquiv.refl :=
  AlgEquiv.ext fun _ => rfl
#align matrix.reindex_alg_equiv_refl Matrix.reindexAlgEquiv_refl

theorem reindexAlgEquiv_mul (e : m ≃ n) (M : Matrix m m R) (N : Matrix m m R) :
    reindexAlgEquiv R e (M ⬝ N) = reindexAlgEquiv R e M ⬝ reindexAlgEquiv R e N :=
  (reindexAlgEquiv R e).map_mul M N
#align matrix.reindex_alg_equiv_mul Matrix.reindexAlgEquiv_mul

end Algebra

/-- Reindexing both indices along the same equivalence preserves the determinant.

For the `simp` version of this lemma, see `det_submatrix_equiv_self`.
-/
theorem det_reindexLinearEquiv_self [CommRing R] [Fintype m] [DecidableEq m] [Fintype n]
    [DecidableEq n] (e : m ≃ n) (M : Matrix m m R) : det (reindexLinearEquiv R R e e M) = det M :=
  det_reindex_self e M
#align matrix.det_reindex_linear_equiv_self Matrix.det_reindexLinearEquiv_self

/-- Reindexing both indices along the same equivalence preserves the determinant.

For the `simp` version of this lemma, see `det_submatrix_equiv_self`.
-/
theorem det_reindexAlgEquiv [CommRing R] [Fintype m] [DecidableEq m] [Fintype n] [DecidableEq n]
    (e : m ≃ n) (A : Matrix m m R) : det (reindexAlgEquiv R e A) = det A :=
  det_reindex_self e A
#align matrix.det_reindex_alg_equiv Matrix.det_reindexAlgEquiv

end Matrix


import data.int.basic
import data.rat
import galois.nat.div_lemmas
import data.nat.basic
import galois.sum
import init.data.ordering
import data.vector

import galois.nat
import .bool

universe u

@[simp]
theorem coe_bool_to_prop (b:bool) : coe b ↔ b = tt :=
begin
  cases b; exact dec_trivial,
end
@[simp]
theorem to_bool_is_tt  (p : Prop) [inst:decidable p] : (to_bool p = tt) = p :=
begin
  cases inst,
  all_goals { unfold decidable.to_bool, simp [a], },
end

namespace nat

lemma lt.intro {n m k : ℕ} (h : n + succ k = m) : n < m :=
  h ▸ nat.succ_le_succ (nat.le_add_right n k)

end nat

namespace list

section
parameter {α : Type u}
parameter (n : ℕ)
parameter (f : fin n → α)

protected
def generate_core : Π (i j : ℕ), i + j = n  → list α
| i 0 pr := []
| i (nat.succ j) pr :=
  let qr : i < n := nat.lt.intro pr in
  let rr : i+1 + j = n :=
      begin
        simp [nat.succ_add i j],
        exact pr,
      end in
  f ⟨i, qr⟩ :: generate_core (i+1) j rr

protected
def generate : list α := generate_core 0 n (nat.zero_add n)

theorem length_generate_core (i j : ℕ)
: Π (pr : i + j = n),
  (generate_core i j pr).length = j :=
begin
  revert i,
  induction j,
  case nat.zero {
    intros,
    exact dec_trivial,
  },
  case nat.succ j ind {
    intros,
    simp only [list.generate_core, length_cons],
    apply congr_arg nat.succ,
    apply ind,
  },
end

protected
theorem length_generate : generate.length = n :=
begin
  apply length_generate_core,
end

end

section foldl₂
parameter {α : Type _}
parameter {β : Type _}
parameter {C : Type _}
parameter (f : C → α → β → C)

def foldl₂
  : C → list α → list β → C
| c [] _ := c
| c _ [] := c
| c (x::xr) (y::yr) := foldl₂ (f c x y) xr yr

end foldl₂

section init
parameter {α : Type _}

protected
theorem length_init (l : list α) : l.init.length = l.length - 1 :=
begin
  induction l,
  case nil {
    simp [init],
  },
  case cons h r ind {
    cases r,
    { simp [init], },
    case list.cons h2 r {
      simp only [init, length_cons, ind, nat.succ_sub_succ],
      trivial,
    }
  }
end

end init
end list

namespace vector

def generate {α : Type u} (n : ℕ) (f : fin n → α) : vector α n :=
  ⟨ list.generate n f, list.length_generate n f⟩

section foldl₂
parameter {α : Type _}
parameter {β : Type _}
parameter {C : Type _}
parameter (f : C → α → β → C)
parameter {n:ℕ}

def foldl₂ (c:C) (x : vector α n) (y: vector β n) : C :=
  list.foldl₂ f c x.to_list y.to_list

end foldl₂

def dotprod {α: Type u} [semiring α] {n:ℕ} : vector α n → vector α n → α :=
  foldl₂ (λc a b, c + a * b) 0

notation `⬝` := dotprod

def last {α:Type u} {n:ℕ} (v : vector α (n+1)) : α :=
  v.to_list.last (list.ne_nil_of_length_eq_succ v.property)

-- Return all but the last element in a vector.
def init {α:Type u} {n:ℕ} (v : vector α (n+1)) : vector α n :=
  let pr : v.to_list.init.length = n :=
      begin
        simp only [list.length_init, to_list_length],
        trivial,
      end in
  ⟨ v.to_list.init, pr⟩

def scale_mul {α:Type u} [has_mul α] {n:ℕ} (c:α) (v : vector α n)
: vector α n :=
  v.map (has_mul.mul c)

end vector

namespace list

protected
def maximum {α:Type _} [decidable_linear_order α] : list α → option α
| [] := option.none
| (h::r) := option.some (r.foldl max h)

protected
def minimum {α:Type _} [decidable_linear_order α] : list α → option α
| [] := option.none
| (h::r) := option.some (r.foldl min h)

end list

namespace rat

def to_string (q:ℚ) : string :=
  if q.denom = 1 then
    to_string (q.num)
  else
    to_string (q.num) ++ "/" ++ to_string q.denom

instance : has_to_string ℚ := ⟨ to_string ⟩

end rat

-----------------------------------------------------------------------
-- bound

-- Return true if either option is none, or both are defined and first is
-- less than second.
def bound_le : option ℚ → option ℚ → Prop
| none _ := true
| (some l) (some u) := l ≤ u
| (some _) none := true

theorem bound_le_maximum_minimum (ll ul : list ℚ)
(pr : ∀ (l u : ℚ), l ∈ ll → u ∈ ul → l ≤ u)
: bound_le (list.maximum ll) (list.minimum ul) := sorry

def le_bound (ol: option ℚ) (u : ℚ) : Prop :=
  match ol with
  | option.none := true
  | (option.some l) := l ≤ u
  end

instance le_bound.decidable (ol : option ℚ) (u:ℚ) : decidable (le_bound ol u) :=
  begin cases ol; unfold le_bound; apply_instance end

def ge_bound (l:ℚ) (ou: option ℚ) : Prop :=
  match ou with
  | option.none := true
  | (option.some u) := l ≤ u
  end

instance ge_bound.decidable (l:ℚ) (ou : option ℚ) : decidable (ge_bound l ou) :=
  begin cases ou; unfold ge_bound; apply_instance end

def choose_bound : option ℚ → option ℚ → ℚ
| (some l) _ := l
| none none := 0
| none (some u) := u

theorem le_bound_choose_bound (l u : option ℚ) : le_bound l (choose_bound l u) :=
begin
  cases l with l,
  all_goals { simp [le_bound, choose_bound], },
end

theorem ge_bound_choose_bound {l u : option ℚ} (pr : bound_le l u) : ge_bound (choose_bound l u) u :=
begin
  cases u with u,
  {
    simp [ge_bound, choose_bound],
  },
  {
    cases l with l,
    { simp [ge_bound, choose_bound], },
    { simp [bound_le] at pr,
      simp [ge_bound, choose_bound, pr],
    },
  },
end

-----------------------------------------------------------------------
-- assignment

@[reducible]
def assignment (α:Type _) (n:ℕ) := vector α n

namespace assignment

section
parameter {α:Type _}

/-- The empty assignment. -/
def empty : assignment α 0 := vector.nil

def zero_assignment_is_empty (a:assignment α 0) : a = empty :=
begin
  simp [empty],
  apply vector.eq_nil,
end

def concat {n:ℕ} (xs : assignment α n) (x : α) : assignment α (n+1) :=
  vector.cons x xs

def shrink {n:ℕ} (a:assignment α n) (i : fin n) : assignment α i.val :=
begin
have H1 : i.val ≤ n,
apply le_of_lt, apply fin.is_lt,
have H := vector.take i.val a,
unfold min at H,
rw (if_pos H1) at H, apply H
end

-- def last_of_fin {n:ℕ} (a:assignment α n) (i : fin n) : α :=
--   sorry

-- def init {n:ℕ} (a:assignment α (n+1)) : assignment α n :=
--   sorry

-- def last {n:ℕ} (a:assignment α (n+1)) : α :=
--   sorry

@[simp]
theorem init_concat {n:ℕ} (a:assignment α n) (z:α) : vector.init (concat a z) = a := sorry

@[simp]
theorem last_concat {n:ℕ} (a:assignment α n) (z:α) : vector.last (concat a z) = z := sorry

end
end assignment

-- denotes the inequality coef <= bound
inductive linear_expr : ℕ → Type
| const : Π {n:ℕ}, ℚ → linear_expr n
| add : Π {n:ℕ} (c:ℚ) (pr : c ≠ 0) (i : fin n), linear_expr i.val → linear_expr n

lemma nat_ordering_char (x y : ℕ)
  : (match nat.cmp x y with
  | ordering.lt := x < y
  | ordering.eq := x = y
  | ordering.gt := x > y
  end : Prop)
:= begin
dsimp [nat.cmp],
apply (if H : x < y then _ else _),
rw (if_pos H), assumption,
rw (if_neg H),
apply (if H' : x = y then _ else _),
rw (if_pos H'), assumption,
rw (if_neg H'), dsimp,
dsimp [(>)],
rw lt_iff_not_ge,
intros contra, apply H', apply le_antisymm,
assumption, apply le_of_not_gt, assumption,
end

namespace fin

lemma lt_char {n : ℕ}
  (x y : fin n) : x < y ↔ x.val < y.val
:= begin
induction x; induction y; reflexivity
end

def extend_le {m n : ℕ} (H : m ≤ n) (x : fin m) : fin n
:= begin
constructor, apply lt_of_lt_of_le, apply fin.is_lt, assumption,
assumption,
end

def restrict_lt {n : ℕ} (x y : fin n) (H : x < y)
  : fin y.val
:= ⟨ x.val, begin
rw lt_char at H, assumption
end ⟩

def ordering_elim {n : ℕ}
  (C : Sort _)
  (x y : fin n)
  (Hlt : x < y → C)
  (Heq : x = y → C)
  (Hgt : x > y → C)
  : C
:= begin
have H := nat_ordering_char x.val y.val,
cases (nat.cmp x.val y.val);
  dsimp at H,
{ apply Hlt, rw lt_char, assumption },
{ induction x, induction y, dsimp at H,
  apply Heq, subst H, },
{ apply Hgt, unfold gt, rw fin.lt_char, assumption },
end

end fin

namespace linear_expr

def scale_mul (x : ℚ) (xne0 : x ≠ 0) : ∀ {n}, linear_expr n → linear_expr n
| _ (const c) := const (x * c)
| _ (add c cne0 i e) := add (x * c) (mul_ne_zero xne0 cne0) i (scale_mul e)

def add_constant (x : ℚ) : ∀ {n}, linear_expr n → linear_expr n
| _ (const c) := const (x + c)
| _ (add c cne0 i e) := add c cne0 i (add_constant e)

def extend {i n :ℕ} : linear_expr i → i ≤ n → linear_expr n
| (const c) is_le := const c
| (add c pr j e) is_le := add c pr ⟨j.val, lt_of_lt_of_le j.is_lt is_le⟩ e

def add_variable (x : ℚ) : ∀ {n}, fin n → linear_expr n → linear_expr n
| _ i (const c) := if xne0 : x ≠ 0
    then add x xne0 i (const c)
    else const c
| n i (add c cne0 i' e) := begin
  apply (fin.ordering_elim (linear_expr n) i i');
    intros,
    { apply (add c cne0 i'),
      apply add_variable,
      apply fin.restrict_lt, assumption,
      assumption,
    },
    { apply (if H : x + c ≠ 0 then _ else _),
      { apply (add (x + c) H i' e), },
      { apply e.extend, apply le_of_lt, apply fin.is_lt, }
    },
    { apply (if H : x ≠ 0 then _ else _),
      { apply (add x H i),
        apply (add c cne0), admit, admit },
      { apply e.extend, apply le_of_lt, apply fin.is_lt, }
    }
   end

def sum : ∀ {n}, linear_expr n → linear_expr n → linear_expr n
| _ (const c) e := add_constant c e
| _ (add c cne0 i e) e' := sorry

def as_const : linear_expr 0 → ℚ
| (const c) := c
| (add _ _ i _) :=
  begin
    have is_lit := i.is_lt,
    have h := nat.not_lt_zero i.val,
    contradiction,
  end

def prepend_sum : string → string → string
| s "" := s
| s t := s ++ " + " ++ t

def to_string_core  : Π {n:ℕ}, linear_expr n → string → string
| _ (const c) s :=
   if s = "" then
     to_string c
  else if c = 0 ∧ s ≠ "" then
    s
  else
    s ++ " + " ++ to_string c
| _  (add c _ i e) s :=
  to_string_core e
    (if c = 1 then
       prepend_sum ("v" ++ to_string i) s
     else
       prepend_sum (to_string c ++"×v" ++ to_string i) s)

def to_string  {n:ℕ} (e:linear_expr n) : string := to_string_core e ""

def var {n:ℕ} (i : fin n) : linear_expr n := add 1 dec_trivial i (const 0)

/-- Return the last coefficient of the linear_expression. -/
def last {n:ℕ} : linear_expr (n+1) → ℚ
| (const c) := 0
| (add c pr i e) := if i.val = n then c else 0

/-- Return the expression with the last variable removed and the coefficient. -/
def drop_last {n:ℕ} : linear_expr (n+1) → linear_expr n
| (const c) := const c
| (add c pr i e) :=
  if i_lt_n : i.val < n then
    add c pr ⟨i.val, i_lt_n⟩ e
  else
    e.extend (nat.pred_le_pred i.is_lt)

section evaluate
parameter {n:ℕ}

def evaluate_core : ℚ → Π{n:ℕ}, linear_expr n → assignment ℚ n → ℚ
| r _ (const c) _ := c + r
| r _ (add c pr i e) a := evaluate_core (r + c * a.nth i) e (a.shrink i)

def evaluate : Π{n:ℕ}, linear_expr n → assignment ℚ n → ℚ := @evaluate_core 0

end evaluate

end linear_expr

-----------------------------------------------------------------------
-- linear_expr_list

def linear_expr_list (n:ℕ) := list (linear_expr n)

namespace linear_expr_list

def to_list {n:ℕ} : linear_expr_list n → list (linear_expr n) := id

instance (n:ℕ) : has_mem (linear_expr n) (linear_expr_list n) :=
  begin unfold linear_expr_list, apply_instance end

section
parameter {n:ℕ}

def evaluate (l : linear_expr_list n) (a : assignment ℚ n) : list ℚ :=
  l.map (λe, e.evaluate a)

theorem evaluate_cons (e : linear_expr n) (l : linear_expr_list n)
  (a : assignment ℚ n)
: evaluate (e :: l) a = e.evaluate a :: l.evaluate a := rfl

theorem mem_evaluate_implies {l: linear_expr_list n} {a:assignment ℚ n} {q : ℚ}
(pr : q ∈ l.evaluate a)
: ∃(e:linear_expr n), e ∈ l ∧ e.evaluate a = q
:= begin
apply list.exists_of_mem_map pr,
end

end
end linear_expr_list

---------------------------------------------------------
-- Inequalities

-- denotes the inequality lhs <= 0
structure inequality (n:ℕ) :=
(lhs : linear_expr n)

namespace inequality

section entails

parameter {n:ℕ}

def from_pair : linear_expr n → linear_expr n → inequality n := sorry

def satisfies (θ:assignment ℚ n) (c:inequality n) : Prop := c.lhs.evaluate θ ≤ 0

theorem satisfies_from_pair (a:assignment ℚ n) (l u:linear_expr n)
: satisfies a (from_pair l u) ↔ l.evaluate a ≤ u.evaluate a := sorry

instance (c:inequality n) (θ:assignment ℚ n)
: decidable (satisfies θ c) :=
  begin unfold satisfies, apply_instance end

end entails

notation `⊧` := satisfies

end inequality

/-- A collection on inequalities -/
def ineqs (n:ℕ) := list (inequality n)

namespace ineqs

instance (n:ℕ) : has_append (ineqs n) := begin unfold ineqs, apply_instance end
instance (n:ℕ) : has_mem (inequality n) (ineqs n) := begin unfold ineqs, apply_instance end

section satisfies

parameter {n:ℕ}
parameter (a:assignment ℚ n)

-- Returns true if assignment satisfies bound.
def satisfies (eqs:ineqs n) : Prop :=
   eqs.all (λb, to_bool (inequality.satisfies a b))

instance (eqs:ineqs n) : decidable (satisfies eqs) :=
  begin unfold satisfies, apply_instance end

@[simp]
theorem satisfies_nil : satisfies [] :=
begin
  simp [satisfies, list.all],
end

@[simp]
theorem satisfies_cons (h : inequality n) (r : ineqs n)
: satisfies (h :: r) ↔ inequality.satisfies a h ∧ satisfies r :=
begin
  simp [satisfies, list.all, list.foldr],
end

@[simp]
theorem satisfies_append (x y : ineqs n) :
 satisfies (x ++ y) = (satisfies x ∧ satisfies y) := sorry

end satisfies

theorem satisfies_list_implies_mem_satisfies {n:ℕ}
{e : inequality n}
{l : ineqs n}
{a:assignment ℚ n}
(pr : satisfies a l)
(in_list : e ∈ l)
: inequality.satisfies a e := sorry

/-- Denotes a solution to the equations. -/
def solution {n:ℕ} (eqs:ineqs n) := { a : assignment ℚ n // eqs.satisfies a }

/-- A proof that the equations are unsatisfiable. -/
def unsat_proof {n:ℕ} (eqs:ineqs n) :=
  ∀(a:assignment ℚ n), ¬ (satisfies a eqs)

end ineqs

-----------------------------------------------------------------------
-- bound

inductive bound (n:ℕ) : Type
-- lower e denotes e <= x
| lower : linear_expr n → bound
-- upper e denotes x <= e
| upper : linear_expr n → bound
-- If variable had a zero in the expression.
| independent  : inequality n → bound

namespace bound

/-- Given an inequality infers the resulting bound on the last variable. -/
def from_ineq {n:ℕ} (le : inequality (n+1)) : bound n :=
  let e := le.lhs in
  let c := e.last in
  let r  := e.drop_last in
   if c > 0 then
    -- "l + c * v <= 0" ~> "v <= -l/c"
    let recip := 1/c in
    bound.upper (linear_expr.scale_mul (-1/c) sorry r)
    -- "l + c * v <= 0" ~> "l/c <= v"
  else if c < 0 then
    bound.lower (linear_expr.scale_mul (1/c) sorry r)
  else
    bound.independent ⟨ r ⟩

section

parameter {n:ℕ}

-- Returns true if assignment satisfies bound.
def satisfies (a:assignment ℚ (n+1)) : bound n → Prop
| (lower e) := e.evaluate a.init ≤ a.last
| (upper e) := a.last ≤ e.evaluate a.init
| (independent le) := le.satisfies a.init

@[simp]
theorem satisfies_from_ineq (a: assignment ℚ (n+1)) (le : inequality (n+1))
: bound.satisfies a (bound.from_ineq le) = inequality.satisfies a le := sorry

end
end bound

-----------------------------------------------------------------------
-- bound_list

structure bound_list (n:ℕ) :=
(lower : linear_expr_list n)
(upper : linear_expr_list n)
(independent : ineqs n)

namespace bound_list

def empty (n:ℕ) : bound_list n :=
  { lower := [], upper := [], independent := []}

def lower_bound {n:ℕ} (b:bound_list n) (a:assignment ℚ n) : option ℚ :=
  (b.lower.evaluate a).maximum

def upper_bound {n:ℕ} (b:bound_list n) (a:assignment ℚ n) : option ℚ :=
  (b.upper.evaluate a).minimum

section satisfies
parameter {n:ℕ}
parameter (a:assignment ℚ (n+1))

-- Returns true if assignment satisfies bound.
def satisfies (b:bound_list n) : Prop :=
     le_bound (b.lower_bound a.init) a.last
   ∧ ge_bound a.last (b.upper_bound a.init)
   ∧ ineqs.satisfies a.init b.independent

instance (b:bound_list n) : decidable (satisfies b) :=
  begin
    unfold satisfies,
    apply_instance,
  end

end satisfies

@[simp]
theorem satisfies_empty (n:ℕ) (a:assignment ℚ (n+1))
: satisfies a (empty n) :=
begin
  simp [empty, satisfies, upper_bound, lower_bound,
        linear_expr_list.evaluate, list.minimum,
        ge_bound, le_bound],
end

section from_ineqs
parameter {n:ℕ}

def add_bound : bound n → bound_list n → bound_list n
| (bound.lower e) b := { b with lower := e :: b.lower }
| (bound.upper e) b := { b with upper := e :: b.upper }
| (bound.independent e) b := { b with independent := e :: b.independent }

theorem satisfies_add_bound (a:assignment ℚ (n+1)) (b:bound n) (l: bound_list n)
: satisfies a (bound_list.add_bound b l) ↔
  (bound.satisfies a b ∧ satisfies a l) :=
begin
  apply iff.intro,
  { cases b,
    case bound.lower e {
      cases l,
      simp [satisfies, add_bound, bound.satisfies, lower_bound, upper_bound],
      intros ineq_sat, admit,
    },
    case bound.upper e {
      admit,
    },
    case bound.independent ineq {
      admit,
    },
  },
  {
    admit,
  }
end

/-- Return bounds on last variable. -/
def from_ineqs (l:ineqs (n+1)) : bound_list n :=
  l.foldr (λe, add_bound (bound.from_ineq e)) (empty n)

@[simp]
theorem from_ineqs_nil : from_ineqs list.nil = empty n := rfl

@[simp]
theorem from_ineqs_cons (e: inequality (n+1)) (l:ineqs (n+1))
: from_ineqs (e::l) =
   add_bound (bound.from_ineq e) (from_ineqs l) :=
begin
  simp [from_ineqs],
end

end from_ineqs

section
parameter {n:ℕ}

def to_ineqs (b:bound_list n) : ineqs n :=
  b.independent ++ (do l ← b.lower.to_list, inequality.from_pair l <$> b.upper.to_list)

theorem lower_upper_in_to_ineqs {l u:linear_expr n} {b: bound_list n}
(in_lower : l ∈ b.lower)
(in_upper : u ∈ b.upper)
: (inequality.from_pair l u ∈ to_ineqs b) := sorry

end

def solution {n:ℕ} (eqs:bound_list n) := { a : assignment ℚ (n+1) // eqs.satisfies a }

theorem to_ineqs_preserve_sat {n:ℕ} {b: bound_list n} (a:assignment ℚ (n+1))
(pr : bound_list.satisfies a b)
: ineqs.satisfies a.init b.to_ineqs :=
begin
  admit,
end

theorem lower_le_upper {n:ℕ} {b: bound_list n} (a:assignment ℚ n)
(pr : ineqs.satisfies a b.to_ineqs)
: bound_le (b.lower_bound a) (b.upper_bound a) :=
begin
  simp [lower_bound, upper_bound],
  apply bound_le_maximum_minimum,
  intros l u l_mem u_mem,
  apply exists.elim (linear_expr_list.mem_evaluate_implies l_mem),
  intros l_eq l_cond,
  apply exists.elim (linear_expr_list.mem_evaluate_implies u_mem),
  intros u_eq u_cond,
  have in_list := lower_upper_in_to_ineqs l_cond.left u_cond.left,
  have is_sat := ineqs.satisfies_list_implies_mem_satisfies pr in_list,
  simp [inequality.satisfies_from_pair] at is_sat,
  cc,
end

end bound_list

-----------------------------------------------------------------------
-- to_ineqs theorems

theorem bounded_list.satisfies_concat {n:ℕ} {b: bound_list n} (a:assignment ℚ n) {z : ℚ}
(pr : ineqs.satisfies a b.to_ineqs)
(sat_lower : le_bound (b.lower_bound a) z)
(sat_upper : ge_bound z (b.upper_bound a))
: bound_list.satisfies (a.concat z) b :=
begin
  unfold bound_list.satisfies,
  simp,
  simp [bound_list.to_ineqs] at pr,
  cc,
end

-----------------------------------------------------------------------
-- from_ineqs theorems

theorem from_ineqs_preserve_sat {n:ℕ} {l: ineqs (n+1)} (a:assignment ℚ (n+1))
: bound_list.satisfies a (bound_list.from_ineqs l) ↔ ineqs.satisfies a l :=
begin
  induction l,
  case list.nil { simp, },
  case list.cons h r ind {
    simp [bound_list.satisfies_add_bound],
    cc,
  },
end

def ineqs.solution.to_bound_list {n:ℕ} {b : bound_list n}
  : b.to_ineqs.solution → b.solution
| ⟨ a, pr ⟩ :=
  let z : ℚ := choose_bound (b.lower_bound a) (b.upper_bound a) in
  let qr : b.satisfies (assignment.concat a z) :=
        begin
          apply bounded_list.satisfies_concat _ pr,
          {
            apply le_bound_choose_bound,
          },
          {
            apply ge_bound_choose_bound,
            apply bound_list.lower_le_upper,
            apply pr,
          }
        end in
  ⟨ (a.concat z : assignment ℚ (n+1)), qr ⟩

def bound_list.solution.to_ineqs {n:ℕ} {l : ineqs (n+1)}
  : (bound_list.from_ineqs l).solution → l.solution
  | ⟨ a, pr ⟩ :=
    let qr : l.satisfies a := iff.mp (from_ineqs_preserve_sat _) pr in
    ⟨ a, qr ⟩

inductive sat_result {n:ℕ} (eqs:ineqs n)
| unsat : eqs.unsat_proof → sat_result
| sat : eqs.solution → sat_result

def solve_inequalities : Π {n:ℕ} (eqs:ineqs n), sat_result eqs
| 0 l :=
  if pr : l.satisfies assignment.empty then
    sat_result.sat ⟨ assignment.empty, pr ⟩
  else
    sat_result.unsat
    (begin
      unfold ineqs.unsat_proof,
      intros a,
      rw [assignment.zero_assignment_is_empty a],
      exact pr,
    end)
| (nat.succ n) l :=
  match solve_inequalities (bound_list.from_ineqs l).to_ineqs with
  | sat_result.sat a := sat_result.sat a.to_bound_list.to_ineqs
  | sat_result.unsat pr := sat_result.unsat $
     begin
       unfold ineqs.unsat_proof,
       intros a contra,
       unfold ineqs.unsat_proof at pr,
       apply pr a.init,
       apply bound_list.to_ineqs_preserve_sat a,
       apply iff.mpr (from_ineqs_preserve_sat a),
       exact contra,
     end
  end

-----------------------------------------------------------------------
-----------------------------------------------------------------------
-- Meta

open tactic

namespace linear

inductive type : Type
| nat : type
| int : type
| rat : type

meta def type.resolve : expr → string ⊕ type
| `(nat) := pure type.nat
| `(int) := pure type.int
| `(rat) := pure type.rat
| e := sum.inl ("Unknown type:" ++ to_string e)

set_option pp.all true

meta inductive lexpr : type → Type
| foreign : Π(tp:type), expr → lexpr tp
| add : Π{tp:type}, lexpr tp → lexpr tp → lexpr tp
| zero : Π(tp:type), lexpr tp
| one : Π(tp:type), lexpr tp
| bit0 : Π{tp:type}, lexpr tp → lexpr tp
| bit1 : Π{tp:type}, lexpr tp → lexpr tp

protected
meta def lexpr.resolve : Π(tp:type), expr → lexpr tp
| ltp `(@has_add.add %%tp %%inst %%x %%y) := lexpr.add (lexpr.resolve ltp x) (lexpr.resolve ltp y)
| ltp `(@has_zero.zero %%tp %%inst) := lexpr.zero ltp
| ltp `(@has_one.one %%tp %%inst)   := lexpr.one ltp
| ltp `(@bit0 %%tp %%inst %%x)                := lexpr.bit0 (lexpr.resolve ltp x)
| ltp `(@bit1 %%tp %%one_inst %%add_inst %%x) := lexpr.bit1 (lexpr.resolve ltp x)
| ltp e := lexpr.foreign ltp e

namespace lexpr

section to_string

protected
meta def to_string : ∀ {tp:type}, lexpr tp → string
| tp (foreign ._ x) := "<" ++ has_to_string.to_string x ++ ">"
| _ (add x y) := "(add " ++ to_string x ++ " " ++ to_string y ++ ")"
| tp (zero ._) := "(zero)"
| tp (one ._) := "(one)"
| _ (bit0 x) := "(bit0 " ++ to_string x ++ ")"
| _ (bit1 x) := "(bit1 " ++ to_string x ++ ")"

meta instance {tp:type} : has_to_string (lexpr tp) := ⟨@lexpr.to_string tp⟩

end to_string

end lexpr

meta inductive prop : Type
| eq : Π(tp:type), lexpr tp → lexpr tp → prop
| ge : Π(tp:type), lexpr tp → lexpr tp → prop
| gt : Π(tp:type), lexpr tp → lexpr tp → prop
| le : Π(tp:type), lexpr tp → lexpr tp → prop
| lt : Π(tp:type), lexpr tp → lexpr tp → prop

set_option pp.all true

meta def prop.mk_bin (f : Π(tp:type), lexpr tp → lexpr tp → prop)
   (resolve_tp : string ⊕ type) (l r : expr) : string ⊕ prop := do
   tp ← resolve_tp,
   pure (f tp (lexpr.resolve tp l) (lexpr.resolve tp r))

/- Resovle an expression into a prop.

N.B. This may do the wrong thing if the expression contains a
non-standard typeclass instance for a primitive type.
-/
meta def prop.resolve : expr → string ⊕ prop
| `(@eq.{1}    %%tp        %%l %%r) :=
  prop.mk_bin prop.eq (type.resolve tp) l r
| `(@ge        %%tp %%inst %%l %%r) := prop.mk_bin prop.ge (type.resolve tp) l r
| `(@gt        %%tp %%inst %%l %%r) := prop.mk_bin prop.gt (type.resolve tp) l r
| `(@has_le.le %%tp %%inst %%l %%r) := prop.mk_bin prop.ge (type.resolve tp) l r
| `(@has_lt.lt %%tp %%inst %%l %%r) := prop.mk_bin prop.gt (type.resolve tp) l r
| _ := sum.inl "Unknown expr"

namespace prop

protected
meta def to_string : prop → string
| (eq tp l r) := "eq " ++ l.to_string ++ " " ++ r.to_string
| (ge tp l r) := "ge " ++ l.to_string ++ " " ++ r.to_string
| (gt tp l r) := "gt " ++ l.to_string ++ " " ++ r.to_string
| (le tp l r) := "le " ++ l.to_string ++ " " ++ r.to_string
| (lt tp l r) := "lt " ++ l.to_string ++ " " ++ r.to_string

meta instance : has_to_string prop := ⟨ prop.to_string ⟩

end prop

meta def linear_solve : tactic unit := do
  intros,
  ctx ← local_context,
  ctx_types ← ctx.mmap infer_type,
  let pp (e : expr) : tactic unit := (do
        match prop.resolve e with
        | sum.inl msg :=
           trace (msg ++ "\n" ++ to_string e)
        | (sum.inr p) := do
          trace (to_string p)
        end),
  _ ← ctx_types.mmap pp,
  t ← target,
  match t with
  | `(true) := do
    trace (to_string (ctx.length)),
    exact `(true.intro)
  | _ := do
    let i := ctx_types.index_of t,
    if i < ctx.length then do
      match ctx.nth i with
      | (option.some pr) := exact pr
      | option.none := fail "ctx.nth failed"
      end
    else trace "nope", pure ()
  end

example (x y : ℕ) : x = 0 → x = 1 → y = 2 → y = 3 → x = 1 :=
begin
  intro p,
--  cc,

  linear_solve,

end

end linear


/-
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, Mario Carneiro

Subtype of open subsets in a topological space.
-/
import topology.bases topology.subset_properties topology.constructions

open filter lattice
variables {α : Type*} [topological_space α]

namespace topological_space
variable (α)
/-- The type of open subsets of a topological space. -/
def opens := {s : set α // _root_.is_open s}

/-- The type of closed subsets of a topological space. -/
def closeds := {s : set α // is_closed s}

/-- The type of non-empty compact subsets of a topological space. The
non-emptiness will be useful in metric spaces, as we will be able to put
a distance (and not merely an edistance) on this space. -/
def nonempty_compacts := {s : set α // s ≠ ∅ ∧ compact s}

section nonempty_compacts
open topological_space set
variable {α}

instance nonempty_compacts.to_compact_space {p : nonempty_compacts α} : compact_space p.val :=
⟨compact_iff_compact_univ.1 p.property.2⟩

instance nonempty_compacts.to_nonempty {p : nonempty_compacts α} : nonempty p.val :=
nonempty_subtype.2 $ ne_empty_iff_exists_mem.1 p.property.1

/-- Associate to a nonempty compact subset the corresponding closed subset -/
def nonempty_compacts.to_closeds [t2_space α] (s : nonempty_compacts α) : closeds α :=
⟨s.val, closed_of_compact _ s.property.2⟩

end nonempty_compacts

variable {α}
namespace opens
instance : has_coe (opens α) (set α) := { coe := subtype.val }

instance : has_subset (opens α) :=
{ subset := λ U V, U.val ⊆ V.val }

instance : has_mem α (opens α) :=
{ mem := λ a U, a ∈ U.val }

@[extensionality] lemma ext {U V : opens α} (h : U.val = V.val) : U = V := subtype.ext.mpr h

instance : partial_order (opens α) := subtype.partial_order _

def interior (s : set α) : opens α := ⟨interior s, is_open_interior⟩

def gc : galois_connection (subtype.val : opens α → set α) interior :=
λ U s, ⟨λ h, interior_maximal h U.property, λ h, le_trans h interior_subset⟩

def gi : @galois_insertion (order_dual (set α)) (order_dual (opens α)) _ _ interior (subtype.val) :=
{ choice := λ s hs, ⟨s, interior_eq_iff_open.mp $ le_antisymm interior_subset hs⟩,
  gc := gc.dual,
  le_l_u := λ _, interior_subset,
  choice_eq := λ s hs, le_antisymm interior_subset hs }

@[simp] lemma gi_choice_val {s : order_dual (set α)} {hs} : (gi.choice s hs).val = s := rfl

instance : complete_lattice (opens α) :=
complete_lattice.copy
(@order_dual.lattice.complete_lattice _
  (@galois_insertion.lift_complete_lattice
    (order_dual (set α)) (order_dual (opens α)) _ interior (subtype.val : opens α → set α) _ gi))
/- le  -/ (λ U V, U.1 ⊆ V.1) rfl
/- top -/ ⟨set.univ, _root_.is_open_univ⟩ (subtype.ext.mpr interior_univ.symm)
/- bot -/ ⟨∅, is_open_empty⟩ rfl
/- sup -/ (λ U V, ⟨U.1 ∪ V.1, _root_.is_open_union U.2 V.2⟩) rfl
/- inf -/ (λ U V, ⟨U.1 ∩ V.1, _root_.is_open_inter U.2 V.2⟩)
begin
  funext,
  apply subtype.ext.mpr,
  symmetry,
  apply interior_eq_of_open,
  exact (_root_.is_open_inter U.2 V.2),
end
/- Sup -/ (λ Us, ⟨⋃₀ (subtype.val '' Us), _root_.is_open_sUnion $ λ U hU,
by { rcases hU with ⟨⟨V, hV⟩, h, h'⟩, dsimp at h', subst h', exact hV}⟩)
begin
  funext,
  apply subtype.ext.mpr,
  simp [Sup_range],
  refl,
end
/- Inf -/ _ rfl

instance : has_inter (opens α) := ⟨λ U V, U ⊓ V⟩
instance : has_union (opens α) := ⟨λ U V, U ⊔ V⟩
instance : has_emptyc (opens α) := ⟨⊥⟩

@[simp] lemma inter_eq (U V : opens α) : U ∩ V = U ⊓ V := rfl
@[simp] lemma union_eq (U V : opens α) : U ∪ V = U ⊔ V := rfl
@[simp] lemma empty_eq : (∅ : opens α) = ⊥ := rfl

@[simp] lemma Sup_s {Us : set (opens α)} : (Sup Us).val = ⋃₀ (subtype.val '' Us) :=
begin
  rw [@galois_connection.l_Sup (opens α) (set α) _ _ (subtype.val : opens α → set α) interior gc Us, set.sUnion_image],
  congr
end

def is_basis (B : set (opens α)) : Prop := is_topological_basis (subtype.val '' B)

lemma is_basis_iff_nbhd {B : set (opens α)} :
  is_basis B ↔ ∀ {U : opens α} {x}, x ∈ U → ∃ U' ∈ B, x ∈ U' ∧ U' ⊆ U :=
begin
  split; intro h,
  { rintros ⟨sU, hU⟩ x hx,
    rcases (mem_nhds_of_is_topological_basis h).mp (mem_nhds_sets hU hx) with ⟨sV, ⟨⟨V, H₁, H₂⟩, hsV⟩⟩,
    refine ⟨V, H₁, _⟩,
    cases V, dsimp at H₂, subst H₂, exact hsV },
  { refine is_topological_basis_of_open_of_nhds _ _,
    { rintros sU ⟨U, ⟨H₁, H₂⟩⟩, subst H₂, exact U.property },
    { intros x sU hx hsU,
      rcases @h (⟨sU, hsU⟩ : opens α) x hx with ⟨V, hV, H⟩,
      exact ⟨V, ⟨V, hV, rfl⟩, H⟩ } }
end

lemma is_basis_iff_cover {B : set (opens α)} :
  is_basis B ↔ ∀ U : opens α, ∃ Us ⊆ B, U = Sup Us :=
begin
  split,
  { intros hB U,
    rcases sUnion_basis_of_is_open hB U.property with ⟨sUs, H, hU⟩,
    existsi {U : opens α | U ∈ B ∧ U.val ∈ sUs},
    split,
    { intros U hU, exact hU.left },
    { apply ext,
      rw [Sup_s, hU],
      congr,
      ext s; split; intro hs,
      { rcases H hs with ⟨V, hV⟩,
        rw ← hV.right at hs,
        refine ⟨V, ⟨⟨hV.left, hs⟩, hV.right⟩⟩ },
      { rcases hs with ⟨V, ⟨⟨H₁, H₂⟩, H₃⟩⟩,
        subst H₃, exact H₂ } } },
  { intro h,
    rw is_basis_iff_nbhd,
    intros U x hx,
    rcases h U with ⟨Us, hUs, H⟩,
    replace H := congr_arg subtype.val H,
    rw Sup_s at H,
    change x ∈ U.val at hx,
    rw H at hx,
    rcases set.mem_sUnion.mp hx with ⟨sV, ⟨⟨V, H₁, H₂⟩, hsV⟩⟩,
    refine ⟨V,hUs H₁,_⟩,
    cases V with V hV,
    dsimp at H₂, subst H₂,
    refine ⟨hsV,_⟩,
    change V ⊆ U.val, rw H,
    exact set.subset_sUnion_of_mem ⟨⟨V, _⟩, ⟨H₁, rfl⟩⟩ }
end

end opens

end topological_space


import model4_c
import model_theory.satisfiability

lemma not_iso_A_B : is_empty (first_order.language.equiv first_order.language.unary_preds (fin 3 × ℕ) (fin 2 × ℕ)) :=
begin
  rw is_empty_iff,
  intro f,
  induction f with fbij h₂ h₁,
  simp at *,
  have h₃ := h₁ (first_order.language.up₁),
  specialize h₁ (first_order.language.up₂),

  specialize h₃ ![(2, 1)],
  specialize h₁ ![(2, 1)],
  rw matrix.vec_single_eq_const at *,
  simp at *,
  rw ← function.const_def at *,
  rw ← matrix.vec_single_eq_const at *,
  rw ← matrix.vec_single_eq_const at *,
  generalize eq₁ : (fbij (2, 1)) = x,
  rw eq₁ at *,
  induction x,
  induction x_fst,
  cases x_fst_val,
  rw first_order.language.Structure.rel_map_apply₁ at *,
  rw first_order.language.Structure.rel_map_apply₁ at *,
  rw first_order.language.up₁ at *,
  rw first_order.language.up₂ at *,
  simp at *,
  injections_and_clear,
  norm_num at h_1,
  cases x_fst_val,
  rw first_order.language.Structure.rel_map_apply₁ at *,
  rw first_order.language.Structure.rel_map_apply₁ at *,
  rw first_order.language.up₁ at *,
  rw first_order.language.up₂ at *,
  simp at *,
  injections_and_clear,
  norm_num at *,
  simp at *,
  clear h₃ h₁ h₂,
  rw nat.succ_lt_succ_iff at *,
  rw nat.succ_lt_succ_iff at *,
  linarith,
end

example : ¬ (cardinal.categorical (cardinal.aleph_0) (first_order.language.Theory.disjoint_unary_preds)) :=
begin
  rw cardinal.categorical,
  simp,
  fconstructor,
  use ModelA,
  split,
  rw ModelA,
  simp,
  exact modelAℵ₀,
  use ModelB,
  split,
  exact modelBℵ₀,
  exact not_iso_A_B,
end


import tactic
import tactic.induction

import .base .bounded .lemma_2_1

noncomputable theory
open_locale classical

def A_trapped_in (pw : ℕ) (s : State) (N : ℕ) :=
∀ (a : A pw) (d : D) (n : ℕ), ((init_game a d s).play n).s.board.A ∈ bounded N

def A_trapped (pw : ℕ) (s : State) :=
∃ (N : ℕ), A_trapped_in pw s N

def can_entrap_in {pw : ℕ} (a : A pw) (d : D) (N : ℕ) :=
∃ (n : ℕ), A_trapped_in pw (simulate a d n).s N

def D_nice_cond (pw : ℕ) (s : State) (n : ℕ) : Prop :=
A_trapped_in pw s n ∧ ∃ (md : Valid_D_move s.board) (p : Point),
md.m = some p ∧ p ∈ bounded n

def D.nice (d : D) (pw : ℕ) :=
∀ (s : State) (hs : s.act) (N : ℕ),
if D_nice_cond pw s N
then ∃ (p : Point),
  (d.f s hs).m = some p ∧
  p ∈ bounded N
else ∀ (p : Point) (b : Board),
  (d.f s hs).m = some p →
  b ∈ s.history →
  pw < dist p b.A

-----

lemma A_trapped_in_ge {pw n k : ℕ} {s : State}
  (h₁ : A_trapped_in pw s k)
  (h₂ : k ≤ n) :
  A_trapped_in pw s n :=
λ a d m, mem_bounded_ge (h₁ a d m) h₂

lemma can_entrap_in_ge {pw n k : ℕ} {a : A pw} {d : D}
  (h₁ : can_entrap_in a d k)
  (h₂ : k ≤ n) :
  can_entrap_in a d n :=
⟨_, A_trapped_in_ge h₁.some_spec h₂⟩

lemma D_nice_cond_ge {pw n k : ℕ} {s : State}
  (h₁ : D_nice_cond pw s k)
  (h₂ : k ≤ n) :
  D_nice_cond pw s n :=
begin
  obtain ⟨md, p, h₃, h₄⟩ := h₁.2,
  exact ⟨A_trapped_in_ge h₁.1 h₂, _, _, h₃, mem_bounded_ge h₄ h₂⟩,
end

lemma mem_bounded_of_A_trapped_in {pw N : ℕ} {s : State}
  (h : A_trapped_in pw s N) :
  s.board.A ∈ bounded N :=
h default default 0

lemma mem_bounded_apply_D_move_of_A_trapped_in {pw N : ℕ}
  {s : State} {md : D_move}
  (h : A_trapped_in pw s N) :
  (apply_D_move s md).board.A ∈ bounded N :=
by { rw apply_D_move_A_eq, exact mem_bounded_of_A_trapped_in h }

lemma mem_bounded_apply_A_move_of_A_trapped_in {pw N : ℕ}
  {s s' : State} {ma : Valid_A_move pw s'.board} {md : Valid_D_move s.board}
  (h₁ : A_trapped_in pw s N)
  (h₂ : s' = apply_D_move s md.m) :
  (apply_A_move s' ma.m).board.A ∈ bounded N :=
begin
  specialize h₁ ((default : A pw).set_move s' ma) ((default : D).set_move s md) 1,
  rw play_1 at h₁,
  rw Game.play_move at h₁,
  split_ifs at h₁ with h₃,
  {
    rw play_A_move_at at h₁,
    rw dif_pos at h₁, swap,
    {
      clear h₁,
      use h₃,
      subst s',
      use ma.m,
      revert h₃,
      simp,
      intro h₃,
      generalize_proofs,
      sorry,
      -- rw (_ : (init_game _ _ _).s = s),
    },
    sorry,
  },
  sorry,
end

#exit

lemma squares_in_bounded_exc_A_lt_bounded_area_of_A_trapped_in
  {pw N : ℕ} {s : State}
  (h : A_trapped_in pw s N) :
  squares_in_bounded_exc_A s.board N < bounded_area N :=
begin
  have h₃ := mem_bounded_of_A_trapped_in h,
  rw [squares_in_bounded_exc_A, bounded_area],
  apply finset.card_lt_card, rw finset.ssubset_iff,
  use s.board.A, fsplit,
  { simp },
  { rintro p hp, rw finset.mem_insert at hp,
    rw set.mem_to_finset, cases hp,
    { subst p, exact h₃ },
    { rw [finset.mem_filter, set.mem_to_finset] at hp, exact hp.1 }},
end

lemma A_trapped_in_play_move {pw N : ℕ} {g : Game pw}
  (h : A_trapped_in pw g.s N) :
  A_trapped_in pw g.play_move.s N :=
begin
  sorry
end

lemma nice_D_wins_upper_bound_of_A_trapped_in {pw N : ℕ}
  {a : A pw} {d : D} {s₀ : State}
  (h₀ : valid_state pw s₀)
  (h₁ : d.nice pw)
  (h₂ : A_trapped_in pw s₀ N) :
  ¬((init_game a d s₀).play (bounded_area N)).act :=
begin
  apply not_act_of_descend_play_move_valid
    (λ (s : State), squares_in_bounded_exc_A s.board N)
    (λ (s : State), A_trapped_in pw s N); try { dsimp },
  sorry {
    exact h₀,
  },
  sorry {
    exact squares_in_bounded_exc_A_lt_bounded_area_of_A_trapped_in h₂,
  },
  sorry {
    exact h₂,
  },
  sorry {
    rintro s hv hs₁ h₃,
    exact A_trapped_in_play_move h₃,
  },
  {
    rintro s hv hs₁ h₃,
    obtain ⟨s', hs, hs', hvm, h₄, h₅⟩ := play_move_state_eq_of_act_play_move hs₁,
    rw h₅, clear h₅,
    simp only [init_game_a_eq, init_game_d_eq, init_game_s_eq] at *,
    rw (_ : squares_in_bounded_exc_A (apply_A_move _ _).board N =
      squares_in_bounded_exc_A s'.board N), swap,
    {
      simp_rw squares_in_bounded_exc_A,
      let ma : Valid_A_move pw s'.board := _,
      change (a.f s' hs' hvm) with ma,
      let t : finset Point := _,
      change _ = t.card,
      have hma₁ : ma.m ∈ bounded N,
      {
        sorry
      },
      have hma₂ : ma.m ∈ s'.board.squares,
      sorry,
      have hma₃ : ma.m ≠ s'.board.A,
      sorry,
      have h₅ : ma.m ∈ t,
      sorry {
        rw [finset.mem_filter, set.mem_to_finset],
        exact ⟨hma₁, hma₂, hma₃⟩,
      },
      have h₆ : s'.board.A ∉ t,
      sorry {
        rw finset.mem_filter,
        simp,
      },
      convert finset_card_insert_erase_eq h₅ h₆,
      ext p,
      simp_rw [finset.mem_filter, finset.mem_insert,
        set.mem_to_finset, finset.mem_erase],
      change (apply_A_move s' ma.m).board.A with ma.m,
      change (apply_A_move s' ma.m).board.squares with s'.board.squares,
      by_cases h₇ : p = ma.m,
      sorry {
        subst p,
        simp,
        exact ma.h.1,
      },
      {
        simp only [true_and, and_true, set.mem_to_finset, ne.def, not_false_iff,
          finset.mem_filter, h₇],
        split; intro h₈,
        sorry {
          tauto,
        },
        {
          change _ ≠ _ at h₇,
          cases h₈,
          {
            clear h₇,
            subst h₈,
            fsplit,
            sorry {
              subst s',
              exact mem_bounded_apply_D_move_of_A_trapped_in h₃,
            },
            {
              sorry -- valid_state pw s
            },
          },
          sorry {
            tauto,
          },
        },
      },
    },
    sorry -- because nice D eats one non-A square from `Bounded N`
  },
end

#exit

lemma nice_D_wins_of_can_entrap_in {pw N : ℕ} {a : A pw} {d : D}
  (h₁ : d.nice pw)
  (h₂ : can_entrap_in a d N) :
  (init_game a d state₀).D_wins :=
begin
  cases h₂ with n h₂, suffices h₃ : ∃ (k : ℕ), ¬(simulate a d (n + k)).act,
  { exact ⟨_, h₃.some_spec⟩ },
  simp_rw simulate_add,let g : Game pw := _,
  change simulate a d n with g at h₂ ⊢, split,
  rw (_ : g = init_game a d g.s), swap,
  { ext,
    { exact play_at_players_eq.1 },
    { exact play_at_players_eq.2 },
    { refl }},
  exact nice_D_wins_upper_bound_of_A_trapped_in h₁ h₂,
end

lemma lem_2_3 {pw : ℕ}
  (h : ∃ (N : ℕ) (d : D), d.nice pw ∧ ∀ (a : A pw), can_entrap_in a d N) :
  ∃ (d : D), d.nice pw ∧ ∀ (a : A pw), (init_game a d state₀).D_wins :=
begin
  rcases h with ⟨N, d, h₁, h₂⟩, use [d, h₁], intro a,
  specialize h₂ a, exact nice_D_wins_of_can_entrap_in h₁ h₂,
end

lemma lem_2_3' {pw : ℕ}
  (h : ∃ (a : A pw), ∀ (d : D) (N : ℕ), d.nice pw →
  ¬A_trapped_in_for a d (bounded N)) :
  ∃ (a : A pw), ∀ (d : D), d.nice pw → (init_game a d state₀).A_wins :=
begin
  cases h with a h, use a, rintro d h₁, specialize h d,
  replace h : ∀ (N : ℕ), ¬A_trapped_in_for a d (bounded N),
  { intro n, exact h n h₁ },
  intro n, contrapose! h, use n * pw, intro k, by_cases h₂ : k ≤ n,
  { exact A_bounded_n_pw h₂ },
  { change ¬(simulate a d n).act at h, have h₃ : ¬(simulate a d k).act,
    { contrapose! h, push_neg at h₂, obtain ⟨k, rfl⟩ := nat.exists_eq_add_of_lt h₂,
      rw add_assoc at h, rw [simulate, play_add] at h, apply act_of_act_play h },
    have h₄ : simulate a d k = simulate a d n,
    { exact play_eq_of_not_act h₃ h },
    rw h₄, apply A_bounded_n_pw, refl },
end


import algebra.ring group_theory.submonoid ring_theory.ideal_operations linear_algebra.basic
import ring_theory.localization

namespace localization_alt

universes u v w
variables {A : Type u} {B : Type v} {C : Type w}
variables [comm_ring A] [comm_ring B] [comm_ring C]
variables (S : set A) [is_submonoid S] (f : A → B) [is_ring_hom f]

/- This is essentially the same logic as units.ext, but in more
   convenient form.
-/
lemma comm_monoid.inv_unique {M : Type*} [comm_monoid M]
  {a ai₁ ai₂ : M} (e₁ : a * ai₁ = 1) (e₂ : a * ai₂ = 1) : ai₁ = ai₂ :=
by rw [← mul_one ai₁, ← e₂, ← mul_assoc, mul_comm ai₁, e₁, one_mul]

/-- preserve definitional equality -/
def ideal.mk (I : set A) (J : ideal A) (H : I = J) : ideal A :=
{ carrier := I,
  zero := H.symm ▸ J.zero,
  add := H.symm ▸ J.add,
  smul := H.symm ▸ J.smul }

def ker : ideal A :=
ideal.mk {x | f x = 0} (ideal.comap f ⊥) $
set.ext $ λ x, (submodule.mem_bot B).symm--(submodule.mem_bot _).symm

def inverts_data (S : set A) (f : A → B) : Type* :=
Π s : S, {si : B // (f s) * si = 1}

def inverts (S : set A) (f : A → B) : Prop :=
∀ s : S, ∃ si : B, (f s) * si = 1

lemma inverts_subsingleton (S : set A) (f : A → B) :
  subsingleton (inverts_data S f) :=
⟨λ fi1 fi2, funext $ λ s, subtype.eq $ comm_monoid.inv_unique (fi1 s).2 (fi2 s).2⟩

def inverts_of_data (h : inverts_data S f) : inverts S f :=
λ s, ⟨(h s).1,(h s).2⟩

noncomputable def inverts_some (h : inverts S f) : inverts_data S f :=
λ s, classical.indefinite_description _ (h s)

def has_denom_data (S : set A) (f : A → B) :=
Π b : B, {sa : S × A // (f sa.1) * b = f sa.2 }

def has_denom (S : set A) (f : A → B) : Prop :=
∀ b : B, ∃ (sa : S × A), (f sa.1) * b = (f sa.2)

def has_denom_of_data (h : has_denom_data S f) : has_denom S f :=
λ b, subtype.exists_of_subtype (h b)

noncomputable def has_denom_some (h : has_denom S f) : has_denom_data S f :=
λ b, classical.indefinite_description _ (h b)

def ann_aux (S : set A) [is_submonoid S] : Type* :=
{ as : A × S // as.1 * as.2 = 0 }

namespace ann_aux

def zero : ann_aux S := ⟨(0, 1), mul_one _⟩

def add (as bt : ann_aux S) : ann_aux S :=
⟨(as.1.1 + bt.1.1, as.1.2 * bt.1.2), show (as.1.1 + bt.1.1) * (as.1.2 * bt.1.2) = 0,
by rw [add_mul, ← mul_assoc, as.2, zero_mul, zero_add, mul_left_comm, bt.2, mul_zero]⟩

def smul (a : A) (bt : ann_aux S) : ann_aux S :=
⟨(a * bt.1.1, bt.1.2), show (a * bt.1.1) * bt.1.2 = 0, by rw [mul_assoc, bt.2, mul_zero]⟩

end ann_aux

def submonoid_ann (S : set A) [is_submonoid S] : ideal A :=
{ carrier := set.range (λ as : ann_aux S, as.1.1),
  zero := ⟨ann_aux.zero S, rfl⟩,
  add := λ _ _ ⟨as,has⟩ ⟨bt,hbt⟩, ⟨ann_aux.add S as bt, has ▸ hbt ▸ rfl⟩,
  smul := λ a _ ⟨bt,h⟩, ⟨ann_aux.smul S a bt, h ▸ rfl⟩ }

lemma inverts_ker (hf : inverts S f) : submonoid_ann S ≤ ker f :=
λ x ⟨⟨⟨a,s⟩,asz⟩,rfl⟩, let ⟨si,e1⟩ := hf s in show f x = 0,
by rw [← mul_one (f x), ← e1, ← mul_assoc, ← is_ring_hom.map_mul f, asz, is_ring_hom.map_zero f, zero_mul]

structure is_localization_data :=
(inverts : inverts_data S f)
(has_denom : has_denom_data S f)
(ker_le : ker f ≤ submonoid_ann S)

def is_localization : Prop :=
(inverts S f) ∧ (has_denom S f) ∧ (ker f = submonoid_ann S)

lemma localization_epi (hf : is_localization S f)
  (g₁ g₂ : B → C) [is_ring_hom g₁] [is_ring_hom g₂]
  (e : g₁ ∘ f = g₂ ∘ f) : g₁ = g₂ :=
begin
  have e' : ∀ x, g₁ (f x) = g₂ (f x) := λ x, by convert congr_fun e x,
  ext b,
  rcases hf.2.1 b with ⟨⟨s,a⟩,e1⟩,
  rcases hf.1 s with ⟨si,e2⟩,
  have e4 : g₁ (f s) * (g₁ si) = 1,
  { rw [← is_ring_hom.map_mul g₁, e2, is_ring_hom.map_one g₁] },
  have e5 : g₁ (f s) * (g₂ si) = 1,
  { rw [e', ← is_ring_hom.map_mul g₂, e2, is_ring_hom.map_one g₂] },
  rw [← mul_one b, ← e2, mul_left_comm, ← mul_assoc, e1],
  rw [is_ring_hom.map_mul g₁, is_ring_hom.map_mul g₂, e', comm_monoid.inv_unique e4 e5]
end

section localization_initial
variables (hf : is_localization_data S f) (g : A → C) [is_ring_hom g] (hg : inverts_data S g)

def is_localization_initial (hf : is_localization_data S f)
  (g : A → C) [is_ring_hom g] (hg : inverts_data S g) : B → C :=
λ b, g (hf.has_denom b).1.2 * hg (hf.has_denom b).1.1

lemma useful (hf : is_localization_data S f) (g : A → C) [is_ring_hom g] (hg : inverts_data S g)
  {a₁ a₂ : A} (H : f a₁ = f a₂) : g a₁ = g a₂ :=
begin
  rw [← sub_eq_zero, ← is_ring_hom.map_sub f] at H,
  rw [← sub_eq_zero, ← is_ring_hom.map_sub g],
  generalize_hyp : a₁ - a₂ = a at H ⊢,
  rcases hf.3 H with ⟨⟨as,h1⟩,h2⟩,
  rw [← h2],
  cases hg as.2 with c h3,
  rw [← mul_one (g as.1), ← h3, ← mul_assoc, ← is_ring_hom.map_mul g, h1, is_ring_hom.map_zero g, zero_mul]
end

lemma useful2 {x y z w : A} (h : x * y = 1) : z * x = w * x ↔ z = w :=
⟨λ H, have _ := congr_arg (* y) H, by rwa [mul_assoc, h, mul_one, mul_assoc, h, mul_one] at this,
λ H, by rw H⟩

instance (hf : is_localization_data S f) (g : A → C) [is_ring_hom g] (hg : inverts_data S g) :
  is_ring_hom (is_localization_initial S f hf g hg) :=
{ map_one := begin
    unfold is_localization_initial,
    rcases hf.has_denom 1 with ⟨⟨s,a⟩,h⟩,
    dsimp only at *,
    rw mul_one at h, replace h := useful S f hf g hg h,
    cases hg s with c hc,
    rw ← h, exact hc
  end,
  map_mul := λ x y, begin
    unfold is_localization_initial,
    rcases hf.has_denom x with ⟨⟨sx,ax⟩,h1⟩,
    rcases hf.has_denom y with ⟨⟨sy,ay⟩,h2⟩,
    rcases hf.has_denom (x*y) with ⟨⟨sxy,axy⟩,h3⟩,
    cases hg sx with sigx h4,
    cases hg sy with sigy h5,
    cases hg sxy with sigxy h6,
    cases hf.inverts sx with sifx h7,
    cases hf.inverts sy with sify h8,
    cases hf.inverts sxy with sifxy h9,
    dsimp only [subtype.coe_mk] at *,
    replace h1 : _ * _ = _ * _ := by convert congr_arg (* sifx) h1,
    rw [mul_right_comm, h7, one_mul] at h1,
    replace h2 : _ * _ = _ * _ := by convert congr_arg (* sify) h2,
    rw [mul_right_comm, h8, one_mul] at h2,
    rw [h1, h2] at h3,
    rw [← useful2 h4, ← useful2 h5, ← useful2 h6],
    have : g axy * sigxy * g ↑sx * g ↑sy * g ↑sxy = g axy * g ↑sx * g ↑sy * (g ↑sxy * sigxy),
    { simp only [mul_assoc, mul_comm, mul_left_comm] }, rw [this, h6, mul_one], clear this,
    have : g ax * sigx * (g ay * sigy) * g ↑sx * g ↑sy * g ↑sxy = g ax * g ay * g ↑sxy * (g ↑sx * sigx) * (g ↑sy * sigy),
    { simp only [mul_assoc, mul_comm, mul_left_comm] }, rw [this, h4, h5, mul_one, mul_one], clear this,
    iterate 4 { rw ← is_ring_hom.map_mul g }, apply useful S f hf g hg,
    iterate 4 { rw is_ring_hom.map_mul f }, rw ← h3,
    have : f ↑sxy * (f ax * sifx * (f ay * sify)) * f ↑sx * f ↑sy = f ax * f ay * f ↑sxy * (f ↑sx * sifx) * (f ↑sy * sify),
    { simp only [mul_assoc, mul_comm, mul_left_comm] }, rw [this, h7, h8, mul_one, mul_one]
  end,
  map_add := λ x y, begin
    unfold is_localization_initial,
    rcases hf.has_denom x with ⟨⟨sx,ax⟩,h1⟩,
    rcases hf.has_denom y with ⟨⟨sy,ay⟩,h2⟩,
    rcases hf.has_denom (x+y) with ⟨⟨sxy,axy⟩,h3⟩,
    cases hg sx with sigx h4,
    cases hg sy with sigy h5,
    cases hg sxy with sigxy h6,
    cases hf.inverts sx with sifx h7,
    cases hf.inverts sy with sify h8,
    cases hf.inverts sxy with sifxy h9,
    dsimp only [subtype.coe_mk] at *,
    replace h1 : _ * _ = _ * _ := by convert congr_arg (* sifx) h1,
    rw [mul_right_comm, h7, one_mul] at h1,
    replace h2 : _ * _ = _ * _ := by convert congr_arg (* sify) h2,
    rw [mul_right_comm, h8, one_mul] at h2,
    rw [h1, h2] at h3,
    rw [← useful2 h4, ← useful2 h5, ← useful2 h6],
    have : g axy * sigxy * g ↑sx * g ↑sy * g ↑sxy = g axy * g ↑sx * g ↑sy * (g ↑sxy * sigxy),
    { simp only [mul_assoc, mul_comm, mul_left_comm] }, rw [this, h6, mul_one], clear this,
    have : (g ax * sigx + g ay * sigy) * g ↑sx * g ↑sy * g ↑sxy =
      g ax * g ↑sy * g ↑sxy * (g ↑sx * sigx) + g ay * g ↑sx * g ↑sxy * (g ↑sy * sigy),
    { simp only [add_mul, mul_add, mul_assoc, mul_comm, mul_left_comm] }, rw [this, h4, h5, mul_one, mul_one], clear this,
    iterate 6 { rw ← is_ring_hom.map_mul g }, rw ← is_ring_hom.map_add g, apply useful S f hf g hg,
    rw is_ring_hom.map_add f, iterate 6 { rw is_ring_hom.map_mul f }, rw ← h3,
    have : f ↑sxy * (f ax * sifx + f ay * sify) * f ↑sx * f ↑sy =
      f ax * f ↑sy * f ↑sxy * (f ↑sx * sifx) + f ay * f ↑sx * f ↑sxy * (f ↑sy * sify),
    { simp only [add_mul, mul_add, mul_assoc, mul_comm, mul_left_comm] }, rw [this, h7, h8, mul_one, mul_one]
  end }

lemma is_localization_initial_comp (hf : is_localization_data S f)
  (g : A → C) [is_ring_hom g] (hg : inverts_data S g) (a : A) :
  is_localization_initial S f hf g hg (f a) = g a :=
begin
  unfold is_localization_initial,
  rcases hf.has_denom (f a) with ⟨⟨s,x⟩,h1⟩,
  cases hg s with si h2,
  dsimp only [subtype.coe_mk] at *,
  rw [← useful2 h2, mul_right_comm, mul_assoc, h2, mul_one, ← is_ring_hom.map_mul g],
  apply useful S f hf g hg,
  rw [← h1, is_ring_hom.map_mul f, mul_comm]
end

end localization_initial

end localization_alt

-- Now applications

/- https://leanprover.zulipchat.com/#narrow/stream/116395-maths/topic/cardinality.20of.20integers.20modulo.20n/near/155197619

Here are some basic test cases:
1. Can we identity A[a−1][b−1]A[a^{-1}][b^{-1}]A[a−1][b−1] with A[(ab)−1]A[(ab)^{-1}]A[(ab)−1]?
2. If e2=ee^2=ee2=e, can we identify A[e−1]A[e^{-1}]A[e−1] with A/(1−e)A/(1-e)A/(1−e)?
3. If we define Z(p)\mathbb{Z}_{(p)}Z(p) as a subring of Q\mathbb{Q}Q, can we produce the ring map Z(p)→Z/p\mathbb{Z}_{(p)}\to\mathbb{Z}/pZ(p)→Z/p?
I think that all of the maps implicit in these examples should be computable under very mild assumptions.

1) R[1/f][1/g]=R[1/fg]
2) If e^2=e then is R[1/e]=R/(1-e)
3) Z_{(p)} -> Z/pZ if Z_{(p)} is a sub of Q?

Reid said:

The test case would be to prove that a composition of is_localization maps is is_localization
  19:32

which should be easy with the universal property

-/
--lemma loc_loc (A : Type*) [comm_ring A] [f g : A] :

lemma invert_powers_of_invert {A B : Type*} [comm_ring A] [comm_ring B]
  {f : A → B} [is_ring_hom f] {a : A}
{b : B} (hb : f a * b = 1) : localization_alt.inverts (powers a) f :=
begin
 rintro ⟨z,n,h⟩,
 use b ^ n,
 show f z * b ^ n = 1,
 rw [←h, is_semiring_hom.map_pow f, ←mul_pow, hb, one_pow],
end

example {R : Type*} [comm_ring R] (e : R) (he : e * e = e) : localization_alt.is_localization (powers e) (ideal.quotient.mk (ideal.span {1-e})) :=
begin
  have H1 : ideal.quotient.mk (ideal.span {1 - e}) e = 1,
  { exact eq.symm (ideal.quotient.eq.2 $ ideal.subset_span $ or.inl rfl) },
  have H2 : (1 - e) * e = 0,
  { rw [sub_mul, he, one_mul, sub_self] },
  refine ⟨_, _, _⟩,
  { rintros ⟨_, n, rfl⟩, use 1,
    change ideal.quotient.mk _ (e^n * 1) = _,
    rw [mul_one, is_semiring_hom.map_pow (ideal.quotient.mk (ideal.span {1-e})) e n, H1, one_pow] },
  { rintro ⟨x⟩, use (1,x), exact one_mul _ },
  { ext x, split; intro hx,
    { replace hx := ideal.quotient.eq_zero_iff_mem.1 hx,
      replace hx := ideal.mem_span_singleton'.1 hx,
      refine ⟨⟨(x, ⟨e, 1, pow_one e⟩), _⟩, rfl⟩,
      cases hx with y hx, change x * e = 0, rw [← hx, mul_assoc, H2, mul_zero] },
    { rcases hx with ⟨⟨⟨x, ⟨_, n, rfl⟩⟩, hx⟩, rfl⟩, change x * e^n = 0 at hx,
      apply ideal.quotient.eq_zero_iff_mem.2,
      apply ideal.mem_span_singleton'.2,
      change ∃ a, a * (1-e) = x, induction n with n ih generalizing x,
      { rw [pow_zero, mul_one] at hx, subst hx, use 0, rw zero_mul },
      rw [pow_succ, ← mul_assoc] at hx, cases ih _ hx with y hy,
      use x + y, rw [add_mul, hy, ← mul_add, sub_add_cancel, mul_one] } },
end

def Z_loc_p {p : ℕ} (hp : nat.prime p) : Type := {q : ℚ // rat.denom q % p ≠ 0 }

namespace Z_loc_p

protected def zero {p : ℕ} (hp : nat.prime p) : Z_loc_p hp := ⟨(0 : ℚ),begin
  show 1 % p ≠ 0,
  rw nat.mod_eq_of_lt, simp,
  exact hp.1,
end⟩

end Z_loc_p