theorem t1 (p: Prop) (Hp : p) : p := Hp
check t1           -- t1 : ∀ p, p → p


/-
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, Patrick Massot

Hausdorff properties of uniform spaces. Separation quotient.
-/
import topology.uniform_space.basic

open filter topological_space lattice set classical
local attribute [instance, priority 0] prop_decidable
noncomputable theory
set_option eqn_compiler.zeta true

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}
variables [uniform_space α] [uniform_space β] [uniform_space γ]

local notation `𝓤` := uniformity

/- separated uniformity -/

/-- The separation relation is the intersection of all entourages.
  Two points which are related by the separation relation are "indistinguishable"
  according to the uniform structure. -/
protected def separation_rel (α : Type u) [u : uniform_space α] :=
⋂₀ (𝓤 α).sets

lemma separated_equiv : equivalence (λx y, (x, y) ∈ separation_rel α) :=
⟨assume x, assume s, refl_mem_uniformity,
  assume x y, assume h (s : set (α×α)) hs,
    have preimage prod.swap s ∈ 𝓤 α,
      from symm_le_uniformity hs,
    h _ this,
  assume x y z (hxy : (x, y) ∈ separation_rel α) (hyz : (y, z) ∈ separation_rel α)
      s (hs : s ∈ 𝓤 α),
    let ⟨t, ht, (h_ts : comp_rel t t ⊆ s)⟩ := comp_mem_uniformity_sets hs in
    h_ts $ show (x, z) ∈ comp_rel t t,
      from ⟨y, hxy t ht, hyz t ht⟩⟩

@[class] def separated (α : Type u) [uniform_space α] :=
separation_rel α = id_rel

theorem separated_def {α : Type u} [uniform_space α] :
  separated α ↔ ∀ x y, (∀ r ∈ 𝓤 α, (x, y) ∈ r) → x = y :=
by simp [separated, id_rel_subset.2 separated_equiv.1, subset.antisymm_iff];
   simp [subset_def, separation_rel]

theorem separated_def' {α : Type u} [uniform_space α] :
  separated α ↔ ∀ x y, x ≠ y → ∃ r ∈ 𝓤 α, (x, y) ∉ r :=
separated_def.trans $ forall_congr $ λ x, forall_congr $ λ y,
by rw ← not_imp_not; simp [classical.not_forall]

