/-
Copyright 2020 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 -/
import measure_theory.measurable_space

import measure_theory.measure_space
import measure_theory.outer_measure
import measure_theory.lebesgue_measure
import measure_theory.integration

import measure_theory.borel_space
import data.set.countable
import formal_ml.nnreal
import formal_ml.ennreal
import formal_ml.sum
import formal_ml.lattice
import formal_ml.measurable_space
import formal_ml.classical
import formal_ml.core
import formal_ml.characteristic
import formal_ml.measure
import data.equiv.list

noncomputable def pi.outer_measure {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} [M:∀ a, measurable_space (β a)]
  (μ:Π a, measure_theory.outer_measure (β a)):measure_theory.outer_measure (Π a, β a) :=
  measure_theory.outer_measure.of_function
  (λ P:set (Π a, β a), finset.univ.prod (λ (a:α), (μ a) ((λ (p:Π a, β a), p a) '' P)))
begin
  simp,
  rw finset.card_pos,
  rw finset.univ_nonempty_iff,
  apply N,
end

section pi

open_locale classical

lemma ennreal.prod_le_prod {α:Type*} {f g:α → ennreal} {s:finset α}:(∀ a∈ s, f a ≤ g a) → s.prod f ≤ s.prod g :=
begin
  apply finset.induction_on s,
  { intros h_le, simp, apply le_refl _ },
  { intros a s' h_not_mem h_ind h_le,
    rw finset.prod_insert h_not_mem, rw finset.prod_insert h_not_mem,
    apply ennreal.mul_le_mul,
    apply h_le, simp,
    apply h_ind, intros a' h_le_a',
    apply h_le, simp [h_le_a'], },
end

lemma finset.insert_erase_univ {α:Type*} [F:fintype α] {d:α}:
insert d (finset.univ.erase d) = finset.univ :=
begin
  rw finset.insert_erase,
  apply finset.mem_univ,
end

noncomputable def pi.measure {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} [M:∀ a, measurable_space (β a)]
  (μ:Π a, measure_theory.measure (β a)):measure_theory.measure (Π a, β a) :=
  (pi.outer_measure (λ a, (μ a).to_outer_measure)).to_measure begin
  unfold measurable_space.pi,
  simp,
  intros d,
  intros P A1,
  unfold measurable_space.comap at A1,
  simp at A1,
  cases A1 with s A1,
  cases A1 with A1 A2,
  subst P,
  apply measure_theory.outer_measure.of_function_caratheodory,
  simp,
  intros t,
  have D1:finset.univ = insert d (finset.univ.erase d),
  { rw finset.insert_erase_univ },
  rw D1,
  rw finset.prod_insert,
  rw finset.prod_insert,
  rw finset.prod_insert,
  have B1:(μ d) ((λ (p : Π (a : α), (λ (a : α), β a) a), p d) '' t∩ s) +
          (μ d) ((λ (p : Π (a : α), (λ (a : α), β a) a), p d) '' t\ s) =
          (μ d) ((λ (p : Π (a : α), (λ (a : α), β a) a), p d) '' t),
  { rw ← measure_theory.measure_eq_inter_diff', apply A1 },
   rw ← B1,
  clear B1,
  rw right_distrib,
  apply @add_le_add ennreal _;
  apply ennreal.mul_le_mul;
  try {apply measure_theory.measure_mono};
  try { simp, apply set.subset.trans,
    apply set.inter_subset_left, apply set.subset_preimage_image };
  try { apply ennreal.prod_le_prod, intros a h_a_mem,
    apply measure_theory.measure_mono, simp, apply set.subset.trans,
    apply set.inter_subset_left, apply set.subset_preimage_image },
  { simp, apply set.diff_subset_diff_left, apply set.subset_preimage_image },
  repeat {simp},
end

def cast.pi {α:Type*} {β:α → Type*} {a a':α} (b:β a) (h:a = a'):β a' := cast begin
rw h end b

def subst.pi {α:Type*} [decidable_eq α] {β:α → Type*} (f:Π (a:α), β a) (a':α) (b:β a'):Π (a:α), β a :=
  λ (a:α), @dite (a' = a) _ (β a) (λ h, cast.pi b h) (λ h, f a)

lemma subst.pi_eq {α:Type*} [decidable_eq α] {β:α → Type*} (f:Π (a:α), β a) (a':α) (b:β a'):
  (subst.pi f a' b) a' = b := begin
  simp [subst.pi],
  refl,
end

lemma subst.pi_ne {α:Type*} [decidable_eq α] {β:α → Type*} (f:Π (a:α), β a) (a a':α) (b:β a')
 (h:a' ≠ a):
  (subst.pi f a' b) a = f a := begin
  simp [subst.pi],
  rw dif_neg,
  apply h,
end

lemma set.project_pi {α:Type*} {β:α → Type*} {f:Π (a:α), set (β a)} (h:∀ a, (f a).nonempty)
  {a':α}:
      ((λ (p : Π (a : α), β a), p a') '' (set.pi set.univ f)) = f a' :=
begin
  ext x,
  split;intros A1,
  simp [set.pi] at A1,
  { cases A1 with y A1,
    cases A1 with A1 A2,
    subst x,
    apply A1 },
  { simp [set.pi],
    have h2:∀ (a:α), ∃ b:β a, b ∈ (f a),
    { intros a, rw ← set.nonempty_def,
      apply h },
    rw classical.skolem at h2,
    cases h2 with g h2,
    apply exists.intro (subst.pi g a' x),
    split,
    intros q,
    cases (classical.em (a' = q)) with A3 A3,
    { subst q,
      rw subst.pi_eq, apply A1 },
    { rw subst.pi_ne,
      apply h2,
      apply A3, },
    rw subst.pi_eq },
end

lemma set.pi_empty {α:Type*} {β:α → Type*} {f:Π (a:α), set (β a)}
  {a':α} (h2:f a' = ∅):
  (set.pi set.univ f) = ∅ :=
begin
  ext x, simp, split,
  { have h3:x a' ∉ f a',
    { simp [h2] },
    apply h3, },
end

lemma pi.outer_measure.Inf_sum {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} [M:∀ a, measurable_space (β a)]
  (μ:Π a, measure_theory.outer_measure (β a)) {P:set (Π a, β a)}:
  pi.outer_measure μ P =
  (⨅ (f:ℕ → (Π (a:α), set (β a))) (h₁:P ⊆ ⋃ (n:ℕ), set.pi set.univ (f n)),
  ∑' (n:ℕ), finset.univ.prod (λ (m:α), μ m (f n m))) := begin
  unfold pi.outer_measure measure_theory.outer_measure.of_function,
  rw ← measure_theory.outer_measure.measure_of_eq_coe,
  simp,
  apply le_antisymm,
  { simp,
  intros f B1,
  apply @infi_le_of_le ennreal  _ _ _ _ (λ (n:ℕ), set.pi set.univ ((f n))),
  apply @infi_le_of_le ennreal  _ _ _ _ _,
  apply ennreal.tsum_le_tsum,
  intros n,
  cases (classical.em (∀ (a:α), (f n a).nonempty)) with B2 B2,
  { have D1:(λ (a : α), (μ a) ((λ (p : Π (a : α), β a), p a) '' (λ (n : ℕ), set.pi set.univ (f n)) n)) = (λ (m : α), (μ m) (f n m)),
    { ext1 a, simp [set.project_pi], rw set.project_pi, apply B2 },
    rw D1, apply le_refl _, },
  { rw classical.not_forall_iff_exists_not at B2,
    cases B2 with a B2, rw set.not_nonempty_iff_eq_empty at B2,
    rw @finset.prod_eq_zero _ _ _ a,
    rw @finset.prod_eq_zero _ _ _ a,
    apply le_refl _,
    apply finset.mem_univ,
    rw B2,
    apply measure_theory.outer_measure.empty,
    apply finset.mem_univ,
    simp,
    rw set.pi_empty B2,
    simp },
    apply B1 },
  { simp,
    intros f A1,
    let f':ℕ → (Π (a:α), set (β a)) := (λ n m, ((λ (p:Π (a:α), β a), p m) '' (f n))),
    begin
      apply @infi_le_of_le ennreal (ℕ → (Π (a:α), set (β a))) _ _ _ f',
      rw infi_prop_def,
      simp [f'],
      apply le_refl _,
      apply @set.subset.trans (Π a, β a) P (set.Union f) (⋃ (n : ℕ), set.pi set.univ (f' n))  A1,
      apply set.Union_subset_Union,
      intros i,
      rw set.subset_def,
      intros x A1,
      simp,
      intros a,
      apply exists.intro x,
      simp [A1],
    end },
end

lemma set.pi_subset_pi {α:Type*} {β:α → Type*} {S:Π (a:α), set (β a)} {T:Π (a:α), set (β a)}:
    (∀ a, S a ⊆ T a) → set.pi set.univ S ⊆ set.pi set.univ T :=
begin
  rw set.subset_def,
  intros A0 x A1,
  simp,
  intros a,
  simp at A1,
  apply A0,
  apply A1,
end

lemma pi.outer_measure.Inf_sum2 {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} [M:∀ (a:α), measurable_space (β a)]
  (μ:Π (a:α), measure_theory.measure (β a)) {P:set (Π (a:α), β a)}:
  pi.outer_measure (λ (a:α), (μ a).to_outer_measure) P =

  (⨅ (f:ℕ → (Π (a:α), set (β a))) (h₁:∀ n m, measurable_set (f n m))
  (h₃:P ⊆ ⋃ (n:ℕ), set.pi set.univ (f n)),
  ∑' (n:ℕ), finset.univ.prod (λ (m:α), μ m (f n m))) := begin
  rw pi.outer_measure.Inf_sum,
  apply le_antisymm,
  { simp,
    intros f h₁ h₃,
    apply @infi_le_trans (ℕ→ Π (a:α), set (β a)) ennreal _ f,
    rw infi_prop_def,
    apply le_refl _,
    apply h₃ },
  { simp,
    intros f h₁,
   have h4_2 := λ (n:ℕ) (m:α), measure_theory.measurable_eq (μ m) (f n m),
    have h4:∀ n, ∃ (g:Π (a:α), set (β a)), ∀ (a:α), measurable_set (g a) ∧ (μ a) (g a) = (μ a) (f n a) ∧ f n a ⊆ g a,
    { intros n, have h5_1 := h4_2 n,
      apply classical.axiom_of_choice h5_1, },
    rw classical.skolem at h4,

    cases h4 with f' h4,

    apply @infi_le_trans (ℕ→ (Π (a:α), set (β a))) ennreal _ f',
    rw infi_prop_def,
    rw infi_prop_def,
    { apply ennreal.tsum_le_tsum,
      intro n,
      apply ennreal.prod_le_prod,
      intros a h_dummy,
      rw (h4 n a).right.left, apply le_refl _, },
    apply set.subset.trans,
    apply h₁,
    apply set.Union_subset_Union,
    intro n,
    apply set.pi_subset_pi,
    intros a,
    apply (h4 n a).right.right,
    intros n m,
    apply (h4 n m).left,
    },
end

/-
  If we can make this into an equality, we're home free.
  See https://www.math.ucdavis.edu/~hunter/measure_theory/measure_notes_ch5.pdf
  Those notes focus on measurable sets. We could theoretically do the same. However,
  it would make the rest of the analysis much more complex.
  I wonder if using an "outer measure lower integral" would make this useful.
-/
lemma pi.outer_measure.apply_prod_le {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} [M:∀ a, measurable_space (β a)]
  (μ:Π a, measure_theory.outer_measure (β a)) {P:(Π a, set (β a))}:
  pi.outer_measure μ (set.pi set.univ P) ≤ finset.univ.prod (λ a, μ a (P a)) :=
begin
  rw pi.outer_measure.Inf_sum,
  { apply @infi_le_of_le ennreal _ _ _ _ (λ (n:ℕ) (a:α), ite (n = 0) (P a) ∅),
    apply @infi_le_of_le ennreal _ _ _ _ _,
    rw tsum_eq_single 0,
    {simp [le_refl]},
    intros b' B1,
    simp [B1],
    rw finset.card_pos,
    rw finset.univ_nonempty_iff,
    apply N,
  apply ennreal.t2_space,
  rw set.subset_def,
  intros p B2,
  simp,
  apply exists.intro 0,
  {simp at B2,simp [B2]}},
end

lemma set.characteristic.pi {α:Type*} [F:fintype α] {β:α → Type*} {P:Π a, set (β a)}
  {x:Π a, β a}:(set.pi set.univ P).characteristic x =
finset.univ.prod (λ a, (P a).characteristic (x a)) :=
begin
  have A1:∀ S:finset α, (set.pi (↑S) P).characteristic x =
       S.prod (λ a, (P a).characteristic (x a)),
  { intros S,
    apply finset.induction_on S,
    { simp },
    { intros a T h_not_mem h_ind,
      rw finset.prod_insert h_not_mem,
      rw ← h_ind,
      cases classical.em ((x a) ∈ (P a)) with A1 A1,
      rw set.characteristic.of_mem A1,
      rw one_mul,
      cases classical.em (x ∈ (set.pi (↑T) P)) with A2 A2,
      { rw set.characteristic.of_mem A2,
        rw set.characteristic.of_mem,
        simp at A2, simp [A1,A2], apply A2, },
      { rw set.characteristic.of_not_mem A2,
        rw set.characteristic.of_not_mem,
        simp at A2,
        simp [A1,A2], },
      { rw set.characteristic.of_not_mem A1,
        rw zero_mul,
        rw set.characteristic.of_not_mem,
        simp [A1], } } },
  have A2:set.univ = ↑(finset.univ),
  { ext x, split; intros A1, rw  @finset.mem_coe α x, simp, simp },
  rw A2,
  apply A1,
end

lemma finset.prod_univ_diff_insert {α:Type*} [fintype α] (f:α → ennreal) (A:finset α) (a:α) (h:a∉ A):
(finset.univ \ A).prod f = f a * (finset.univ \ (insert a A)).prod f :=
begin
  have A1:finset.univ \ A = (insert a (finset.univ \ (insert a A))),
  { ext x, split;intros A1_1; simp at A1_1; simp [A1_1], apply classical.em (x = a),
    cases A1_1,
    subst x,
    apply h,
    intros contra,
    apply A1_1,
    right,
    apply contra },
  rw A1,
  rw finset.prod_insert,
  simp,
end

lemma pi.outer_measure.le_apply_prod {α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} [M:∀ a, measurable_space (β a)]
  (μ:Π a, measure_theory.measure (β a)) {P:(Π a, set (β a))}:(∀ (a:α), measurable_set (P a)) →
  finset.univ.prod (λ a, μ a (P a)) ≤
  pi.outer_measure (λ a, (μ a).to_outer_measure) (set.pi set.univ P) :=
begin
  intro A4,
  /- Due to an implementation detail, it is best to consider an empty set separately. -/
  cases (classical.em (∀ (a:α), (P a).nonempty)) with h_all_nonempty h_exists_empty,

  rw pi.outer_measure.Inf_sum2,
  simp,
  intros f A2 A3,
  have h2:(set.pi set.univ P).characteristic ≤ ∑' (n : ℕ), (set.pi set.univ (f n)).characteristic,
  { apply function.le_trans (set.characteristic.subset A3),
    apply set.characteristic.Union },
  have h3:∀ (x:Π (a:α), β a), finset.univ.prod (λ a, (P a).characteristic (x a))  ≤
          ∑' (n : ℕ), finset.univ.prod (λ a, (f n a).characteristic (x a)),
  { intros x,
    rw ← set.characteristic.pi,
    have h3a: (λ n, (finset.univ.prod (λ a, (f n a).characteristic (x a)))) =
              (λ n, (set.pi (set.univ) (f n)).characteristic x),
    { ext1 n, rw set.characteristic.pi },
    rw h3a,
    have h3b:((∑' (n : ℕ), (set.pi set.univ (f n)).characteristic) x) =
        (∑' (n : ℕ), (set.pi set.univ (f n)).characteristic x) ,
    { apply ennreal.tsum_apply },
    rw ← h3b,
    apply h2 },
  have h4:∀ (A:finset α), ∀ (x:Π (a:α), β a),
    (A.prod (λ a, μ a (P a))) * ((finset.univ \ A).prod (λ a, (P a).characteristic (x a))) ≤
    ∑' (n:ℕ), (A.prod (λ a, μ a (f n a))) * ((finset.univ \ A).prod (λ a, (f n a).characteristic (x a))),
  { intros A, apply finset.induction_on A,
    { intros x, simp, apply h3 },
    { intros a' s h_not_mem h_ind x,
      have h4_1:(λ (x':β a'), (P a').characteristic (x') *
      (s.prod (λ (a : α), (μ a) (P a)) *
         (finset.univ \ insert a' s).prod (λ (a : α), (P a).characteristic (x a)))) ≤
    (λ (x':β a'), ∑' (n : ℕ),
      (f n a').characteristic (x') *
        (s.prod (λ (a : α), (μ a) (f n a)) *
           (finset.univ \ insert a' s).prod (λ (a : α), (f n a).characteristic (x a)))),
      { rw has_le_fun_def, intros x',
        have h4_1_1 := h_ind (subst.pi x a' x'),
        have h4_1_2 :s.prod (λ (a : α), (μ a) (P a)) * (finset.univ \ s).prod (λ (a : α), (P a).characteristic (subst.pi x a' x' a)) =
 (P a').characteristic (x') *
(s.prod (λ (a : α), (μ a) (P a)) *
       (finset.univ \ insert a' s).prod (λ (a : α), (P a).characteristic (x a))),
      {
        have h4_1_2_1:
      (finset.univ \ (insert  a' s)).prod (λ (a : α), (P a).characteristic (subst.pi x a' x' a)) =
      (finset.univ \ (insert a' s)).prod (λ ⦃a' : α⦄, (P a').characteristic (x a')),
       { apply finset.prod_congr,
         refl, intros a'' h4_1_2_1_1, rw subst.pi_ne, simp at h4_1_2_1_1, intros contra, apply
         h4_1_2_1_1, left, rw contra,  },
        rw ← h4_1_2_1,
        clear h4_1_2_1,
        rw ← mul_assoc, rw mul_comm ((P a').characteristic (x')),
        rw mul_assoc,
        have h4_1_2_2:(P a').characteristic x' = (λ a, (P a).characteristic (subst.pi x a' x' a)) a',
        { simp, rw subst.pi_eq x a' x' },
        rw h4_1_2_2,
        rw finset.prod_univ_diff_insert _ _ a' h_not_mem,
         },
      rw h4_1_2 at h4_1_1,
      clear h4_1_2,
     have h4_1_3:(λ
(n : ℕ),
      s.prod (λ (a : α), (μ a) (f n a)) *
        (finset.univ \ s).prod (λ (a : α), (f n a).characteristic (subst.pi x a' x' a))) =
(λ (n:ℕ),
      (f n a').characteristic x' *
        (s.prod (λ (a : α), (μ a) (f n a)) *
           (finset.univ \ insert a' s).prod (λ (a : α), (f n a).characteristic (x a)))),
      { ext1 n,
        have h4_1_2_1:
      (finset.univ \ (insert  a' s)).prod (λ (a : α), (f n a).characteristic (subst.pi x a' x' a)) =
      (finset.univ \ (insert a' s)).prod (λ ⦃a' : α⦄, (f n a').characteristic (x a')),
       { apply finset.prod_congr,
         refl, intros a'' h4_1_2_1_1, rw subst.pi_ne, simp at h4_1_2_1_1, intros contra, apply
         h4_1_2_1_1, left, rw contra,  },
        rw ← h4_1_2_1,
        clear h4_1_2_1,
        rw ← mul_assoc, rw mul_comm ((f n a').characteristic (x')),
        rw mul_assoc,
        have h4_1_2_2:(f n a').characteristic x' = (λ a, (f n a).characteristic (subst.pi x a' x' a)) a',
        { simp, rw subst.pi_eq x a' x' },
        rw h4_1_2_2,
        rw finset.prod_univ_diff_insert _ _ a' h_not_mem,

         },
    rw h4_1_3 at h4_1_1,
    clear h4_1_3,
    apply h4_1_1,
  },
      have h4_2:measure_theory.lintegral (μ a') (λ (x':β a'), (P a').characteristic (x') *
      (s.prod (λ (a : α), (μ a) (P a)) *
         (finset.univ \ insert a' s).prod (λ (a : α), (P a).characteristic (x a)))) ≤
         measure_theory.lintegral (μ a')
    (λ (x':β a'), ∑' (n : ℕ),
      (f n a').characteristic (x') *
        (s.prod (λ (a : α), (μ a) (f n a)) *
           (finset.univ \ insert a' s).prod (λ (a : α), (f n a).characteristic (x a)))),
      { apply measure_theory.lintegral_mono, apply h4_1, },
      clear h4_1,
      have h4_3:measure_theory.lintegral (μ a') (λ (x':β a'), (P a').characteristic (x') *
      (s.prod (λ (a : α), (μ a) (P a)) *
         (finset.univ \ insert a' s).prod (λ (a : α), (P a).characteristic (x a)))) =
         (insert a' s).prod (λ (a : α), (μ a) (P a)) *
         (finset.univ \ insert a' s).prod (λ (a : α), (P a).characteristic (x a)),
      { rw measure_theory.lintegral_mul_const,
        rw measure_theory.lintegral_characteristic,
        rw ← mul_assoc,
        rw finset.prod_insert h_not_mem, apply A4, apply measurable.characteristic,
        apply A4 },
      rw h4_3 at h4_2,
      clear h4_3,
      have h4_4:(∫⁻ (x' : β a'),
      (∑' (n : ℕ),
         (f n a').characteristic x' *
           (s.prod (λ (a : α), (μ a) (f n a)) *
              (finset.univ \ insert a' s).prod (λ (a : α), (f n a).characteristic (x a)))) ∂μ a')
        =
      (∑' (n : ℕ),
∫⁻ (x' : β a'),
(f n a').characteristic x' *
           (s.prod (λ (a : α), (μ a) (f n a)) *
              (finset.univ \ insert a' s).prod (λ (a : α), (f n a).characteristic (x a))) ∂μ a'),
      { rw measure_theory.lintegral_tsum,
        intros n, apply measurable.ennreal_mul,
        apply measurable.characteristic,
        apply A2,
        apply measurable_const },
      rw h4_4 at h4_2,
      clear h4_4,
      have h4_5:(λ (n : ℕ),
∫⁻ (x' : β a'),
(f n a').characteristic x' *
           (s.prod (λ (a : α), (μ a) (f n a)) *
              (finset.univ \ insert a' s).prod (λ (a : α), (f n a).characteristic (x a))) ∂μ a') =
(λ (n : ℕ),
           (insert a' s).prod (λ (a : α), (μ a) (f n a)) *
              (finset.univ \ insert a' s).prod (λ (a : α), (f n a).characteristic (x a))),
      { ext1 n,
        rw measure_theory.lintegral_mul_const,
        rw measure_theory.lintegral_characteristic,
        rw ← mul_assoc,
        rw finset.prod_insert h_not_mem,
        apply A2, apply measurable.characteristic, apply A2, },
   rw h4_5 at h4_2,
   clear h4_5,
   apply h4_2,
 } },

  have h7:∀ (a:α), ∃ x, x ∈ P a,
  { intros a, rw ← set.nonempty_def, apply h_all_nonempty },
  have h8 := classical.axiom_of_choice h7,
  cases h8 with g h8,
  have h6 := h4 finset.univ g,
  simp at h6,
  apply h6,
  rw classical.not_forall_iff_exists_not at h_exists_empty,
  cases h_exists_empty with a h_empty,
  rw set.not_nonempty_iff_eq_empty at h_empty,
  rw @finset.prod_eq_zero _ _ _ a,
  { simp },
  { simp },
  simp [h_empty],
end

lemma pi.measure_apply
{α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} [M:∀ a, measurable_space (β a)]
  (μ:Π a, measure_theory.measure (β a)) {P:set (Π a, β a)}:measurable_set P →
  pi.measure μ P =
  pi.outer_measure (λ a, (μ a).to_outer_measure) P :=
begin
  intro h,
  simp [pi.measure],
  rw measure_theory.to_measure_apply,
  apply h,
end

lemma measurable_set.pi'' {α:Type*} [F:fintype α] {β:α → Type*} [M:∀ a, measurable_space (β a)]
  {P:Π a, set (β a)}:(∀ a, measurable_set (P a)) →
  measurable_set (set.pi set.univ P) := begin
  intros A0,
  have A1:(set.pi set.univ P) = ⋂ a, ((λ (p:Π a, β a), p a) ⁻¹' (P a)),
  { ext x, simp,  },
  rw A1,
  have A3:trunc (encodable α) := encodable.trunc_encodable_of_fintype α,
  trunc_cases A3,
  haveI:encodable α := A3,
  apply measurable_set.Inter,
  intros a',
  have A2:measurable_space.comap (λ (p:Π a, β a), p a') (M a') ≤ measurable_space.pi,
  { simp [measurable_space.pi], apply @le_supr (measurable_space (Π a, β a)) _ _ _ (a') },
  apply A2,
  simp [measurable_space.comap],
  apply exists.intro (P a'),
  simp,
  apply A0 a',
end

lemma pi.measure.apply_prod
{α:Type*} [F:fintype α] [N:nonempty α] {β:α → Type*} [M:∀ a, measurable_space (β a)]
  (μ:Π a, measure_theory.measure (β a)) {P:Π a, set (β a)}:(∀ a, measurable_set (P a)) →
  pi.measure μ (set.pi set.univ P) =
  finset.univ.prod (λ a, μ a (P a)) :=
begin
  intros A1,
  rw pi.measure_apply,
  apply le_antisymm,
  { apply pi.outer_measure.apply_prod_le },
  apply pi.outer_measure.le_apply_prod,
  apply A1,
  apply measurable_set.pi'' A1,
end

end pi


import Mt.Reservation
import Mt.Thread

namespace SampleSimple

structure State where
  x : Nat
  y : Nat

def spec : Mt.Spec :={
  State
  Reservation :=Nat
  validate := fun (luft : Nat) ⟨x, y⟩ => x ≥ y + luft
}

open Mt
open Mt.TaskM

def thread1 : Thread spec :=mk_thread do
  -- increase x atomically
  atomic_read_modify λ s => { s with x := s.x + 1 }

  -- increase y atomically
  atomic_read_modify λ s => { s with y := s.y + 1 }

  atomic_assert fun ⟨x, y⟩ => x ≥ y

theorem thread1_valid : thread1.valid :=by
  rw [Thread.valid]
  apply valid_bind (spec :=spec) λ _ (luft : Nat) => luft = 1
  . -- validate ++x
    ---------------
    apply valid_rm
    intro (env_luft : Nat) ⟨x, y⟩ _ initial_valid
    exists (1 : Nat)
    simp only [and_true]

    have : x ≥ y + env_luft :=initial_valid
    show x + 1 ≥ y + env_luft + 1

    exact Nat.succ_le_succ (by assumption)

  intro (luft : Nat) ⟨⟩ luft_def
  apply valid_bind (spec :=spec) λ _ (luft : Nat) => luft = 0
  . -- validate ++y knowing luft = 1
    --------------------------------
    apply valid_rm
    intro (env_luft : Nat) ⟨x, y⟩ _ initial_valid
    exists (0 : Nat)
    simp only [and_true]

    rw [luft_def] at initial_valid

    have : x ≥ y + env_luft + 1 :=initial_valid
    show x ≥ y + 1 + env_luft

    rw [Nat.add_right_comm] ; assumption

  clear luft luft_def
  intro (luft : Nat) ⟨⟩ luft_def
  apply valid_assert (spec :=spec) luft_def
  . -- validate `assert x ≥ y`
    ----------------------------
    intro (env_luft : Nat) ⟨x, y⟩ _ initial_valid

    have : x ≥ y + (env_luft + luft) :=initial_valid
    show decide (x ≥ y) = true

    exact decide_eq_true <| calc
      y ≤ y + (env_luft + luft) :=by simp_arith
      _ ≤ x                     :=by assumption

end SampleSimple


import data.bool.misc
import data.list.misc
import logic.misc
import logic.finite
import tactic.unirewrite
import .basic .hom .bool

namespace binary_module

open binary_module

local attribute [instance] binary_abelian

@[reducible]
protected
definition has_finite_support (α : Type _) [decidable_eq α] (φ : Type _) [decidable_eq φ] [model binary_module φ] : inv_pred binary_module (α → φ) :=
{
  p := λ f, is_finite {x // f x ≠ 0},
  hinv :=
    begin
      intros n μ fs hall,
      cases μ,
      case ops.zero {
        cases fs,
        apply is_finite.of_empty,
        intros x,
        exact not_not_intro rfl
      },
      case ops.add {
        cases fs with _ f fs; cases fs with _ g gs; cases gs,
        dsimp [vect.is_all] at hall,
        let hfin := hall.left.of_union hall.right.left,
        let hfin' := hfin.of_subrestrict (λ x, f x + g x ≠ 0),
        dsimp at hfin',
        refine is_finite.of_iff _ hfin',
        intros x,
        have : @premodel.act binary_module _ _ _ ops.add ⁅f,g⁆ x = f x + g x,
          by refl,
        rw [this],
        split,
        exact and.right,
        intros hfgx,
        split; try { assumption },
        refine dite (f x = 0) _ _,
        show f x = 0 → _, {
          intros hfx,
          rw [hfx, _root_.zero_add] at hfgx,
          exact or.inr hfgx
        },
        show f x ≠ 0 → _, {
          exact or.inl
        }
      }
    end
}

@[reducible]
definition finsupp_fun (α : Type _) [decidable_eq α] (φ : Type _) [decidable_eq φ] [model binary_module φ] :=
  submodel binary_module (binary_module.has_finite_support α φ)

@[reducible,inline]
definition finsupp_bits (α : Type _) [decidable_eq α] :=
  finsupp_fun α bool

@[reducible]
definition singlebit {α : Type _} [decidable_eq α] : α → finsupp_bits α :=
  λ a, subtype.mk (λ x, to_bool (a=x)) $
    begin
      dunfold binary_module.has_finite_support,
      dsimp *,
      apply is_finite.of_exhaustive_list,
      have ha : to_bool (a = a) ≠ 0,
        by rw [to_bool_tt rfl]; intro h; exact bool.ff_ne_tt h.symm,
      refine subtype.mk [⟨a,ha⟩] ⟨list.nodup.nil.cons (list.not_mem_nil _), _⟩,
      intros x,
      refine dite (a = x.val) _ _,
      show a = x.val → _, {
        intros hax,
        exact or.inl (subtype.eq hax.symm)
      },
      show a ≠ x.val → _, {
        intros hax,
        have : ff ≠ 0,
          by let h := x.property; rw [to_bool_ff hax] at h; exact h,
        exact false.elim (this rfl)
      }
    end

--- `singlebit a` classifies `a`.
lemma singlebit_nonzero_iff {α : Type _} [decidable_eq α] {a : α} : ∀ x, (singlebit a).val x ≠ 0 ↔ x = a :=
  λ x, iff.intro
    (λ h,
      begin
        dsimp [singlebit] at h,
        by_cases hax: a=x,
        exact hax.symm,
        rw [to_bool_ff hax] at h,
        injection ((neq_ff_iff ff).mp h),
      end
    )
    (λ hxa h,
      begin
        dsimp [singlebit] at h;
        rw [to_bool_tt hxa.symm] at h;
        injection h
      end
    )

--- Support of `singlebit a` consists of only `a`.
lemma singlebit_support {α : Type _} [decidable_eq α] {a : α} : ∀ (l : exhaustive_list {x // (singlebit a).val x ≠ 0}), l.underlying = [a] :=
  begin
    intros l,
    calc
      l.underlying
          = (l.of_iff singlebit_nonzero_iff).underlying
            : (l.of_iff_underlying _).symm
      ... = (exhaustive_list.singleton a).underlying
            : by rw [(l.of_iff singlebit_nonzero_iff).singleton_unique]
      ... = [a] : rfl
  end

--- If `a` lies in the support of `w : finsupp_bits α`, then the support of `w + singlebit a` is exactly the support of `w` minus `a`.
lemma support_of_add_singlebit_of_nonzero {α : Type _} [decidable_eq α] {w : finsupp_bits α} {a : α} : w.val a ≠ 0 → ∀ (l : exhaustive_list {x // w.val x ≠ 0}) (la : exhaustive_list {x // w.val x + (singlebit a).val x ≠ 0}), list.perm l.underlying (a :: la.underlying) :=
  begin
    intros hwa l la,
    dsimp [singlebit] at la,
    have ha : a ∉ la.underlying, {
      intros h,
      let h' := (la.underlying_mem_iff a).mpr h,
      rw [(neq_ff_iff _).mp hwa, to_bool_tt rfl] at h',
      exact h' rfl
    },
    apply list.nodup_perm_of_mem
      l.underlying_nodup
      (list.nodup.cons ha la.underlying_nodup),
    intros x,
    split,
    show x ∈ l.underlying → _, {
      intros hx,
      by_cases hxa: a = x; try { exact or.inl hxa.symm },
      right,
      apply (la.underlying_mem_iff x).mp,
      apply (neq_ff_iff _).mpr,
      have : w.val x = tt,
        from (neq_ff_iff _).mp ((l.underlying_mem_iff x).mpr hx),
      rw [this, to_bool_ff hxa],
      refl
    },
    show x ∈ a :: la.underlying → _, {
      refine implies.trans _ (l.underlying_mem_iff x).mp,
      intros hx; cases hx,
      case or.inl { rw [hx]; exact hwa },
      case or.inr {
        have hax: a ≠ x,
          from (λ h, ha (by rw [←h] at hx; exact hx)),
        let hwxa := (la.underlying_mem_iff x).mpr hx,
        rw [to_bool_ff hax] at hwxa,
        intros h,
        rw [h] at hwxa,
        exact hwxa rfl
      }
    }
  end

--- The functional relation that represents the accumuration of a `binary_module`-valued function with boolean weights.
definition waccum_funrel {α : Type _} [decidable_eq α] {φ : Type _} [model binary_module φ] (f : α → φ) : finsupp_bits α ⇒ φ :=
{
  p := λ w y, ∀ (l : exhaustive_list {a // w.val a ≠ 0}), accum f l.underlying = y,
  huniq :=
    begin
      intros w; cases w,
      dunfold binary_module.has_finite_support at w_property,
      dsimp * at w_property,
      cases @is_finite.has_exhaustive_list _ w_property with l,
      existsi accum f l.underlying,
      dsimp *,
      split,
      show ∀ (l' : exhaustive_list _), accum f l'.underlying = accum f l.underlying, {
        intros l',
        exact accum_perm (l'.underlying_perm l)
      },
      show ∀ y h, y = _, {
        intros y h; rw [h]
      }
    end
}

--- `waccum` with zero weight equals zero.
lemma waccum_funrel_zero {α : Type _} [decidable_eq α] {φ : Type _} [model binary_module φ] (f : α → φ) : (waccum_funrel f).p (binary_module.zero _) 0 :=
  begin
    dsimp [waccum_funrel],
    intros l,
    suffices : l.underlying = [], {
      rw [this]; exact accum_nil
    },
    refine l.of_empty_underlying _,
    intros x,
    apply not_not_intro,
    refl
  end

--- `waccum` is just an evaluation on `singlebit`.
lemma waccum_funrel_single {α : Type _} [decidable_eq α] {φ : Type _} [model binary_module φ] (f : α → φ) : ∀ (a : α), (waccum_funrel f).p (singlebit a) (f a) :=
  begin
    intros a,
    dsimp [waccum_funrel],
    intros l,
    rw [singlebit_support],
    dsimp [accum],
    rw [add_zero]
  end

--- `waccum` respects the addition of weights.
lemma waccum_funrel_add {α : Type _} [decidable_eq α] {φ : Type _} [model binary_module φ] (f : α → φ) : ∀ (v w : finsupp_bits α) (y z : φ), (waccum_funrel f).p v y → (waccum_funrel f).p w z → (waccum_funrel f).p (binary_module.add v w) (y+z) :=
  begin
    dsimp [waccum_funrel],
    intros v w y z hvy hwz l,
    have : ∀ a, (binary_module.add v w).val a ≠ 0 ↔ (v.val a ≠ 0 ∧ ¬w.val a ≠ 0) ∨ (¬v.val a ≠ 0 ∧ w.val a ≠ 0), {
      intros a,
      dsimp [binary_module.add, premodel.act],
      dsimp [vect.unzip_fam, vect.map, vect.foldl],
      rw [ff_bxor_safe],
      calc
        bxor (v.val a) (w.val a) ≠ 0
            ↔ bxor (v.val a) (w.val a) = tt : neq_ff_iff _
        ... ↔ v.val a ≠ w.val a : bxor_eq_tt_iff _ _
        ... ↔ (v.val a = tt ∧ w.val a = 0) ∨ (v.val a = 0 ∧ w.val a = tt)
            : bool.neq_iff (v.val a) (w.val a)
        ... ↔ (v.val a ≠ 0 ∧ ¬w.val a ≠ 0) ∨ (¬v.val a ≠ 0 ∧ w.val a ≠ ff)
            : or_congr
              (and_congr (neq_ff_iff _) (@decidable.not_not_iff (w.val a=0) (bool.decidable_eq _ _))).symm
              (and_congr (@decidable.not_not_iff (v.val a=0) (bool.decidable_eq _ _)) (neq_ff_iff _)).symm
    },
    let suppvw := l.of_iff this,
    cases @is_finite.has_exhaustive_list {x // v.val x ≠ 0} v.property with suppv,
    cases @is_finite.has_exhaustive_list {x // w.val x ≠ 0} w.property with suppw,
    specialize hvy suppv,
    specialize hwz suppw,
    rw [accum_partition (λ x, w.val x ≠ 0)] at hvy,
    rw [accum_partition (λ x, v.val x ≠ 0)] at hwz,
    rw [←suppv.subrestrict_underlying (λ x, w.val x≠ 0)] at hvy,
    rw [←suppv.subrestrict_underlying (λ x, ¬w.val x≠ 0)] at hvy,
    rw [←suppw.subrestrict_underlying (λ x, v.val x≠ 0)] at hwz,
    rw [←suppw.subrestrict_underlying (λ x, ¬v.val x≠ 0)] at hwz,
    let suppv_only := suppv.subrestrict (λ x, ¬w.val x≠0),
    let suppv_w := suppv.subrestrict (λ x, w.val x≠0),
    unirewrite suppv.subrestrict (λ x, ¬w.val x≠0) with suppv_only at hvy,
    unirewrite suppv.subrestrict (λ x, w.val x≠0) with suppv_w at hvy,
    let suppw_only := suppw.subrestrict (λ x, ¬v.val x≠0),
    let suppw_v := suppw.subrestrict (λ x, v.val x≠0),
    unirewrite suppw.subrestrict (λ x, ¬v.val x≠0) with suppw_only at hwz,
    unirewrite suppw.subrestrict (λ x, v.val x≠0) with suppw_v at hwz,
    dsimp only [] at hvy hwz,
    let suppw_only' := suppw_only.of_iff (λ x, @and.comm (w.val x≠ 0) (¬v.val x≠ 0)),
    rw [←suppw_only.of_iff_underlying _] at hwz,
    unirewrite (suppw_only.of_iff _) with suppw_only' at hwz,
    have : list.perm suppv_w.underlying suppw_v.underlying, {
      rw [←suppw_v.of_iff_underlying (λ x, @and.comm (w.val x≠0) (v.val x≠0))],
      exact suppv_w.underlying_perm _
    },
    symmetry,
    calc
      y+z = (accum f suppv_w.underlying + accum f suppv_only.underlying)
            + (accum f suppw_v.underlying + accum f suppw_only'.underlying)
            : by rw [←hvy,←hwz]
      ... = (accum f suppv_w.underlying + accum f suppv_only.underlying)
            + (accum f suppv_w.underlying + accum f suppw_only'.underlying)
            : by rw [accum_perm this]
      ... = (accum f suppv_w.underlying + accum f suppv_only.underlying)
            + (-accum f suppv_w.underlying + accum f suppw_only'.underlying)
            : rfl
      ... = accum f suppv_only.underlying + accum f suppw_only'.underlying
            : by rw [add_comm (accum f suppv_w.underlying) _];
                 rw [add_assoc,←_root_.add_assoc (accum f suppv_w.underlying)];
                 rw [add_neg (accum f suppv_w.underlying)];
                 rw [zero_add]
      ... = accum f (suppv_only.union suppw_only').underlying
            : by rw [exhaustive_list.disjoint_union_underlying (λ x (h : (¬v.val x = 0 ∧ ¬¬w.val x = 0) ∧ ¬v.val x ≠ 0 ∧ w.val x ≠ 0), h.left.right h.right.right)];
                 rw [←accum_append]
      ... = accum f suppvw.underlying
            : accum_perm (suppvw.underlying_perm (suppv_only.union (suppw_only.of_iff (λ x, @and.comm (w.val x≠ 0) (¬v.val x≠ 0))))).symm
      ... = accum f l.underlying : congr_arg (accum f) (l.of_iff_underlying _)
  --/
  end

namespace unsafe

open funrel.unsafe

local attribute [instance] model.unsafe.pi

variables {α : Type _} [decidable_eq α]

--- `finsupp_bits` is non-zero precisely if it has at least one `tt` bit.
lemma finsupp_bits.nonzero (w : finsupp_bits α) : w ≠ 0 → ∃ a, w.val a = tt :=
  begin
    intros hw,
    cases @is_finite.has_exhaustive_list _ w.property with l,
    cases hl: l.underlying with a tl,
    case nil {
      suffices : w = 0,
        by exfalso; exact hw this,
      unirewrite @has_zero.zero (finsupp_bits α) _ with binary_module.zero _,
      dsimp [binary_module.zero],
      apply subtype.eq,
      funext,
      dsimp [premodel.act],
      dsimp [vect.map, vect.unzip_fam, vect.foldl],
      cases (bool.decidable_eq (w.val x) ff),
      case is_false {
        exfalso,
        have : x ∈ l.underlying,
          from (l.underlying_mem_iff x).mp h,
        rw [hl] at this,
        exact list.not_mem_nil _ this
      },
      case is_true { exact h }
    },
    case cons {
      existsi a,
      apply (neq_ff_iff (w.val a)).mp,
      have : a ∈ l.underlying,
        by let h := list.mem_cons_self a tl; rw [←hl] at h; exact h,
      exact (l.underlying_mem_iff a).mpr this
    }
  end

-- Realization of the weighted accumuration `waccum_funrel` using `definite_description`.
noncomputable definition waccum {φ : Type _} [model binary_module φ] (f : α → φ) : finsupp_bits α → φ :=
  reify (waccum_funrel f)

noncomputable definition waccum_hom {φ : Type _} [model binary_module φ] (f : α → φ) : hom (finsupp_bits α) φ :=
  subtype.mk (waccum f) $
    begin
      intros _ μ as,
      dunfold waccum,
      cases μ,
      case ops.zero {
        cases as,
        dunfold vect.map,
        drefold binary_module.zero _,
        rw [iff.mp (reify_eq (waccum_funrel f)) (waccum_funrel_zero f)],
        refl
      },
      case ops.add {
        cases as with _ v vs; cases vs with _ w ws; cases ws,
        dunfold vect.map,
        drefold binary_module.add _ _,
        drefold binary_module.add _ _,
        unirewrite binary_module.add v w with has_add.add v w,
        let y := funrel.unsafe.reify (waccum_funrel f) v,
        let z := funrel.unsafe.reify (waccum_funrel f) w,
        unirewrite funrel.unsafe.reify (waccum_funrel f) v with y,
        unirewrite funrel.unsafe.reify (waccum_funrel f) w with z,
        have hvy : (waccum_funrel f).p v y,
          from iff.mpr (reify_eq (waccum_funrel f)) rfl,
        have hwz : (waccum_funrel f).p w z,
          from iff.mpr (reify_eq (waccum_funrel f)) rfl,
        apply iff.mp (reify_eq (waccum_funrel f)),
        apply waccum_funrel_add f v w y z hvy hwz
      }
    end

--- `waccum` is just the evaluation at `singlebit a`.
lemma waccum_single {φ : Type _} [model binary_module φ] (f : α → φ) : ∀ (a : α), waccum f (singlebit a) = f a :=
  begin
    intros a,
    apply iff.mp (reify_eq (waccum_funrel f)),
    exact waccum_funrel_single f a
  end

---`finsupp_bits α` is free with basis `α` provided `decidable_eq α`.
theorem finsupp_bits_free {φ : Type _} [model binary_module φ] (f : α → φ) : ∃! (g : morphism binary_module (finsupp_bits α) φ), ∀ a, g.val (singlebit a) = f a :=
  begin
    existsi waccum_hom f,
    dsimp [waccum_hom],
    split,
    show ∀ (a : α), _ = f a,
      from waccum_single f,
    show ∀ (g : morphism binary_module (finsupp_bits α) _), _, {
      intros g hg,
      apply subtype.eq; dsimp *,
      apply funext,
      suffices : ∀ (n : ℕ) (w : finsupp_bits α) (l : exhaustive_list {x // w.val x ≠ 0}), l.underlying.length = n → g.val w = waccum f w, {
        intros w,
        cases @is_finite.has_exhaustive_list _ w.property with l,
        exact this l.underlying.length w l rfl,
      },
      intros n,
      induction n with k h_ind,
      case zero {
        intros w l hl,
        suffices : w = binary_module.zero _, {
          repeat { rw [this] },
          unirewrite waccum f with (waccum_hom f).val,
          rw [g.property ops.zero, (waccum_hom f).property ops.zero],
          dsimp [vect.map],
          refl
        },
        apply subtype.eq,
        funext,
        dsimp [binary_module.zero, premodel.act],
        dsimp [vect.map, vect.unzip_fam, vect.foldl],
        cases bool.decidable_eq (w.val x) ff,
        case is_true { exact h },
        exfalso,
        have hx : x ∈ l.underlying,
          from (l.underlying_mem_iff x).mp h,
        have : l.underlying = [],
          from list.eq_nil_of_length_eq_zero hl,
        rw [this] at hx,
        exact list.not_mem_nil x hx
      },
      case succ {
        intros w l hl_len,
        cases hl: l.underlying with a tl,
        case nil {
          exfalso,
          rw [hl] at hl_len,
          exact nat.succ_ne_zero _ hl_len.symm
        },
        have ha : w.val a ≠ 0, {
          apply (l.underlying_mem_iff a).mpr,
          rw [hl]; exact list.mem_cons_self _ _
        },
        have hwa : g.val (w + singlebit a) = waccum f (w + singlebit a), {
          cases @is_finite.has_exhaustive_list _ (w + singlebit a).property with la,
          apply h_ind _ la,
          apply nat.succ.inj,
          refine eq.trans _ hl_len,
          unirewrite nat.succ _ with _+1,
          drefold list.length (a::la.underlying),
          apply list.perm.length,
          symmetry,
          exact support_of_add_singlebit_of_nonzero ha l la,
        },
        calc
          g.val w
              = g.val (w + (singlebit a - singlebit a))
                : by rw [sub_self, add_zero]
          ... = g.val (w + (singlebit a + singlebit a))
                : by refl
          ... = g.val (w + singlebit a) + g.val (singlebit a)
                : by rw [←add_assoc, morphism.respect_add g]
          ... = waccum f (w + singlebit a) + f a
                : by rw [hwa,hg]
          ... = waccum f (w + singlebit a) + waccum f (singlebit a)
                : by rw [waccum_single f a]
          ... = waccum f (w + singlebit a + singlebit a)
                : by unirewrite waccum f with (waccum_hom f).val;
                     rw [←morphism.respect_add (waccum_hom f)]
          ... = waccum f (w + (singlebit a + singlebit a))
                : by rw [add_assoc]
          ... = waccum f w
                : by unirewrite @has_add.add (finsupp_bits α) _ (singlebit a) (singlebit a) with @has_sub.sub (finsupp_bits α) _ (singlebit a) (singlebit a);
                     rw [sub_self, add_zero]
      }
    --/
    }
  end

---`finsupp_bits α` is free with basis `α` provided `decidable_eq α`.
theorem finsupp_bits.is_free : is_free binary_module (@singlebit α _) :=
  @finsupp_bits_free α _

end unsafe

end binary_module


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

import category_theory.functor_category
import category_theory.isomorphism
import tactic.interactive

namespace category_theory

universes u₁ v₁ u₂ v₂ u₃ v₃ u₄ v₄

section
variables (C : Type u₁) [𝒞 : category.{u₁ v₁} C] (D : Type u₂) [𝒟 : category.{u₂ v₂} D]
include 𝒞 𝒟

/--
`prod.category C D` gives the cartesian product of two categories.
-/
instance prod : category.{(max u₁ u₂) (max v₁ v₂)} (C × D) :=
{ hom     := λ X Y, ((X.1) ⟶ (Y.1)) × ((X.2) ⟶ (Y.2)),
  id      := λ X, ⟨ 𝟙 (X.1), 𝟙 (X.2) ⟩,
  comp    := λ _ _ _ f g, (f.1 ≫ g.1, f.2 ≫ g.2) }

-- rfl lemmas for category.prod
@[simp] lemma prod_id (X : C) (Y : D) : 𝟙 (X, Y) = (𝟙 X, 𝟙 Y) := rfl
@[simp] lemma prod_comp {P Q R : C} {S T U : D} (f : (P, S) ⟶ (Q, T)) (g : (Q, T) ⟶ (R, U)) : f ≫ g = (f.1 ≫ g.1, f.2 ≫ g.2) := rfl
end

section
variables (C : Type u₁) [𝒞 : category.{u₁ v₁} C] (D : Type u₁) [𝒟 : category.{u₁ v₁} D]
include 𝒞 𝒟
/--
`prod.category.uniform C D` is an additional instance specialised so both factors have the same universe levels. This helps typeclass resolution.
-/
instance uniform_prod : category (C × D) := category_theory.prod C D
end
-- Next we define the natural functors into and out of product categories. For now this doesn't address the universal properties.

namespace prod

variables (C : Type u₁) [𝒞 : category.{u₁ v₁} C] (D : Type u₂) [𝒟 : category.{u₂ v₂} D]
include 𝒞 𝒟

/-- `inl C Z` is the functor `X ↦ (X, Z)`. -/
def inl (Z : D) : C ⥤ (C × D) :=
{ obj      := λ X, (X, Z),
  map'     := λ X Y f, (f, 𝟙 Z) }

/-- `inr D Z` is the functor `X ↦ (Z, X)`. -/
def inr (Z : C) : D ⥤ (C × D) :=
{ obj      := λ X, (Z, X),
  map'     := λ X Y f, (𝟙 Z, f) }

/-- `fst` is the functor `(X, Y) ↦ X`. -/
def fst : (C × D) ⥤ C :=
{ obj      := λ X, X.1,
  map'     := λ X Y f, f.1 }

/-- `snd` is the functor `(X, Y) ↦ Y`. -/
def snd : (C × D) ⥤ D :=
{ obj      := λ X, X.2,
  map'     := λ X Y f, f.2 }

def swap : (C × D) ⥤ (D × C) :=
{ obj := λ X, (X.2, X.1),
  map' := λ _ _ f, (f.2, f.1) }

def symmetry : ((swap C D) ⋙ (swap D C)) ≅ (functor.id (C × D)) :=
{ hom := { app := λ X, 𝟙 X,
           naturality' := begin intros, erw [category.comp_id (C × D), category.id_comp (C × D)], dsimp [swap], simp, end },
  inv := { app := λ X, 𝟙 X,
           naturality' := begin intros, erw [category.comp_id (C × D), category.id_comp (C × D)], dsimp [swap], simp, end } }

end prod

section
variables (C : Type u₁) [𝒞 : category.{u₁ v₁} C] (D : Type u₂) [𝒟 : category.{u₂ v₂} D]
include 𝒞 𝒟

-- TODO, later this can be defined by uncurrying `functor.id (C ⥤ D)`
def evaluation : ((C ⥤ D) × C) ⥤ D :=
{ obj := λ p, p.1 p.2,
  map' := λ x y f, (x.1.map f.2) ≫ (f.1 y.2),
  map_comp' := begin
                 intros X Y Z f g, cases g, cases f, cases Z, cases Y, cases X, dsimp at *, simp at *,
                 erw [←nat_trans.vcomp_app, nat_trans.naturality, category.assoc, nat_trans.naturality]
               end }
end

variables {A : Type u₁} [𝒜 : category.{u₁ v₁} A] {B : Type u₂} [ℬ : category.{u₂ v₂} B] {C : Type u₃} [𝒞 : category.{u₃ v₃} C] {D : Type u₄} [𝒟 : category.{u₄ v₄} D]
include 𝒜 ℬ 𝒞 𝒟

namespace functor
/-- The cartesian product of two functors. -/
def prod (F : A ⥤ B) (G : C ⥤ D) : (A × C) ⥤ (B × D) :=
{ obj  := λ X, (F X.1, G X.2),
  map' := λ _ _ f, (F.map f.1, G.map f.2) }

/- Because of limitations in Lean 3's handling of notations, we do not setup a notation `F × G`.
   You can use `F.prod G` as a "poor man's infix", or just write `functor.prod F G`. -/

@[simp] lemma prod_obj  (F : A ⥤ B) (G : C ⥤ D) (a : A) (c : C) : (F.prod G) (a, c) = (F a, G c) := rfl
@[simp] lemma prod_map  (F : A ⥤ B) (G : C ⥤ D) {a a' : A} {c c' : C} (f : (a, c) ⟶ (a', c')) : (F.prod G).map f = (F.map f.1, G.map f.2) := rfl
end functor

namespace nat_trans

/-- The cartesian product of two natural transformations. -/
def prod {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟹ G) (β : H ⟹ I) : F.prod H ⟹ G.prod I :=
{ app         := λ X, (α X.1, β X.2),
  naturality' := begin /- `obviously'` says: -/ intros, cases f, cases Y, cases X, dsimp at *, simp, split, rw naturality, rw naturality end }

/- Again, it is inadvisable in Lean 3 to setup a notation `α × β`; use instead `α.prod β` or `nat_trans.prod α β`. -/

@[simp] lemma prod_app  {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟹ G) (β : H ⟹ I) (a : A) (c : C) : (nat_trans.prod α β) (a, c) = (α a, β c) := rfl
end nat_trans

end category_theory


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

! This file was ported from Lean 3 source module data.prod.basic
! leanprover-community/mathlib commit bd9851ca476957ea4549eb19b40e7b5ade9428cc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Init.Core
import Mathlib.Init.Data.Prod
import Mathlib.Init.Function
import Mathlib.Logic.Function.Basic
import Mathlib.Tactic.Inhabit

/-!
# Extra facts about `prod`

This file defines `prod.swap : α × β → β × α` and proves various simple lemmas about `prod`.
-/

variable {α : Type _} {β : Type _} {γ : Type _} {δ : Type _}

@[simp]
theorem Prod_map (f : α → γ) (g : β → δ) (p : α × β) : Prod.map f g p = (f p.1, g p.2) :=
  rfl
#align prod_map Prod_map

namespace Prod

@[simp]
theorem «forall» {p : α × β → Prop} : (∀ x, p x) ↔ ∀ a b, p (a, b) :=
  ⟨fun h a b ↦ h (a, b), fun h ⟨a, b⟩ ↦ h a b⟩
#align prod.forall Prod.forall

@[simp]
theorem «exists» {p : α × β → Prop} : (∃ x, p x) ↔ ∃ a b, p (a, b) :=
  ⟨fun ⟨⟨a, b⟩, h⟩ ↦ ⟨a, b, h⟩, fun ⟨a, b, h⟩ ↦ ⟨⟨a, b⟩, h⟩⟩
#align prod.exists Prod.exists

theorem forall' {p : α → β → Prop} : (∀ x : α × β, p x.1 x.2) ↔ ∀ a b, p a b :=
  Prod.forall
#align prod.forall' Prod.forall'

theorem exists' {p : α → β → Prop} : (∃ x : α × β, p x.1 x.2) ↔ ∃ a b, p a b :=
  Prod.exists
#align prod.exists' Prod.exists'

@[simp]
theorem snd_comp_mk (x : α) : Prod.snd ∘ (Prod.mk x : β → α × β) = id :=
  rfl
#align prod.snd_comp_mk Prod.snd_comp_mk

@[simp]
theorem fst_comp_mk (x : α) : Prod.fst ∘ (Prod.mk x : β → α × β) = Function.const β x :=
  rfl
#align prod.fst_comp_mk Prod.fst_comp_mk

@[simp]
theorem map_mk (f : α → γ) (g : β → δ) (a : α) (b : β) : map f g (a, b) = (f a, g b) :=
  rfl
#align prod.map_mk Prod.map_mk

theorem map_fst (f : α → γ) (g : β → δ) (p : α × β) : (map f g p).1 = f p.1 :=
  rfl
#align prod.map_fst Prod.map_fst

theorem map_snd (f : α → γ) (g : β → δ) (p : α × β) : (map f g p).2 = g p.2 :=
  rfl
#align prod.map_snd Prod.map_snd

theorem map_fst' (f : α → γ) (g : β → δ) : Prod.fst ∘ map f g = f ∘ Prod.fst :=
  funext <| map_fst f g
#align prod.map_fst' Prod.map_fst'

theorem map_snd' (f : α → γ) (g : β → δ) : Prod.snd ∘ map f g = g ∘ Prod.snd :=
  funext <| map_snd f g
#align prod.map_snd' Prod.map_snd'

/-- Composing a `Prod.map` with another `Prod.map` is equal to
a single `Prod.map` of composed functions.
-/
theorem map_comp_map {ε ζ : Type _} (f : α → β) (f' : γ → δ) (g : β → ε) (g' : δ → ζ) :
    Prod.map g g' ∘ Prod.map f f' = Prod.map (g ∘ f) (g' ∘ f') :=
  rfl
#align prod.map_comp_map Prod.map_comp_map

/-- Composing a `Prod.map` with another `Prod.map` is equal to
a single `Prod.map` of composed functions, fully applied.
-/
theorem map_map {ε ζ : Type _} (f : α → β) (f' : γ → δ) (g : β → ε) (g' : δ → ζ) (x : α × γ) :
    Prod.map g g' (Prod.map f f' x) = Prod.map (g ∘ f) (g' ∘ f') x :=
  rfl
#align prod.map_map Prod.map_map

-- Porting note: mathlib3 proof uses `by cc` for the mpr direction
-- Porting note: `@[simp]` tag removed because auto-generated `mk.injEq` simplifies LHS
-- @[simp]
theorem mk.inj_iff {a₁ a₂ : α} {b₁ b₂ : β} : (a₁, b₁) = (a₂, b₂) ↔ a₁ = a₂ ∧ b₁ = b₂ :=
  Iff.of_eq (mk.injEq _ _ _ _)
#align prod.mk.inj_iff Prod.mk.inj_iff

theorem mk.inj_left {α β : Type _} (a : α) : Function.Injective (Prod.mk a : β → α × β) := by
  intro b₁ b₂ h
  simpa only [true_and, Prod.mk.inj_iff, eq_self_iff_true] using h
#align prod.mk.inj_left Prod.mk.inj_left

lemma mk_inj_left : (a, b₁) = (a, b₂) ↔ b₁ = b₂ := (mk.inj_left _).eq_iff
lemma mk_inj_right : (a₁, b) = (a₂, b) ↔ a₁ = a₂ := (mk.inj_right _).eq_iff
#align prod.mk_inj_right Prod.mk_inj_right
#align prod.mk_inj_left Prod.mk_inj_left

theorem ext_iff {p q : α × β} : p = q ↔ p.1 = q.1 ∧ p.2 = q.2 := by
  rw [← @mk.eta _ _ p, ← @mk.eta _ _ q, mk.inj_iff]
#align prod.ext_iff Prod.ext_iff

@[ext]
theorem ext {α β} {p q : α × β} (h₁ : p.1 = q.1) (h₂ : p.2 = q.2) : p = q :=
  ext_iff.2 ⟨h₁, h₂⟩
#align prod.ext Prod.ext

theorem map_def {f : α → γ} {g : β → δ} : Prod.map f g = fun p : α × β ↦ (f p.1, g p.2) :=
  funext fun p ↦ ext (map_fst f g p) (map_snd f g p)
#align prod.map_def Prod.map_def

theorem id_prod : (fun p : α × β ↦ (p.1, p.2)) = id :=
  rfl
#align prod.id_prod Prod.id_prod

theorem map_id : Prod.map (@id α) (@id β) = id :=
  id_prod
#align prod.map_id Prod.map_id

theorem fst_surjective [h : Nonempty β] : Function.Surjective (@fst α β) :=
  fun x ↦ h.elim fun y ↦ ⟨⟨x, y⟩, rfl⟩
#align prod.fst_surjective Prod.fst_surjective

theorem snd_surjective [h : Nonempty α] : Function.Surjective (@snd α β) :=
  fun y ↦ h.elim fun x ↦ ⟨⟨x, y⟩, rfl⟩
#align prod.snd_surjective Prod.snd_surjective

theorem fst_injective [Subsingleton β] : Function.Injective (@fst α β) :=
  fun _ _ h ↦ ext h (Subsingleton.elim _ _)
#align prod.fst_injective Prod.fst_injective

theorem snd_injective [Subsingleton α] : Function.Injective (@snd α β) :=
  fun _ _ h ↦ ext (Subsingleton.elim _ _) h
#align prod.snd_injective Prod.snd_injective

/-- Swap the factors of a product. `swap (a, b) = (b, a)` -/
def swap : α × β → β × α := fun p ↦ (p.2, p.1)
#align prod.swap Prod.swap

@[simp]
theorem swap_swap : ∀ x : α × β, swap (swap x) = x
  | ⟨_, _⟩ => rfl
#align prod.swap_swap Prod.swap_swap

@[simp]
theorem fst_swap {p : α × β} : (swap p).1 = p.2 :=
  rfl
#align prod.fst_swap Prod.fst_swap

@[simp]
theorem snd_swap {p : α × β} : (swap p).2 = p.1 :=
  rfl
#align prod.snd_swap Prod.snd_swap

@[simp]
theorem swap_prod_mk {a : α} {b : β} : swap (a, b) = (b, a) :=
  rfl
#align prod.swap_prod_mk Prod.swap_prod_mk

@[simp]
theorem swap_swap_eq : swap ∘ swap = @id (α × β) :=
  funext swap_swap
#align prod.swap_swap_eq Prod.swap_swap_eq

@[simp]
theorem swap_leftInverse : Function.LeftInverse (@swap α β) swap :=
  swap_swap
#align prod.swap_left_inverse Prod.swap_leftInverse

@[simp]
theorem swap_rightInverse : Function.RightInverse (@swap α β) swap :=
  swap_swap
#align prod.swap_right_inverse Prod.swap_rightInverse

theorem swap_injective : Function.Injective (@swap α β) :=
  swap_leftInverse.injective
#align prod.swap_injective Prod.swap_injective

theorem swap_surjective : Function.Surjective (@swap α β) :=
  swap_leftInverse.surjective
#align prod.swap_surjective Prod.swap_surjective

theorem swap_bijective : Function.Bijective (@swap α β) :=
  ⟨swap_injective, swap_surjective⟩
#align prod.swap_bijective Prod.swap_bijective

@[simp]
theorem swap_inj {p q : α × β} : swap p = swap q ↔ p = q :=
  swap_injective.eq_iff
#align prod.swap_inj Prod.swap_inj

theorem eq_iff_fst_eq_snd_eq : ∀ {p q : α × β}, p = q ↔ p.1 = q.1 ∧ p.2 = q.2
  | ⟨p₁, p₂⟩, ⟨q₁, q₂⟩ => by simp
#align prod.eq_iff_fst_eq_snd_eq Prod.eq_iff_fst_eq_snd_eq

theorem fst_eq_iff : ∀ {p : α × β} {x : α}, p.1 = x ↔ p = (x, p.2)
  | ⟨a, b⟩, x => by simp
#align prod.fst_eq_iff Prod.fst_eq_iff

theorem snd_eq_iff : ∀ {p : α × β} {x : β}, p.2 = x ↔ p = (p.1, x)
  | ⟨a, b⟩, x => by simp
#align prod.snd_eq_iff Prod.snd_eq_iff

variable {r : α → α → Prop} {s : β → β → Prop} {x y : α × β}

theorem lex_def (r : α → α → Prop) (s : β → β → Prop) {p q : α × β} :
    Prod.Lex r s p q ↔ r p.1 q.1 ∨ p.1 = q.1 ∧ s p.2 q.2 :=
  ⟨fun h ↦ by cases h <;> simp [*], fun h ↦
    match p, q, h with
    | (a, b), (c, d), Or.inl h => Lex.left _ _ h
    | (a, b), (c, d), Or.inr ⟨e, h⟩ => by subst e; exact Lex.right _ h⟩
#align prod.lex_def Prod.lex_def

lemma lex_iff : Prod.Lex r s x y ↔ r x.1 y.1 ∨ x.1 = y.1 ∧ s x.2 y.2 := lex_def _ _
#align prod.lex_iff Prod.lex_iff

instance Lex.decidable [DecidableEq α]
    (r : α → α → Prop) (s : β → β → Prop) [DecidableRel r] [DecidableRel s] :
    DecidableRel (Prod.Lex r s) :=
  fun _ _ ↦ decidable_of_decidable_of_iff (lex_def r s).symm

@[refl]
theorem Lex.refl_left (r : α → α → Prop) (s : β → β → Prop) [IsRefl α r] : ∀ x, Prod.Lex r s x x
  | (_, _) => Lex.left _ _ (refl _)
#align prod.lex.refl_left Prod.Lex.refl_left

instance {r : α → α → Prop} {s : β → β → Prop} [IsRefl α r] : IsRefl (α × β) (Prod.Lex r s) :=
  ⟨Lex.refl_left _ _⟩

@[refl]
theorem Lex.refl_right (r : α → α → Prop) (s : β → β → Prop) [IsRefl β s] : ∀ x, Prod.Lex r s x x
  | (_, _) => Lex.right _ (refl _)
#align prod.lex.refl_right Prod.Lex.refl_right

instance {r : α → α → Prop} {s : β → β → Prop} [IsRefl β s] : IsRefl (α × β) (Prod.Lex r s) :=
  ⟨Lex.refl_right _ _⟩

instance isIrrefl [IsIrrefl α r] [IsIrrefl β s] : IsIrrefl (α × β) (Prod.Lex r s) :=
⟨by rintro ⟨i, a⟩ (⟨_, _, h⟩ | ⟨_, h⟩) <;> exact irrefl _ h⟩

@[trans]
theorem Lex.trans {r : α → α → Prop} {s : β → β → Prop} [IsTrans α r] [IsTrans β s] :
    ∀ {x y z : α × β}, Prod.Lex r s x y → Prod.Lex r s y z → Prod.Lex r s x z
  | (_, _), (_, _), (_, _), left  _ _ hxy₁, left  _ _ hyz₁ => left  _ _ (_root_.trans hxy₁ hyz₁)
  | (_, _), (_, _), (_, _), left  _ _ hxy₁, right _ _      => left  _ _ hxy₁
  | (_, _), (_, _), (_, _), right _ _,      left  _ _ hyz₁ => left  _ _ hyz₁
  | (_, _), (_, _), (_, _), right _ hxy₂,   right _ hyz₂   => right _ (_root_.trans hxy₂ hyz₂)
#align prod.lex.trans Prod.Lex.trans

instance {r : α → α → Prop} {s : β → β → Prop} [IsTrans α r] [IsTrans β s] :
  IsTrans (α × β) (Prod.Lex r s) :=
  ⟨fun _ _ _ ↦ Lex.trans⟩

instance {r : α → α → Prop} {s : β → β → Prop} [IsStrictOrder α r] [IsAntisymm β s] :
    IsAntisymm (α × β) (Prod.Lex r s) :=
  ⟨fun x₁ x₂ h₁₂ h₂₁ ↦
    match x₁, x₂, h₁₂, h₂₁ with
    | (a, _), (_, _), .left  _ _ hr₁, .left  _ _ hr₂ => (irrefl a (_root_.trans hr₁ hr₂)).elim
    | (_, _), (_, _), .left  _ _ hr₁, .right _ _     => (irrefl _ hr₁).elim
    | (_, _), (_, _), .right _ _,     .left  _ _ hr₂ => (irrefl _ hr₂).elim
    | (_, _), (_, _), .right _ hs₁,   .right _ hs₂   => antisymm hs₁ hs₂ ▸ rfl⟩

instance isTotal_left {r : α → α → Prop} {s : β → β → Prop} [IsTotal α r] :
    IsTotal (α × β) (Prod.Lex r s) :=
  ⟨fun ⟨a₁, _⟩ ⟨a₂, _⟩ ↦ (IsTotal.total a₁ a₂).imp (Lex.left _ _) (Lex.left _ _)⟩
#align prod.is_total_left Prod.isTotal_left

instance isTotal_right {r : α → α → Prop} {s : β → β → Prop} [IsTrichotomous α r] [IsTotal β s] :
    IsTotal (α × β) (Prod.Lex r s) :=
  ⟨fun ⟨i, a⟩ ⟨j, b⟩ ↦ by
    obtain hij | rfl | hji := trichotomous_of r i j
    · exact Or.inl (.left _ _ hij)
    · exact (total_of s a b).imp (.right _) (.right _)
    · exact Or.inr (.left _ _ hji) ⟩
#align prod.is_total_right Prod.isTotal_right

instance IsTrichotomous [IsTrichotomous α r] [IsTrichotomous β s] :
  IsTrichotomous (α × β) (Prod.Lex r s) :=
⟨fun ⟨i, a⟩ ⟨j, b⟩ ↦ by
  obtain hij | rfl | hji := trichotomous_of r i j
  { exact Or.inl (Lex.left _ _ hij) }
  { exact (trichotomous_of (s) a b).imp3 (Lex.right _) (congr_arg _) (Lex.right _) }
  { exact Or.inr (Or.inr $ Lex.left _ _ hji) }⟩

end Prod

open Prod

namespace Function

variable {f : α → γ} {g : β → δ} {f₁ : α → β} {g₁ : γ → δ} {f₂ : β → α} {g₂ : δ → γ}

theorem Injective.Prod_map (hf : Injective f) (hg : Injective g) : Injective (map f g) :=
  fun _ _ h ↦ ext (hf (ext_iff.1 h).1) (hg <| (ext_iff.1 h).2)
#align function.injective.prod_map Function.Injective.Prod_map

theorem Surjective.Prod_map (hf : Surjective f) (hg : Surjective g) : Surjective (map f g) :=
  fun p ↦
  let ⟨x, hx⟩ := hf p.1
  let ⟨y, hy⟩ := hg p.2
  ⟨(x, y), Prod.ext hx hy⟩
#align function.surjective.prod_map Function.Surjective.Prod_map

theorem Bijective.Prod_map (hf : Bijective f) (hg : Bijective g) : Bijective (map f g) :=
  ⟨hf.1.Prod_map hg.1, hf.2.Prod_map hg.2⟩
#align function.bijective.prod_map Function.Bijective.Prod_map

theorem LeftInverse.Prod_map (hf : LeftInverse f₁ f₂) (hg : LeftInverse g₁ g₂) :
    LeftInverse (map f₁ g₁) (map f₂ g₂) :=
  fun a ↦ by rw [Prod.map_map, hf.comp_eq_id, hg.comp_eq_id, map_id, id]
#align function.left_inverse.prod_map Function.LeftInverse.Prod_map

theorem RightInverse.Prod_map :
    RightInverse f₁ f₂ → RightInverse g₁ g₂ → RightInverse (map f₁ g₁) (map f₂ g₂) :=
  LeftInverse.Prod_map
#align function.right_inverse.prod_map Function.RightInverse.Prod_map

theorem Involutive.Prod_map {f : α → α} {g : β → β} :
    Involutive f → Involutive g → Involutive (map f g) :=
  LeftInverse.Prod_map
#align function.involutive.prod_map Function.Involutive.Prod_map

end Function

namespace Prod

open Function

@[simp]
theorem map_injective [Nonempty α] [Nonempty β] {f : α → γ} {g : β → δ} :
    Injective (map f g) ↔ Injective f ∧ Injective g :=
  ⟨fun h =>
    ⟨fun a₁ a₂ ha => by
      inhabit β
      injection
        @h (a₁, default) (a₂, default) (congr_arg (fun c : γ => Prod.mk c (g default)) ha : _),
      fun b₁ b₂ hb => by
      inhabit α
      injection @h (default, b₁) (default, b₂) (congr_arg (Prod.mk (f default)) hb : _)⟩,
    fun h => h.1.Prod_map h.2⟩
#align prod.map_injective Prod.map_injective

@[simp]
theorem map_surjective [Nonempty γ] [Nonempty δ] {f : α → γ} {g : β → δ} :
    Surjective (map f g) ↔ Surjective f ∧ Surjective g :=
  ⟨fun h =>
    ⟨fun c => by
      inhabit δ
      obtain ⟨⟨a, b⟩, h⟩ := h (c, default)
      exact ⟨a, congr_arg Prod.fst h⟩,
      fun d => by
      inhabit γ
      obtain ⟨⟨a, b⟩, h⟩ := h (default, d)
      exact ⟨b, congr_arg Prod.snd h⟩⟩,
    fun h => h.1.Prod_map h.2⟩
#align prod.map_surjective Prod.map_surjective

@[simp]
theorem map_bijective [Nonempty α] [Nonempty β] {f : α → γ} {g : β → δ} :
    Bijective (map f g) ↔ Bijective f ∧ Bijective g := by
  haveI := Nonempty.map f ‹_›
  haveI := Nonempty.map g ‹_›
  exact (map_injective.and map_surjective).trans (and_and_and_comm)
#align prod.map_bijective Prod.map_bijective

@[simp]
theorem map_leftInverse [Nonempty β] [Nonempty δ] {f₁ : α → β} {g₁ : γ → δ} {f₂ : β → α}
    {g₂ : δ → γ} : LeftInverse (map f₁ g₁) (map f₂ g₂) ↔ LeftInverse f₁ f₂ ∧ LeftInverse g₁ g₂ :=
  ⟨fun h =>
    ⟨fun b => by
      inhabit δ
      exact congr_arg Prod.fst (h (b, default)),
      fun d => by
      inhabit β
      exact congr_arg Prod.snd (h (default, d))⟩,
    fun h => h.1.Prod_map h.2 ⟩
#align prod.map_left_inverse Prod.map_leftInverse

@[simp]
theorem map_rightInverse [Nonempty α] [Nonempty γ] {f₁ : α → β} {g₁ : γ → δ} {f₂ : β → α}
    {g₂ : δ → γ} : RightInverse (map f₁ g₁) (map f₂ g₂) ↔ RightInverse f₁ f₂ ∧ RightInverse g₁ g₂ :=
  map_leftInverse
#align prod.map_right_inverse Prod.map_rightInverse

@[simp]
theorem map_involutive [Nonempty α] [Nonempty β] {f : α → α} {g : β → β} :
    Involutive (map f g) ↔ Involutive f ∧ Involutive g :=
  map_leftInverse
#align prod.map_involutive Prod.map_involutive

end Prod


/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan
-/
import general_bernoulli_number.lim_even_character
import dirichlet_character.dvd_conductor_mul

/-!
# A convergence property regarding (ℤ/dp^n ℤ)ˣ
This file proves Proposition 7.11 in Introduction to Cyclotomic Fields, Washington.
It gives a convergence property relating to generalized Bernoulli numbers.

# Main Theorems
 * `U`
 * `helper_U_3`

## Tags
p-adic, L-function, Bernoulli measure, Dirichlet character
-/

open_locale big_operators
local attribute [instance] zmod.topological_space

open filter ind_fn dirichlet_character
open_locale topological_space

open_locale big_operators

variables {p : ℕ} [fact (nat.prime p)] {d : ℕ} [fact (0 < d)] {R : Type*} [normed_comm_ring R] (m : ℕ)
(hd : d.gcd p = 1) (χ : dirichlet_character R (d*(p^m))) {c : ℕ} (hc : c.gcd p = 1)
(hc' : c.gcd d = 1) (na : ∀ (n : ℕ) (f : ℕ → R),
  ∥ ∑ (i : ℕ) in finset.range n, f i∥ ≤ ⨆ (i : zmod n), ∥f i.val∥)
(w : continuous_monoid_hom (units (zmod d) × units ℤ_[p]) R)
variables (p d R) [complete_space R] [char_zero R]
open continuous_map

variables [normed_algebra ℚ_[p] R] [fact (0 < m)]
open clopen_from
variable [fact (0 < d)]

open eventually_constant_seq clopen_from

/-- The first sum in the proof of Theorem 12.2. -/
noncomputable def U_def [algebra ℚ R] [norm_one_class R] (n : ℕ) (k : ℕ) :=
  ∑ (x : (zmod (d * p ^ k))ˣ),
  ((asso_dirichlet_character (χ.mul (teichmuller_character_mod_p' p R^n)) x : R) *
  ((((x : zmod (d * p^k))).val)^(n - 1) : R)) •
  (algebra_map ℚ R) (int.fract (↑x / (↑d * ↑p ^ k)))
-- Idea 1 : replacing k by m + k so we can remove (hk : m ≤ k)
-- Idea 2 : Use `asso_dirichlet_character` instead to get rid of hk, since coercion on non-units
-- can be anywhere

-- not needed?
lemma set.finite_of_finite_inter {α : Type*} (s : finset α) (t : set α) :
  set.finite ((s : set α) ∩ t : set α) := set.finite.inter_of_left (finset.finite_to_set s) t

lemma sum_units_eq {x : ℕ} (hx : 0 < x) (f : ℕ → R) :
  ∑ (i : units (zmod (d * p^x))), f (i : zmod (d * p^x)).val =
  ∑ i in set.finite.to_finset (set.finite_of_finite_inter (finset.range (d * p^x))
  ({x | x.coprime d} ∩ {x | x.coprime p})), f i :=
begin
  apply finset.sum_bij,
  swap 5, { refine λ a ha, (a : zmod (d * p^x)).val, },
  { intros a ha,
    simp only [set.finite.mem_to_finset, set.mem_inter_eq, finset.mem_coe, finset.mem_range,
      set.mem_set_of_eq],
    refine ⟨zmod.val_lt _, _⟩,
    set b := zmod.units_equiv_coprime a,
    have := nat.coprime_mul_iff_right.1 b.2,
    rw nat.coprime_pow_right_iff hx at this,
    apply this, },
  { intros a ha, refl, },
  { intros a₁ a₂ ha₁ ha₂ h,
    --haveI : fact (0 < d * p^x) := imp p d x,
    rw units.ext_iff, rw zmod.val_injective _ h, },
  { intros b hb,
    simp only [set.finite.mem_to_finset, set.mem_inter_eq, finset.mem_coe, finset.mem_range,
      set.mem_set_of_eq] at hb,
    refine ⟨zmod.units_equiv_coprime.inv_fun ⟨b, (zmod.val_cast_of_lt hb.1).symm ▸
      (nat.coprime.mul_right hb.2.1 (nat.coprime.pow_right _ hb.2.2)) ⟩, finset.mem_univ _, _⟩,
    rw zmod.units_equiv_coprime,
    simp only [zmod.coe_unit_of_coprime, zmod.nat_cast_val, zmod.cast_nat_cast'],
    rw zmod.val_cast_of_lt hb.1, },
end

lemma helper_U_3' [algebra ℚ R] [norm_one_class R] {n : ℕ} (hn : 1 < n) (x : ℕ) :
  ∑ (x_1 : ℕ) in finset.range (d * p ^ x), (1 / ↑(d * p ^ x : ℕ) : ℚ) •
  ((asso_dirichlet_character (χ.mul (teichmuller_character_mod_p' p R ^ n))) (↑p * ↑x_1) *
  (↑p ^ (n - 1) * ↑x_1 ^ n)) = ∑ y in set.finite.to_finset (set.finite_of_finite_inter
  (finset.range (d * p^x.succ)) ({x | ¬ x.coprime p})), ((asso_dirichlet_character
  (χ.mul (teichmuller_character_mod_p' p R ^ n))) ↑y * ↑y ^ (n - 1)) •
  (algebra_map ℚ R) (↑y / (↑d * ↑p ^ x.succ)) :=
begin
  symmetry,
  apply finset.sum_bij,
  swap 5, { refine λ a ha, _,
    simp only [set.finite.mem_to_finset, set.mem_inter_eq, finset.mem_coe, finset.mem_range,
      set.mem_set_of_eq] at ha,
    refine classical.some (nat.prime_dvd_of_not_coprime p ha.2), },
  { intros a ha,
    simp only [set.finite.mem_to_finset, set.mem_inter_eq, finset.mem_coe, finset.mem_range,
      set.mem_set_of_eq] at ha,
    simp only [finset.mem_range],
    apply lt_of_mul_lt_mul_right', swap, { exact p, },
    rw mul_assoc, rw ← pow_succ', rw mul_comm,
    rw ← classical.some_spec (nat.prime_dvd_of_not_coprime p ha.2), apply ha.1, },
  { intros a ha,
    have h1 : ∀ x : ℕ, ((d * p^x : ℕ) : ℚ) ≠ 0 := λ x, nat.cast_ne_zero.2 (nat.ne_zero_of_lt' 0),
    simp only [set.finite.mem_to_finset, set.mem_inter_eq, finset.mem_coe, finset.mem_range,
      set.mem_set_of_eq] at ha,
    simp_rw [← nat.cast_pow, ← nat.cast_mul],
    rw ← classical.some_spec (nat.prime_dvd_of_not_coprime p ha.2),
    rw ← mul_smul_comm, rw smul_eq_mul, rw mul_assoc, congr,
    rw ← algebra_map_smul R, rw smul_eq_mul,
    conv_rhs { congr, skip, congr, congr, skip, rw ← nat.succ_pred_eq_of_pos
      (lt_trans zero_lt_one hn), rw pow_succ', },
    rw ← mul_assoc (p ^ (n - 1)) _ _, rw nat.pred_eq_sub_one, rw ← mul_pow,
    rw ← classical.some_spec (nat.prime_dvd_of_not_coprime p ha.2), rw nat.cast_mul (a ^ (n - 1)) _,
    rw mul_comm ((algebra_map ℚ R) (1 / ↑(d * p ^ x))) _,
    rw mul_assoc, congr, rw ← map_nat_cast (algebra_map ℚ R), rw ← ring_hom.map_mul,
    apply congr_arg, rw mul_one_div, rw div_eq_div_iff (h1 _) (h1 _), norm_cast,
    rw mul_comm _ (d * p^x.succ),
    conv_rhs { congr, congr, skip, rw nat.succ_eq_add_one x, rw pow_succ' p x, },
    rw ← mul_assoc d _ _, rw mul_assoc (d * p^x) _ _,
    rw ← classical.some_spec (nat.prime_dvd_of_not_coprime p ha.2), rw mul_comm _ a,
    { apply_instance, }, },
  { intros a b ha hb h,
    simp only [set.finite.mem_to_finset, set.mem_inter_eq, finset.mem_coe, finset.mem_range,
      set.mem_set_of_eq] at ha,
    simp only [set.finite.mem_to_finset, set.mem_inter_eq, finset.mem_coe, finset.mem_range,
      set.mem_set_of_eq] at hb,
    have h2 : p * (classical.some (nat.prime_dvd_of_not_coprime p ha.2)) =
      p * (classical.some (nat.prime_dvd_of_not_coprime p hb.2)),
    { congr, apply h, },
    rw ← classical.some_spec (nat.prime_dvd_of_not_coprime p ha.2) at h2,
    rw ← classical.some_spec (nat.prime_dvd_of_not_coprime p hb.2) at h2, rw h2, },
  { intros b hb, refine ⟨p * b, _, _⟩,
    { simp only [set.finite.mem_to_finset, set.mem_inter_eq, finset.mem_coe, finset.mem_range,
        set.mem_set_of_eq], split,
      { rw mul_comm p, rw pow_succ', rw ← mul_assoc,
        apply nat.mul_lt_mul (finset.mem_range.1 hb) le_rfl (nat.prime.pos (fact.out _)),
        apply_instance, },
      { rw nat.prime.not_coprime_iff_dvd, refine ⟨p, fact.out _, dvd_mul_right p b, dvd_rfl⟩, }, },
    { apply nat.eq_of_mul_eq_mul_left (nat.prime.pos (fact.out _)) _,
      { exact p, },
      { apply_instance, },
      { rw ← classical.some_spec (nat.prime_dvd_of_not_coprime p _), }, }, },
end

open dirichlet_character
variable (hd)

lemma helper_U_2' [no_zero_divisors R] [algebra ℚ R] [norm_one_class R] (n : ℕ) (hn : 1 < n)
  (hχ : χ.is_even) (hp : 2 < p)
  (na : ∀ (n : ℕ) (f : ℕ → R), ∥ ∑ (i : ℕ) in finset.range n, f i∥ ≤ ⨆ (i : zmod n), ∥f i.val∥) :
  tendsto (λ x : ℕ, ∑ y in set.finite.to_finset (set.finite_of_finite_inter
  (finset.range (d * p^x.succ)) ({x | ¬ x.coprime p})), ((asso_dirichlet_character
  (χ.mul (teichmuller_character_mod_p' p R ^ n))) ↑y * ↑y ^ (n - 1)) •
  (algebra_map ℚ R) (↑y / (↑d * ↑p ^ x.succ)) ) at_top (nhds ((asso_dirichlet_character
  (dirichlet_character.mul χ (teichmuller_character_mod_p' p R^n)) (p) * p^(n - 1)) *
  (general_bernoulli_number (dirichlet_character.mul χ
  (teichmuller_character_mod_p' p R^n)) n))) :=
begin
  conv { congr, funext, rw ← helper_U_3' p d R m χ hn, },
  apply (tendsto_congr _).1 (tendsto.const_mul ((asso_dirichlet_character
    (dirichlet_character.mul χ (teichmuller_character_mod_p' p R^n)) (p) * p^(n - 1)))
    (lim_even_character' p d R m χ hn hχ hp na)),
  intro x, rw mul_smul_comm, rw finset.mul_sum, rw finset.smul_sum,
  apply finset.sum_congr rfl,
  intros x hx, rw monoid_hom.map_mul, rw div_smul_eq_div_smul p R, apply congr_arg, ring,
end

lemma helper_U_1' [no_zero_divisors R] [algebra ℚ R] [norm_one_class R] (n : ℕ) (hn : 1 < n)
  (hχ : χ.is_even) (hp : 2 < p)
  (na : ∀ (n : ℕ) (f : ℕ → R), ∥ ∑ (i : ℕ) in finset.range n, f i∥ ≤ ⨆ (i : zmod n), ∥f i.val∥) :
  tendsto (λ x : ℕ, ∑ y in set.finite.to_finset (set.finite_of_finite_inter
  (finset.range (d * p^x)) ({x | ¬ x.coprime p})), ((asso_dirichlet_character
  (χ.mul (teichmuller_character_mod_p' p R ^ n))) ↑y * ↑y ^ (n - 1)) •
  (algebra_map ℚ R) (↑y / (↑d * ↑p ^ x)) ) at_top (nhds ((asso_dirichlet_character
  (dirichlet_character.mul χ (teichmuller_character_mod_p' p R^n)) (p) * p^(n - 1) ) *
  (general_bernoulli_number (dirichlet_character.mul χ
  (teichmuller_character_mod_p' p R^n)) n))) :=
begin
  have h1 := helper_U_2' p d R m χ n hn hχ hp na,
  have h2 : tendsto nat.pred at_top at_top,
  { rw tendsto_at_top, intro b, simp, refine ⟨b.succ, λ c hc, _⟩,
    rw nat.pred_eq_sub_one,
    apply (nat.add_le_to_le_sub _ _).1 _,
    { apply le_trans (nat.one_le_iff_ne_zero.2 (nat.succ_ne_zero _)) hc, },
    { apply hc, }, },
  have h3 : function.comp (λ x : ℕ, ∑ y in set.finite.to_finset (set.finite_of_finite_inter
  (finset.range (d * p^x.succ)) ({x | ¬ x.coprime p})), ((asso_dirichlet_character
  (χ.mul (teichmuller_character_mod_p' p R ^ n))) ↑y * ↑y ^ (n - 1)) •
  (algebra_map ℚ R) (↑y / (↑d * ↑p ^ x.succ)) ) nat.pred =ᶠ[at_top] (λ x : ℕ, ∑ y in set.finite.to_finset (set.finite_of_finite_inter
  (finset.range (d * p^x)) ({x | ¬ x.coprime p})), ((asso_dirichlet_character
  (χ.mul (teichmuller_character_mod_p' p R ^ n))) ↑y * ↑y ^ (n - 1)) •
  (algebra_map ℚ R) (↑y / (↑d * ↑p ^ x)) ),
  { rw eventually_eq, rw eventually_at_top,
    refine ⟨1, λ x hx, _⟩, rw function.comp_apply,
    rw nat.succ_pred_eq_of_pos (nat.succ_le_iff.1 hx), },
  apply (tendsto_congr' h3).1 _, clear h3,
  apply tendsto.comp h1 h2,
end

open zmod
lemma helper_U_2 [no_zero_divisors R] [algebra ℚ R] [norm_one_class R] (n : ℕ)
  (hd : d.coprime p) (hχ : d ∣ χ.conductor) :
  tendsto (λ x : ℕ, ∑ y in set.finite.to_finset (set.finite_of_finite_inter
  (finset.range (d * p^x)) ({x | ¬ x.coprime d})), ((asso_dirichlet_character
  (χ.mul (teichmuller_character_mod_p' p R ^ n))) ↑y * ↑y ^ (n - 1)) •
  (algebra_map ℚ R) (↑y / (↑d * ↑p ^ x))) at_top (nhds 0) :=
begin
  apply (tendsto_congr _).2 (tendsto_const_nhds),
  intro x,
  apply finset.sum_eq_zero,
  intros y hy,
  rw smul_eq_mul,
  rw mul_eq_zero, left,
  rw mul_eq_zero, left,
  simp only [set.finite.mem_to_finset, set.mem_inter_eq, finset.mem_coe, finset.mem_range,
    set.mem_set_of_eq] at hy,
  cases hy with h1 h2,
  rw asso_dirichlet_character_eq_zero,
  contrapose h2, rw not_not at *, apply zmod.coprime_of_is_unit,
  obtain ⟨k, hk⟩ := dvd_mul_of_dvd_conductor p d R m χ n hd hχ,
  rw (is_primitive_def _).1 (is_primitive.mul _ _) at hk,
  rw hk at h2,
  apply is_unit_of_is_unit_mul y h2,
end

lemma helper_U_4 [algebra ℚ R] [no_zero_divisors R] (hd : d.coprime p) (hχ : d ∣ χ.conductor) (n x : ℕ) : ∑ (x_1 : ℕ) in (set.finite_of_finite_inter
  (finset.range (d * p ^ x)) {x : ℕ | ¬x.coprime d}).to_finset ∩ (set.finite_of_finite_inter
  (finset.range (d * p ^ x)) {x : ℕ | ¬x.coprime p}).to_finset,
  ((asso_dirichlet_character (χ.mul (teichmuller_character_mod_p' p R ^ n))) ↑x_1 *
  ↑x_1 ^ (n - 1)) • (algebra_map ℚ R) (↑x_1 / (↑d * ↑p ^ x)) = 0 :=
begin
  apply finset.sum_eq_zero, intros y hy,
  simp only [finset.mem_inter, set.finite.mem_to_finset, set.mem_inter_eq, finset.mem_coe,
    finset.mem_range, set.mem_set_of_eq] at hy,
  convert zero_smul R _, rw mul_eq_zero, left,
  rw asso_dirichlet_character_eq_zero,
  cases hy with p1 p3,
  cases p1 with p1 p2,
  cases p3 with p3 p4,
  contrapose p2, rw not_not at *, apply coprime_of_is_unit,
  obtain ⟨k, hk⟩ := dvd_mul_of_dvd_conductor p d R m χ n hd hχ,
  rw (is_primitive_def _).1 (is_primitive.mul _ _) at hk,
  rw hk at p2,
  apply is_unit_of_is_unit_mul y p2,
end

lemma helper_U_3 (x : ℕ) : finset.range (d * p^x) = set.finite.to_finset (set.finite_of_finite_inter
  (finset.range (d * p^x)) ({x | ¬ x.coprime d})) ∪ ((set.finite.to_finset (set.finite_of_finite_inter
  (finset.range (d * p^x)) ({x | ¬ x.coprime p}))) ∪ set.finite.to_finset (set.finite_of_finite_inter (finset.range (d * p^x))
  ({x | x.coprime d} ∩ {x | x.coprime p}))) :=
begin
  ext,
  simp only [finset.mem_range, finset.mem_union, set.finite.mem_to_finset, set.mem_inter_eq,
    finset.mem_coe, set.mem_set_of_eq],
  split, -- better way to do this?
  { intro h,
    by_cases h' : a.coprime d ∧ a.coprime p, { right, right, refine ⟨h, h'⟩, },
    { rw not_and_distrib at h', cases h',
      { left, refine ⟨h, h'⟩, },
      { right, left, refine ⟨h, h'⟩, }, }, },
  { intro h, cases h, apply h.1,
    cases h, apply h.1, apply h.1, },
end

open zmod
lemma U [algebra ℚ R] [norm_one_class R] [no_zero_divisors R] [is_scalar_tower ℚ ℚ_[p] R]
  (hd : d.coprime p) (n : ℕ) (hn : 1 < n) (hχ : χ.is_even) (hχ' : d ∣ χ.conductor) (hp : 2 < p)
  (na : ∀ (n : ℕ) (f : ℕ → R), ∥ ∑ (i : ℕ) in finset.range n, f i∥ ≤ ⨆ (i : zmod n), ∥f i.val∥) :
  filter.tendsto (λ j : ℕ, U_def p d R m χ n j)
  filter.at_top (nhds ((1 - asso_dirichlet_character (dirichlet_character.mul χ
  (teichmuller_character_mod_p' p R^n)) (p) * p^(n - 1) ) *
  (general_bernoulli_number (dirichlet_character.mul χ
  (teichmuller_character_mod_p' p R^n)) n)) ) :=
begin
  delta U_def,
  convert (tendsto_congr' _).2 (filter.tendsto.sub (filter.tendsto.sub
    (lim_even_character' p d R m χ hn hχ hp na) (helper_U_2 p d R m χ n hd hχ')) (helper_U_1' p d R m χ n hn hχ hp na)), -- might need a tendsto_congr' here
  { rw sub_zero, rw ← one_sub_mul, },
  { rw eventually_eq, rw eventually_at_top,
    refine ⟨m, λ x hx, _⟩,
    --simp only,
    have h1 : d * p^m ∣ d * p^x := mul_dvd_mul_left d (pow_dvd_pow p hx),
    rw finset.smul_sum,
    conv_lhs { apply_congr, skip, rw coe_coe, rw coe_coe,
      rw ← zmod.nat_cast_val (x_1 : zmod (d * p^x)),
      rw ← zmod.nat_cast_val (x_1 : zmod (d * p^x)),
      rw ← nat.cast_pow p, rw ← nat.cast_mul,
      rw int.fract_eq_self.2 (@zero_le_div_and_div_lt_one (d * p^x) _ _), -- (zero_le_div_and_div_lt_one p d _ _).2,
      rw nat.cast_mul, rw nat.cast_pow p,
      /-conv { congr, rw ← dirichlet_character.mul_eq_mul R χ
        (teichmuller_character_mod_p' p R ^ n) (zmod.is_unit_val_of_unit h1 x_1), }, -/ },
    convert sum_units_eq p d R _ (λ (y : ℕ), ((asso_dirichlet_character
      (χ.mul (teichmuller_character_mod_p' p R ^ n))) ↑y * ↑y ^ (n - 1)) •
      (algebra_map ℚ R) (((y : ℚ) / (↑d * ↑p ^ x)))),
    -- ext, congr,
    rw sub_sub, rw ← finset.sum_union_inter, rw add_comm,
    apply sub_eq_of_eq_add', rw add_assoc, rw ← finset.sum_union _,
    rw helper_U_4 p d R m χ hd hχ', rw zero_add,
--    apply sub_eq_of_eq_add', rw ← finset.sum_union _,
    { apply finset.sum_congr,
      { rw finset.union_assoc, rw ← helper_U_3, },
      { intros y hy, rw ←algebra_map_smul R (1 / ↑(d * p ^ x : ℕ) : ℚ_[p]),
        rw smul_eq_mul, rw smul_eq_mul,
        { rw mul_comm, rw ← mul_one (y : ℚ), rw ← mul_div, rw ring_hom.map_mul, rw map_nat_cast,
          rw ← mul_assoc, rw [nat.cast_mul d _, nat.cast_pow p], apply congr_arg2 _ _ _,
          rw mul_assoc, apply congr_arg2 _ rfl _, rw ← pow_succ', rw nat.sub_add_cancel (le_of_lt hn),
          rw is_scalar_tower.algebra_map_apply ℚ ℚ_[p] R,
          simp_rw [← nat.cast_pow, ← nat.cast_mul],
          apply congr_arg,
          symmetry,
          apply eq_one_div_of_mul_eq_one_left,
          rw ←smul_eq_mul, rw algebra_map_smul,
          rw one_div_smul_self _ (nat.ne_zero_of_lt' 0),
          apply_instance, },
        { apply_instance, }, }, },
    { rw finset.disjoint_union_left, simp_rw finset.disjoint_iff_inter_eq_empty,
      refine ⟨_, _⟩,
      { ext,
        simp only [finset.mem_inter, set.finite.mem_to_finset, set.mem_inter_eq,
          finset.mem_coe, finset.mem_range, set.mem_set_of_eq, finset.not_mem_empty, iff_false,
          not_and, and_imp],
        intros p1 p2 p3 p4 p5,
        apply p2 p4, },
      { ext,
        simp only [finset.mem_inter, set.finite.mem_to_finset, set.mem_inter_eq,
          finset.mem_coe, finset.mem_range, set.mem_set_of_eq, finset.not_mem_empty, iff_false,
          not_and, and_imp],
        intros p1 p2 p3 p4 p5,
        apply p2 p5, }, },
    { apply lt_of_lt_of_le (fact.out _) hx, apply_instance, }, },
end


import M4R.Algebra.Ring.MaxPrimeIdeal
import M4R.Algebra.Ring.Prod

namespace M4R
  open Monoid NCSemiring Semiring

  namespace Ideal
    variable [Ring α] (I : Ideal α)

    protected def is_radical : Prop := ∀ (x : α) (n : Nat), n ≠ 0 → x^n ∈ I → x ∈ I

    def radical : Ideal α where
      subset     := {x | ∃ n : Nat, n ≠ 0 ∧ x^n ∈ I}
      has_zero   := ⟨1, Nat.one_ne_zero, by rw [pow_nat_1]; exact I.has_zero⟩
      add_closed := by
        intro a b ⟨m, hm, ham⟩ ⟨n, hn, hbn⟩; exact ⟨m+n-1,
          ⟨by
            apply Nat.ge_one_iff_ne_zero.mp
            apply Nat.le_of_succ_le_succ
            rw [Nat.sub_one, Nat.succ_pred_eq_of_pos (Nat.add_zero 0 ▸
              (Nat.add_lt_add (Nat.pos_iff_ne_zero.mpr hm) (Nat.pos_iff_ne_zero.mpr hn)))]
            exact Nat.add_le_add (Nat.ge_one_iff_ne_zero.mpr hm) (Nat.ge_one_iff_ne_zero.mpr hn),
          by
            rw [Semiring.binomial, Finset.map_sum.antidiagonal_eq_range, Finset.range_eq_range',
              Finset.map_sum.range'_split m (by
                rw [Nat.sub_one, Nat.succ_pred_eq_of_pos (Nat.add_zero 0 ▸
                  Nat.add_lt_add (Nat.pos_iff_ne_zero.mpr hm) (Nat.pos_iff_ne_zero.mpr hn))]
                exact Nat.le_add_right m n)]
            exact I.add_closed (Ideal.div_mem.mpr ⟨b^n, hbn,
              Finset.map_sum.prop_sum _ _ _ (divides_zero _) (fun k hk =>
                ⟨((m + n - 1).choose k) * a ^ k * b ^ (m - 1 - k), by
                  rw [Semiring.mul_comm, NCSemiring.mul_assoc, ←NCSemiring.pow_nat_add_distrib]
                  have : m - 1 - k + n = m + n - 1 - k := by
                    rw [Nat.add_sub_comm (Nat.ge_one_iff_ne_zero.mpr hm), Nat.add_sub_comm (by
                      apply Nat.lt_succ_if_le.mp
                      rw [Nat.sub_one, Nat.succ_pred_eq_of_pos (Nat.pos_iff_ne_zero.mpr hm), ←Nat.zero_add m]
                      exact (Finset.range'.mem_range'.mp hk).right)]
                  rw [this]⟩) (@divides_add _ _ (b^n))⟩)
              (Ideal.div_mem.mpr ⟨a^m, ham,
              Finset.map_sum.prop_sum _ _ _ (divides_zero _) (fun k hk =>
                ⟨((m + n - 1).choose k) * a ^ (k - m) * b ^ (m + n - 1 - k), by
                  rw [Semiring.mul_comm, NCSemiring.mul_assoc, Semiring.mul_comm _ (a^m),
                    NCSemiring.mul_assoc, ←NCSemiring.mul_assoc (a^_),
                    ←NCSemiring.pow_nat_add_distrib, ←NCSemiring.mul_assoc,
                    Nat.sub_add_cancel (Nat.zero_add m ▸ (Finset.range'.mem_range'.mp hk).left)]⟩)
                  (@divides_add _ _ (a^m))⟩)⟩⟩
      mul_closed := fun a b ⟨m, ⟨hm, hbm⟩⟩ => ⟨m, ⟨hm, by rw [pow_nat_mul_distrib]; exact I.mul_closed (a^m) hbm⟩⟩

    namespace radical
      protected theorem is_radical : I.radical.is_radical :=
        fun x n hn ⟨m, hm, hx⟩ => ⟨n * m, (Nat.mul_neq_zero _ _).mpr ⟨hn, hm⟩,
          by rw [←pow_nat_comp]; exact hx⟩

      protected theorem sub_self : I ⊆ I.radical := fun x hx =>
        ⟨1, Nat.one_ne_zero, NCSemiring.pow_nat_1 x ▸ hx⟩

      theorem subset {I J : Ideal α} (h : I ⊆ J) : I.radical ⊆ J.radical :=
        fun x ⟨n, hn0, hxn⟩ => ⟨n, hn0, h hxn⟩

      protected theorem of_unit (α) [Ring α] : (1 : Ideal α).radical = 1 :=
        unit_ideal_in (radical.sub_self 1)

      protected theorem repeat : I.radical.radical = I.radical :=
        Ideal.ext'.mpr fun x => ⟨fun ⟨n, hn, m, hm, hxm⟩ => ⟨n * m, (Nat.mul_neq_zero n m).mpr ⟨hn, hm⟩,
          pow_nat_comp x n m ▸ hxm⟩, (radical.sub_self _ ·)⟩

      protected theorem add (J : Ideal α) : (I + J).radical = (I.radical + J.radical).radical :=
        Ideal.ext'.mpr fun x => ⟨fun ⟨n, hn, i, hi, j, hj, hij⟩ => ⟨n, hn, i, radical.sub_self I hi, j,
          radical.sub_self J hj, hij⟩, fun ⟨n, hn, i, hi, j, hj, hij⟩ => radical.repeat _ ▸ ⟨n, hn, hij ▸
            (I + J).radical.add_closed (radical.subset (Ideal.add.subset I J) hi) (radical.subset (Ideal.add.subset' I J) hj)⟩⟩

      protected theorem eq_unit_ideal_iff {I : Ideal α} : I.radical = 1 ↔ I = 1 :=
        ⟨fun h => let ⟨n, hn, h1n⟩ := is_unit_ideal.mp h; is_unit_ideal.mpr (pow_nat_one n ▸ h1n),
          (· ▸ radical.of_unit α)⟩

      protected theorem proper_iff {I : Ideal α} : I.radical.proper_ideal ↔ I.proper_ideal :=
        not_iff_not.mpr radical.eq_unit_ideal_iff

      protected theorem add_eq_one {I J : Ideal α} (h : I.radical + J.radical = 1) : I + J = 1 := by
        have := congrArg Ideal.radical h
        rw [←radical.add, radical.of_unit] at this
        exact radical.eq_unit_ideal_iff.mp this
    end radical

    protected theorem is_radical.eq_rad {I : Ideal α} (hI : I.is_radical) : I.radical = I :=
      Ideal.antisymm (fun x hx => let ⟨n, hn0, hxn⟩ := hx; hI x n hn0 hxn) (radical.sub_self I)

    theorem prime_radical {P : Ideal α} (hP : P.is_prime) : P.is_radical := fun x n hn hxn => by
      induction n with
      | zero   => contradiction
      | succ n ih =>
        byCases hn' : n = 0
        { rw [hn', pow_nat_1] at hxn; exact hxn }
        { exact Or.elim (hP.right (x^n) x (pow_nat_succ x n ▸ hxn)) (ih hn') id }

    def is_primary : Prop := I.proper_ideal ∧ ∀ a b : α, a * b ∈ I → a ∈ I ∨ b ∈ I.radical

    theorem is_primary_of_prime {I : Ideal α} (hI : I.is_prime) : I.is_primary :=
      And.imp_right (fun h a b hab => Or.imp_right (Ideal.radical.sub_self I ·) (h a b hab)) hI

    theorem is_primary_of_radical_maximal {I : Ideal α} (h : I.radical.is_maximal) : I.is_primary :=
      ⟨Ideal.proper_ideal_subset (radical.sub_self I) h.left, fun a b hab => by
        apply or_iff_not_imp_right.mpr; intro hb
        have := (h.right (Ideal.add.subset I.radical (principal b))).resolve_left
          fun h => hb (h ▸ Ideal.add.subset' _ _ (generator_in_principal b))
        have : I.radical + (principal b).radical = 1 :=
          unit_ideal_in (this ▸ Ideal.add.subset_add_subset (Subset.refl _) (radical.sub_self _))
        let ⟨i, hi, j, ⟨k, hk⟩, hij⟩ := is_unit_ideal.mp (radical.add_eq_one this)
        rw [←mul_one a, ←hij, ←hk, mul_distrib_left, ←mul_assoc]
        exact I.add_closed (I.mul_closed a hi) (I.mul_closed' hab k)⟩

    theorem contraction_radical [Ring β] (f : α →ᵣ₁ β) (I : Ideal β) : contractionᵣ₁ f I.radical = (contractionᵣ₁ f I).radical :=
      Ideal.ext'.mpr fun x => ⟨fun ⟨n, hn, hnx⟩ => ⟨n, hn, by rw [←f.preserve_pow x n] at hnx; exact hnx⟩,
        fun ⟨n, hn, hnx⟩ => ⟨n, hn, f.preserve_pow x n ▸ hnx⟩⟩

    theorem contraction_is_primary [Ring β] (f : α →ᵣ₁ β) {I : Ideal β} (hI : I.is_primary) : (contractionᵣ₁ f I).is_primary :=
      ⟨contraction.proper_of_preserve_one f.preserve_mul_right f.preserve_one hI.left, fun a b hab =>
        (hI.right (f a) (f b) (f.preserve_mul a b ▸ hab)).imp_right (fun h => contraction_radical f I ▸ h)⟩

    theorem radical_prime_of_primary {I : Ideal α} (hI : I.is_primary) : I.radical.is_prime :=
      ⟨radical.proper_iff.mpr hI.left, fun a b ⟨n, hn, habn⟩ => or_iff_not_imp_left.mpr fun ha =>
        radical.is_radical I b n hn ((hI.right (a ^ n) (b ^ n) (pow_nat_mul_distrib a b n
          ▸ habn)).resolve_left (fun ha' => ha (radical.is_radical I a n hn (radical.sub_self I ha'))))⟩

    theorem radical_minimal_prime_of_primary {I : Ideal α} (hI : I.is_primary) : I.radical.minimal_prime_ideal_of I :=
      ⟨radical_prime_of_primary hI, radical.sub_self I, fun hJ hIJ hJI => Ideal.antisymm hJI (is_radical.eq_rad (prime_radical hJ) ▸ radical.subset hIJ)⟩

    theorem radical_pow_of_prime {P : Ideal α} (hP : P.is_prime) (n : Nat) (hn : n ≠ 0) : (P ^ n).radical = P :=
      Ideal.antisymm (fun x ⟨k, hk, hkx⟩ => prime_radical hP x k hk (product.pow_subset P n hn hkx)) (fun x hx => ⟨n, hn, product.pow_contains n hx⟩)

  end Ideal

  namespace Ring
    open QuotientRing
    variable (α : Type _) [Ring α]

    def nil_radical : Ideal α := (0 : Ideal α).radical

    protected theorem nil_radical.def : (0 : Ideal α).radical = nil_radical α := rfl

    def is_reduced : Prop := nil_radical α = 0

    abbrev reduced := QClass (nil_radical α)

    theorem reduced_reduced : is_reduced (reduced α) :=
      Ideal.is_zero_ideal.mpr fun a ⟨n, hn0, han⟩ =>
        @Quotient.ind α (QSetoid _) (fun (x : QClass _) => x^n = 0 → x = 0) (fun x (hxn : toQuotient _ _ ^ n = 0) =>
          let ⟨m, hm0, hxnm⟩ : x^n ∈ nil_radical α := is_zero.mp (preserve_pow_nat _ x n ▸ hxn)
          is_zero.mpr ⟨n * m, (Nat.mul_neq_zero n m).mpr ⟨hn0, hm0⟩, pow_nat_comp x n m ▸ hxnm⟩) a han

    noncomputable def jacobson_radical : Ideal α := ⋂₀ Ring.MaxSpec α

    variable {α}

    theorem nil_radical_proper (h : Ring.is_NonTrivial α) : (nil_radical α).proper_ideal :=
      fun h' => let ⟨n, hn, h1n⟩ := Ideal.is_unit_ideal.mp h'; absurd (pow_nat_one n ▸ h1n) h

    theorem maximal_subset_jacobson {M : Ideal α} (hM : M.is_maximal) : jacobson_radical α ⊆ M :=
      fun x hx => Ideal.sIntersection.mem.mp hx M hM

  end Ring
end M4R


/-
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, Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.bases
import Mathlib.topology.homeomorph
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Open sets

## Summary

We define the subtype of open sets in a topological space.

## Main Definitions

- `opens α` is the type of open subsets of a topological space `α`.
- `open_nhds_of x` is the type of open subsets of a topological space `α` containing `x : α`.
-
-/

namespace topological_space

/-- The type of open subsets of a topological space. -/
def opens (α : Type u_1) [topological_space α] :=
  Subtype fun (s : set α) => is_open s

namespace opens

protected instance set.has_coe {α : Type u_1} [topological_space α] : has_coe (opens α) (set α) :=
  has_coe.mk subtype.val

theorem val_eq_coe {α : Type u_1} [topological_space α] (U : opens α) : subtype.val U = ↑U :=
  rfl

/-- the coercion `opens α → set α` applied to a pair is the same as taking the first component -/
theorem coe_mk {α : Type u_1} [topological_space α] {U : set α} {hU : is_open U} : ↑{ val := U, property := hU } = U :=
  rfl

protected instance has_subset {α : Type u_1} [topological_space α] : has_subset (opens α) :=
  has_subset.mk fun (U V : opens α) => ↑U ⊆ ↑V

protected instance has_mem {α : Type u_1} [topological_space α] : has_mem α (opens α) :=
  has_mem.mk fun (a : α) (U : opens α) => a ∈ ↑U

@[simp] theorem subset_coe {α : Type u_1} [topological_space α] {U : opens α} {V : opens α} : ↑U ⊆ ↑V = (U ⊆ V) :=
  rfl

@[simp] theorem mem_coe {α : Type u_1} [topological_space α] {x : α} {U : opens α} : x ∈ ↑U = (x ∈ U) :=
  rfl

theorem ext {α : Type u_1} [topological_space α] {U : opens α} {V : opens α} (h : ↑U = ↑V) : U = V :=
  iff.mpr subtype.ext_iff h

theorem ext_iff {α : Type u_1} [topological_space α] {U : opens α} {V : opens α} : ↑U = ↑V ↔ U = V :=
  { mp := ext, mpr := congr_arg coe }

protected instance partial_order {α : Type u_1} [topological_space α] : partial_order (opens α) :=
  subtype.partial_order fun (s : set α) => is_open s

/-- The interior of a set, as an element of `opens`. -/
def interior {α : Type u_1} [topological_space α] (s : set α) : opens α :=
  { val := interior s, property := is_open_interior }

theorem gc {α : Type u_1} [topological_space α] : galois_connection coe interior :=
  fun (U : opens α) (s : set α) =>
    { mp := fun (h : ↑U ≤ s) => interior_maximal h (subtype.property U),
      mpr := fun (h : U ≤ interior s) => le_trans h interior_subset }

/-- The galois insertion between sets and opens, but ordered by reverse inclusion. -/
def gi {α : Type u_1} [topological_space α] : galois_insertion interior subtype.val :=
  galois_insertion.mk
    (fun (s : order_dual (set α)) (hs : subtype.val (interior s) ≤ s) => { val := s, property := sorry }) sorry sorry
    sorry

@[simp] theorem gi_choice_val {α : Type u_1} [topological_space α] {s : order_dual (set α)} {hs : subtype.val (interior s) ≤ s} : subtype.val (galois_insertion.choice gi s hs) = s :=
  rfl

protected instance complete_lattice {α : Type u_1} [topological_space α] : complete_lattice (opens α) :=
  complete_lattice.copy (order_dual.complete_lattice (order_dual (opens α))) (fun (U V : opens α) => U ⊆ V) sorry
    { val := set.univ, property := is_open_univ } sorry { val := ∅, property := is_open_empty } sorry
    (fun (U V : opens α) => { val := ↑U ∪ ↑V, property := sorry }) sorry
    (fun (U V : opens α) => { val := ↑U ∩ ↑V, property := sorry }) sorry
    (fun (Us : set (opens α)) => { val := ⋃₀(coe '' Us), property := sorry }) sorry complete_lattice.Inf sorry

/- le  -/ (λ U V, U ⊆ V) rfl
/- top -/ ⟨set.univ, is_open_univ⟩ (subtype.ext_iff_val.mpr interior_univ.symm)
/- bot -/ ⟨∅, is_open_empty⟩ rfl
/- sup -/ (λ U V, ⟨↑U ∪ ↑V, is_open_union U.2 V.2⟩) rfl
/- inf -/ (λ U V, ⟨↑U ∩ ↑V, is_open_inter U.2 V.2⟩)
begin
  funext,
  apply subtype.ext_iff_val.mpr,
  exact (is_open_inter U.2 V.2).interior_eq.symm,
end
/- Sup -/ (λ Us, ⟨⋃₀ (coe '' Us), 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_iff_val.mpr,
  simp [Sup_range],
  refl,
end
/- Inf -/ _ rfl

lemma le_def {U V : opens α} : U ≤ V ↔ (U : set α) ≤ (V : set α) :=
by refl
theorem le_def {α : Type u_1} [topological_space α] {U : opens α} {V : opens α} : U ≤ V ↔ ↑U ≤ ↑V :=
  iff.refl (U ≤ V)

@[simp] lemma mk_inf_mk {U V : set α} {hU : is_open U} {hV : is_open V} :
  (⟨U, hU⟩ ⊓ ⟨V, hV⟩ : opens α) = ⟨U ⊓ V, is_open_inter hU hV⟩ := rfl
@[simp] theorem mk_inf_mk {α : Type u_1} [topological_space α] {U : set α} {V : set α} {hU : is_open U} {hV : is_open V} : { val := U, property := hU } ⊓ { val := V, property := hV } = { val := U ⊓ V, property := is_open_inter hU hV } :=
  rfl

@[simp,norm_cast] lemma coe_inf {U V : opens α} :
  ((U ⊓ V : opens α) : set α) = (U : set α) ⊓ (V : set α) := rfl
@[simp] theorem coe_inf {α : Type u_1} [topological_space α] {U : opens α} {V : opens α} : ↑(U ⊓ V) = ↑U ⊓ ↑V :=
  rfl

instance : has_inter (opens α) := ⟨λ U V, U ⊓ V⟩
instance : has_union (opens α) := ⟨λ U V, U ⊔ V⟩
protected instance has_inter {α : Type u_1} [topological_space α] : has_inter (opens α) :=
  has_inter.mk fun (U V : opens α) => U ⊓ V

instance : has_emptyc (opens α) := ⟨⊥⟩
protected instance has_union {α : Type u_1} [topological_space α] : has_union (opens α) :=
  has_union.mk fun (U V : opens α) => U ⊔ V

instance : inhabited (opens α) := ⟨∅⟩
protected instance has_emptyc {α : Type u_1} [topological_space α] : has_emptyc (opens α) :=
  has_emptyc.mk ⊥

protected instance inhabited {α : Type u_1} [topological_space α] : Inhabited (opens α) :=
  { default := ∅ }

@[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] theorem inter_eq {α : Type u_1} [topological_space α] (U : opens α) (V : opens α) : U ∩ V = U ⊓ V :=
  rfl

@[simp] lemma empty_eq : (∅ : opens α) = ⊥ := rfl
@[simp] theorem union_eq {α : Type u_1} [topological_space α] (U : opens α) (V : opens α) : U ∪ V = U ⊔ V :=
  rfl

@[simp] theorem empty_eq {α : Type u_1} [topological_space α] : ∅ = ⊥ :=
  rfl

@[simp] lemma Sup_s {Us : set (opens α)} : ↑(Sup Us) = ⋃₀ ((coe : _ → set α) '' Us) :=
begin
@[simp] theorem Sup_s {α : Type u_1} [topological_space α] {Us : set (opens α)} : ↑(Sup Us) = ⋃₀(coe '' Us) := sorry

  rw [@galois_connection.l_Sup (opens α) (set α) _ _ (coe : opens α → set α) interior gc Us],
  rw [set.sUnion_image]
end

lemma supr_def {ι} (s : ι → opens α) : (⨆ i, s i) = ⟨⋃ i, s i, is_open_Union $ λ i, (s i).2⟩ :=
by { ext, simp only [supr, opens.Sup_s, sUnion_image, bUnion_range], refl }
theorem supr_def {α : Type u_1} [topological_space α] {ι : Sort u_2} (s : ι → opens α) : (supr fun (i : ι) => s i) =
  { val := set.Union fun (i : ι) => ↑(s i), property := is_open_Union fun (i : ι) => subtype.property (s i) } := sorry

@[simp] lemma supr_mk {ι} (s : ι → set α) (h : Π i, is_open (s i)) :
  (⨆ i, ⟨s i, h i⟩ : opens α) = ⟨⨆ i, s i, is_open_Union h⟩ :=
@[simp] theorem supr_mk {α : Type u_1} [topological_space α] {ι : Sort u_2} (s : ι → set α) (h : ∀ (i : ι), is_open (s i)) : (supr fun (i : ι) => { val := s i, property := h i }) = { val := supr fun (i : ι) => s i, property := is_open_Union h } := sorry

by { rw supr_def, simp }

@[simp] lemma supr_s {ι} (s : ι → opens α) : ((⨆ i, s i : opens α) : set α) = ⋃ i, s i :=
by simp [supr_def]
@[simp] theorem supr_s {α : Type u_1} [topological_space α] {ι : Sort u_2} (s : ι → opens α) : ↑(supr fun (i : ι) => s i) = set.Union fun (i : ι) => ↑(s i) := sorry

theorem mem_supr {ι} {x : α} {s : ι → opens α} : x ∈ supr s ↔ ∃ i, x ∈ s i :=
by { rw [←mem_coe], simp, }
theorem mem_supr {α : Type u_1} [topological_space α] {ι : Sort u_2} {x : α} {s : ι → opens α} : x ∈ supr s ↔ ∃ (i : ι), x ∈ s i := sorry

lemma open_embedding_of_le {U V : opens α} (i : U ≤ V) :
  open_embedding (set.inclusion i) :=
theorem open_embedding_of_le {α : Type u_1} [topological_space α] {U : opens α} {V : opens α} (i : U ≤ V) : open_embedding (set.inclusion i) :=
  open_embedding.mk (embedding.mk (inducing.mk (Eq.symm induced_compose)) (set.inclusion_injective i))
    (eq.mpr (id (Eq._oldrec (Eq.refl (is_open (set.range (set.inclusion i)))) (set.range_inclusion i)))
      (is_open.preimage continuous_subtype_val (subtype.property U)))

{ inj := set.inclusion_injective i,
  induced := (@induced_compose _ _ _ _ (set.inclusion i) coe).symm,
  open_range :=
  begin
    rw set.range_inclusion i,
    exact U.property.preimage continuous_subtype_val
  end, }

def is_basis (B : set (opens α)) : Prop := is_topological_basis ((coe : _ → set α) '' B)

def is_basis {α : Type u_1} [topological_space α] (B : set (opens α)) :=
  is_topological_basis (coe '' B)

lemma is_basis_iff_nbhd {B : set (opens α)} :
  is_basis B ↔ ∀ {U : opens α} {x}, x ∈ U → ∃ U' ∈ B, x ∈ U' ∧ U' ⊆ U :=
theorem is_basis_iff_nbhd {α : Type u_1} [topological_space α] {B : set (opens α)} : is_basis B ↔ ∀ {U : opens α} {x : α}, x ∈ U → ∃ (U' : opens α), ∃ (H : U' ∈ B), x ∈ U' ∧ U' ⊆ U := sorry

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 :=
theorem is_basis_iff_cover {α : Type u_1} [topological_space α] {B : set (opens α)} : is_basis B ↔ ∀ (U : opens α), ∃ (Us : set (opens α)), ∃ (H : Us ⊆ B), U = Sup Us := sorry

begin
  split,
  { intros hB U,
    rcases sUnion_basis_of_is_open hB U.prop with ⟨sUs, H, hU⟩,
    existsi {U : opens α | U ∈ B ∧ ↑U ∈ sUs},
    split,
    { intros U hU, exact hU.left },
    { apply ext,
      rw [Sup_s, hU],
      congr' with 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 (coe : _ → set α) H,
    rw Sup_s at H,
    change x ∈ ↑U 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, rw H,
    exact set.subset_sUnion_of_mem ⟨⟨V, _⟩, ⟨H₁, rfl⟩⟩ }
end

/-- The preimage of an open set, as an open set. -/

def comap {f : α → β} (hf : continuous f) (V : opens β) : opens α :=
⟨f ⁻¹' V.1, V.2.preimage hf⟩
def comap {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] {f : α → β} (hf : continuous f) (V : opens β) : opens α :=
  { val := f ⁻¹' subtype.val V, property := sorry }

@[simp] lemma comap_id (U : opens α) : U.comap continuous_id = U := by { ext, refl }

@[simp] theorem comap_id {α : Type u_1} [topological_space α] (U : opens α) : comap continuous_id U = U :=
  ext (set.ext fun (x : α) => iff.refl (x ∈ ↑(comap continuous_id U)))

lemma comap_mono {f : α → β} (hf : continuous f) {V W : opens β} (hVW : V ⊆ W) :
  V.comap hf ⊆ W.comap hf :=
theorem comap_mono {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] {f : α → β} (hf : continuous f) {V : opens β} {W : opens β} (hVW : V ⊆ W) : comap hf V ⊆ comap hf W :=
  fun (_x : α) (h : _x ∈ ↑(comap hf V)) => hVW h

λ _ h, hVW h

@[simp] lemma coe_comap {f : α → β} (hf : continuous f) (U : opens β) :
  ↑(U.comap hf) = f ⁻¹' U := rfl
@[simp] theorem coe_comap {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] {f : α → β} (hf : continuous f) (U : opens β) : ↑(comap hf U) = f ⁻¹' ↑U :=
  rfl

@[simp] lemma comap_val {f : α → β} (hf : continuous f) (U : opens β) :
  (U.comap hf).1 = f ⁻¹' U := rfl
@[simp] theorem comap_val {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] {f : α → β} (hf : continuous f) (U : opens β) : subtype.val (comap hf U) = f ⁻¹' ↑U :=
  rfl

protected lemma comap_comp {g : β → γ} {f : α → β} (hg : continuous g) (hf : continuous f)
  (U : opens γ) : U.comap (hg.comp hf) = (U.comap hg).comap hf :=
protected theorem comap_comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α] [topological_space β] [topological_space γ] {g : β → γ} {f : α → β} (hg : continuous g) (hf : continuous f) (U : opens γ) : comap (continuous.comp hg hf) U = comap hf (comap hg U) := sorry

by { ext1, simp only [coe_comap, preimage_preimage] }

/-- A homeomorphism induces an equivalence on open sets, by taking comaps. -/
@[simp] protected def equiv {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (f : α ≃ₜ β) : opens α ≃ opens β :=
  equiv.mk (comap sorry) (comap (homeomorph.continuous f)) sorry sorry

end opens

/-- The open neighborhoods of a point. See also `opens` or `nhds`. -/
def open_nhds_of {α : Type u_1} [topological_space α] (x : α) :=
  Subtype fun (s : set α) => is_open s ∧ x ∈ s

protected instance open_nhds_of.inhabited {α : Type u_1} [topological_space α] (x : α) : Inhabited (open_nhds_of x) :=
  { default := { val := set.univ, property := sorry } }