instance separated_t2 [s : separated α] : t2_space α :=
⟨assume x y, assume h : x ≠ y,
let ⟨d, hd, (hxy : (x, y) ∉ d)⟩ := separated_def'.1 s x y h in
let ⟨d', hd', (hd'd' : comp_rel d' d' ⊆ d)⟩ := comp_mem_uniformity_sets hd in
have {y | (x, y) ∈ d'} ∈ nhds x,
  from mem_nhds_left x hd',
let ⟨u, hu₁, hu₂, hu₃⟩ := mem_nhds_sets_iff.mp this in
have {x | (x, y) ∈ d'} ∈ nhds y,
  from mem_nhds_right y hd',
let ⟨v, hv₁, hv₂, hv₃⟩ := mem_nhds_sets_iff.mp this in
have u ∩ v = ∅, from
  eq_empty_of_subset_empty $
  assume z ⟨(h₁ : z ∈ u), (h₂ : z ∈ v)⟩,
  have (x, y) ∈ comp_rel d' d', from ⟨z, hu₁ h₁, hv₁ h₂⟩,
  hxy $ hd'd' this,
⟨u, v, hu₂, hv₂, hu₃, hv₃, this⟩⟩

instance separated_regular [separated α] : regular_space α :=
{ regular := λs a hs ha,
    have -s ∈ nhds a,
      from mem_nhds_sets hs ha,
    have {p : α × α | p.1 = a → p.2 ∈ -s} ∈ 𝓤 α,
      from mem_nhds_uniformity_iff.mp this,
    let ⟨d, hd, h⟩ := comp_mem_uniformity_sets this in
    let e := {y:α| (a, y) ∈ d} in
    have hae : a ∈ closure e, from subset_closure $ refl_mem_uniformity hd,
    have set.prod (closure e) (closure e) ⊆ comp_rel d (comp_rel (set.prod e e) d),
    begin
      rw [←closure_prod_eq, closure_eq_inter_uniformity],
      change (⨅d' ∈ 𝓤 α, _) ≤ comp_rel d (comp_rel _ d),
      exact (infi_le_of_le d $ infi_le_of_le hd $ le_refl _)
    end,
    have e_subset : closure e ⊆ -s,
      from assume a' ha',
        let ⟨x, (hx : (a, x) ∈ d), y, ⟨hx₁, hx₂⟩, (hy : (y, _) ∈ d)⟩ := @this ⟨a, a'⟩ ⟨hae, ha'⟩ in
        have (a, a') ∈ comp_rel d d, from ⟨y, hx₂, hy⟩,
        h this rfl,
    have closure e ∈ nhds a, from (nhds a).sets_of_superset (mem_nhds_left a hd) subset_closure,
    have nhds a ⊓ principal (-closure e) = ⊥,
      from (@inf_eq_bot_iff_le_compl _ _ _ (principal (- closure e)) (principal (closure e))
        (by simp [principal_univ, union_comm]) (by simp)).mpr (by simp [this]),
    ⟨- closure e, is_closed_closure, assume x h₁ h₂, @e_subset x h₂ h₁, this⟩,
  ..separated_t2 }

/- separation space -/
namespace uniform_space
def separation_setoid (α : Type u) [uniform_space α] : setoid α :=
⟨λx y, (x, y) ∈ separation_rel α, separated_equiv⟩

local attribute [instance] separation_setoid

instance {α : Type u} [u : uniform_space α] : uniform_space (quotient (separation_setoid α)) :=
{ to_topological_space := u.to_topological_space.coinduced (λx, ⟦x⟧),
  uniformity := map (λp:(α×α), (⟦p.1⟧, ⟦p.2⟧)) u.uniformity,
  refl := le_trans (by simp [quotient.exists_rep]) (filter.map_mono refl_le_uniformity),
  symm := tendsto_map' $
    by simp [prod.swap, (∘)]; exact tendsto_swap_uniformity.comp tendsto_map,
  comp := calc (map (λ (p : α × α), (⟦p.fst⟧, ⟦p.snd⟧)) u.uniformity).lift' (λs, comp_rel s s) =
          u.uniformity.lift' ((λs, comp_rel s s) ∘ image (λ (p : α × α), (⟦p.fst⟧, ⟦p.snd⟧))) :
      map_lift'_eq2 $ monotone_comp_rel monotone_id monotone_id
    ... ≤ u.uniformity.lift' (image (λ (p : α × α), (⟦p.fst⟧, ⟦p.snd⟧)) ∘ (λs:set (α×α), comp_rel s (comp_rel s s))) :
      lift'_mono' $ assume s hs ⟨a, b⟩ ⟨c, ⟨⟨a₁, a₂⟩, ha, a_eq⟩, ⟨⟨b₁, b₂⟩, hb, b_eq⟩⟩,
      begin
        simp at a_eq,
        simp at b_eq,
        have h : ⟦a₂⟧ = ⟦b₁⟧, { rw [a_eq.right, b_eq.left] },
        have h : (a₂, b₁) ∈ separation_rel α := quotient.exact h,
        simp [function.comp, set.image, comp_rel, and.comm, and.left_comm, and.assoc],
        exact ⟨a₁, a_eq.left, b₂, b_eq.right, a₂, ha, b₁, h s hs, hb⟩
      end
    ... = map (λp:(α×α), (⟦p.1⟧, ⟦p.2⟧)) (u.uniformity.lift' (λs:set (α×α), comp_rel s (comp_rel s s))) :
      by rw [map_lift'_eq];
        exact monotone_comp_rel monotone_id (monotone_comp_rel monotone_id monotone_id)
    ... ≤ map (λp:(α×α), (⟦p.1⟧, ⟦p.2⟧)) u.uniformity :
      map_mono comp_le_uniformity3,
  is_open_uniformity := assume s,
    have ∀a, ⟦a⟧ ∈ s →
        ({p:α×α | p.1 = a → ⟦p.2⟧ ∈ s} ∈ 𝓤 α ↔
          {p:α×α | p.1 ≈ a → ⟦p.2⟧ ∈ s} ∈ 𝓤 α),
      from assume a ha,
      ⟨assume h,
        let ⟨t, ht, hts⟩ := comp_mem_uniformity_sets h in
        have hts : ∀{a₁ a₂}, (a, a₁) ∈ t → (a₁, a₂) ∈ t → ⟦a₂⟧ ∈ s,
          from assume a₁ a₂ ha₁ ha₂, @hts (a, a₂) ⟨a₁, ha₁, ha₂⟩ rfl,
        have ht' : ∀{a₁ a₂}, a₁ ≈ a₂ → (a₁, a₂) ∈ t,
          from assume a₁ a₂ h, sInter_subset_of_mem ht h,
        u.uniformity.sets_of_superset ht $ assume ⟨a₁, a₂⟩ h₁ h₂, hts (ht' $ setoid.symm h₂) h₁,
        assume h, u.uniformity.sets_of_superset h $ by simp {contextual := tt}⟩,
    begin
      simp [topological_space.coinduced, u.is_open_uniformity, uniformity, forall_quotient_iff],
      exact ⟨λh a ha, (this a ha).mp $ h a ha, λh a ha, (this a ha).mpr $ h a ha⟩
    end }

lemma uniformity_quotient :
  𝓤 (quotient (separation_setoid α)) = (𝓤 α).map (λp:(α×α), (⟦p.1⟧, ⟦p.2⟧)) :=
rfl

lemma uniform_continuous_quotient_mk :
  uniform_continuous (quotient.mk : α → quotient (separation_setoid α)) :=
le_refl _

lemma uniform_continuous_quotient {f : quotient (separation_setoid α) → β}
  (hf : uniform_continuous (λx, f ⟦x⟧)) : uniform_continuous f :=
hf

lemma uniform_continuous_quotient_lift
  {f : α → β} {h : ∀a b, (a, b) ∈ separation_rel α → f a = f b}
  (hf : uniform_continuous f) : uniform_continuous (λa, quotient.lift f h a) :=
uniform_continuous_quotient hf

lemma uniform_continuous_quotient_lift₂ [uniform_space γ]
  {f : α → β → γ} {h : ∀a c b d, (a, b) ∈ separation_rel α → (c, d) ∈ separation_rel β → f a c = f b d}
  (hf : uniform_continuous (λp:α×β, f p.1 p.2)) :
  uniform_continuous (λp:_×_, quotient.lift₂ f h p.1 p.2) :=
begin
  rw [uniform_continuous, uniformity_prod_eq_prod, uniformity_quotient, uniformity_quotient,
    filter.prod_map_map_eq, filter.tendsto_map'_iff, filter.tendsto_map'_iff],
  rwa [uniform_continuous, uniformity_prod_eq_prod, filter.tendsto_map'_iff] at hf
end

lemma comap_quotient_le_uniformity :
  (𝓤 $ quotient $ separation_setoid α).comap (λ (p : α × α), (⟦p.fst⟧, ⟦p.snd⟧)) ≤ (𝓤 α) :=
assume t' ht',
let ⟨t, ht, tt_t'⟩ := comp_mem_uniformity_sets ht' in
let ⟨s, hs, ss_t⟩ := comp_mem_uniformity_sets ht in
⟨(λp:α×α, (⟦p.1⟧, ⟦p.2⟧)) '' s,
  (𝓤 α).sets_of_superset hs $ assume x hx, ⟨x, hx, rfl⟩,
  assume ⟨a₁, a₂⟩ ⟨⟨b₁, b₂⟩, hb, ab_eq⟩,
  have ⟦b₁⟧ = ⟦a₁⟧ ∧ ⟦b₂⟧ = ⟦a₂⟧, from prod.mk.inj ab_eq,
  have b₁ ≈ a₁ ∧ b₂ ≈ a₂, from and.imp quotient.exact quotient.exact this,
  have ab₁ : (a₁, b₁) ∈ t, from (setoid.symm this.left) t ht,
  have ba₂ : (b₂, a₂) ∈ s, from this.right s hs,
  tt_t' ⟨b₁, show ((a₁, a₂).1, b₁) ∈ t, from ab₁,
    ss_t ⟨b₂, show ((b₁, a₂).1, b₂) ∈ s, from hb, ba₂⟩⟩⟩

lemma comap_quotient_eq_uniformity :
  (𝓤 $ quotient $ separation_setoid α).comap (λ (p : α × α), (⟦p.fst⟧, ⟦p.snd⟧)) = 𝓤 α :=
le_antisymm comap_quotient_le_uniformity le_comap_map

instance separated_separation : separated (quotient (separation_setoid α)) :=
set.ext $ assume ⟨a, b⟩, quotient.induction_on₂ a b $ assume a b,
  ⟨assume h,
    have a ≈ b, from assume s hs,
      have s ∈ (𝓤 $ quotient $ separation_setoid α).comap (λp:(α×α), (⟦p.1⟧, ⟦p.2⟧)),
        from comap_quotient_le_uniformity hs,
      let ⟨t, ht, hts⟩ := this in
      hts begin dsimp, exact h t ht end,
    show ⟦a⟧ = ⟦b⟧, from quotient.sound this,

  assume heq : ⟦a⟧ = ⟦b⟧, assume h hs,
  heq ▸ refl_mem_uniformity hs⟩

lemma separated_of_uniform_continuous {f : α → β} {x y : α}
  (H : uniform_continuous f) (h : x ≈ y) : f x ≈ f y :=
assume _ h', h _ (H h')

lemma eq_of_separated_of_uniform_continuous [separated β] {f : α → β} {x y : α}
  (H : uniform_continuous f) (h : x ≈ y) : f x = f y :=
separated_def.1 (by apply_instance) _ _ $ separated_of_uniform_continuous H h

def separation_quotient (α : Type*) [uniform_space α] := quotient (separation_setoid α)

namespace separation_quotient
instance : uniform_space (separation_quotient α) := by dunfold separation_quotient ; apply_instance
instance : separated (separation_quotient α) := by dunfold separation_quotient ; apply_instance

def lift [separated β] (f : α → β) : (separation_quotient α → β) :=
if h : uniform_continuous f then
  quotient.lift f (λ x y, eq_of_separated_of_uniform_continuous h)
else
  λ x, f (classical.inhabited_of_nonempty $ (nonempty_quotient_iff $ separation_setoid α).1 ⟨x⟩).default

lemma lift_mk [separated β] {f : α → β} (h : uniform_continuous f) (a : α) : lift f ⟦a⟧ = f a :=
by rw [lift, dif_pos h]; refl

lemma uniform_continuous_lift [separated β] (f : α → β) : uniform_continuous (lift f) :=
begin
  by_cases hf : uniform_continuous f,
  { rw [lift, dif_pos hf], exact uniform_continuous_quotient_lift hf },
  { rw [lift, dif_neg hf], exact uniform_continuous_of_const (assume a b, rfl) }
end

def map (f : α → β) : separation_quotient α → separation_quotient β :=
lift (quotient.mk ∘ f)

lemma map_mk {f : α → β} (h : uniform_continuous f) (a : α) : map f ⟦a⟧ = ⟦f a⟧ :=
by rw [map, lift_mk (h.comp uniform_continuous_quotient_mk)]

lemma uniform_continuous_map (f : α → β): uniform_continuous (map f) :=
uniform_continuous_lift (quotient.mk ∘ f)

lemma map_unique {f : α → β} (hf : uniform_continuous f)
  {g : separation_quotient α → separation_quotient β}
  (comm : quotient.mk ∘ f = g ∘ quotient.mk) : map f = g :=
by ext ⟨a⟩;
calc map f ⟦a⟧ = ⟦f a⟧ : map_mk hf a
  ... = g ⟦a⟧ : congr_fun comm a

lemma map_id : map (@id α) = id :=
map_unique uniform_continuous_id rfl

lemma map_comp {f : α → β} {g : β → γ} (hf : uniform_continuous f) (hg : uniform_continuous g) :
  map g ∘ map f = map (g ∘ f) :=
(map_unique (hf.comp hg) $ by simp only [(∘), map_mk, hf, hg]).symm

end separation_quotient

lemma separation_prod {a₁ a₂ : α} {b₁ b₂ : β} : (a₁, b₁) ≈ (a₂, b₂) ↔ a₁ ≈ a₂ ∧ b₁ ≈ b₂ :=
begin
  split,
  { assume h,
    exact ⟨separated_of_uniform_continuous uniform_continuous_fst h,
           separated_of_uniform_continuous uniform_continuous_snd h⟩ },
  { rintros ⟨eqv_α, eqv_β⟩ r r_in,
    rw uniformity_prod at r_in,
    rcases r_in with ⟨t_α, ⟨r_α, r_α_in, h_α⟩, t_β, ⟨r_β, r_β_in, h_β⟩, H⟩,

    let p_α := λ(p : (α × β) × (α × β)), (p.1.1, p.2.1),
    let p_β := λ(p : (α × β) × (α × β)), (p.1.2, p.2.2),
    have key_α : p_α ((a₁, b₁), (a₂, b₂)) ∈ r_α, { simp [p_α, eqv_α r_α r_α_in] },
    have key_β : p_β ((a₁, b₁), (a₂, b₂)) ∈ r_β, { simp [p_β, eqv_β r_β r_β_in] },
    exact H ⟨h_α key_α, h_β key_β⟩ },
end

instance separated.prod [separated α] [separated β] : separated (α × β) :=
separated_def.2 $ assume x y H, prod.ext
  (eq_of_separated_of_uniform_continuous uniform_continuous_fst H)
  (eq_of_separated_of_uniform_continuous uniform_continuous_snd H)
end uniform_space


import data.zmod.basic
import data.finset
import tactic.fin_cases

--A set of necessary lemmas about the natural numbers to prove the first construction is valid
lemma div_mul_self_gt_sub (a b : ℕ) (h : b > 0): a - a/b * b < b := (nat.sub_lt_right_iff_lt_add (nat.div_mul_le_self a b)).2 (nat.lt_of_div_lt_div (by {rw [nat.add_mul_div_right b (a/b) h,nat.div_self h,add_comm,nat.add_one],exact nat.lt_succ_self _}))

def fin_sub_ge (a b : ℕ) (h : b > 0): {c : ℕ // c * b ≤ a ∧ a - c * b < b} :=
begin
  use a/b,
  exact ⟨nat.div_mul_le_self a b,div_mul_self_gt_sub a b h⟩,
end

lemma mod_sub_chain {a b c : ℕ} (h : c * b ≤ a ∧ a - c * b < b) (j : b > 0) : ∀ (n : ℕ), n ≤ c → ((a - n * b) % b = a % b) :=
begin
  intros n h₁,
  induction n,
  { simp, },
  { rw [←nat.add_one,nat.right_distrib,one_mul,← nat.sub_sub,← nat.mod_eq_sub_mod,n_ih (nat.le_of_succ_le h₁)],
    exact nat.le_sub_left_of_add_le (by { rw [←mul_one(b),←mul_assoc,mul_one,mul_comm,←nat.left_distrib,nat.add_one,mul_comm], exact le_trans (nat.mul_le_mul_right b h₁) h.1, } ) },
end

def sub_mod_eq_mul (a b : ℕ) (h : b > 0): {c : ℕ // a - a % b = b * c} :=
begin
  cases (fin_sub_ge a b h),
  use val,
  rw [←(mod_sub_chain property h val (le_of_eq rfl)),(nat.mod_eq_of_lt property.2),nat.sub_sub_self (property.1),mul_comm],
end

def eq_mod_add_mul (a b : ℕ) (h : b > 0): {c : ℕ // a = (a % b) + b * c} :=
begin
  cases (sub_mod_eq_mul a b h),
  use val,
  rw [←add_left_inj(a % b),←nat.add_sub_assoc(nat.mod_le a b),nat.add_sub_cancel_left] at property,
  exact property,
end

lemma mod_add_non_assoc {a b c : ℕ} (h : c > 0) : (a + b) % c = (a % c + b % c) % c :=
begin
  cases eq_mod_add_mul a c h,
  cases eq_mod_add_mul b c h,
  rw [property,property_1],
  simp[left_distrib],
  rw [←left_distrib,←add_assoc,nat.add_mul_mod_self_left],
end

lemma mod_add_left {a b c d : ℕ} (h : d > 0): b % d = c % d → (a + b) % d = (a + c) % d :=
λ h₁, by {rw [mod_add_non_assoc h,h₁,←mod_add_non_assoc h]}

--Simplest construction of what is trying to be proven under the % operator
def mod_conv (a : ℕ) (b c : ℕ+) : {d : ℕ // d < c ∧ (a % (b * c) = ( a % b + d * b ) % (b * c)) } :=
begin
  cases (eq_mod_add_mul a b (pnat.pos b)),
  use (val % c),
  split,
  { refine nat.mod_lt val (pnat.pos c), },
  { conv {to_lhs, rw property},
    exact mod_add_left (mul_pos (pnat.pos b) (pnat.pos c)) (by { rw [nat.mul_mod_mul_left b val c,mul_comm(val % c),nat.mul_mod_mul_left b (val % c) c,nat.mod_mod], }) },
end

--Equivalent construction in the zmod ring
--This is essentially just showing the definition is the same
def zmod_conv {a : ℕ} {b : ℕ+} {d : zmod b} (c : ℕ+) (h : (a : zmod b) = d) : {e : ℕ // (e ∈ finset.Ico 0 c ∧ (a : zmod (b * c)) = d.val + e * b.val)} :=
begin
  rcases mod_conv a b c,
  use val,
  have h₁ : (a : zmod (b * c)) = ((a % (↑b * ↑c) : ℕ) : zmod (b * c)) := by simp,
  simp[list.Ico.mem],
  simp[property,h₁],
  rw [←h,zmod.val_cast_nat],
  refl,
end

--A simple proof that for any integer there is a natural number with the same value mod b
--Namely that integer mod b considered as a natural number
def zmod_nat_from_int (a : ℤ) (b : ℕ+) : {c : ℕ // (c : zmod b) = (a : zmod b)} :=
begin
  use (a : zmod b).val,
  simp,
end

--A proof that equality in mod c×d implies equality in mod c
--This is true for both the left and right values however only this case was needed
lemma zmod_eq_of_zmod_mul_eq {a : ℤ} {b : ℕ} {c d : ℕ+} (h : (a : zmod (c * d)) = (b : zmod (c * d))) : (a : zmod c) = (b : zmod c) :=
begin
  have h₁ : ((c : ℕ) : ℤ) = (c : ℤ) := by simp,
  have h₂ : (a : zmod (c * d)) = ((b : ℤ) : zmod (c * d)) := by simp[h],
  have h₃  : a % (↑c * ↑d) = b % (↑c * ↑d) := zmod.eq_iff_modeq_int.1 h₂,
  rw [← int.mod_add_div a (c * d),← nat.mod_add_div b (c * d),h₃,← zmod.cast_mod_int,mul_assoc,h₁,int.add_mul_mod_self_left],
  conv {to_rhs, rw [← zmod.cast_mod_nat,mul_assoc,nat.add_mul_mod_self_left]},
  simp,
end

--The previous construction defined over all of the integers instead of only the natural numbers
def zmod_conv_int {a : ℤ} {b : ℕ+} {d : zmod b} (c : ℕ+) (h : (a : zmod b) = d) : {e : ℕ // (e ∈ finset.Ico 0 c ∧ (a : zmod (b * c)) = d.val + e * b.val)} :=
begin
  rcases zmod_nat_from_int a (b * c),
  rw ←h,
  rw [(zmod_eq_of_zmod_mul_eq property.symm)] at h,
  rcases zmod_conv c h,
  rw [(zmod_eq_of_zmod_mul_eq property.symm),←property,h],
  use val_1,
  exact property_1,
end

--An equivalency between zmod rings which are equal but have different represenations could not be constructed
--It was instead shown that equlaity in one ring implies equality inthe other ring
--It was then possible to convert equality statements between the rings
lemma zmod_interchange {a b : ℤ } {c d e : ℕ+} (h : c = d * e) : (a : zmod (d * e)) = (b : zmod (d * e)) ↔ (a : zmod c) = (b : zmod c) :=
begin
  split,
  { intros h₁,
    rw [zmod.eq_iff_modeq_int,h,← zmod.eq_iff_modeq_int,h₁], },
  { intros h₂,
    rw [zmod.eq_iff_modeq_int,←h,← zmod.eq_iff_modeq_int,h₂], },
end

--An alternative form of the construction which takes a division hypothesis and uses this to generate the multplicative index
def zmod_conv_div {a : ℤ} {b c : ℕ+} {d : zmod b} (h : (a : zmod b) = d) (h₁ : (b : ℕ) ∣ (c : ℕ)) : {e : ℕ // (e ∈ finset.Ico 0 (c/b) ∧ (a : zmod c) = (((d.val + e * b.val) : ℕ) : zmod c))} :=
begin
  let f : ℕ+ := nat.to_pnat' ((c : ℕ)/(b : ℕ)),
  have h₂ : (c : ℕ) = b * f := by rw [← nat.div_eq_iff_eq_mul_right (pnat.pos b) h₁,pnat.to_pnat'_coe (nat.div_pos (nat.le_of_dvd (pnat.pos c) h₁) (pnat.pos b))],
  have h₃ : c = b * f := by rw [← pnat.coe_to_pnat' c,h₂,← pnat.mul_coe,pnat.coe_to_pnat'],
  have h₄ : (f : ℕ) = (c : ℕ)/(b : ℕ) := by rw pnat.to_pnat'_coe (nat.div_pos (nat.le_of_dvd (pnat.pos c) h₁) (pnat.pos b)),
  rcases zmod_conv_int f h,
  use val,
  let g : ℤ := (a : zmod b).val + val * b.val,
  have h₅ : (a : zmod c) = (g : zmod c) := (zmod_interchange h₃).1 (by simp[h,property.2]),
  rw [←h₄,h₅,←h],
  refine ⟨property.1,rfl⟩,
end

def int_to_pnat (z : ℤ) : ℕ+ := nat.to_pnat' (int.nat_abs z) --specifically for use with modular arithmatic, not a great coercion in a general context

section

local attribute [semireducible] reflected

meta instance pnat_reflect : has_reflect ℕ+
| n := expr.app `(nat.to_pnat') (nat.reflect n)

meta instance pnat_pexpr : has_to_pexpr ℕ+ := ⟨pexpr.of_expr ∘ λ n, reflect n⟩

meta instance zmod_reflect {n : ℕ+} : has_reflect (zmod n)
| m := (nat.reflect m.val)

meta instance zmod_pexpr {n : ℕ+} : has_to_pexpr (zmod n) := ⟨pexpr.of_expr ∘ λ n, reflect n.val⟩

--Not sure why these next two are necessary, mathlib should have these but apply instance isn't finding them for some reason.

meta instance nat_pexpr : has_to_pexpr ℕ := ⟨pexpr.of_expr ∘ λ n, reflect n⟩

meta instance int_pexpr : has_to_pexpr ℤ := ⟨pexpr.of_expr ∘ λ n, reflect n⟩

end

namespace tactic

namespace interactive

--Converts a hypothesis of the form (a ≡ b [ZMOD c]) to a hypothesis of the form (a : zmod c) = b)
--Will try to clear the orignal hypothesis if possible
--Rely's on the int_to_pnat map above to preserve modulo relationship if a negative integer is given
meta def eqmod_to_zmod (p : interactive.parse lean.parser.pexpr) : tactic unit :=
do  e ← i_to_expr p,
    `(%%α ≡ %%γ [ZMOD %%β]) ← infer_type e <|> fail ("Invalid Hypothesis : should be of type (_ ≡ _ [ZMOD _])"),
    b ← eval_expr ℤ β,
    a ← eval_expr ℤ α <|> eval_expr ℤ β,
    if a = b then do equi ← to_expr ```(((%%α : (zmod %%(reflect (int_to_pnat b)))) = %%γ)),
      tactic.assert e.local_pp_name equi,
      `[by {rw zmod.eq_iff_modeq_int, exact %%e}],
      tactic.clear e <|> trace ("Original hypothesis could not be removed due to dependency by another hypothesis")
    else do equi ← to_expr ```(((%%γ : (zmod %%(reflect (int_to_pnat b)))) = %%α)),
      tactic.assert e.local_pp_name equi,
      `[by {rw zmod.eq_iff_modeq_int, exact (%%e).symm}],
      tactic.clear e <|> trace ("Original hypothesis could not be removed due to dependency by another hypothesis")

--Converts a hypothesis of the form (a : zmod c) = b) to a hypothesis of the form (a ≡ b [ZMOD c])
--Will try to clear the orignal hypothesis if possible
--Can handle (a : zmod c) = b) or b = (a : zmod c) but will always return (a ≡ b [ZMOD c])
meta def zmod_to_eqmod (p : interactive.parse lean.parser.pexpr) : tactic unit :=
do  e ← i_to_expr p,
    α ← mk_mvar,
    β ← mk_mvar,
    γ ← mk_mvar,
    to_expr ``(_ : ((↑%%α : zmod %%β) = %%γ)) tt ff >>= unify e <|> to_expr ``(_ : %%γ = ((↑%%α : zmod %%β))) tt ff >>= unify e <|> fail ("Invalid Hypothesis1 : should be of type (_ : zmod _) = _)"),
    b ← eval_expr ℕ+ β,
    d ← eval_expr (zmod b) γ,
    equi ← to_expr ``(%%α ≡ (%%d.val : ℤ) [ZMOD ((%%β : ℕ) : ℤ)]),
    tactic.assert e.local_pp_name equi,
    `[by {rw ← zmod.eq_iff_modeq_int, exact %%e}] <|> `[by {rw ← zmod.eq_iff_modeq_int, exact (%%e).symm}],
    tactic.clear e <|> trace ("Original Hypothesis could not be removed due to dependency by another hypothesis")

--Tactic which applys the main construction from the above section
--Will try to clear the original hypothesis, after makingthe new construction
--Use of this as a temporary hypothesis is hardcoded, however does not appear to cause any naming conflicts
meta def apply_mod_conv (β : expr) (c : ℕ+) (e : expr) : tactic unit :=
do b ← eval_expr ℕ+ β,
  if (b : ℕ) ∣ c
  then do
    divproof ← to_expr ``(by norm_num : (%%(reflect b) : ℕ) ∣ %%(reflect c)),
    divtype ← infer_type divproof,
    divname ← get_unused_name,
    tactic.assertv divname divtype divproof,
    divhyp ← get_local divname,
    thmproof ← to_expr ```(zmod_conv_div %%e %%divhyp) <|> to_expr ```(zmod_conv_div (%%e).symm %%divhyp),
    thmtype ← infer_type thmproof,
    tactic.clear divhyp,
    let lname := e.local_pp_name,
    tactic.clear e <|> trace ("Original Hypothesis could not be removed due to dependency by another hypothesis"),
    tactic.assertv lname thmtype thmproof,
    hyp1 ← get_local lname,
    name1 ← get_unused_name,
    tactic.cases_core hyp1 [name1,lname],
    hyp2 ← get_local lname,
    name2 ← get_unused_name,
    tactic.cases_core hyp2 [name2,`this],
    hyp3 ← get_local name2,
    tactic.fin_cases_at none hyp3;
    zmod_to_eqmod ```(this);
    `[simp only [nat.to_pnat', int.coe_nat_zero, int.coe_nat_succ, nat.succ_pnat_coe, nat.pred_succ] at this];
    `[norm_num1 at this];
    tactic.rename `this lname
else fail ("Must input a multiple of the existing mod type")

--Interactive wrapper/guard for the apply sub_tactic
--Also handles the conversions between different acceptable input and output hypothesis
meta def mod_conv_tactic (p : interactive.parse lean.parser.pexpr) (c : ℕ+) : tactic unit :=
do e ← i_to_expr p,
  let l := e.local_pp_name,
  β ← mk_mvar,
  to_expr ``(_ : ((_ : zmod %%β) = _)) tt ff >>= unify e <|> to_expr ``(_ : _ ≡ _ [ZMOD %%β]) tt ff >>= unify e <|> fail ("Invalid Hypothesis : should be of type ((_ : zmod _) = _) or (_ ≡ _ [ZMOD _])"),
  b ← instantiate_mvars β,
  type ← infer_type b,
  if type = reflect ℕ+ then do apply_mod_conv b c e;
                            eqmod_to_zmod p
  else do eqmod_to_zmod p,
  e ← i_to_expr p,
  β ← mk_mvar,
  to_expr ``(_ : ((_ : zmod %%β) = _)) tt ff >>= unify e,
  apply_mod_conv β c e

example {a : ℤ} (this : (a : zmod 15) = 6) : a = 2 :=
begin
mod_conv_tactic this 135, --135 is the largest input that works

end

example {a : ℤ} (r : (a ≡ 12 [ZMOD 17])) : a = 2 := --17 is the largest number to work with a value larger than 100 as input
begin
mod_conv_tactic r 119,

end

example {a : ℤ} (r : (a ≡ 1 [ZMOD 2])) : a = 2 :=
begin
mod_conv_tactic r 104, --104 is the largest multiple of 2 which works, making 52 the maximum number of cases that works

end

example {a : ℤ} (thisr : (a ≡ 1 [ZMOD 41])) : a = 2 := --41 is the largest number that works as an initial value
begin
mod_conv_tactic thisr 82, --however it can only got up to 2 cases, 123 will fail

end

end interactive
end tactic


import algebra.char_p
import data.zmod.basic
import data.equiv.algebra

import vector_space

universes u v

namespace char_p

variable {α : Type u}
variable [ring α]

open nat

--char_p
lemma char_p_eq_mod (n : ℕ) [char_p α n] (k : ℕ) : (k : α) = (k % n : ℕ) :=
calc (k : α) = (k % n + n * (k / n) : ℕ) : by rw [mod_add_div]
         ... = ↑(k % n) + ↑n * ↑(k / n)  : by rw [cast_add, cast_mul]
         ... = ↑(k % n) + 0              : by rw [char_p.cast_eq_zero α n, zero_mul]
         ... = ↑(k % n)                  : by rw [add_zero]

end char_p

namespace zmod

variable {n : ℕ+}
variable (α : Type u)
variables [ring α]

open char_p nat

--zmod n or char_p
def cast : zmod n → α := nat.cast ∘ fin.val

--zmod n or char_p
instance cast_is_ring_hom [char_p α n] : is_ring_hom (cast α) :=
{ map_one := by rw ←cast_one; exact eq.symm (char_p_eq_mod n 1),
  map_mul := assume x y : zmod n, show ↑((x * y).val) = ↑(x.val) * ↑(y.val), from
    by rw [zmod.mul_val, ←char_p_eq_mod, cast_mul],
  map_add := assume x y : zmod n, show ↑((x + y).val) = ↑(x.val) + ↑(y.val), from
    by rw [zmod.add_val, ←char_p_eq_mod, cast_add] }

open is_ring_hom

--zmod n or char_p
instance to_module [char_p α n] : module (zmod n) α :=
module.of_core
{ smul := λ r x, (cast α) r * x,
  smul_add := λ r x y, by unfold has_scalar.smul; rw[mul_add]; refl,
  add_smul := λ r s x, by unfold has_scalar.smul;
    rw[map_add (cast α), add_mul]; apply_instance,
  mul_smul := λ r s x, by unfold has_scalar.smul;
    rw[map_mul (cast α), mul_assoc]; apply_instance,
  one_smul := λ x, show (cast α) 1 * x = _,
    by rw[map_one (cast α), one_mul]; apply_instance }

instance to_module' {m : ℕ} {hm : m > 0} [hc : char_p α m] : module (zmod ⟨m, hm⟩) α :=
@zmod.to_module ⟨m, hm⟩ α _ hc

end zmod

namespace char_p

variables (α : Type u) [ring α]

open function nat

--char_p
lemma ne_zero [fintype α] [decidable_eq α] (p : ℕ) [char_p α p] : p ≠ 0 :=
(assume h : p = 0,
have ∀ n : ℕ, (n : α) = 0 → n = 0, from
  assume (n : ℕ) (h₀ : (n : α) = 0),
  have 0 ∣ n, from h ▸ (cast_eq_zero_iff α p n).mp h₀,
  show n = 0, from zero_dvd_iff.mp this,
have char_zero α, from add_group.char_zero_of_inj_zero this,
have ht :  injective nat.cast, from @cast_injective α _ _ this,
have hf : ¬injective nat.cast, from @set.not_injective_nat_fintype α _ _ _,
absurd ht hf)

end char_p

section integral_domain

variables (α : Type u) [integral_domain α]

open nat function char_p

--integral_domain
lemma char_p_ne_one (p : ℕ) [hc : char_p α p] : p ≠ 1 :=
assume hp : p = 1,
have (↑1 : α) = 0, from (cast_eq_zero_iff α p 1).mpr (hp ▸ (dvd_refl p)),
have ( 1 : α) = 0, from @cast_one α _ _ ▸ this,
absurd this one_ne_zero

--integral_domain
lemma char_p_prime_of_ge_two (p : ℕ) [hc : char_p α p] (hp : p ≥ 2) : nat.prime p :=
suffices ∀d ∣ p, d = 1 ∨ d = p, from ⟨hp, this⟩,
assume (d : ℕ) (hdvd : ∃ e, p = d * e),
let ⟨e, hmul⟩ := hdvd in
have (p : α) = 0, from (cast_eq_zero_iff α p p).mpr (dvd_refl p),
have (d : α) * e = 0, from (@cast_mul α _ d e) ▸ (hmul ▸ this),
or.elim (no_zero_divisors.eq_zero_or_eq_zero_of_mul_eq_zero (d : α) e this)
  (assume hd : (d : α) = 0,
  have p ∣ d, from (cast_eq_zero_iff α p d).mp hd,
  show d = 1 ∨ d = p, from or.inr (dvd_antisymm ⟨e, hmul⟩ this))
  (assume he : (e : α) = 0,
  have p ∣ e, from (cast_eq_zero_iff α p e).mp he,
  have e ∣ p, from dvd_of_mul_left_eq d (eq.symm hmul),
  have e = p, from dvd_antisymm ‹e ∣ p› ‹p ∣ e›,
  have h₀ : p > 0, from gt_of_ge_of_gt hp (nat.zero_lt_succ 1),
  have d * p = 1 * p, by rw ‹e = p› at hmul; rw [one_mul]; exact eq.symm hmul,
  show d = 1 ∨ d = p, from or.inl (eq_of_mul_eq_mul_right h₀ this))

--integral_domain
lemma char_p_prime_or_zero (p : ℕ) [hc : char_p α p] : nat.prime p ∨ p = 0 :=
match p, hc with
| 0,     _  := or.inr rfl
| 1,     hc := absurd (eq.refl (1 : ℕ)) (@char_p_ne_one α _ (1 : ℕ) hc)
| (m+2), hc := or.inl (@char_p_prime_of_ge_two α _ (m+2) hc (nat.le_add_left 2 m))
end

--integral_domain
lemma char_p_prime [fintype α] [decidable_eq α] (p : ℕ) [char_p α p] : nat.prime p :=
or.resolve_right (char_p_prime_or_zero α p) (char_p.ne_zero α p)

lemma ring_char_prime [fintype α] [decidable_eq α] : nat.prime (ring_char α) :=
@char_p_prime α _ _ _ (ring_char α) ⟨ring_char.spec α⟩

end integral_domain

namespace finite_field

open fintype

variables (α : Type u) {β : Type v}
variables [discrete_field α] [fintype α]
variables [discrete_field β] [fintype β]

--finite field
theorem fin_field_card (p : ℕ) [char_p α p] :
∃ (n : ℕ+), nat.prime p ∧ card α = p^(n : ℕ) :=
have hp : nat.prime p, from char_p_prime α p,
have V : vector_space (zmodp p hp) α, from {..zmod.to_module' α},
let ⟨n, h⟩ := @vector_space.card_fin _ _ _ _ _ _ V _ in
have hn : n > 0, from or.resolve_left (nat.eq_zero_or_pos n)
  (assume h0 : n = 0,
  have card α = 1, by rw[←nat.pow_zero (card _), ←h0]; exact h,
  have (1 : α) = 0, from (fintype.card_le_one_iff.mp (le_of_eq this)) 1 0,
  absurd this one_ne_zero),
⟨⟨n, hn⟩, hp, fintype.card_fin p ▸ h⟩

theorem fin_field_card_exists :
∃ (p : ℕ) (n : ℕ+), nat.prime p ∧ card α = p^(n : ℕ) :=
let ⟨p, hc⟩ := char_p.exists α in
⟨p, @fin_field_card α _ _ p hc⟩

theorem finite_field.exists : ∀ (p : ℕ) (n : ℕ+), nat.prime p →
∃ (α : Type*) [hf : field α] [hfin : fintype α], @card α hfin = p^(n : ℕ) :=
sorry

theorem finite_field.unique : card α = card β → (α ≃r β) :=
sorry

def fin_field (p : ℕ) (n : ℕ+) {hp : nat.prime p} :=
classical.some (finite_field.exists p n hp)

notation `𝔽_[` p `;` n `]` := fin_field p n --find better notation?

variables {p : ℕ} {n : ℕ+} {hp : nat.prime p}

noncomputable instance : field 𝔽_[p;n] :=
classical.some (classical.some_spec (finite_field.exists p n hp))

noncomputable instance : fintype 𝔽_[p;n] :=
classical.some (classical.some_spec $ classical.some_spec (finite_field.exists p n hp))

end finite_field


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.special_functions.pow
import logic.equiv.list
import measure_theory.constructions.borel_space
import measure_theory.measure.lebesgue
import topology.metric_space.holder
import topology.metric_space.metric_separated

/-!
# Hausdorff measure and metric (outer) measures

In this file we define the `d`-dimensional Hausdorff measure on an (extended) metric space `X` and
the Hausdorff dimension of a set in an (extended) metric space. Let `μ d δ` be the maximal outer
measure such that `μ d δ s ≤ (emetric.diam s) ^ d` for every set of diameter less than `δ`. Then
the Hausdorff measure `μH[d] s` of `s` is defined as `⨆ δ > 0, μ d δ s`. By Caratheodory theorem
`measure_theory.outer_measure.is_metric.borel_le_caratheodory`, this is a Borel measure on `X`.

The value of `μH[d]`, `d > 0`, on a set `s` (measurable or not) is given by
```
μH[d] s = ⨆ (r : ℝ≥0∞) (hr : 0 < r), ⨅ (t : ℕ → set X) (hts : s ⊆ ⋃ n, t n)
    (ht : ∀ n, emetric.diam (t n) ≤ r), ∑' n, emetric.diam (t n) ^ d
```

For every set `s` for any `d < d'` we have either `μH[d] s = ∞` or `μH[d'] s = 0`, see
`measure_theory.measure.hausdorff_measure_zero_or_top`. In
`topology.metric_space.hausdorff_dimension` we use this fact to define the Hausdorff dimension
`dimH` of a set in an (extended) metric space.

We also define two generalizations of the Hausdorff measure. In one generalization (see
`measure_theory.measure.mk_metric`) we take any function `m (diam s)` instead of `(diam s) ^ d`. In
an even more general definition (see `measure_theory.measure.mk_metric'`) we use any function
of `m : set X → ℝ≥0∞`. Some authors start with a partial function `m` defined only on some sets
`s : set X` (e.g., only on balls or only on measurable sets). This is equivalent to our definition
applied to `measure_theory.extend m`.

We also define a predicate `measure_theory.outer_measure.is_metric` which says that an outer measure
is additive on metric separated pairs of sets: `μ (s ∪ t) = μ s + μ t` provided that
`⨅ (x ∈ s) (y ∈ t), edist x y ≠ 0`. This is the property required for the Caratheodory theorem
`measure_theory.outer_measure.is_metric.borel_le_caratheodory`, so we prove this theorem for any
metric outer measure, then prove that outer measures constructed using `mk_metric'` are metric outer
measures.

## Main definitions

* `measure_theory.outer_measure.is_metric`: an outer measure `μ` is called *metric* if
  `μ (s ∪ t) = μ s + μ t` for any two metric separated sets `s` and `t`. A metric outer measure in a
  Borel extended metric space is guaranteed to satisfy the Caratheodory condition, see
  `measure_theory.outer_measure.is_metric.borel_le_caratheodory`.
* `measure_theory.outer_measure.mk_metric'` and its particular case
  `measure_theory.outer_measure.mk_metric`: a construction of an outer measure that is guaranteed to
  be metric. Both constructions are generalizations of the Hausdorff measure. The same measures
  interpreted as Borel measures are called `measure_theory.measure.mk_metric'` and
  `measure_theory.measure.mk_metric`.
* `measure_theory.measure.hausdorff_measure` a.k.a. `μH[d]`: the `d`-dimensional Hausdorff measure.
  There are many definitions of the Hausdorff measure that differ from each other by a
  multiplicative constant. We put
  `μH[d] s = ⨆ r > 0, ⨅ (t : ℕ → set X) (hts : s ⊆ ⋃ n, t n) (ht : ∀ n, emetric.diam (t n) ≤ r),
    ∑' n, ⨆ (ht : ¬set.subsingleton (t n)), (emetric.diam (t n)) ^ d`,
  see `measure_theory.measure.hausdorff_measure_apply'`. In the most interesting case `0 < d` one
  can omit the `⨆ (ht : ¬set.subsingleton (t n))` part.

## Main statements

### Basic properties

* `measure_theory.outer_measure.is_metric.borel_le_caratheodory`: if `μ` is a metric outer measure
  on an extended metric space `X` (that is, it is additive on pairs of metric separated sets), then
  every Borel set is Caratheodory measurable (hence, `μ` defines an actual
  `measure_theory.measure`). See also `measure_theory.measure.mk_metric`.
* `measure_theory.measure.hausdorff_measure_mono`: `μH[d] s` is an antitone function
  of `d`.
* `measure_theory.measure.hausdorff_measure_zero_or_top`: if `d₁ < d₂`, then for any `s`, either
  `μH[d₂] s = 0` or `μH[d₁] s = ∞`. Together with the previous lemma, this means that `μH[d] s` is
  equal to infinity on some ray `(-∞, D)` and is equal to zero on `(D, +∞)`, where `D` is a possibly
  infinite number called the *Hausdorff dimension* of `s`; `μH[D] s` can be zero, infinity, or
  anything in between.
* `measure_theory.measure.no_atoms_hausdorff`: Hausdorff measure has no atoms.

### Hausdorff measure in `ℝⁿ`

* `measure_theory.hausdorff_measure_pi_real`: for a nonempty `ι`, `μH[card ι]` on `ι → ℝ` equals
  Lebesgue measure.

## Notations

We use the following notation localized in `measure_theory`.

- `μH[d]` : `measure_theory.measure.hausdorff_measure d`

## Implementation notes

There are a few similar constructions called the `d`-dimensional Hausdorff measure. E.g., some
sources only allow coverings by balls and use `r ^ d` instead of `(diam s) ^ d`. While these
construction lead to different Hausdorff measures, they lead to the same notion of the Hausdorff
dimension.

## TODO

* prove that `1`-dimensional Hausdorff measure on `ℝ` equals `volume`;
* prove a similar statement for `ℝ × ℝ`.

## References

* [Herbert Federer, Geometric Measure Theory, Chapter 2.10][Federer1996]

## Tags

Hausdorff measure, measure, metric measure
-/

open_locale nnreal ennreal topological_space big_operators

open emetric set function filter encodable finite_dimensional topological_space

noncomputable theory

variables {ι X Y : Type*} [emetric_space X] [emetric_space Y]

namespace measure_theory

namespace outer_measure

/-!
### Metric outer measures

In this section we define metric outer measures and prove Caratheodory theorem: a metric outer
measure has the Caratheodory property.
-/

/-- We say that an outer measure `μ` in an (e)metric space is *metric* if `μ (s ∪ t) = μ s + μ t`
for any two metric separated sets `s`, `t`. -/
def is_metric (μ : outer_measure X) : Prop :=
∀ (s t : set X), is_metric_separated s t → μ (s ∪ t) = μ s + μ t

namespace is_metric

variables {μ : outer_measure X}

/-- A metric outer measure is additive on a finite set of pairwise metric separated sets. -/
lemma finset_Union_of_pairwise_separated (hm : is_metric μ) {I : finset ι} {s : ι → set X}
  (hI : ∀ (i ∈ I) (j ∈ I), i ≠ j → is_metric_separated (s i) (s j)) :
  μ (⋃ i ∈ I, s i) = ∑ i in I, μ (s i) :=
begin
  classical,
  induction I using finset.induction_on with i I hiI ihI hI, { simp },
  simp only [finset.mem_insert] at hI,
  rw [finset.set_bUnion_insert, hm, ihI, finset.sum_insert hiI],
  exacts [λ i hi j hj hij, (hI i (or.inr hi) j (or.inr hj) hij),
    is_metric_separated.finset_Union_right
      (λ j hj, hI i (or.inl rfl) j (or.inr hj) (ne_of_mem_of_not_mem hj hiI).symm)]
end

/-- Caratheodory theorem. If `m` is a metric outer measure, then every Borel measurable set `t` is
Caratheodory measurable: for any (not necessarily measurable) set `s` we have
`μ (s ∩ t) + μ (s \ t) = μ s`. -/
lemma borel_le_caratheodory (hm : is_metric μ) :
  borel X ≤ μ.caratheodory :=
begin
  rw [borel_eq_generate_from_is_closed],
  refine measurable_space.generate_from_le (λ t ht, μ.is_caratheodory_iff_le.2 $ λ s, _),
  set S : ℕ → set X := λ n, {x ∈ s | (↑n)⁻¹ ≤ inf_edist x t},
  have n0 : ∀ {n : ℕ}, (n⁻¹ : ℝ≥0∞) ≠ 0, from λ n, ennreal.inv_ne_zero.2 ennreal.coe_nat_ne_top,
  have Ssep : ∀ n, is_metric_separated (S n) t,
    from λ n, ⟨n⁻¹, n0, λ x hx y hy, hx.2.trans $ inf_edist_le_edist_of_mem hy⟩,
  have Ssep' : ∀ n, is_metric_separated (S n) (s ∩ t),
    from λ n, (Ssep n).mono subset.rfl (inter_subset_right _ _),
  have S_sub : ∀ n, S n ⊆ s \ t,
    from λ n, subset_inter (inter_subset_left _ _) (Ssep n).subset_compl_right,
  have hSs : ∀ n, μ (s ∩ t) + μ (S n) ≤ μ s, from λ n,
  calc μ (s ∩ t) + μ (S n) = μ (s ∩ t ∪ S n) :
    eq.symm $ hm _ _ $ (Ssep' n).symm
  ... ≤ μ (s ∩ t ∪ s \ t)  : by { mono*, exact le_rfl }
  ... = μ s : by rw [inter_union_diff],
  have Union_S : (⋃ n, S n) = s \ t,
  { refine subset.antisymm (Union_subset S_sub) _,
    rintro x ⟨hxs, hxt⟩,
    rw mem_iff_inf_edist_zero_of_closed ht at hxt,
    rcases ennreal.exists_inv_nat_lt hxt with ⟨n, hn⟩,
    exact mem_Union.2 ⟨n, hxs, hn.le⟩ },
  /- Now we have `∀ n, μ (s ∩ t) + μ (S n) ≤ μ s` and we need to prove
  `μ (s ∩ t) + μ (⋃ n, S n) ≤ μ s`. We can't pass to the limit because
  `μ` is only an outer measure. -/
  by_cases htop : μ (s \ t) = ∞,
  { rw [htop, ennreal.add_top, ← htop],
    exact μ.mono (diff_subset _ _) },
  suffices : μ (⋃ n, S n) ≤ ⨆ n, μ (S n),
  calc μ (s ∩ t) + μ (s \ t) = μ (s ∩ t) + μ (⋃ n, S n) :
    by rw Union_S
  ... ≤ μ (s ∩ t) + ⨆ n, μ (S n) :
    add_le_add le_rfl this
  ... = ⨆ n, μ (s ∩ t) + μ (S n) : ennreal.add_supr
  ... ≤ μ s : supr_le hSs,
  /- It suffices to show that `∑' k, μ (S (k + 1) \ S k) ≠ ∞`. Indeed, if we have this,
  then for all `N` we have `μ (⋃ n, S n) ≤ μ (S N) + ∑' k, m (S (N + k + 1) \ S (N + k))`
  and the second term tends to zero, see `outer_measure.Union_nat_of_monotone_of_tsum_ne_top`
  for details. -/
  have : ∀ n, S n ⊆ S (n + 1), from λ n x hx,
    ⟨hx.1, le_trans (ennreal.inv_le_inv.2 $ ennreal.coe_nat_le_coe_nat.2 n.le_succ) hx.2⟩,
  refine (μ.Union_nat_of_monotone_of_tsum_ne_top this _).le, clear this,
  /- While the sets `S (k + 1) \ S k` are not pairwise metric separated, the sets in each
  subsequence `S (2 * k + 1) \ S (2 * k)` and `S (2 * k + 2) \ S (2 * k)` are metric separated,
  so `m` is additive on each of those sequences. -/
  rw [← tsum_even_add_odd ennreal.summable ennreal.summable, ennreal.add_ne_top],
  suffices : ∀ a, (∑' (k : ℕ), μ (S (2 * k + 1 + a) \ S (2 * k + a))) ≠ ∞,
    from ⟨by simpa using this 0, by simpa using this 1⟩,
  refine λ r, ne_top_of_le_ne_top htop _,
  rw [← Union_S, ennreal.tsum_eq_supr_nat, supr_le_iff],
  intro n,
  rw [← hm.finset_Union_of_pairwise_separated],
  { exact μ.mono (Union_subset $ λ i, Union_subset $ λ hi x hx, mem_Union.2 ⟨_, hx.1⟩) },
  suffices : ∀ i  j, i < j → is_metric_separated (S (2 * i + 1 + r)) (s \ S (2 * j + r)),
    from λ i _ j _ hij, hij.lt_or_lt.elim
      (λ h, (this i j h).mono (inter_subset_left _ _) (λ x hx, ⟨hx.1.1, hx.2⟩))
      (λ h, (this j i h).symm.mono  (λ x hx, ⟨hx.1.1, hx.2⟩) (inter_subset_left _ _)),
  intros i j hj,
  have A : ((↑(2 * j + r))⁻¹ : ℝ≥0∞) < (↑(2 * i + 1 + r))⁻¹,
    by { rw [ennreal.inv_lt_inv, ennreal.coe_nat_lt_coe_nat], linarith },
  refine ⟨(↑(2 * i + 1 + r))⁻¹ - (↑(2 * j + r))⁻¹, by simpa using A, λ x hx y hy, _⟩,
  have : inf_edist y t < (↑(2 * j + r))⁻¹, from not_le.1 (λ hle, hy.2 ⟨hy.1, hle⟩),
  rcases inf_edist_lt_iff.mp this with ⟨z, hzt, hyz⟩,
  have hxz : (↑(2 * i + 1 + r))⁻¹ ≤ edist x z, from le_inf_edist.1 hx.2 _ hzt,
  apply ennreal.le_of_add_le_add_right hyz.ne_top,
  refine le_trans _ (edist_triangle _ _ _),
  refine (add_le_add le_rfl hyz.le).trans (eq.trans_le _ hxz),
  rw [tsub_add_cancel_of_le A.le]
end

lemma le_caratheodory [measurable_space X] [borel_space X] (hm : is_metric μ) :
  ‹measurable_space X› ≤ μ.caratheodory :=
by { rw @borel_space.measurable_eq X _ _, exact hm.borel_le_caratheodory }

end is_metric

/-!
### Constructors of metric outer measures

In this section we provide constructors `measure_theory.outer_measure.mk_metric'` and
`measure_theory.outer_measure.mk_metric` and prove that these outer measures are metric outer
measures. We also prove basic lemmas about `map`/`comap` of these measures.
-/

/-- Auxiliary definition for `outer_measure.mk_metric'`: given a function on sets
`m : set X → ℝ≥0∞`, returns the maximal outer measure `μ` such that `μ s ≤ m s`
for any set `s` of diameter at most `r`.-/
def mk_metric'.pre (m : set X → ℝ≥0∞) (r : ℝ≥0∞) :
  outer_measure X :=
bounded_by $ extend (λ s (hs : diam s ≤ r), m s)

/-- Given a function `m : set X → ℝ≥0∞`, `mk_metric' m` is the supremum of `mk_metric'.pre m r`
over `r > 0`. Equivalently, it is the limit of `mk_metric'.pre m r` as `r` tends to zero from
the right. -/
def mk_metric' (m : set X → ℝ≥0∞) :
  outer_measure X :=
⨆ r > 0, mk_metric'.pre m r

/-- Given a function `m : ℝ≥0∞ → ℝ≥0∞` and `r > 0`, let `μ r` be the maximal outer measure such that
`μ s ≤ m (emetric.diam s)` whenever `emetric.diam s < r`. Then
`mk_metric m = ⨆ r > 0, μ r`. -/
def mk_metric (m : ℝ≥0∞ → ℝ≥0∞) : outer_measure X :=
mk_metric' (λ s, m (diam s))

namespace mk_metric'

variables {m : set X → ℝ≥0∞} {r : ℝ≥0∞} {μ : outer_measure X} {s : set X}

lemma le_pre : μ ≤ pre m r ↔ ∀ s : set X, diam s ≤ r → μ s ≤ m s :=
by simp only [pre, le_bounded_by, extend, le_infi_iff]

lemma pre_le (hs : diam s ≤ r) : pre m r s ≤ m s :=
(bounded_by_le _).trans $ infi_le _ hs

lemma mono_pre (m : set X → ℝ≥0∞) {r r' : ℝ≥0∞} (h : r ≤ r') :
  pre m r' ≤ pre m r :=
le_pre.2 $ λ s hs, pre_le (hs.trans h)

lemma mono_pre_nat (m : set X → ℝ≥0∞) :
  monotone (λ k : ℕ, pre m k⁻¹) :=
λ k l h, le_pre.2 $ λ s hs, pre_le (hs.trans $ by simpa)

lemma tendsto_pre (m : set X → ℝ≥0∞) (s : set X) :
  tendsto (λ r, pre m r s) (𝓝[>] 0) (𝓝 $ mk_metric' m s) :=
begin
  rw [← map_coe_Ioi_at_bot, tendsto_map'_iff],
  simp only [mk_metric', outer_measure.supr_apply, supr_subtype'],
  exact tendsto_at_bot_supr (λ r r' hr, mono_pre _ hr _)
end

lemma tendsto_pre_nat (m : set X → ℝ≥0∞) (s : set X) :
  tendsto (λ n : ℕ, pre m n⁻¹ s) at_top (𝓝 $ mk_metric' m s) :=
begin
  refine (tendsto_pre m s).comp (tendsto_inf.2 ⟨ennreal.tendsto_inv_nat_nhds_zero, _⟩),
  refine tendsto_principal.2 (eventually_of_forall $ λ n, _),
  simp
end

lemma eq_supr_nat (m : set X → ℝ≥0∞) :
  mk_metric' m = ⨆ n : ℕ, mk_metric'.pre m n⁻¹ :=
begin
  ext1 s,
  rw supr_apply,
  refine tendsto_nhds_unique (mk_metric'.tendsto_pre_nat m s)
    (tendsto_at_top_supr $ λ k l hkl, mk_metric'.mono_pre_nat m hkl s)
end

/-- `measure_theory.outer_measure.mk_metric'.pre m r` is a trimmed measure provided that
`m (closure s) = m s` for any set `s`. -/
lemma trim_pre [measurable_space X] [opens_measurable_space X]
  (m : set X → ℝ≥0∞) (hcl : ∀ s, m (closure s) = m s) (r : ℝ≥0∞) :
  (pre m r).trim = pre m r :=
begin
  refine le_antisymm (le_pre.2 $ λ s hs, _) (le_trim _),
  rw trim_eq_infi,
  refine (infi_le_of_le (closure s) $ infi_le_of_le subset_closure $
    infi_le_of_le measurable_set_closure ((pre_le _).trans_eq (hcl _))),
  rwa diam_closure
end

end mk_metric'

/-- An outer measure constructed using `outer_measure.mk_metric'` is a metric outer measure. -/
lemma mk_metric'_is_metric (m : set X → ℝ≥0∞) :
  (mk_metric' m).is_metric :=
begin
  rintros s t ⟨r, r0, hr⟩,
  refine tendsto_nhds_unique_of_eventually_eq
    (mk_metric'.tendsto_pre _ _)
    ((mk_metric'.tendsto_pre _ _).add (mk_metric'.tendsto_pre _ _)) _,
  rw [← pos_iff_ne_zero] at r0,
  filter_upwards [Ioo_mem_nhds_within_Ioi ⟨le_rfl, r0⟩],
  rintro ε ⟨ε0, εr⟩,
  refine bounded_by_union_of_top_of_nonempty_inter _,
  rintro u ⟨x, hxs, hxu⟩ ⟨y, hyt, hyu⟩,
  have : ε < diam u, from εr.trans_le ((hr x hxs y hyt).trans $ edist_le_diam_of_mem hxu hyu),
  exact infi_eq_top.2 (λ h, (this.not_le h).elim)
end

/-- If `c ∉ {0, ∞}` and `m₁ d ≤ c * m₂ d` for `d < ε` for some `ε > 0`
(we use `≤ᶠ[𝓝[≥] 0]` to state this), then `mk_metric m₁ hm₁ ≤ c • mk_metric m₂ hm₂`. -/
lemma mk_metric_mono_smul {m₁ m₂ : ℝ≥0∞ → ℝ≥0∞} {c : ℝ≥0∞} (hc : c ≠ ∞) (h0 : c ≠ 0)
  (hle : m₁ ≤ᶠ[𝓝[≥] 0] c • m₂) :
  (mk_metric m₁ : outer_measure X) ≤ c • mk_metric m₂ :=
begin
  classical,
  rcases (mem_nhds_within_Ici_iff_exists_Ico_subset' ennreal.zero_lt_one).1 hle with ⟨r, hr0, hr⟩,
  refine λ s, le_of_tendsto_of_tendsto (mk_metric'.tendsto_pre _ s)
    (ennreal.tendsto.const_mul (mk_metric'.tendsto_pre _ s) (or.inr hc))
    (mem_of_superset (Ioo_mem_nhds_within_Ioi ⟨le_rfl, hr0⟩) (λ r' hr', _)),
  simp only [mem_set_of_eq, mk_metric'.pre, ring_hom.id_apply],
  rw [←smul_eq_mul, ← smul_apply, smul_bounded_by hc],
  refine le_bounded_by.2 (λ t, (bounded_by_le _).trans _) _,
  simp only [smul_eq_mul, pi.smul_apply, extend, infi_eq_if],
  split_ifs with ht ht,
  { apply hr,
    exact ⟨zero_le _, ht.trans_lt hr'.2⟩ },
  { simp [h0] }
end

/-- If `m₁ d ≤ m₂ d` for `d < ε` for some `ε > 0` (we use `≤ᶠ[𝓝[≥] 0]` to state this), then
`mk_metric m₁ hm₁ ≤ mk_metric m₂ hm₂`-/
lemma mk_metric_mono {m₁ m₂ : ℝ≥0∞ → ℝ≥0∞} (hle : m₁ ≤ᶠ[𝓝[≥] 0] m₂) :
  (mk_metric m₁ : outer_measure X) ≤ mk_metric m₂ :=
by { convert mk_metric_mono_smul ennreal.one_ne_top ennreal.zero_lt_one.ne' _; simp * }

lemma isometry_comap_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) {f : X → Y} (hf : isometry f)
  (H : monotone m ∨ surjective f) :
  comap f (mk_metric m) = mk_metric m :=
begin
  simp only [mk_metric, mk_metric', mk_metric'.pre, induced_outer_measure, comap_supr],
  refine surjective_id.supr_congr id (λ ε, surjective_id.supr_congr id $ λ hε, _),
  rw comap_bounded_by _ (H.imp (λ h_mono, _) id),
  { congr' with s : 1,
    apply extend_congr,
    { simp [hf.ediam_image] },
    { intros, simp [hf.injective.subsingleton_image_iff, hf.ediam_image] } },
  { assume s t hst,
    simp only [extend, le_infi_iff],
    assume ht,
    apply le_trans _ (h_mono (diam_mono hst)),
    simp only [(diam_mono hst).trans ht, le_refl, cinfi_pos] }
end

lemma isometry_map_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) {f : X → Y} (hf : isometry f)
  (H : monotone m ∨ surjective f) :
  map f (mk_metric m) = restrict (range f) (mk_metric m) :=
by rw [← isometry_comap_mk_metric _ hf H, map_comap]

lemma isometric_comap_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) (f : X ≃ᵢ Y) :
  comap f (mk_metric m) = mk_metric m :=
isometry_comap_mk_metric _ f.isometry (or.inr f.surjective)

lemma isometric_map_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) (f : X ≃ᵢ Y) :
  map f (mk_metric m) = mk_metric m :=
by rw [← isometric_comap_mk_metric _ f, map_comap_of_surjective f.surjective]

lemma trim_mk_metric [measurable_space X] [borel_space X] (m : ℝ≥0∞ → ℝ≥0∞) :
  (mk_metric m : outer_measure X).trim = mk_metric m :=
begin
  simp only [mk_metric, mk_metric'.eq_supr_nat, trim_supr],
  congr' 1 with n : 1,
  refine mk_metric'.trim_pre _ (λ s, _) _,
  simp
end

lemma le_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) (μ : outer_measure X)
  (r : ℝ≥0∞) (h0 : 0 < r) (hr : ∀ s, diam s ≤ r → μ s ≤ m (diam s)) :
  μ ≤ mk_metric m :=
le_supr₂_of_le r h0 $ mk_metric'.le_pre.2 $ λ s hs, hr _ hs

end outer_measure

/-!
### Metric measures

In this section we use `measure_theory.outer_measure.to_measure` and theorems about
`measure_theory.outer_measure.mk_metric'`/`measure_theory.outer_measure.mk_metric` to define
`measure_theory.measure.mk_metric'`/`measure_theory.measure.mk_metric`. We also restate some lemmas
about metric outer measures for metric measures.
-/

namespace measure

variables [measurable_space X] [borel_space X]

/-- Given a function `m : set X → ℝ≥0∞`, `mk_metric' m` is the supremum of `μ r`
over `r > 0`, where `μ r` is the maximal outer measure `μ` such that `μ s ≤ m s`
for all `s`. While each `μ r` is an *outer* measure, the supremum is a measure. -/
def mk_metric' (m : set X → ℝ≥0∞) : measure X :=
(outer_measure.mk_metric' m).to_measure (outer_measure.mk_metric'_is_metric _).le_caratheodory

/-- Given a function `m : ℝ≥0∞ → ℝ≥0∞`, `mk_metric m` is the supremum of `μ r` over `r > 0`, where
`μ r` is the maximal outer measure `μ` such that `μ s ≤ m s` for all sets `s` that contain at least
two points. While each `mk_metric'.pre` is an *outer* measure, the supremum is a measure. -/
def mk_metric (m : ℝ≥0∞ → ℝ≥0∞) : measure X :=
(outer_measure.mk_metric m).to_measure (outer_measure.mk_metric'_is_metric _).le_caratheodory

@[simp] lemma mk_metric'_to_outer_measure (m : set X → ℝ≥0∞) :
  (mk_metric' m).to_outer_measure = (outer_measure.mk_metric' m).trim :=
rfl

@[simp] lemma mk_metric_to_outer_measure (m : ℝ≥0∞ → ℝ≥0∞) :
  (mk_metric m : measure X).to_outer_measure = outer_measure.mk_metric m :=
outer_measure.trim_mk_metric m

end measure

lemma outer_measure.coe_mk_metric [measurable_space X] [borel_space X] (m : ℝ≥0∞ → ℝ≥0∞) :
  ⇑(outer_measure.mk_metric m : outer_measure X) = measure.mk_metric m :=
by rw [← measure.mk_metric_to_outer_measure, coe_to_outer_measure]

namespace measure

variables [measurable_space X] [borel_space X]

/-- If `c ∉ {0, ∞}` and `m₁ d ≤ c * m₂ d` for `d < ε` for some `ε > 0`
(we use `≤ᶠ[𝓝[≥] 0]` to state this), then `mk_metric m₁ hm₁ ≤ c • mk_metric m₂ hm₂`. -/
lemma mk_metric_mono_smul {m₁ m₂ : ℝ≥0∞ → ℝ≥0∞} {c : ℝ≥0∞} (hc : c ≠ ∞) (h0 : c ≠ 0)
  (hle : m₁ ≤ᶠ[𝓝[≥] 0] c • m₂) :
  (mk_metric m₁ : measure X) ≤ c • mk_metric m₂ :=
begin
  intros s hs,
  rw [← outer_measure.coe_mk_metric, coe_smul, ← outer_measure.coe_mk_metric],
  exact outer_measure.mk_metric_mono_smul hc h0 hle s
end

/-- If `m₁ d ≤ m₂ d` for `d < ε` for some `ε > 0` (we use `≤ᶠ[𝓝[≥] 0]` to state this), then
`mk_metric m₁ hm₁ ≤ mk_metric m₂ hm₂`-/
lemma mk_metric_mono {m₁ m₂ : ℝ≥0∞ → ℝ≥0∞} (hle : m₁ ≤ᶠ[𝓝[≥] 0] m₂) :
  (mk_metric m₁ : measure X) ≤ mk_metric m₂ :=
by { convert mk_metric_mono_smul ennreal.one_ne_top ennreal.zero_lt_one.ne' _; simp * }

/-- A formula for `measure_theory.measure.mk_metric`. -/
lemma mk_metric_apply (m : ℝ≥0∞ → ℝ≥0∞) (s : set X) :
  mk_metric m s = ⨆ (r : ℝ≥0∞) (hr : 0 < r),
    ⨅ (t : ℕ → set X) (h : s ⊆ Union t) (h' : ∀ n, diam (t n) ≤ r),
      ∑' n, ⨆ (h : (t n).nonempty), m (diam (t n)) :=
begin
  -- We mostly unfold the definitions but we need to switch the order of `∑'` and `⨅`
  classical,
  simp only [← outer_measure.coe_mk_metric, outer_measure.mk_metric, outer_measure.mk_metric',
    outer_measure.supr_apply, outer_measure.mk_metric'.pre, outer_measure.bounded_by_apply,
    extend],
  refine surjective_id.supr_congr (λ r, r) (λ r, supr_congr_Prop iff.rfl $ λ hr,
    surjective_id.infi_congr _ $ λ t, infi_congr_Prop iff.rfl $ λ ht, _),
  dsimp,
  by_cases htr : ∀ n, diam (t n) ≤ r,
  { rw [infi_eq_if, if_pos htr],
    congr' 1 with n : 1,
    simp only [infi_eq_if, htr n, id, if_true, supr_and'] },
  { rw [infi_eq_if, if_neg htr],
    push_neg at htr, rcases htr with ⟨n, hn⟩,
    refine ennreal.tsum_eq_top_of_eq_top ⟨n, _⟩,
    rw [supr_eq_if, if_pos, infi_eq_if, if_neg],
    exact hn.not_le,
    rcases diam_pos_iff.1 ((zero_le r).trans_lt hn) with ⟨x, hx, -⟩,
    exact ⟨x, hx⟩ }
end

lemma le_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) (μ : measure X) (ε : ℝ≥0∞) (h₀ : 0 < ε)
  (h : ∀ s : set X, diam s ≤ ε → μ s ≤ m (diam s)) :
  μ ≤ mk_metric m :=
begin
  rw [← to_outer_measure_le, mk_metric_to_outer_measure],
  exact outer_measure.le_mk_metric m μ.to_outer_measure ε h₀ h
end

/-- To bound the Hausdorff measure (or, more generally, for a measure defined using
`measure_theory.measure.mk_metric`) of a set, one may use coverings with maximum diameter tending to
`0`, indexed by any sequence of encodable types. -/

/-- To bound the Hausdorff measure (or, more generally, for a measure defined using
`measure_theory.measure.mk_metric`) of a set, one may use coverings with maximum diameter tending to
`0`, indexed by any sequence of finite types. -/
lemma mk_metric_le_liminf_sum {β : Type*} {ι : β → Type*} [hι : ∀ n, fintype (ι n)] (s : set X)
  {l : filter β} (r : β → ℝ≥0∞) (hr : tendsto r l (𝓝 0)) (t : Π (n : β), ι n → set X)
  (ht : ∀ᶠ n in l, ∀ i, diam (t n i) ≤ r n) (hst : ∀ᶠ n in l, s ⊆ ⋃ i, t n i)
  (m : ℝ≥0∞ → ℝ≥0∞) :
  mk_metric m s ≤ liminf l (λ n, ∑ i, m (diam (t n i))) :=
begin
  haveI : ∀ n, encodable (ι n), from λ n, fintype.encodable _,
  simpa only [tsum_fintype] using mk_metric_le_liminf_tsum s r hr t ht hst m,
end

/-!
### Hausdorff measure and Hausdorff dimension
-/

/-- Hausdorff measure on an (e)metric space. -/
def hausdorff_measure (d : ℝ) : measure X := mk_metric (λ r, r ^ d)

localized "notation `μH[` d `]` := measure_theory.measure.hausdorff_measure d" in measure_theory

lemma le_hausdorff_measure (d : ℝ) (μ : measure X) (ε : ℝ≥0∞) (h₀ : 0 < ε)
  (h : ∀ s : set X, diam s ≤ ε → μ s ≤ diam s ^ d) :
  μ ≤ μH[d] :=
le_mk_metric _ μ ε h₀ h

/-- A formula for `μH[d] s`. -/
lemma hausdorff_measure_apply (d : ℝ) (s : set X) :
  μH[d] s = ⨆ (r : ℝ≥0∞) (hr : 0 < r), ⨅ (t : ℕ → set X) (hts : s ⊆ ⋃ n, t n)
    (ht : ∀ n, diam (t n) ≤ r), ∑' n, ⨆ (h : (t n).nonempty), (diam (t n)) ^ d :=
mk_metric_apply _ _

/-- To bound the Hausdorff measure of a set, one may use coverings with maximum diameter tending
to `0`, indexed by any sequence of encodable types. -/
lemma hausdorff_measure_le_liminf_tsum {β : Type*}  {ι : β → Type*} [hι : ∀ n, encodable (ι n)]
  (d : ℝ) (s : set X)
  {l : filter β} (r : β → ℝ≥0∞) (hr : tendsto r l (𝓝 0)) (t : Π (n : β), ι n → set X)
  (ht : ∀ᶠ n in l, ∀ i, diam (t n i) ≤ r n) (hst : ∀ᶠ n in l, s ⊆ ⋃ i, t n i) :
  μH[d] s ≤ liminf l (λ n, ∑' i, diam (t n i) ^ d) :=
mk_metric_le_liminf_tsum s r hr t ht hst _

/-- To bound the Hausdorff measure of a set, one may use coverings with maximum diameter tending
to `0`, indexed by any sequence of finite types. -/
lemma hausdorff_measure_le_liminf_sum {β : Type*}  {ι : β → Type*} [hι : ∀ n, fintype (ι n)]
  (d : ℝ) (s : set X)
  {l : filter β} (r : β → ℝ≥0∞) (hr : tendsto r l (𝓝 0)) (t : Π (n : β), ι n → set X)
  (ht : ∀ᶠ n in l, ∀ i, diam (t n i) ≤ r n) (hst : ∀ᶠ n in l, s ⊆ ⋃ i, t n i) :
  μH[d] s ≤ liminf l (λ n, ∑ i, diam (t n i) ^ d) :=
mk_metric_le_liminf_sum s r hr t ht hst _

/-- If `d₁ < d₂`, then for any set `s` we have either `μH[d₂] s = 0`, or `μH[d₁] s = ∞`. -/
lemma hausdorff_measure_zero_or_top {d₁ d₂ : ℝ} (h : d₁ < d₂) (s : set X) :
  μH[d₂] s = 0 ∨ μH[d₁] s = ∞ :=
begin
  by_contra' H,
  suffices : ∀ (c : ℝ≥0), c ≠ 0 → μH[d₂] s ≤ c * μH[d₁] s,
  { rcases ennreal.exists_nnreal_pos_mul_lt H.2 H.1 with ⟨c, hc0, hc⟩,
    exact hc.not_le (this c (pos_iff_ne_zero.1 hc0)) },
  intros c hc,
  refine le_iff'.1 (mk_metric_mono_smul ennreal.coe_ne_top (by exact_mod_cast hc) _) s,
  have : 0 < (c ^ (d₂ - d₁)⁻¹ : ℝ≥0∞),
  { rw [ennreal.coe_rpow_of_ne_zero hc, pos_iff_ne_zero, ne.def, ennreal.coe_eq_zero,
      nnreal.rpow_eq_zero_iff],
    exact mt and.left hc },
  filter_upwards [Ico_mem_nhds_within_Ici ⟨le_rfl, this⟩],
  rintro r ⟨hr₀, hrc⟩,
  lift r to ℝ≥0 using ne_top_of_lt hrc,
  rw [pi.smul_apply, smul_eq_mul, ← ennreal.div_le_iff_le_mul (or.inr ennreal.coe_ne_top)
    (or.inr $ mt ennreal.coe_eq_zero.1 hc)],
  rcases eq_or_ne r 0 with rfl|hr₀,
  { rcases lt_or_le 0 d₂ with h₂|h₂,
    { simp only [h₂, ennreal.zero_rpow_of_pos, zero_le', ennreal.coe_nonneg, ennreal.zero_div,
        ennreal.coe_zero] },
    { simp only [h.trans_le h₂, ennreal.div_top, zero_le', ennreal.coe_nonneg,
        ennreal.zero_rpow_of_neg, ennreal.coe_zero] } },
  { have : (r : ℝ≥0∞) ≠ 0, by simpa only [ennreal.coe_eq_zero, ne.def] using hr₀,
    rw [← ennreal.rpow_sub _ _ this ennreal.coe_ne_top],
    refine (ennreal.rpow_lt_rpow hrc (sub_pos.2 h)).le.trans _,
    rw [← ennreal.rpow_mul, inv_mul_cancel (sub_pos.2 h).ne', ennreal.rpow_one],
    exact le_rfl }
end

/-- Hausdorff measure `μH[d] s` is monotone in `d`. -/
lemma hausdorff_measure_mono {d₁ d₂ : ℝ} (h : d₁ ≤ d₂) (s : set X) : μH[d₂] s ≤ μH[d₁] s :=
begin
  rcases h.eq_or_lt with rfl|h, { exact le_rfl },
  cases hausdorff_measure_zero_or_top h s with hs hs,
  { rw hs, exact zero_le _ },
  { rw hs, exact le_top }
end

variables (X)
lemma no_atoms_hausdorff {d : ℝ} (hd : 0 < d) : has_no_atoms (hausdorff_measure d : measure X) :=
begin
  refine ⟨λ x, _⟩,
  rw [← nonpos_iff_eq_zero, hausdorff_measure_apply],
  refine supr₂_le (λ ε ε0, infi₂_le_of_le (λ n, {x}) _ $ infi_le_of_le (λ n, _) _),
  { exact subset_Union (λ n, {x} : ℕ → set X) 0 },
  { simp only [emetric.diam_singleton, zero_le] },
  { simp [hd] }
end
variables {X}

@[simp] lemma hausdorff_measure_zero_singleton (x : X) : μH[0] ({x} : set X) = 1 :=
begin
  apply le_antisymm,
  { let r : ℕ → ℝ≥0∞ := λ _, 0,
    let t : ℕ → unit → set X := λ n _, {x},
    have ht : ∀ᶠ n in at_top, ∀ i, diam (t n i) ≤ r n,
      by simp only [implies_true_iff, eq_self_iff_true, diam_singleton, eventually_at_top,
        nonpos_iff_eq_zero, exists_const],
    simpa [liminf_const] using hausdorff_measure_le_liminf_sum 0 {x} r tendsto_const_nhds t ht },
  { rw hausdorff_measure_apply,
    suffices : (1 : ℝ≥0∞) ≤ ⨅ (t : ℕ → set X) (hts : {x} ⊆ ⋃ n, t n)
      (ht : ∀ n, diam (t n) ≤ 1), ∑' n, ⨆ (h : (t n).nonempty), (diam (t n)) ^ (0 : ℝ),
    { apply le_trans this _,
      convert le_supr₂ (1 : ℝ≥0∞) (ennreal.zero_lt_one),
      refl },
    simp only [ennreal.rpow_zero, le_infi_iff],
    assume t hst h't,
    rcases mem_Union.1 (hst (mem_singleton x)) with ⟨m, hm⟩,
    have A : (t m).nonempty := ⟨x, hm⟩,
    calc (1 : ℝ≥0∞) = ⨆ (h : (t m).nonempty), 1 : by simp only [A, csupr_pos]
    ... ≤ ∑' n, ⨆ (h : (t n).nonempty), 1 : ennreal.le_tsum _ }
end

lemma one_le_hausdorff_measure_zero_of_nonempty {s : set X} (h : s.nonempty) :
  1 ≤ μH[0] s :=
begin
  rcases h with ⟨x, hx⟩,
  calc (1 : ℝ≥0∞) = μH[0] ({x} : set X) : (hausdorff_measure_zero_singleton x).symm
  ... ≤ μH[0] s : measure_mono (singleton_subset_iff.2 hx)
end

lemma hausdorff_measure_le_one_of_subsingleton
  {s : set X} (hs : s.subsingleton) {d : ℝ} (hd : 0 ≤ d) :
  μH[d] s ≤ 1 :=
begin
  rcases eq_empty_or_nonempty s with rfl|⟨x, hx⟩,
  { simp only [measure_empty, zero_le] },
  { rw (subsingleton_iff_singleton hx).1 hs,
    rcases eq_or_lt_of_le hd with rfl|dpos,
    { simp only [le_refl, hausdorff_measure_zero_singleton] },
    { haveI := no_atoms_hausdorff X dpos,
      simp only [zero_le, measure_singleton] } }
end

end measure

open_locale measure_theory
open measure

/-!
### Hausdorff measure and Lebesgue measure
-/

/-- In the space `ι → ℝ`, Hausdorff measure coincides exactly with Lebesgue measure. -/
@[simp] theorem hausdorff_measure_pi_real {ι : Type*} [fintype ι] :
  (μH[fintype.card ι] : measure (ι → ℝ)) = volume :=
begin
  classical,
  -- it suffices to check that the two measures coincide on products of rational intervals
  refine (pi_eq_generate_from (λ i, real.borel_eq_generate_from_Ioo_rat.symm)
    (λ i, real.is_pi_system_Ioo_rat) (λ i, real.finite_spanning_sets_in_Ioo_rat _)
    _).symm,
  simp only [mem_Union, mem_singleton_iff],
  -- fix such a product `s` of rational intervals, of the form `Π (a i, b i)`.
  intros s hs,
  choose a b H using hs,
  obtain rfl : s = λ i, Ioo (a i) (b i), from funext (λ i, (H i).2), replace H := λ i, (H i).1,
  apply le_antisymm _,
  -- first check that `volume s ≤ μH s`
  { have Hle : volume ≤ (μH[fintype.card ι] : measure (ι → ℝ)),
    { refine le_hausdorff_measure _ _ ∞ ennreal.coe_lt_top (λ s _, _),
      rw [ennreal.rpow_nat_cast],
      exact real.volume_pi_le_diam_pow s },
    rw [← volume_pi_pi (λ i, Ioo (a i : ℝ) (b i))],
    exact measure.le_iff'.1 Hle _ },
  /- For the other inequality `μH s ≤ volume s`, we use a covering of `s` by sets of small diameter
  `1/n`, namely cubes with left-most point of the form `a i + f i / n` with `f i` ranging between
  `0` and `⌈(b i - a i) * n⌉`. Their number is asymptotic to `n^d * Π (b i - a i)`. -/
  have I : ∀ i, 0 ≤ (b i : ℝ) - a i := λ i, by simpa only [sub_nonneg, rat.cast_le] using (H i).le,
  let γ := λ (n : ℕ), (Π (i : ι), fin ⌈((b i : ℝ) - a i) * n⌉₊),
  let t : Π (n : ℕ), γ n → set (ι → ℝ) :=
    λ n f, set.pi univ (λ i, Icc (a i + f i / n) (a i + (f i + 1) / n)),
  have A : tendsto (λ (n : ℕ), 1/(n : ℝ≥0∞)) at_top (𝓝 0),
    by simp only [one_div, ennreal.tendsto_inv_nat_nhds_zero],
  have B : ∀ᶠ n in at_top, ∀ (i : γ n), diam (t n i) ≤ 1 / n,
  { apply eventually_at_top.2 ⟨1, λ n hn, _⟩,
    assume f,
    apply diam_pi_le_of_le (λ b, _),
    simp only [real.ediam_Icc, add_div, ennreal.of_real_div_of_pos (nat.cast_pos.mpr hn), le_refl,
      add_sub_add_left_eq_sub, add_sub_cancel', ennreal.of_real_one, ennreal.of_real_coe_nat] },
  have C : ∀ᶠ n in at_top, set.pi univ (λ (i : ι), Ioo (a i : ℝ) (b i)) ⊆ ⋃ (i : γ n), t n i,
  { apply eventually_at_top.2 ⟨1, λ n hn, _⟩,
    have npos : (0 : ℝ) < n := nat.cast_pos.2 hn,
    assume x hx,
    simp only [mem_Ioo, mem_univ_pi] at hx,
    simp only [mem_Union, mem_Ioo, mem_univ_pi, coe_coe],
    let f : γ n := λ i, ⟨⌊(x i - a i) * n⌋₊,
    begin
      apply nat.floor_lt_ceil_of_lt_of_pos,
      { refine (mul_lt_mul_right npos).2 _,
        simp only [(hx i).right, sub_lt_sub_iff_right] },
      { refine mul_pos _ npos,
        simpa only [rat.cast_lt, sub_pos] using H i }
    end⟩,
    refine ⟨f, λ i, ⟨_, _⟩⟩,
    { calc (a i : ℝ) + ⌊(x i - a i) * n⌋₊ / n
      ≤ (a i : ℝ) + ((x i - a i) * n) / n :
          begin
            refine add_le_add le_rfl ((div_le_div_right npos).2 _),
            exact nat.floor_le (mul_nonneg (sub_nonneg.2 (hx i).1.le) npos.le),
          end
      ... = x i : by field_simp [npos.ne'] },
    { calc x i
      = (a i : ℝ) + ((x i - a i) * n) / n : by field_simp [npos.ne']
      ... ≤ (a i : ℝ) + (⌊(x i - a i) * n⌋₊ + 1) / n :
        add_le_add le_rfl ((div_le_div_right npos).2 (nat.lt_floor_add_one _).le) } },
  calc μH[fintype.card ι] (set.pi univ (λ (i : ι), Ioo (a i : ℝ) (b i)))
    ≤ liminf at_top (λ (n : ℕ), ∑ (i : γ n), diam (t n i) ^ ↑(fintype.card ι)) :
      hausdorff_measure_le_liminf_sum _ (set.pi univ (λ i, Ioo (a i : ℝ) (b i)))
        (λ (n : ℕ), 1/(n : ℝ≥0∞)) A t B C
  ... ≤ liminf at_top (λ (n : ℕ), ∑ (i : γ n), (1/n) ^ (fintype.card ι)) :
    begin
      refine liminf_le_liminf _ (by is_bounded_default),
      filter_upwards [B] with _ hn,
      apply finset.sum_le_sum (λ i _, _),
      rw ennreal.rpow_nat_cast,
      exact pow_le_pow_of_le_left' (hn i) _,
    end
  ... = liminf at_top (λ (n : ℕ), ∏ (i : ι), (⌈((b i : ℝ) - a i) * n⌉₊ : ℝ≥0∞) / n) :
  begin
    simp only [finset.card_univ, nat.cast_prod, one_mul, fintype.card_fin,
      finset.sum_const, nsmul_eq_mul, fintype.card_pi, div_eq_mul_inv, finset.prod_mul_distrib,
      finset.prod_const]
  end
  ... = ∏ (i : ι), volume (Ioo (a i : ℝ) (b i)) :
  begin
    simp only [real.volume_Ioo],
    apply tendsto.liminf_eq,
    refine ennreal.tendsto_finset_prod_of_ne_top _ (λ i hi, _) (λ i hi, _),
    { apply tendsto.congr' _ ((ennreal.continuous_of_real.tendsto _).comp
        ((tendsto_nat_ceil_mul_div_at_top (I i)).comp tendsto_coe_nat_at_top_at_top)),
      apply eventually_at_top.2 ⟨1, λ n hn, _⟩,
      simp only [ennreal.of_real_div_of_pos (nat.cast_pos.mpr hn), comp_app,
        ennreal.of_real_coe_nat] },
    { simp only [ennreal.of_real_ne_top, ne.def, not_false_iff] }
  end
end

end measure_theory

/-!
### Hausdorff measure, Hausdorff dimension, and Hölder or Lipschitz continuous maps
-/

open_locale measure_theory
open measure_theory measure_theory.measure

variables [measurable_space X] [borel_space X] [measurable_space Y] [borel_space Y]

namespace holder_on_with

variables {C r : ℝ≥0} {f : X → Y} {s t : set X}

/-- If `f : X → Y` is Hölder continuous on `s` with a positive exponent `r`, then
`μH[d] (f '' s) ≤ C ^ d * μH[r * d] s`. -/
lemma hausdorff_measure_image_le (h : holder_on_with C r f s) (hr : 0 < r) {d : ℝ} (hd : 0 ≤ d) :
  μH[d] (f '' s) ≤ C ^ d * μH[r * d] s :=
begin
  -- We start with the trivial case `C = 0`
  rcases (zero_le C).eq_or_lt with rfl|hC0,
  { rcases eq_empty_or_nonempty s with rfl|⟨x, hx⟩,
    { simp only [measure_empty, nonpos_iff_eq_zero, mul_zero, image_empty] },
    have : f '' s = {f x},
    { have : (f '' s).subsingleton, by simpa [diam_eq_zero_iff] using h.ediam_image_le,
      exact (subsingleton_iff_singleton (mem_image_of_mem f hx)).1 this },
    rw this,
    rcases eq_or_lt_of_le hd with rfl|h'd,
    { simp only [ennreal.rpow_zero, one_mul, mul_zero],
      rw hausdorff_measure_zero_singleton,
      exact one_le_hausdorff_measure_zero_of_nonempty ⟨x, hx⟩ },
    { haveI := no_atoms_hausdorff Y h'd,
      simp only [zero_le, measure_singleton] } },
  -- Now assume `C ≠ 0`
  { have hCd0 : (C : ℝ≥0∞) ^ d ≠ 0, by simp [hC0.ne'],
    have hCd : (C : ℝ≥0∞) ^ d ≠ ∞, by simp [hd],
    simp only [hausdorff_measure_apply, ennreal.mul_supr, ennreal.mul_infi_of_ne hCd0 hCd,
      ← ennreal.tsum_mul_left],
    refine supr_le (λ R, supr_le $ λ hR, _),
    have : tendsto (λ d : ℝ≥0∞, (C : ℝ≥0∞) * d ^ (r : ℝ)) (𝓝 0) (𝓝 0),
      from ennreal.tendsto_const_mul_rpow_nhds_zero_of_pos ennreal.coe_ne_top hr,
    rcases ennreal.nhds_zero_basis_Iic.eventually_iff.1 (this.eventually (gt_mem_nhds hR))
      with ⟨δ, δ0, H⟩,
    refine le_supr₂_of_le δ δ0 (infi₂_mono' $ λ t hst, ⟨λ n, f '' (t n ∩ s), _, infi_mono' $ λ htδ,
      ⟨λ n, (h.ediam_image_inter_le (t n)).trans (H (htδ n)).le, _⟩⟩),
    { rw [← image_Union, ← Union_inter],
      exact image_subset _ (subset_inter hst subset.rfl) },
    { apply ennreal.tsum_le_tsum (λ n, _),
      simp only [supr_le_iff, nonempty_image_iff],
      assume hft,
      simp only [nonempty.mono ((t n).inter_subset_left s) hft, csupr_pos],
      rw [ennreal.rpow_mul, ← ennreal.mul_rpow_of_nonneg _ _ hd],
      exact ennreal.rpow_le_rpow (h.ediam_image_inter_le _) hd } }
end

end holder_on_with

namespace lipschitz_on_with

variables {K : ℝ≥0} {f : X → Y} {s t : set X}

/-- If `f : X → Y` is `K`-Lipschitz on `s`, then `μH[d] (f '' s) ≤ K ^ d * μH[d] s`. -/
lemma hausdorff_measure_image_le (h : lipschitz_on_with K f s) {d : ℝ} (hd : 0 ≤ d) :
  μH[d] (f '' s) ≤ K ^ d * μH[d] s :=
by simpa only [nnreal.coe_one, one_mul]
  using h.holder_on_with.hausdorff_measure_image_le zero_lt_one hd

end lipschitz_on_with

namespace lipschitz_with

variables {K : ℝ≥0} {f : X → Y}

/-- If `f` is a `K`-Lipschitz map, then it increases the Hausdorff `d`-measures of sets at most
by the factor of `K ^ d`.-/
lemma hausdorff_measure_image_le (h : lipschitz_with K f) {d : ℝ} (hd : 0 ≤ d) (s : set X) :
  μH[d] (f '' s) ≤ K ^ d * μH[d] s :=
(h.lipschitz_on_with s).hausdorff_measure_image_le hd

end lipschitz_with

/-!
### Antilipschitz maps do not decrease Hausdorff measures and dimension
-/

namespace antilipschitz_with

variables {f : X → Y} {K : ℝ≥0} {d : ℝ}

lemma hausdorff_measure_preimage_le (hf : antilipschitz_with K f) (hd : 0 ≤ d) (s : set Y) :
  μH[d] (f ⁻¹' s) ≤ K ^ d * μH[d] s :=
begin
  rcases eq_or_ne K 0 with rfl|h0,
  { rcases eq_empty_or_nonempty (f ⁻¹' s) with hs|⟨x, hx⟩,
    { simp only [hs, measure_empty, zero_le], },
    have : f ⁻¹' s = {x},
    { haveI : subsingleton X := hf.subsingleton,
      have : (f ⁻¹' s).subsingleton, from subsingleton_univ.mono (subset_univ _),
      exact (subsingleton_iff_singleton hx).1 this },
    rw this,
    rcases eq_or_lt_of_le hd with rfl|h'd,
    { simp only [ennreal.rpow_zero, one_mul, mul_zero],
      rw hausdorff_measure_zero_singleton,
      exact one_le_hausdorff_measure_zero_of_nonempty ⟨f x, hx⟩ },
    { haveI := no_atoms_hausdorff X h'd,
      simp only [zero_le, measure_singleton] } },
  have hKd0 : (K : ℝ≥0∞) ^ d ≠ 0, by simp [h0],
  have hKd : (K : ℝ≥0∞) ^ d ≠ ∞, by simp [hd],
  simp only [hausdorff_measure_apply, ennreal.mul_supr, ennreal.mul_infi_of_ne hKd0 hKd,
    ← ennreal.tsum_mul_left],
  refine supr₂_le (λ ε ε0, _),
  refine le_supr₂_of_le (ε / K) (by simp [ε0.ne']) _,
  refine le_infi₂ (λ t hst, le_infi $ λ htε, _),
  replace hst : f ⁻¹' s ⊆ _ := preimage_mono hst, rw preimage_Union at hst,
  refine infi₂_le_of_le _ hst (infi_le_of_le (λ n, _) _),
  { exact (hf.ediam_preimage_le _).trans (ennreal.mul_le_of_le_div' $ htε n) },
  { refine ennreal.tsum_le_tsum (λ n, supr_le_iff.2 (λ hft, _)),
    simp only [nonempty_of_nonempty_preimage hft, csupr_pos],
    rw [← ennreal.mul_rpow_of_nonneg _ _ hd],
    exact ennreal.rpow_le_rpow (hf.ediam_preimage_le _) hd }
end

lemma le_hausdorff_measure_image (hf : antilipschitz_with K f) (hd : 0 ≤ d) (s : set X) :
  μH[d] s ≤ K ^ d * μH[d] (f '' s) :=
calc μH[d] s ≤ μH[d] (f ⁻¹' (f '' s)) : measure_mono (subset_preimage_image _ _)
         ... ≤ K ^ d * μH[d] (f '' s) : hf.hausdorff_measure_preimage_le hd (f '' s)

end antilipschitz_with

/-!
### Isometries preserve the Hausdorff measure and Hausdorff dimension
-/

namespace isometry

variables {f : X → Y} {d : ℝ}

lemma hausdorff_measure_image (hf : isometry f) (hd : 0 ≤ d ∨ surjective f) (s : set X) :
  μH[d] (f '' s) = μH[d] s :=
begin
  simp only [hausdorff_measure, ← outer_measure.coe_mk_metric, ← outer_measure.comap_apply],
  rw [outer_measure.isometry_comap_mk_metric _ hf (hd.imp_left _)],
  exact λ hd x y hxy, ennreal.rpow_le_rpow hxy hd
end

lemma hausdorff_measure_preimage (hf : isometry f) (hd : 0 ≤ d ∨ surjective f) (s : set Y) :
  μH[d] (f ⁻¹' s) = μH[d] (s ∩ range f) :=
by rw [← hf.hausdorff_measure_image hd, image_preimage_eq_inter_range]

lemma map_hausdorff_measure (hf : isometry f) (hd : 0 ≤ d ∨ surjective f) :
  measure.map f μH[d] = (μH[d]).restrict (range f) :=
begin
  ext1 s hs,
  rw [map_apply hf.continuous.measurable hs, restrict_apply hs, hf.hausdorff_measure_preimage hd]
end

end isometry

namespace isometric

@[simp] lemma hausdorff_measure_image (e : X ≃ᵢ Y) (d : ℝ) (s : set X) :
  μH[d] (e '' s) = μH[d] s :=
e.isometry.hausdorff_measure_image (or.inr e.surjective) s

@[simp] lemma hausdorff_measure_preimage (e : X ≃ᵢ Y) (d : ℝ) (s : set Y) :
  μH[d] (e ⁻¹' s) = μH[d] s :=
by rw [← e.image_symm, e.symm.hausdorff_measure_image]

end isometric


/-
Copyright (c) 2022 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca
-/

import number_theory.cyclotomic.discriminant
import ring_theory.polynomial.eisenstein.is_integral

/-!
# Ring of integers of `p ^ n`-th cyclotomic fields
We gather results about cyclotomic extensions of `ℚ`. In particular, we compute the ring of
integers of a `p ^ n`-th cyclotomic extension of `ℚ`.

## Main results
* `is_cyclotomic_extension.rat.is_integral_closure_adjoin_singleton_of_prime_pow`: if `K` is a
  `p ^ k`-th cyclotomic extension of `ℚ`, then `(adjoin ℤ {ζ})` is the integral closure of
  `ℤ` in `K`.
* `is_cyclotomic_extension.rat.cyclotomic_ring_is_integral_closure_of_prime_pow`: the integral
  closure of `ℤ` inside `cyclotomic_field (p ^ k) ℚ` is `cyclotomic_ring (p ^ k) ℤ ℚ`.
-/

universes u

open algebra is_cyclotomic_extension polynomial number_field

open_locale cyclotomic number_field nat

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

include hp

namespace is_cyclotomic_extension.rat

/-- The discriminant of the power basis given by `ζ - 1`. -/
lemma discr_prime_pow_ne_two' [is_cyclotomic_extension {p ^ (k + 1)} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ (k + 1))) (hk : p ^ (k + 1) ≠ 2) :
  discr ℚ (hζ.sub_one_power_basis ℚ).basis =
  (-1) ^ (((p ^ (k + 1) : ℕ).totient) / 2) * p ^ ((p : ℕ) ^ k * ((p - 1) * (k + 1) - 1)) :=
begin
  rw [← discr_prime_pow_ne_two hζ (cyclotomic.irreducible_rat (p ^ (k + 1)).pos) hk],
  exact hζ.discr_zeta_eq_discr_zeta_sub_one.symm
end

lemma discr_odd_prime' [is_cyclotomic_extension {p} ℚ K] (hζ : is_primitive_root ζ p)
  (hodd : p ≠ 2) :
  discr ℚ (hζ.sub_one_power_basis ℚ).basis = (-1) ^ (((p : ℕ) - 1) / 2) * p ^ ((p : ℕ) - 2) :=
begin
  rw [← discr_odd_prime hζ (cyclotomic.irreducible_rat hp.out.pos) hodd],
  exact hζ.discr_zeta_eq_discr_zeta_sub_one.symm
end

/-- The discriminant of the power basis given by `ζ - 1`. Beware that in the cases `p ^ k = 1` and
`p ^ k = 2` the formula uses `1 / 2 = 0` and `0 - 1 = 0`. It is useful only to have a uniform
result. See also `is_cyclotomic_extension.rat.discr_prime_pow_eq_unit_mul_pow'`. -/
lemma discr_prime_pow' [is_cyclotomic_extension {p ^ k} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ k)) :
  discr ℚ (hζ.sub_one_power_basis ℚ).basis =
  (-1) ^ (((p ^ k : ℕ).totient) / 2) * p ^ ((p : ℕ) ^ (k - 1) * ((p - 1) * k - 1)) :=
begin
  rw [← discr_prime_pow hζ (cyclotomic.irreducible_rat (p ^ k).pos)],
  exact hζ.discr_zeta_eq_discr_zeta_sub_one.symm
end

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ k} K L`, then there are `u : ℤˣ` and
`n : ℕ` such that the discriminant of the power basis given by `ζ - 1` is `u * p ^ n`. Often this is
enough and less cumbersome to use than `is_cyclotomic_extension.rat.discr_prime_pow'`. -/
lemma discr_prime_pow_eq_unit_mul_pow' [is_cyclotomic_extension {p ^ k} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ k)) :
  ∃ (u : ℤˣ) (n : ℕ), discr ℚ (hζ.sub_one_power_basis ℚ).basis = u * p ^ n :=
begin
  rw [hζ.discr_zeta_eq_discr_zeta_sub_one.symm],
  exact discr_prime_pow_eq_unit_mul_pow hζ (cyclotomic.irreducible_rat (p ^ k).pos)
end

/-- If `K` is a `p ^ k`-th cyclotomic extension of `ℚ`, then `(adjoin ℤ {ζ})` is the
integral closure of `ℤ` in `K`. -/
lemma is_integral_closure_adjoin_singleton_of_prime_pow
  [hcycl : is_cyclotomic_extension {p ^ k} ℚ K] (hζ : is_primitive_root ζ ↑(p ^ k)) :
  is_integral_closure (adjoin ℤ ({ζ} : set K)) ℤ K :=
begin
  refine ⟨subtype.val_injective, λ x, ⟨λ h, ⟨⟨x, _⟩, rfl⟩, _⟩⟩,
  swap,
  { rintro ⟨y, rfl⟩,
    exact is_integral.algebra_map (le_integral_closure_iff_is_integral.1
      (adjoin_le_integral_closure (hζ.is_integral (p ^ k).pos)) _) },
  let B := hζ.sub_one_power_basis ℚ,
  have hint : is_integral ℤ B.gen :=  is_integral_sub (hζ.is_integral (p ^ k).pos)
    is_integral_one,
  have H := discr_mul_is_integral_mem_adjoin ℚ hint h,
  obtain ⟨u, n, hun⟩ := discr_prime_pow_eq_unit_mul_pow' hζ,
  rw [hun] at H,
  replace H := subalgebra.smul_mem _ H u.inv,
  rw [← smul_assoc, ← smul_mul_assoc, units.inv_eq_coe_inv, coe_coe, zsmul_eq_mul,
    ← int.cast_mul, units.inv_mul, int.cast_one, one_mul,
    show (p : ℚ) ^ n • x = ((p : ℕ) : ℤ) ^ n • x, by simp [smul_def]] at H,
  unfreezingI { cases k },
  { haveI : is_cyclotomic_extension {1} ℚ K := by simpa using hcycl,
    have : x ∈ (⊥ : subalgebra ℚ K),
    { rw [singleton_one ℚ K],
      exact mem_top },
    obtain ⟨y, rfl⟩ := mem_bot.1 this,
    replace h := (is_integral_algebra_map_iff (algebra_map ℚ K).injective).1 h,
    obtain ⟨z, hz⟩ := is_integrally_closed.is_integral_iff.1 h,
    rw [← hz, ← is_scalar_tower.algebra_map_apply],
    exact subalgebra.algebra_map_mem  _ _ },
  { have hmin : (minpoly ℤ B.gen).is_eisenstein_at (submodule.span ℤ {((p : ℕ) : ℤ)}),
    { have h₁ := minpoly.is_integrally_closed_eq_field_fractions' ℚ hint,
      have h₂ := hζ.minpoly_sub_one_eq_cyclotomic_comp
        (cyclotomic.irreducible_rat (p ^ _).pos),
      rw [is_primitive_root.sub_one_power_basis_gen] at h₁,
      rw [h₁, ← map_cyclotomic_int, show int.cast_ring_hom ℚ = algebra_map ℤ ℚ, by refl,
        show ((X + 1)) = map (algebra_map ℤ ℚ) (X + 1), by simp, ← map_comp] at h₂,
      haveI : char_zero ℚ := strict_ordered_semiring.to_char_zero,
      rw [is_primitive_root.sub_one_power_basis_gen, map_injective (algebra_map ℤ ℚ)
        ((algebra_map ℤ ℚ).injective_int) h₂],
      exact cyclotomic_prime_pow_comp_X_add_one_is_eisenstein_at _ _ },
    refine adjoin_le _ (mem_adjoin_of_smul_prime_pow_smul_of_minpoly_is_eiseinstein_at
      (nat.prime_iff_prime_int.1 hp.out) hint h H hmin),
    simp only [set.singleton_subset_iff, set_like.mem_coe],
    exact subalgebra.sub_mem _ (self_mem_adjoin_singleton ℤ _) (subalgebra.one_mem _) }
end

lemma is_integral_closure_adjoin_singleton_of_prime [hcycl : is_cyclotomic_extension {p} ℚ K]
  (hζ : is_primitive_root ζ ↑p) :
  is_integral_closure (adjoin ℤ ({ζ} : set K)) ℤ K :=
begin
  rw [← pow_one p] at hζ hcycl,
  exactI is_integral_closure_adjoin_singleton_of_prime_pow hζ,
end

local attribute [-instance] cyclotomic_field.algebra

/-- The integral closure of `ℤ` inside `cyclotomic_field (p ^ k) ℚ` is
`cyclotomic_ring (p ^ k) ℤ ℚ`. -/
lemma cyclotomic_ring_is_integral_closure_of_prime_pow :
  is_integral_closure (cyclotomic_ring (p ^ k) ℤ ℚ) ℤ (cyclotomic_field (p ^ k) ℚ) :=
begin
  haveI : char_zero ℚ := strict_ordered_semiring.to_char_zero,
  haveI : is_cyclotomic_extension {p ^ k} ℚ (cyclotomic_field (p ^ k) ℚ),
  { convert cyclotomic_field.is_cyclotomic_extension (p ^ k) _,
    { exact subsingleton.elim _ _ },
    { exact ne_zero.char_zero } },
  have hζ := zeta_spec (p ^ k) ℚ (cyclotomic_field (p ^ k) ℚ),
  refine ⟨is_fraction_ring.injective _ _, λ x, ⟨λ h, ⟨⟨x, _⟩, rfl⟩, _⟩⟩,
  { have := (is_integral_closure_adjoin_singleton_of_prime_pow hζ).is_integral_iff,
    obtain ⟨y, rfl⟩ := this.1 h,
    convert adjoin_mono _ y.2,
    { simp only [eq_iff_true_of_subsingleton] },
    { simp only [eq_iff_true_of_subsingleton] },
    { simp only [pnat.pow_coe, set.singleton_subset_iff, set.mem_set_of_eq],
      exact hζ.pow_eq_one } },
  { haveI : is_cyclotomic_extension {p ^ k} ℤ (cyclotomic_ring (p ^ k) ℤ ℚ),
    { convert cyclotomic_ring.is_cyclotomic_extension _ ℤ ℚ,
      { exact subsingleton.elim _ _ },
      { exact ne_zero.char_zero } },
    rintro ⟨y, rfl⟩,
    exact is_integral.algebra_map ((is_cyclotomic_extension.integral {p ^ k} ℤ _) _) }
end

lemma cyclotomic_ring_is_integral_closure_of_prime :
  is_integral_closure (cyclotomic_ring p ℤ ℚ) ℤ (cyclotomic_field p ℚ) :=
begin
  rw [← pow_one p],
  exact cyclotomic_ring_is_integral_closure_of_prime_pow
end

end is_cyclotomic_extension.rat

section power_basis

open is_cyclotomic_extension.rat

namespace is_primitive_root

/-- The algebra isomorphism `adjoin ℤ {ζ} ≃ₐ[ℤ] (𝓞 K)`, where `ζ` is a primitive `p ^ k`-th root of
unity and `K` is a `p ^ k`-th cyclotomic extension of `ℚ`. -/
@[simps] noncomputable def _root_.is_primitive_root.adjoin_equiv_ring_of_integers
  [hcycl : is_cyclotomic_extension {p ^ k} ℚ K] (hζ : is_primitive_root ζ ↑(p ^ k)) :
  adjoin ℤ ({ζ} : set K) ≃ₐ[ℤ] (𝓞 K) :=
let _ := is_integral_closure_adjoin_singleton_of_prime_pow hζ in
  by exactI (is_integral_closure.equiv ℤ (adjoin ℤ ({ζ} : set K)) K (𝓞 K))

/-- The ring of integers of a `p ^ k`-th cyclotomic extension of `ℚ` is a cyclotomic extension. -/
instance _root_.is_cyclotomic_extension.ring_of_integers
  [is_cyclotomic_extension {p ^ k} ℚ K] : is_cyclotomic_extension {p ^ k} ℤ (𝓞 K) :=
let _ := (zeta_spec (p ^ k) ℚ K).adjoin_is_cyclotomic_extension ℤ in by exactI
  is_cyclotomic_extension.equiv _ ℤ _ ((zeta_spec (p ^ k) ℚ K).adjoin_equiv_ring_of_integers)

/-- The integral `power_basis` of `𝓞 K` given by a primitive root of unity, where `K` is a `p ^ k`
cyclotomic extension of `ℚ`. -/
noncomputable def integral_power_basis [hcycl : is_cyclotomic_extension {p ^ k} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ k)) : power_basis ℤ (𝓞 K) :=
(adjoin.power_basis' (hζ.is_integral (p ^ k).pos)).map hζ.adjoin_equiv_ring_of_integers

@[simp] lemma integral_power_basis_gen [hcycl : is_cyclotomic_extension {p ^ k} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ k)) :
  hζ.integral_power_basis.gen = ⟨ζ, hζ.is_integral (p ^ k).pos⟩ :=
subtype.ext $ show algebra_map _ K hζ.integral_power_basis.gen = _, by simpa [integral_power_basis]

@[simp] lemma integral_power_basis_dim [hcycl : is_cyclotomic_extension {p ^ k} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ k)) : hζ.integral_power_basis.dim = φ (p ^ k) :=
by simp [integral_power_basis, ←cyclotomic_eq_minpoly hζ, nat_degree_cyclotomic]

/-- The algebra isomorphism `adjoin ℤ {ζ} ≃ₐ[ℤ] (𝓞 K)`, where `ζ` is a primitive `p`-th root of
unity and `K` is a `p`-th cyclotomic extension of `ℚ`. -/
@[simps] noncomputable def _root_.is_primitive_root.adjoin_equiv_ring_of_integers'
  [hcycl : is_cyclotomic_extension {p} ℚ K] (hζ : is_primitive_root ζ p) :
  adjoin ℤ ({ζ} : set K) ≃ₐ[ℤ] (𝓞 K) :=
@adjoin_equiv_ring_of_integers p 1 K _ _ _ _ (by { convert hcycl, rw pow_one }) (by rwa pow_one)

/-- The ring of integers of a `p`-th cyclotomic extension of `ℚ` is a cyclotomic extension. -/
instance _root_.is_cyclotomic_extension.ring_of_integers'
  [is_cyclotomic_extension {p} ℚ K] : is_cyclotomic_extension {p} ℤ (𝓞 K) :=
let _ := (zeta_spec p ℚ K).adjoin_is_cyclotomic_extension ℤ in by exactI
  is_cyclotomic_extension.equiv _ ℤ _ ((zeta_spec p ℚ K).adjoin_equiv_ring_of_integers')

/-- The integral `power_basis` of `𝓞 K` given by a primitive root of unity, where `K` is a `p`-th
cyclotomic extension of `ℚ`. -/
noncomputable def integral_power_basis' [hcycl : is_cyclotomic_extension {p} ℚ K]
  (hζ : is_primitive_root ζ p) : power_basis ℤ (𝓞 K) :=
@integral_power_basis p 1 K _ _ _ _ (by { convert hcycl, rw pow_one }) (by rwa pow_one)

@[simp] lemma integral_power_basis'_gen [hcycl : is_cyclotomic_extension {p} ℚ K]
  (hζ : is_primitive_root ζ p) : hζ.integral_power_basis'.gen = ⟨ζ, hζ.is_integral p.pos⟩ :=
@integral_power_basis_gen p 1 K _ _ _ _ (by { convert hcycl, rw pow_one }) (by rwa pow_one)

@[simp] lemma power_basis_int'_dim [hcycl : is_cyclotomic_extension {p} ℚ K]
  (hζ : is_primitive_root ζ p) : hζ.integral_power_basis'.dim = φ p :=
by erw [@integral_power_basis_dim p 1 K _ _ _ _ (by { convert hcycl, rw pow_one })
  (by rwa pow_one), pow_one]

/-- The integral `power_basis` of `𝓞 K` given by `ζ - 1`, where `K` is a `p ^ k` cyclotomic
extension of `ℚ`. -/
noncomputable def sub_one_integral_power_basis [is_cyclotomic_extension {p ^ k} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ k)) : power_basis ℤ (𝓞 K) :=
power_basis.of_gen_mem_adjoin' hζ.integral_power_basis (is_integral_of_mem_ring_of_integers $
  subalgebra.sub_mem _ (hζ.is_integral (p ^ k).pos) (subalgebra.one_mem _))
begin
  simp only [integral_power_basis_gen],
  convert subalgebra.add_mem _
    (self_mem_adjoin_singleton ℤ (⟨ζ - 1, _⟩ : 𝓞 K))
    (subalgebra.one_mem _),
  simp
end

@[simp] lemma sub_one_integral_power_basis_gen [is_cyclotomic_extension {p ^ k} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ k)) :
  hζ.sub_one_integral_power_basis.gen =
  ⟨ζ - 1, subalgebra.sub_mem _ (hζ.is_integral (p ^ k).pos) (subalgebra.one_mem _)⟩ :=
by simp [sub_one_integral_power_basis]

/-- The integral `power_basis` of `𝓞 K` given by `ζ - 1`, where `K` is a `p`-th cyclotomic
extension of `ℚ`. -/
noncomputable def sub_one_integral_power_basis' [hcycl : is_cyclotomic_extension {p} ℚ K]
  (hζ : is_primitive_root ζ p) : power_basis ℤ (𝓞 K) :=
@sub_one_integral_power_basis p 1 K _ _ _ _ (by { convert hcycl, rw pow_one }) (by rwa pow_one)

@[simp] lemma sub_one_integral_power_basis'_gen [hcycl : is_cyclotomic_extension {p} ℚ K]
  (hζ : is_primitive_root ζ p) :
  hζ.sub_one_integral_power_basis'.gen =
  ⟨ζ - 1, subalgebra.sub_mem _ (hζ.is_integral p.pos) (subalgebra.one_mem _)⟩ :=
@sub_one_integral_power_basis_gen p 1 K _ _ _ _ (by { convert hcycl, rw pow_one }) (by rwa pow_one)

end is_primitive_root

end power_basis


theorem add_le_add_left {a b : mynat} (h : a ≤ b) (t : mynat) :
  t + a ≤ t + b :=
begin
cases h with c hc,
rw hc,
use c,
rw add_assoc,
refl,
end


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

! This file was ported from Lean 3 source module data.polynomial.expand
! leanprover-community/mathlib commit bbeb185db4ccee8ed07dc48449414ebfa39cb821
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.Polynomial.Basic
import Mathbin.RingTheory.Ideal.LocalRing
import Mathbin.Tactic.RingExp

/-!
# Expand a polynomial by a factor of p, so `∑ aₙ xⁿ` becomes `∑ aₙ xⁿᵖ`.

## Main definitions

* `polynomial.expand R p f`: expand the polynomial `f` with coefficients in a
  commutative semiring `R` by a factor of p, so `expand R p (∑ aₙ xⁿ)` is `∑ aₙ xⁿᵖ`.
* `polynomial.contract p f`: the opposite of `expand`, so it sends `∑ aₙ xⁿᵖ` to `∑ aₙ xⁿ`.

-/

universe u v w

open Classical BigOperators Polynomial

open Finset

namespace Polynomial

section CommSemiring

variable (R : Type u) [CommSemiring R] {S : Type v} [CommSemiring S] (p q : ℕ)

/-- Expand the polynomial by a factor of p, so `∑ aₙ xⁿ` becomes `∑ aₙ xⁿᵖ`. -/
noncomputable def expand : R[X] →ₐ[R] R[X] :=
  { (eval₂RingHom C (X ^ p) : R[X] →+* R[X]) with commutes' := fun r => eval₂_C _ _ }
#align polynomial.expand Polynomial.expand

theorem coe_expand : (expand R p : R[X] → R[X]) = eval₂ C (X ^ p) :=
  rfl
#align polynomial.coe_expand Polynomial.coe_expand

variable {R}

theorem expand_eq_sum {f : R[X]} : expand R p f = f.Sum fun e a => C a * (X ^ p) ^ e :=
  by
  dsimp [expand, eval₂]
  rfl
#align polynomial.expand_eq_sum Polynomial.expand_eq_sum

@[simp]
theorem expand_c (r : R) : expand R p (C r) = C r :=
  eval₂_C _ _
#align polynomial.expand_C Polynomial.expand_c

@[simp]
theorem expand_x : expand R p X = X ^ p :=
  eval₂_X _ _
#align polynomial.expand_X Polynomial.expand_x

@[simp]
theorem expand_monomial (r : R) : expand R p (monomial q r) = monomial (q * p) r := by
  simp_rw [← smul_X_eq_monomial, AlgHom.map_smul, AlgHom.map_pow, expand_X, mul_comm, pow_mul]
#align polynomial.expand_monomial Polynomial.expand_monomial

theorem expand_expand (f : R[X]) : expand R p (expand R q f) = expand R (p * q) f :=
  Polynomial.induction_on f (fun r => by simp_rw [expand_C])
    (fun f g ihf ihg => by simp_rw [AlgHom.map_add, ihf, ihg]) fun n r ih => by
    simp_rw [AlgHom.map_mul, expand_C, AlgHom.map_pow, expand_X, AlgHom.map_pow, expand_X, pow_mul]
#align polynomial.expand_expand Polynomial.expand_expand

theorem expand_mul (f : R[X]) : expand R (p * q) f = expand R p (expand R q f) :=
  (expand_expand p q f).symm
#align polynomial.expand_mul Polynomial.expand_mul

@[simp]
theorem expand_zero (f : R[X]) : expand R 0 f = C (eval 1 f) := by simp [expand]
#align polynomial.expand_zero Polynomial.expand_zero

@[simp]
theorem expand_one (f : R[X]) : expand R 1 f = f :=
  Polynomial.induction_on f (fun r => by rw [expand_C])
    (fun f g ihf ihg => by rw [AlgHom.map_add, ihf, ihg]) fun n r ih => by
    rw [AlgHom.map_mul, expand_C, AlgHom.map_pow, expand_X, pow_one]
#align polynomial.expand_one Polynomial.expand_one

theorem expand_pow (f : R[X]) : expand R (p ^ q) f = (expand R p^[q]) f :=
  Nat.recOn q (by rw [pow_zero, expand_one, Function.iterate_zero, id]) fun n ih => by
    rw [Function.iterate_succ_apply', pow_succ, expand_mul, ih]
#align polynomial.expand_pow Polynomial.expand_pow

theorem derivative_expand (f : R[X]) :
    (expand R p f).derivative = expand R p f.derivative * (p * X ^ (p - 1)) := by
  rw [coe_expand, derivative_eval₂_C, derivative_pow, C_eq_nat_cast, derivative_X, mul_one]
#align polynomial.derivative_expand Polynomial.derivative_expand

theorem coeff_expand {p : ℕ} (hp : 0 < p) (f : R[X]) (n : ℕ) :
    (expand R p f).coeff n = if p ∣ n then f.coeff (n / p) else 0 :=
  by
  simp only [expand_eq_sum]
  simp_rw [coeff_sum, ← pow_mul, C_mul_X_pow_eq_monomial, coeff_monomial, Sum]
  split_ifs with h
  · rw [Finset.sum_eq_single (n / p), Nat.mul_div_cancel' h, if_pos rfl]
    · intro b hb1 hb2
      rw [if_neg]
      intro hb3
      apply hb2
      rw [← hb3, Nat.mul_div_cancel_left b hp]
    · intro hn
      rw [not_mem_support_iff.1 hn]
      split_ifs <;> rfl
  · rw [Finset.sum_eq_zero]
    intro k hk
    rw [if_neg]
    exact fun hkn => h ⟨k, hkn.symm⟩
#align polynomial.coeff_expand Polynomial.coeff_expand

@[simp]
theorem coeff_expand_mul {p : ℕ} (hp : 0 < p) (f : R[X]) (n : ℕ) :
    (expand R p f).coeff (n * p) = f.coeff n := by
  rw [coeff_expand hp, if_pos (dvd_mul_left _ _), Nat.mul_div_cancel _ hp]
#align polynomial.coeff_expand_mul Polynomial.coeff_expand_mul

@[simp]
theorem coeff_expand_mul' {p : ℕ} (hp : 0 < p) (f : R[X]) (n : ℕ) :
    (expand R p f).coeff (p * n) = f.coeff n := by rw [mul_comm, coeff_expand_mul hp]
#align polynomial.coeff_expand_mul' Polynomial.coeff_expand_mul'

/-- Expansion is injective. -/
theorem expand_injective {n : ℕ} (hn : 0 < n) : Function.Injective (expand R n) := fun g g' H =>
  ext fun k => by rw [← coeff_expand_mul hn, H, coeff_expand_mul hn]
#align polynomial.expand_injective Polynomial.expand_injective

theorem expand_inj {p : ℕ} (hp : 0 < p) {f g : R[X]} : expand R p f = expand R p g ↔ f = g :=
  (expand_injective hp).eq_iff
#align polynomial.expand_inj Polynomial.expand_inj

theorem expand_eq_zero {p : ℕ} (hp : 0 < p) {f : R[X]} : expand R p f = 0 ↔ f = 0 :=
  (expand_injective hp).eq_iff' (map_zero _)
#align polynomial.expand_eq_zero Polynomial.expand_eq_zero

theorem expand_ne_zero {p : ℕ} (hp : 0 < p) {f : R[X]} : expand R p f ≠ 0 ↔ f ≠ 0 :=
  (expand_eq_zero hp).Not
#align polynomial.expand_ne_zero Polynomial.expand_ne_zero

theorem expand_eq_c {p : ℕ} (hp : 0 < p) {f : R[X]} {r : R} : expand R p f = C r ↔ f = C r := by
  rw [← expand_C, expand_inj hp, expand_C]
#align polynomial.expand_eq_C Polynomial.expand_eq_c

theorem natDegree_expand (p : ℕ) (f : R[X]) : (expand R p f).natDegree = f.natDegree * p :=
  by
  cases' p.eq_zero_or_pos with hp hp
  · rw [hp, coe_expand, pow_zero, MulZeroClass.mul_zero, ← C_1, eval₂_hom, nat_degree_C]
  by_cases hf : f = 0
  · rw [hf, AlgHom.map_zero, nat_degree_zero, MulZeroClass.zero_mul]
  have hf1 : expand R p f ≠ 0 := mt (expand_eq_zero hp).1 hf
  rw [← WithBot.coe_eq_coe, ← degree_eq_nat_degree hf1]
  refine' le_antisymm ((degree_le_iff_coeff_zero _ _).2 fun n hn => _) _
  · rw [coeff_expand hp]
    split_ifs with hpn
    · rw [coeff_eq_zero_of_nat_degree_lt]
      contrapose! hn
      rw [WithBot.coe_le_coe, ← Nat.div_mul_cancel hpn]
      exact Nat.mul_le_mul_right p hn
    · rfl
  · refine' le_degree_of_ne_zero _
    rw [coeff_expand_mul hp, ← leading_coeff]
    exact mt leading_coeff_eq_zero.1 hf
#align polynomial.nat_degree_expand Polynomial.natDegree_expand

theorem Monic.expand {p : ℕ} {f : R[X]} (hp : 0 < p) (h : f.Monic) : (expand R p f).Monic :=
  by
  rw [monic.def, leading_coeff, nat_degree_expand, coeff_expand hp]
  simp [hp, h]
#align polynomial.monic.expand Polynomial.Monic.expand

theorem map_expand {p : ℕ} {f : R →+* S} {q : R[X]} : map f (expand R p q) = expand S p (map f q) :=
  by
  by_cases hp : p = 0
  · simp [hp]
  ext
  rw [coeff_map, coeff_expand (Nat.pos_of_ne_zero hp), coeff_expand (Nat.pos_of_ne_zero hp)]
  split_ifs <;> simp
#align polynomial.map_expand Polynomial.map_expand

@[simp]
theorem expand_eval (p : ℕ) (P : R[X]) (r : R) : eval r (expand R p P) = eval (r ^ p) P :=
  by
  refine' Polynomial.induction_on P (fun a => by simp) (fun f g hf hg => _) fun n a h => by simp
  rw [AlgHom.map_add, eval_add, eval_add, hf, hg]
#align polynomial.expand_eval Polynomial.expand_eval

@[simp]
theorem expand_aeval {A : Type _} [Semiring A] [Algebra R A] (p : ℕ) (P : R[X]) (r : A) :
    aeval r (expand R p P) = aeval (r ^ p) P :=
  by
  refine' Polynomial.induction_on P (fun a => by simp) (fun f g hf hg => _) fun n a h => by simp
  rw [AlgHom.map_add, aeval_add, aeval_add, hf, hg]
#align polynomial.expand_aeval Polynomial.expand_aeval

/-- The opposite of `expand`: sends `∑ aₙ xⁿᵖ` to `∑ aₙ xⁿ`. -/
noncomputable def contract (p : ℕ) (f : R[X]) : R[X] :=
  ∑ n in range (f.natDegree + 1), monomial n (f.coeff (n * p))
#align polynomial.contract Polynomial.contract

theorem coeff_contract {p : ℕ} (hp : p ≠ 0) (f : R[X]) (n : ℕ) :
    (contract p f).coeff n = f.coeff (n * p) :=
  by
  simp only [contract, coeff_monomial, sum_ite_eq', finset_sum_coeff, mem_range, not_lt,
    ite_eq_left_iff]
  intro hn
  apply (coeff_eq_zero_of_nat_degree_lt _).symm
  calc
    f.nat_degree < f.nat_degree + 1 := Nat.lt_succ_self _
    _ ≤ n * 1 := by simpa only [mul_one] using hn
    _ ≤ n * p := mul_le_mul_of_nonneg_left (show 1 ≤ p from hp.bot_lt) (zero_le n)

#align polynomial.coeff_contract Polynomial.coeff_contract

theorem contract_expand {f : R[X]} (hp : p ≠ 0) : contract p (expand R p f) = f :=
  by
  ext
  simp [coeff_contract hp, coeff_expand hp.bot_lt, Nat.mul_div_cancel _ hp.bot_lt]
#align polynomial.contract_expand Polynomial.contract_expand

section CharP

variable [CharP R p]

theorem expand_contract [NoZeroDivisors R] {f : R[X]} (hf : f.derivative = 0) (hp : p ≠ 0) :
    expand R p (contract p f) = f := by
  ext n
  rw [coeff_expand hp.bot_lt, coeff_contract hp]
  split_ifs with h
  · rw [Nat.div_mul_cancel h]
  · cases n
    · exact absurd (dvd_zero p) h
    have := coeff_derivative f n
    rw [hf, coeff_zero, zero_eq_mul] at this
    cases this
    · rw [this]
    rw [← Nat.cast_succ, CharP.cast_eq_zero_iff R p] at this
    exact absurd this h
#align polynomial.expand_contract Polynomial.expand_contract

variable [hp : Fact p.Prime]

include hp

theorem expand_char (f : R[X]) : map (frobenius R p) (expand R p f) = f ^ p :=
  by
  refine' f.induction_on' (fun a b ha hb => _) fun n a => _
  · rw [AlgHom.map_add, Polynomial.map_add, ha, hb, add_pow_char]
  · rw [expand_monomial, map_monomial, ← C_mul_X_pow_eq_monomial, ← C_mul_X_pow_eq_monomial,
      mul_pow, ← C.map_pow, frobenius_def]
    ring
#align polynomial.expand_char Polynomial.expand_char

theorem map_expand_pow_char (f : R[X]) (n : ℕ) :
    map (frobenius R p ^ n) (expand R (p ^ n) f) = f ^ p ^ n :=
  by
  induction n
  · simp [RingHom.one_def]
  symm
  rw [pow_succ', pow_mul, ← n_ih, ← expand_char, pow_succ, RingHom.mul_def, ← map_map, mul_comm,
    expand_mul, ← map_expand]
#align polynomial.map_expand_pow_char Polynomial.map_expand_pow_char

end CharP

end CommSemiring

section IsDomain

variable (R : Type u) [CommRing R] [IsDomain R]

theorem isLocalRingHom_expand {p : ℕ} (hp : 0 < p) :
    IsLocalRingHom (↑(expand R p) : R[X] →+* R[X]) :=
  by
  refine' ⟨fun f hf1 => _⟩; rw [← coeFn_coeBase] at hf1
  have hf2 := eq_C_of_degree_eq_zero (degree_eq_zero_of_is_unit hf1)
  rw [coeff_expand hp, if_pos (dvd_zero _), p.zero_div] at hf2
  rw [hf2, is_unit_C] at hf1; rw [expand_eq_C hp] at hf2; rwa [hf2, is_unit_C]
#align polynomial.is_local_ring_hom_expand Polynomial.isLocalRingHom_expand

variable {R}

theorem of_irreducible_expand {p : ℕ} (hp : p ≠ 0) {f : R[X]} (hf : Irreducible (expand R p f)) :
    Irreducible f :=
  let _ := isLocalRingHom_expand R hp.bot_lt
  of_irreducible_map (↑(expand R p)) hf
#align polynomial.of_irreducible_expand Polynomial.of_irreducible_expand

theorem of_irreducible_expand_pow {p : ℕ} (hp : p ≠ 0) {f : R[X]} {n : ℕ} :
    Irreducible (expand R (p ^ n) f) → Irreducible f :=
  Nat.recOn n (fun hf => by rwa [pow_zero, expand_one] at hf) fun n ih hf =>
    ih <|
      of_irreducible_expand hp <| by
        rw [pow_succ] at hf
        rwa [expand_expand]
#align polynomial.of_irreducible_expand_pow Polynomial.of_irreducible_expand_pow

end IsDomain

end Polynomial