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

import padic_int.properties
import topology.discrete_quotient

/-!
# Properties of clopen sets of p-adic integers

This file describes some properties of the clopen sets of `ℤ_[p]`. In particular,
we show that clopen sets of the form `a + p^n ℤ_[p]` form a topological basis for `ℤ_[p]`.

## TODO
* Move first few lemmas to right place

## Tags
p-adic, clopen
-/

section char_fn -- move elsewhere
variables {X : Type*} [topological_space X] (R : Type*) [mul_zero_one_class R]

/-- Characteristic functions are locally constant functions taking `x : X` to `1` if `x ∈ U`,
  where `U` is a clopen set, and `0` otherwise. -/
noncomputable def char_fn {U : set X} (hU : is_clopen U) : locally_constant X R :=
{ to_fun := λ x, by classical; exact if (x ∈ U) then 1 else 0,
  is_locally_constant :=
    begin
      rw is_locally_constant.iff_exists_open, rintros x,
      by_cases x ∈ U,
      { refine ⟨U, hU.1, h, _⟩, rintros y hy, simp [h, hy], },
      { rw ←set.mem_compl_iff at h, refine ⟨Uᶜ, (is_clopen.compl hU).1, h, _⟩,
        rintros y hy, rw set.mem_compl_iff at h, rw set.mem_compl_iff at hy,
        simp [h, hy], },
    end, }

lemma char_fn_one [nontrivial R] (x : X) {U : set X} (hU : is_clopen U) :
  x ∈ U ↔ char_fn R hU x = (1 : R) :=
begin
  rw char_fn, simp only [locally_constant.coe_mk, ite_eq_left_iff],
  split, any_goals { intro h, },
  { intro h',
    exfalso, apply h', exact h, },
  { by_contra h', apply @one_ne_zero _ _ _,
    swap, exact R,
    any_goals { apply_instance, },
    { symmetry, apply h, apply h', }, },
end

lemma char_fn_zero [nontrivial R] (x : X) {U : set X} (hU : is_clopen U) :
  x ∈ U → false ↔ char_fn R hU x = (0 : R) :=
begin
  rw char_fn,
  simp only [ite_eq_right_iff, one_ne_zero, locally_constant.coe_mk],
end

lemma char_fn_inj [nontrivial R] {U V : set X} (hU : is_clopen U) (hV : is_clopen V)
  (h : char_fn R hU = char_fn R hV) : U = V :=
begin
  ext,
  rw locally_constant.ext_iff at h, specialize h x,
  split,
  { intros h', apply (char_fn_one R _ _).2,
    { rw (char_fn_one R _ _).1 h' at h, rw h.symm, }, },
  { intros h', apply (char_fn_one R _ _).2,
    { rw (char_fn_one R _ _).1 h' at h, rw h, }, },
end

end char_fn

/-- The product of clopen sets is clopen. -/
lemma is_clopen_prod {α β : Type*} [topological_space α] [topological_space β] {s : set α}
  {t : set β} (hs : is_clopen s) (ht : is_clopen t) : is_clopen (s ×ˢ t) :=
  ⟨is_open_prod_iff'.2 (or.inl ⟨(hs).1, (ht).1⟩), is_closed.prod (hs).2 (ht).2⟩

/-- Any singleton in a discrete space is clopen. -/
lemma is_clopen_singleton {α : Type*} [topological_space α] [discrete_topology α] (b : α) :
  is_clopen ({b} : set α) := ⟨is_open_discrete _, is_closed_discrete _⟩

variables (p : ℕ) [fact p.prime] {d : ℕ}

open padic_int

/-- Gives the clopen sets that act as a topological basis for `ℤ_[p]`. -/
abbreviation clopen_basis : set (set ℤ_[p]) := {x : set ℤ_[p] | ∃ (n : ℕ) (a : zmod (p^n)),
  x = set.preimage (padic_int.to_zmod_pow n) {a} }

variable {p}
/-- The clopen sets that form a topological basis for `zmod d × ℤ_[p]`. It is better than
  `clopen_basis` because one need not use `classical.choice`. -/
abbreviation clopen_from {n : ℕ} (a : zmod (d * (p^n))) : set (zmod d × ℤ_[p]) :=
  ({a} : set (zmod d)) ×ˢ ((@padic_int.to_zmod_pow p _ n)⁻¹' {(a : zmod (p^n))})

local attribute [instance] zmod.topological_space

namespace clopen_from

lemma is_clopen {n : ℕ} (a : zmod (d * (p^n))) : is_clopen (clopen_from a) :=
  is_clopen_prod (is_clopen_singleton (a : zmod d)) (proj_lim_preimage_clopen d a)

lemma mem_clopen_from {n : ℕ} (a : zmod (d * p^n)) (y : zmod d × ℤ_[p]) :
  y ∈ (clopen_from a) ↔ y.fst = (a : zmod d) ∧
    (a : zmod (p^n)) = (to_zmod_pow n) y.snd :=
and.congr_right_iff.2 (λ hy, begin
  simp only [set.mem_preimage, set.mem_singleton_iff, set.mem_prod],
  rw eq_comm, end)

lemma self_mem_clopen_from {n : ℕ} (a : zmod (d * p^n)) : (a : zmod d × ℤ_[p]) ∈ clopen_from a :=
(mem_clopen_from _ _).2 ⟨prod.fst_zmod_cast _, begin
  rw [prod.snd_zmod_cast, ←zmod.int_cast_cast a],
  conv_rhs { rw ←zmod.int_cast_cast a, },
  change (int.cast_ring_hom (zmod (p^n))) (a : ℤ) =
    (ring_hom.comp (to_zmod_pow n) (int.cast_ring_hom (ℤ_[p]))) (a : ℤ),
  apply _root_.congr_fun _, congr,
  convert @ring_hom.ext_zmod 0 _ _ _ _, end⟩

end clopen_from

variables (p) (d)
/-- The version of `clopen_basis` that also incorporates `d` coprime to `p`. -/
@[reducible] abbreviation clopen_basis' :=
{ x : set ((zmod d) × ℤ_[p]) | ∃ (n : ℕ) (a : zmod (d * (p^n))), x = clopen_from a }

variables {p} {d}
lemma mem_clopen_basis {n : ℕ} (a : zmod (p^n)) :
  (padic_int.to_zmod_pow n)⁻¹' {a} ∈ (clopen_basis p) := ⟨n, a, rfl⟩

lemma clopen_basis_is_topological_basis : topological_space.is_topological_basis (clopen_basis p) :=
topological_space.is_topological_basis_of_open_of_nhds (λ u ⟨n, a, hu⟩,
  hu.symm ▸ (proj_lim_preimage_clopen_one n a).1)
  (λ a u mema hu, begin
    obtain ⟨ε, hε, h⟩ := (metric.is_open_iff.1 hu) a mema,
    obtain ⟨m, fm⟩ := exists_one_div_pow_lt_of_prime p (half_pos hε),
    set b := ((to_zmod_pow m.succ a) : ℤ_[p]) with hb,
    have arith : -(m : ℤ) = 1 - (m.succ : ℤ),
    { rw [int.coe_nat_succ, sub_add_eq_sub_sub_swap, sub_self, zero_sub], },
    refine ⟨metric.ball b (p^(-(m : ℤ))), _, _, λ c hc, h _⟩,
    { rw [arith, ←preimage_to_zmod_pow_eq_ball (to_zmod_pow m.succ a)],
      refine mem_clopen_basis ((to_zmod_pow m.succ) a), },
    { rw [metric.mem_ball, dist_eq_norm, hb, cast_to_zmod_pow_eq_appr a m.succ],
      refine gt_of_gt_of_ge _ ((norm_le_pow_iff_mem_span_pow _ m.succ).2 (appr_spec m.succ a)),
      rw [zpow_neg, ←one_div, zpow_neg, ←one_div],
      apply one_div_lt_one_div_of_lt,
      { norm_num, refine pow_pos _ m, norm_num, apply nat.prime.pos (fact.out _), apply_instance, },
      { rw zpow_lt_iff_lt _,
        { norm_num, },
        { norm_cast, apply nat.prime.one_lt, apply fact.out, }, }, },
    { simp only [metric.mem_ball, zpow_neg, zpow_coe_nat] at hc,
      simp only [metric.mem_ball],
      suffices f1 : dist c a < 2 / (p^m),
      { refine lt_trans f1 ((lt_div_iff' _).mp ((one_div ((p : ℝ)^m)) ▸ fm)), exact zero_lt_two, },
      have := dist_triangle c a b,
      refine gt_of_gt_of_ge _ (dist_triangle c b a),
      have ha : dist a b ≤ (↑p ^ m)⁻¹,
      { rw [hb, cast_to_zmod_pow_eq_appr a m.succ],
        have : (↑p ^ m)⁻¹ = (p : ℝ)^(-m : ℤ),
        { have f : (p : ℝ) ≠ 0,
          { norm_cast, apply nat.prime.ne_zero, apply fact.out, },
          rw [←one_div _, div_eq_iff _],
          { rw [←zpow_coe_nat (p : ℝ) m, ←zpow_add₀],
            { rw [neg_add_self, zpow_zero _], },
            apply f, },
          { apply pow_ne_zero _, apply f, apply_instance, }, },
        rw this, refine le_trans (dist_appr_spec a m.succ) _,
        { rw zpow_le_iff_le _,
          { apply neg_le_neg, norm_num, },
          { norm_cast, apply nat.prime.one_lt, apply fact.out, }, }, },
      rw dist_comm b a,
      convert add_lt_add_of_lt_of_le hc ha,
      rw [←one_div, div_add_div_same, one_add_one_eq_two], }, end)

theorem clopen_basis_clopen : topological_space.is_topological_basis (clopen_basis p) ∧
  ∀ x ∈ (clopen_basis p), is_clopen x :=
⟨clopen_basis_is_topological_basis, λ x ⟨n, a, hx⟩, hx.symm ▸ (proj_lim_preimage_clopen_one n a)⟩

lemma helper_1 (x : zmod d × ℤ_[p]) (n : ℕ) :
  is_clopen {b : zmod d × ℤ_[p] | (to_zmod_pow n) x.snd = (to_zmod_pow n) b.snd ∧ x.fst = b.fst} :=
begin
  set f : zmod d × ℤ_[p] → zmod d × zmod (p^n) := prod.map id (to_zmod_pow n) with hf,
  convert_to is_clopen (set.preimage f {f x}),
  { ext y,
    rw hf,
    simp only [set.mem_set_of_eq, prod_map, id.def, set.mem_preimage, set.mem_singleton_iff,
      prod.mk.inj_iff],
    rw [and_comm, eq_comm, @eq_comm _ ((to_zmod_pow n) x.snd) _], },
  have cont_f : continuous f := continuous.prod_map (continuous_id) (continuous_to_zmod_pow n),
  refine ⟨continuous_def.mp cont_f {f x} (is_open_discrete {f x}),
    continuous_iff_is_closed.mp cont_f {f x} (is_closed_discrete {f x})⟩,
end

variables (p d)

/-- A discrete quotient induced by `to_zmod_pow`. -/
def discrete_quotient_of_to_zmod_pow : ℕ → discrete_quotient (zmod d × ℤ_[p]) :=
λ n, ⟨λ a b, to_zmod_pow n a.2 = to_zmod_pow n b.2 ∧ a.1 = b.1, ⟨by tauto, by tauto,
  λ a b c hab hbc, ⟨eq.trans hab.1 hbc.1, eq.trans hab.2 hbc.2⟩⟩, λ x, helper_1 x n⟩

variables {p d}

namespace discrete_quotient_of_to_zmod_pow

lemma rel (x y : zmod d × ℤ_[p]) (n : ℕ) :
  (discrete_quotient_of_to_zmod_pow p d n).rel x y ↔
  (to_zmod_pow n) x.snd = (to_zmod_pow n) y.snd ∧ x.fst = y.fst :=
by { rw discrete_quotient_of_to_zmod_pow, }

end discrete_quotient_of_to_zmod_pow

open discrete_quotient_of_to_zmod_pow

/-- Given a natural `n`, takes an element of `zmod d × ℤ_[p]` to `zmod (d * p^n)` using CRT. -/
noncomputable abbreviation prod_padic_to_zmod (n : ℕ) (x : zmod d × ℤ_[p]) (hd : d.coprime p) :
  zmod (d * p^n) :=
(zmod.chinese_remainder (nat.coprime.pow_right _ (nat.coprime_iff_gcd_eq_one.1 hd))).symm
  (x.1, (to_zmod_pow n)x.2)

lemma prod_padic_to_zmod_def (n : ℕ) (x : zmod d × ℤ_[p]) (hd : d.coprime p) :
  prod_padic_to_zmod n x hd = (zmod.chinese_remainder (nat.coprime.pow_right _
  (nat.coprime_iff_gcd_eq_one.1 hd))).symm (x.1, (to_zmod_pow n)x.2) := rfl

/-- Given an open set `U` of `zmod d × ℤ_[p]`, this is the set of all `n` such that
  all clopen sets of level `n` are contained in `U`. -/
def bound_set (U : set (zmod d × ℤ_[p])) (hd : d.coprime p) :=
{n : ℕ | ∀ (a : zmod d × ℤ_[p]) (H : a ∈ U), (clopen_from (prod_padic_to_zmod n a hd)) ⊆ U }

/-- Given a set `U`, it is the infimum of the `bound_set`. It is the least `n` for which all
  clopen basis elements of level `n` and above are contained in `U`. -/
noncomputable def bound (U : set (zmod d × ℤ_[p])) (hd : d.coprime p) : ℕ := Inf (bound_set U hd)

open nat clopen_from

namespace clopen_from

lemma mem_clopen_from' (n : ℕ) (x y : zmod d × ℤ_[p]) (hd : d.coprime p) :
  y ∈ (clopen_from (prod_padic_to_zmod n x hd)) ↔
  (discrete_quotient_of_to_zmod_pow p d n).rel x y :=
begin
  rw [mem_clopen_from, discrete_quotient_of_to_zmod_pow.rel, prod_padic_to_zmod_def],
  refine ⟨λ h, _, λ h, _⟩,
  { rw [and_comm, eq_comm], convert h,
    { apply (proj_fst _ _).symm, },
    { apply (proj_snd _ _).symm, }, },
  { rw [←h.2, ←h.1],
    refine ⟨(proj_fst x (coprime.pow_right n hd)).symm, (proj_snd x (coprime.pow_right n hd))⟩, },
end

lemma mem_clopen_from_prod_padic_to_zmod (n : ℕ) (x : zmod d × ℤ_[p]) (hd : d.coprime p) :
  x ∈ (clopen_from (prod_padic_to_zmod n x hd)) :=
(mem_clopen_from' _ _ _ hd).2 ((discrete_quotient_of_to_zmod_pow p d n).refl x)

lemma mem_clopen_from'' (n : ℕ) (x y : zmod d × ℤ_[p]) (hd : d.coprime p)
  (hy : y ∈ (clopen_from (prod_padic_to_zmod n x hd))) :
  (clopen_from (prod_padic_to_zmod n x hd)) = (clopen_from (prod_padic_to_zmod n y hd)) :=
begin
  ext z,
  repeat { rw mem_clopen_from at *, },
  rw [←hy.1, hy.2, prod_padic_to_zmod_def, proj_fst y (coprime.pow_right n hd),
    proj_snd y (coprime.pow_right n hd)],
end

end clopen_from

namespace discrete_quotient_of_to_zmod_pow
variables (p d)
lemma le_of_ge {k n : ℕ} (h : k ≤ n) :
  (discrete_quotient_of_to_zmod_pow p d n) ≤ (discrete_quotient_of_to_zmod_pow p d k) :=
λ x y hn, begin rw rel at *,
  refine ⟨_, hn.2⟩,
  simp_rw ←cast_to_zmod_pow _ _ h _,
  refine congr_arg _ hn.1, end

variables {p d}
open clopen_from

lemma self_rel_prod_padic_to_zmod (n : ℕ) (x : zmod d × ℤ_[p]) (hd : d.coprime p) :
  (discrete_quotient_of_to_zmod_pow p d n).rel x (prod_padic_to_zmod n x hd) :=
(mem_clopen_from' _ _ _ hd).1 (self_mem_clopen_from _)

end discrete_quotient_of_to_zmod_pow

namespace clopen_from

lemma clopen_sub_clopen {k n : ℕ} (h : k ≤ n) (x : zmod d × ℤ_[p]) (hd : d.coprime p) :
  (clopen_from (prod_padic_to_zmod n x hd)) ⊆ (clopen_from (prod_padic_to_zmod k x hd)) :=
λ z hz, (mem_clopen_from' k x z hd).2 (discrete_quotient_of_to_zmod_pow.le_of_ge p d h x z
  ((mem_clopen_from' n x z hd).1 hz))

end clopen_from

theorem clopen_basis'_topo_basis (hd : d.coprime p) : topological_space.is_topological_basis
  (clopen_basis' p d) :=
begin
  convert (topological_space.is_topological_basis.prod
    (@discrete_topology.is_topological_basis (zmod d) _ _ _) clopen_basis_clopen.1),
  ext V,
  refine ⟨λ ⟨n, w, h⟩, ⟨{(w : zmod d)}, ((to_zmod_pow n) ⁻¹' {↑w}),
    ⟨(w : zmod d), set.singleton_monoid_hom_apply _⟩, ⟨n, (w : zmod (p^n)), rfl⟩,
    by { rw h, }⟩, λ hy, _⟩,
  { rcases hy with ⟨x', y', ⟨x, hx⟩, ⟨n, y, hy⟩, h⟩,
    set U' : set (zmod d × ℤ_[p]) := ({x} : set (zmod d)) ×ˢ ((padic_int.to_zmod_pow n)⁻¹' {y})
      with hU',
    have hU : U' ∈ clopen_basis' p d,
    { refine ⟨n, ((zmod.chinese_remainder (coprime.pow_right n hd)).inv_fun (x, y)), _⟩,
      rw hU',
      congr,
      { apply (proj_fst' (coprime.pow_right _ hd) _ _).symm, },
      { apply (proj_snd' (coprime.pow_right _ hd) _ _).symm, }, },
    { convert hU,
      rw [←h, hU'],
      congr,
      { rw [←hx, set.singleton_monoid_hom_apply], },
      { rw hy, }, }, },
end

lemma clopen_basis'_clopen (U : clopen_basis' p d) : is_clopen U.val :=
begin
  obtain ⟨n, a, h⟩ := U.prop,
  rw [subtype.val_eq_coe, h],
  apply clopen_from.is_clopen,
end

namespace clopen_from
lemma exists_clopen_from_subset {U : set (zmod d × ℤ_[p])} (hU : is_open U) (hd : d.coprime p)
  {x : zmod d × ℤ_[p]} (memU : x ∈ U) : ∃ n : ℕ, (clopen_from (prod_padic_to_zmod n x hd)) ⊆ U :=
begin
  obtain ⟨V, ⟨n, a, H⟩, memV, U_sub_V⟩ :=
    topological_space.is_topological_basis.exists_subset_of_mem_open
    (clopen_basis'_topo_basis hd) memU hU,
  refine ⟨n, λ y hy, U_sub_V _⟩,
  rw [H, mem_clopen_from] at memV,
  rw [mem_clopen_from, prod_padic_to_zmod_def, proj_snd, proj_fst] at hy,
  simp [H, mem_clopen_from, memV, hy],
end

end clopen_from

open clopen_from

lemma bound_set_inhabited [fact (0 < d)] {U : set (zmod d × ℤ_[p])} (hU : is_clopen U)
  (hd : d.coprime p) : (bound_set U hd).nonempty :=
begin
  have com : U ⊆ ⋃ (x : zmod d × ℤ_[p]) (hx : x ∈ U),
  (clopen_from (prod_padic_to_zmod (classical.some (exists_clopen_from_subset hU.1 hd hx)) x hd)),
  { refine λ y hy, set.mem_Union.2 ⟨y, set.mem_Union.2 ⟨hy, _⟩⟩,
    rw [mem_clopen_from, prod_padic_to_zmod_def, proj_fst, proj_snd],
    simp only [eq_self_iff_true, and_self], },
  obtain ⟨t, ht⟩ := is_compact.elim_finite_subcover (compact_of_is_closed_subset compact_univ hU.2
    (set.subset_univ _)) _ _ com,
  { simp only at ht,
    set n : ℕ := Sup ⨆ (x : zmod d × ℤ_[p]) (H : x ∈ t) (hx : x ∈ U),
      {(classical.some (exists_clopen_from_subset hU.1 hd hx))} with hn,
    refine ⟨n, λ y hy, _⟩,
    obtain ⟨z, hz⟩ := set.mem_Union.1 (ht hy),
    obtain ⟨H, hz⟩ := set.mem_Union.1 hz,
    obtain ⟨hz, h⟩ := set.mem_Union.1 hz,
    transitivity (clopen_from (prod_padic_to_zmod (classical.some _) z hd)),
    { rw mem_clopen_from'' _ _ _ hd h,
      apply (clopen_sub_clopen (le_cSup _ _) _ _),
      { refine (set.finite.bdd_above_bUnion (finset.finite_to_set t)).2 (λ i hi,
          (set.finite.bdd_above (set.finite_Union (λ i, set.finite_singleton _)))), },
      { refine set.mem_Union.2 ⟨z, set.mem_Union.2 ⟨H, set.mem_Union.2 ⟨hz, rfl⟩⟩⟩, }, },
    { apply classical.some_spec (exists_clopen_from_subset _ _ hz), }, },
  { refine λ i, is_open_Union (λ hi, (clopen_from.is_clopen _).1), },
end

lemma bound_mem_bound_set [fact(0 < d)] {U : set (zmod d × ℤ_[p])} (hU : is_clopen U)
  (hd : d.coprime p) : bound U hd ∈ bound_set U hd := nat.Inf_mem (bound_set_inhabited hU _)

namespace clopen_from
lemma clopen_from_subset_of_bound_le [fact (0 < d)] {U : set (zmod d × ℤ_[p])}
  (hU : _root_.is_clopen U) (hd : d.coprime p) {x : zmod d × ℤ_[p]} (memU : x ∈ U) (n : ℕ)
  (h : bound U hd ≤ n) : (clopen_from (prod_padic_to_zmod n x hd)) ⊆ U :=
begin
  transitivity (clopen_from (prod_padic_to_zmod (bound U hd) x hd)),
  intros y,
  repeat { rw mem_clopen_from', },
  suffices :  (discrete_quotient_of_to_zmod_pow  p d n) ≤
    (discrete_quotient_of_to_zmod_pow  p d (bound U hd)),
  { apply this x y, },
  { apply discrete_quotient_of_to_zmod_pow.le_of_ge p d h, },
  { apply bound_mem_bound_set hU hd x memU, },
end

/-- The `units` version of `clopen_from` -/
abbreviation units {n : ℕ} (a : (zmod d)ˣ × (zmod (p^n))ˣ) :
  set ((zmod d)ˣ × ℤ_[p]ˣ) :=
({a.1} : set (zmod d)ˣ) ×ˢ ((units.map (@padic_int.to_zmod_pow p _ n).to_monoid_hom)⁻¹' {a.2})

lemma is_clopen_units {n : ℕ} (a : (zmod d)ˣ × (zmod (p^n))ˣ) :
  _root_.is_clopen (clopen_from.units a) :=
is_clopen_prod (is_clopen_singleton a.1) (proj_lim_preimage_units_clopen a.2)

end clopen_from

namespace discrete_quotient_of_to_zmod_pow
lemma le {R : Type*} [normed_comm_ring R] [fact (0 < d)]
  (hd : d.coprime p) (f : locally_constant (zmod d × ℤ_[p]) R) :
  ∃ N : ℕ, discrete_quotient_of_to_zmod_pow p d N ≤ f.discrete_quotient :=
begin
  have : ∀ x : R, is_open (f⁻¹' {x}) := λ x, f.is_locally_constant _,
  have pre_univ : f⁻¹' (set.univ : set R) = ⋃ (x : R), f⁻¹' {x},
  { ext y,
    simp only [set.mem_preimage, set.mem_Union, set.mem_univ, set.mem_singleton_iff, exists_eq'], },
  obtain ⟨t, ht⟩ := is_compact.elim_finite_subcover compact_univ _ this
    (set.univ_subset_iff.2 pre_univ.symm),
  set n : ℕ := Sup ⨆ (x : R) (H : x ∈ t), {bound (f⁻¹' {x}) hd} with hn,
  refine ⟨n, λ x y hF, _⟩,
  obtain ⟨i, hi⟩ := set.mem_Union.1 (ht (set.mem_univ x)),
  obtain ⟨hi, htx⟩ := set.mem_Union.1 hi,
  simp only [set.mem_preimage, set.mem_singleton_iff] at htx,
  rw rel at hF,
  change f y = f x,
  rw htx,
  have h1 : y ∈ (clopen_from (prod_padic_to_zmod n x hd)),
  { rw [mem_clopen_from, prod_padic_to_zmod_def, proj_fst, proj_snd],
    simp only [hF, eq_self_iff_true, and_self], },
  rw [←set.mem_singleton_iff, ←set.mem_preimage],
  refine clopen_from.clopen_from_subset_of_bound_le ⟨this i,
    is_closed.preimage (locally_constant.continuous f) (t1_space.t1 i)⟩ hd
    (set.mem_preimage.2 (set.mem_singleton_iff.2 htx)) _ (le_cSup _ _) h1,
  { refine (set.finite.bdd_above_bUnion (finset.finite_to_set t)).2 (λ i hi, bdd_above_singleton), },
  { refine set.mem_Union.2 ⟨i, set.mem_Union.2 ⟨hi, rfl⟩⟩, },
end

end discrete_quotient_of_to_zmod_pow

variables (p d) (R : Type*) [normed_comm_ring R]

open locally_constant

/-- Looking at the set of characteristic functions obtained from the clopen basis. -/
abbreviation char_fn_set : set (locally_constant (zmod d × ℤ_[p]) R) := ⨆ n : ℕ, set.range
  (λ (a : zmod (d * p^n)), _root_.char_fn R (clopen_from.is_clopen a))

variables {p d}

lemma mem_char_fn_set (U : clopen_basis' p d) :
  (char_fn R (clopen_basis'_clopen U)) ∈ (char_fn_set p d R) :=
begin
  delta char_fn_set,
  rw [set.supr_eq_Union, set.mem_Union],
  obtain ⟨n, a, hU⟩ := U.prop,
  refine ⟨n, set.mem_range.2 ⟨a, _⟩⟩,
  congr,
  rw [subtype.val_eq_coe, hU],
end

variable {R}
lemma mem_char_fn_set' (x : char_fn_set p d R) : ∃ (i : ℕ) (y : zmod (d * p ^ i)),
  char_fn R (clopen_from.is_clopen y) = x := set.mem_Union.1 x.prop

variable (R)
/-- An equivalence between the clopen basis and the characteristic functions corresponding to it.-/
noncomputable def clopen_char_fn_equiv [nontrivial R] : clopen_basis' p d ≃ char_fn_set p d R :=
{ to_fun := λ U, ⟨(char_fn R (clopen_basis'_clopen U)), mem_char_fn_set R U⟩,
  inv_fun := λ f, ⟨clopen_from (classical.some (classical.some_spec (set.mem_Union.1 f.prop))),
    ⟨classical.some (set.mem_Union.1 f.prop), classical.some (classical.some_spec
      (set.mem_Union.1 f.prop)), rfl⟩ ⟩,
  left_inv := function.left_inverse_iff_comp.mpr (function.funext_iff.2 (λ U, subtype.ext_iff_val.2
    (char_fn_inj R (clopen_from.is_clopen _) (clopen_basis'_clopen U) (classical.some_spec
    (classical.some_spec (set.mem_Union.1 (mem_char_fn_set R U))))))),
  right_inv := function.right_inverse_iff_comp.mpr (begin ext,
    simp only [id.def, function.comp_app, subtype.coe_mk, subtype.val_eq_coe],
    congr,
    refine classical.some_spec (classical.some_spec (mem_char_fn_set' x)), end), }


theorem and_swap (p q : Prop) : p ∧ q ↔ q ∧ p :=
iff.intro
  (assume H : p ∧ q,
    and.intro (and.right H) (and.left H))
  (assume H : q ∧ p,
    and.intro (and.right H) (and.left H))

check and_swap    -- p ∧ q ↔ q ∧ p


import tactic
import data.real.irrational

/-- √3 is irrational. -/
lemma part_a : irrational (real.sqrt 3) :=
begin
  sorry
end

/-- There are no rationals r,s such that √3 = r + s √2. -/
lemma part_b : ¬ ∃ (r s : ℚ), real.sqrt 3 = r + s * real.sqrt 2 :=
begin
  sorry
end


theorem succ_ne_zero (a : mynat) : succ a ≠ 0 :=
begin
symmetry,
exact zero_ne_succ a,
end


import data.real.basic

variables {α : Type*} {β : Type*} {γ : Type*}
variables {g : β → γ} {f : α → β}
variables a b c : ℝ

#check add_left_inj
#check add_left_inj b
#check @mul_right_inj
#check @mul_right_inj'

open function

-- BEGIN

example (c : ℝ) : injective (λ x, x + c) :=
begin
  intros x₁ x₂ h',
  exact (add_left_inj c).mp h',
end

example {c : ℝ} (h : c ≠ 0) : injective (λ x, c * x) :=
begin
  intros x₁ x₂ h1,
  exact (mul_right_inj' h).mp h1,
end

example (injg : injective g) (injf : injective f) :
  injective (λ x, g (f x)) :=
begin
  intros x₁ x₂ h,
  dsimp at h,
  apply injf,
  apply injg,
  exact h,
end

-- END


/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import tactic.norm_num
import data.nat.sqrt

/-! ### `norm_num` plugin for `sqrt`

The `norm_num` plugin evaluates `sqrt` by bounding it between consecutive integers.
-/

namespace norm_num
open tactic nat

lemma is_sqrt {n a a2 b : ℕ}
  (ha2 : a * a = a2) (hb : a2 + b = n) (hle : b ≤ bit0 a) : sqrt n = a :=
by { rw [← hb, ← ha2, ← pow_two], exact sqrt_add_eq' _ hle }

/-- Given `n` provides `(a, ⊢ nat.sqrt n = a)`. -/
meta def prove_sqrt (ic : instance_cache) (n : expr) : tactic (instance_cache × expr × expr) := do
  nn ← n.to_nat,
  let na := nn.sqrt,
  (ic, a) ← ic.of_nat na,
  (ic, a2, ha2) ← prove_mul_nat ic a a,
  (ic, b) ← ic.of_nat (nn - na*na),
  (ic, hb) ← prove_add_nat ic a2 b n,
  (ic, hle) ← prove_le_nat ic b (`(bit0:ℕ→ℕ).mk_app [a]),
  pure (ic, a, `(@is_sqrt).mk_app [n, a, a2, b, ha2, hb, hle])

/-- A `norm_num` plugin for `sqrt n` when `n` is a numeral. -/
@[norm_num] meta def eval_sqrt : expr → tactic (expr × expr)
| `(sqrt %%en) := do
    n ← en.to_nat,
    match n with
    | 0 := pure (`(0:ℕ), `(sqrt_zero))
    | _ := do
      c ← mk_instance_cache `(ℕ),
      prod.snd <$> prove_sqrt c en
    end
| _ := failed

end norm_num


/-
7. Prove the theorem below, using only the ring properties of ℤ enumerated in Section 4.2 and the theorem sub_self.
-/

import data.int.basic

#check sub_self

example (x : ℤ) : x * 0 = 0 :=
    calc
        x * 0 = x * (x - x) : by rw sub_self x
          ... = x * x - x * x : by rw mul_sub x
          ... = 0 : by rw sub_self (x * x)


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

import topology.algebra.algebra
import topology.continuous_function.compact
import topology.urysohns_lemma
import data.is_R_or_C.basic
import analysis.normed_space.units
import topology.algebra.module.character_space

/-!
# Ideals of continuous functions

For a topological ring `R` and a topological space `X` there is a Galois connection between
`ideal C(X, R)` and `set X` given by sending each `I : ideal C(X, R)` to
`{x : X | ∀ f ∈ I, f x = 0}ᶜ` and mapping `s : set X` to the ideal with carrier
`{f : C(X, R) | ∀ x ∈ sᶜ, f x = 0}`, and we call these maps `continuous_map.set_of_ideal` and
`continuous_map.ideal_of_set`. As long as `R` is Hausdorff, `continuous_map.set_of_ideal I` is open,
and if, in addition, `X` is locally compact, then `continuous_map.set_of_ideal s` is closed.

When `R = 𝕜` with `is_R_or_C 𝕜` and `X` is compact Hausdorff, then this Galois connection can be
improved to a true Galois correspondence (i.e., order isomorphism) between the type `opens X` and
the subtype of closed ideals of `C(X, 𝕜)`. Because we do not have a bundled type of closed ideals,
we simply register this as a Galois insertion between `ideal C(X, 𝕜)` and `opens X`, which is
`continuous_map.ideal_opens_gi`. Consequently, the maximal ideals of `C(X, 𝕜)` are precisely those
ideals corresponding to (complements of) singletons in `X`.

In addition, when `X` is locally compact and `𝕜` is a nontrivial topological integral domain, then
there is a natural continuous map from `X` to `character_space 𝕜 C(X, 𝕜)` given by point evaluation,
which is herein called `weak_dual.character_space.continuous_map_eval`. Again, when `X` is compact
Hausdorff and `is_R_or_C 𝕜`, more can be obtained. In particular, in that context this map is
bijective, and since the domain is compact and the codomain is Hausdorff, it is a homeomorphism,
herein called `weak_dual.character_space.homeo_eval`.

## Main definitions

* `continuous_map.ideal_of_set`: ideal of functions which vanish on the complement of a set.
* `continuous_map.set_of_ideal`: complement of the set on which all functions in the ideal vanish.
* `continuous_map.opens_of_ideal`: `continuous_map.set_of_ideal` as a term of `opens X`.
* `continuous_map.ideal_opens_gi`: The Galois insertion `continuous_map.opens_of_ideal` and
  `λ s, continuous_map.ideal_of_set ↑s`.
* `weak_dual.character_space.continuous_map_eval`: the natural continuous map from a locally compact
  topological space `X` to the `character_space 𝕜 C(X, 𝕜)` which sends `x : X` to point evaluation
  at `x`, with modest hypothesis on `𝕜`.
* `weak_dual.character_space.homeo_eval`: this is `weak_dual.character_space.continuous_map_eval`
  upgraded to a homeomorphism when `X` is compact Hausdorff and `is_R_or_C 𝕜`.

## Main statements

* `continuous_map.ideal_of_set_of_ideal_eq_closure`: when `X` is compact Hausdorff and
  `is_R_or_C 𝕜`, `ideal_of_set 𝕜 (set_of_ideal I) = I.closure` for any ideal `I : ideal C(X, 𝕜)`.
* `continuous_map.set_of_ideal_of_set_eq_interior`: when `X` is compact Hausdorff and `is_R_or_C 𝕜`,
  `set_of_ideal (ideal_of_set 𝕜 s) = interior s` for any `s : set X`.
* `continuous_map.ideal_is_maximal_iff`: when `X` is compact Hausdorff and `is_R_or_C 𝕜`, a closed
  ideal of `C(X, 𝕜)` is maximal if and only if it is `ideal_of_set 𝕜 {x}ᶜ` for some `x : X`.

## Implementation details

Because there does not currently exist a bundled type of closed ideals, we don't provide the actual
order isomorphism described above, and instead we only consider the Galois insertion
`continuous_map.ideal_opens_gi`.

## Tags

ideal, continuous function, compact, Hausdorff
-/

open_locale nnreal

namespace continuous_map

open topological_space

section topological_ring

variables {X R : Type*} [topological_space X] [ring R] [topological_space R] [topological_ring R]

variable (R)

/-- Given a topological ring `R` and `s : set X`, construct the ideal in `C(X, R)` of functions
which vanish on the complement of `s`. -/
def ideal_of_set (s : set X) : ideal C(X, R) :=
{ carrier := {f : C(X, R) | ∀ x ∈ sᶜ, f x = 0},
  add_mem' := λ f g hf hg x hx, by simp only [hf x hx, hg x hx, coe_add, pi.add_apply, add_zero],
  zero_mem' := λ _ _, rfl,
  smul_mem' := λ c f hf x hx, mul_zero (c x) ▸ congr_arg (λ y, c x * y) (hf x hx), }

lemma ideal_of_set_closed [locally_compact_space X] [t2_space R] (s : set X) :
  is_closed (ideal_of_set R s : set C(X, R) ) :=
begin
  simp only [ideal_of_set, submodule.coe_set_mk, set.set_of_forall],
  exact is_closed_Inter (λ x, is_closed_Inter $
    λ hx, is_closed_eq (continuous_eval_const' x) continuous_const),
end

variable {R}

lemma mem_ideal_of_set {s : set X} {f : C(X, R)} :
  f ∈ ideal_of_set R s ↔ ∀ ⦃x : X⦄, x ∈ sᶜ → f x = 0 := iff.rfl

lemma not_mem_ideal_of_set {s : set X} {f : C(X, R)} :
  f ∉ ideal_of_set R s ↔ ∃ x ∈ sᶜ, f x ≠ 0 :=
by { simp_rw [mem_ideal_of_set, exists_prop], push_neg }

/-- Given an ideal `I` of `C(X, R)`, construct the set of points for which every function in the
ideal vanishes on the complement. -/
def set_of_ideal (I : ideal C(X, R)) : set X :=
{x : X | ∀ f ∈ I, (f : C(X, R)) x = 0}ᶜ

lemma not_mem_set_of_ideal {I : ideal C(X, R)} {x : X} :
  x ∉ set_of_ideal I ↔ ∀ ⦃f : C(X, R)⦄, f ∈ I → f x = 0 :=
by rw [←set.mem_compl_iff, set_of_ideal, compl_compl, set.mem_set_of]

lemma mem_set_of_ideal {I : ideal C(X, R)} {x : X} :
  x ∈ set_of_ideal I ↔ ∃ f ∈ I, (f : C(X, R)) x ≠ 0 :=
by { simp_rw [set_of_ideal, set.mem_compl_iff, set.mem_set_of, exists_prop], push_neg }

lemma set_of_ideal_open [t2_space R] (I : ideal C(X, R)) : is_open (set_of_ideal I) :=
begin
  simp only [set_of_ideal, set.set_of_forall, is_open_compl_iff],
  exact is_closed_Inter (λ f, is_closed_Inter $
    λ hf, is_closed_eq (map_continuous f) continuous_const)
end

/-- The open set `set_of_ideal I` realized as a term of `opens X`. -/
@[simps] def opens_of_ideal [t2_space R] (I : ideal C(X, R)) : opens X :=
⟨set_of_ideal I, set_of_ideal_open I⟩

@[simp] lemma set_of_top_eq_univ [nontrivial R] : (set_of_ideal (⊤ : ideal C(X, R))) = set.univ :=
set.univ_subset_iff.mp $ λ x hx, mem_set_of_ideal.mpr ⟨1, submodule.mem_top, one_ne_zero⟩

@[simp] lemma ideal_of_empty_eq_bot : (ideal_of_set R (∅ : set X)) = ⊥ :=
ideal.ext (λ f, by simpa only [mem_ideal_of_set, set.compl_empty, set.mem_univ, forall_true_left,
  ideal.mem_bot, fun_like.ext_iff] using iff.rfl)

@[simp] lemma mem_ideal_of_set_compl_singleton (x : X) (f : C(X, R)) :
  f ∈ ideal_of_set R ({x}ᶜ : set X) ↔ f x = 0 :=
by simp only [mem_ideal_of_set, compl_compl, set.mem_singleton_iff, forall_eq]

variables (X R)
lemma ideal_gc : galois_connection (set_of_ideal : ideal C(X, R) → set X) (ideal_of_set R) :=
begin
  refine λ I s, ⟨λ h f hf, _, λ h x hx, _⟩,
  { by_contra h',
    rcases not_mem_ideal_of_set.mp h' with ⟨x, hx, hfx⟩,
    exact hfx (not_mem_set_of_ideal.mp (mt (@h x) hx) hf) },
  { obtain ⟨f, hf, hfx⟩ := mem_set_of_ideal.mp hx,
    by_contra hx',
    exact not_mem_ideal_of_set.mpr ⟨x, hx', hfx⟩ (h hf) },
end

end topological_ring

section is_R_or_C
open is_R_or_C

variables {X 𝕜 : Type*} [is_R_or_C 𝕜] [topological_space X]

/-- An auxiliary lemma used in the proof of `ideal_of_set_of_ideal_eq_closure` which may be useful
on its own. -/
lemma exists_mul_le_one_eq_on_ge (f : C(X, ℝ≥0)) {c : ℝ≥0} (hc : 0 < c) :
  ∃ g : C(X, ℝ≥0), (∀ x : X, (g * f) x ≤ 1) ∧ {x : X | c ≤ f x}.eq_on (g * f) 1 :=
⟨{ to_fun := (f ⊔ (const X c))⁻¹,
   continuous_to_fun := ((map_continuous f).sup $ map_continuous _).inv₀
     (λ _, (hc.trans_le le_sup_right).ne')},
 λ x, (inv_mul_le_iff (hc.trans_le le_sup_right)).mpr ((mul_one (f x ⊔ c)).symm ▸ le_sup_left),
 λ x hx, by simpa only [coe_const, coe_mk, pi.mul_apply, pi.inv_apply, pi.sup_apply,
   function.const_apply, pi.one_apply, sup_eq_left.mpr (set.mem_set_of.mp hx)]
   using inv_mul_cancel (hc.trans_le hx).ne'⟩

variables [compact_space X] [t2_space X]

@[simp] lemma ideal_of_set_of_ideal_eq_closure (I : ideal C(X, 𝕜)) :
  ideal_of_set 𝕜 (set_of_ideal I) = I.closure :=
begin
  /- Since `ideal_of_set 𝕜 (set_of_ideal I)` is closed and contains `I`, it contains `I.closure`.
  For the reverse inclusion, given `f ∈ ideal_of_set 𝕜 (set_of_ideal I)` and `(ε : ℝ≥0) > 0` it
  suffices to show that `f` is within `ε` of `I`.-/
  refine le_antisymm (λ f hf, metric.mem_closure_iff.mpr (λ ε hε, _))
    ((ideal_of_set_closed 𝕜 $ set_of_ideal I).closure_subset_iff.mpr $
    λ f hf x hx, not_mem_set_of_ideal.mp hx hf),
  lift ε to ℝ≥0 using hε.lt.le,
  replace hε := (show (0 : ℝ≥0) < ε, from hε),
  simp_rw dist_nndist,
  norm_cast,
  -- Let `t := {x : X | ε / 2 ≤ ‖f x‖₊}}` which is closed and disjoint from `set_of_ideal I`.
  set t := {x : X | ε / 2 ≤ ‖f x‖₊},
  have ht : is_closed t := is_closed_le continuous_const (map_continuous f).nnnorm,
  have htI : disjoint t (set_of_ideal I)ᶜ,
  { refine set.subset_compl_iff_disjoint_left.mp (λ x hx, _),
    simpa only [t, set.mem_set_of, set.mem_compl_iff, not_le]
      using (nnnorm_eq_zero.mpr (mem_ideal_of_set.mp hf hx)).trans_lt (half_pos hε), },
  /- It suffices to produce `g : C(X, ℝ≥0)` which takes values in `[0,1]` and is constantly `1` on
  `t` such that when composed with the natural embedding of `ℝ≥0` into `𝕜` lies in the ideal `I`.
  Indeed, then `‖f - f * ↑g‖ ≤ ‖f * (1 - ↑g)‖ ≤ ⨆ ‖f * (1 - ↑g) x‖`. When `x ∉ t`, `‖f x‖ < ε / 2`
  and `‖(1 - ↑g) x‖ ≤ 1`, and when `x ∈ t`, `(1 - ↑g) x = 0`, and clearly `f * ↑g ∈ I`. -/
  suffices : ∃ g : C(X, ℝ≥0),
    (algebra_map_clm ℝ≥0 𝕜 : C(ℝ≥0, 𝕜)).comp g ∈ I ∧ (∀ x, g x ≤ 1) ∧ t.eq_on g 1,
  { obtain ⟨g, hgI, hg, hgt⟩ := this,
    refine ⟨f * (algebra_map_clm ℝ≥0 𝕜 : C(ℝ≥0, 𝕜)).comp g, I.mul_mem_left f hgI, _⟩,
    rw nndist_eq_nnnorm,
    refine (nnnorm_lt_iff _ hε).2 (λ x, _),
    simp only [coe_sub, coe_mul, pi.sub_apply, pi.mul_apply],
    by_cases hx : x ∈ t,
    { simpa only [hgt hx, comp_apply, pi.one_apply, continuous_map.coe_coe, algebra_map_clm_apply,
        map_one, mul_one, sub_self, nnnorm_zero] using hε, },
    { refine lt_of_le_of_lt _ (half_lt_self hε),
      have := calc ‖((1 - (algebra_map_clm ℝ≥0 𝕜 : C(ℝ≥0, 𝕜)).comp g) x : 𝕜)‖₊
            = ‖1 - algebra_map ℝ≥0 𝕜 (g x)‖₊
            : by simp only [coe_sub, coe_one, coe_comp, continuous_map.coe_coe, pi.sub_apply,
                pi.one_apply, function.comp_app, algebra_map_clm_apply]
        ... = ‖algebra_map ℝ≥0 𝕜 (1 - g x)‖₊
            : by simp only [algebra.algebra_map_eq_smul_one, nnreal.smul_def, nnreal.coe_sub (hg x),
                sub_smul, nonneg.coe_one, one_smul]
        ... ≤ 1 : (nnnorm_algebra_map_nnreal 𝕜 (1 - g x)).trans_le tsub_le_self,
      calc ‖f x - f x * (algebra_map_clm ℝ≥0 𝕜 : C(ℝ≥0, 𝕜)).comp g x‖₊
          = ‖f x * (1 - (algebra_map_clm ℝ≥0 𝕜 : C(ℝ≥0, 𝕜)).comp g) x‖₊
          : by simp only [mul_sub, coe_sub, coe_one, pi.sub_apply, pi.one_apply, mul_one]
      ... ≤ (ε / 2) * ‖(1 - (algebra_map_clm ℝ≥0 𝕜 : C(ℝ≥0, 𝕜)).comp g) x‖₊
          : (nnnorm_mul_le _ _).trans (mul_le_mul_right'
              (not_le.mp $ show ¬ ε / 2 ≤ ‖f x‖₊, from hx).le _)
      ... ≤ ε / 2 : by simpa only [mul_one] using mul_le_mul_left' this _, } },
  /- There is some `g' : C(X, ℝ≥0)` which is strictly positive on `t` such that the composition
  `↑g` with the natural embedding of `ℝ≥0` into `𝕜` lies in `I`. This follows from compactness of
  `t` and that we can do it in any neighborhood of a point `x ∈ t`. Indeed, since `x ∈ t`, then
  `fₓ x ≠ 0` for some `fₓ ∈ I` and so `λ y, ‖(star fₓ * fₓ) y‖₊` is strictly posiive in a
  neighborhood of `y`. Moreover, `(‖(star fₓ * fₓ) y‖₊ : 𝕜) = (star fₓ * fₓ) y`, so composition of
  this map with the natural embedding is just `star fₓ * fₓ ∈ I`. -/
  have : ∃ g' : C(X, ℝ≥0), (algebra_map_clm ℝ≥0 𝕜 : C(ℝ≥0, 𝕜)).comp g' ∈ I ∧ (∀ x ∈ t, 0 < g' x),
  { refine @is_compact.induction_on _ _ _ ht.is_compact (λ s, ∃ g' : C(X, ℝ≥0),
      (algebra_map_clm ℝ≥0 𝕜 : C(ℝ≥0, 𝕜)).comp g' ∈ I ∧ (∀ x ∈ s, 0 < g' x)) _ _ _ _,
    { refine ⟨0, _, λ x hx, false.elim hx⟩,
      convert I.zero_mem,
      ext,
      simp only [coe_zero, pi.zero_apply, continuous_map.coe_coe, continuous_map.coe_comp,
        map_zero, pi.comp_zero] },
    { rintro s₁ s₂ hs ⟨g, hI, hgt⟩, exact ⟨g, hI, λ x hx, hgt x (hs hx)⟩, },
    { rintro s₁ s₂ ⟨g₁, hI₁, hgt₁⟩ ⟨g₂, hI₂, hgt₂⟩,
      refine ⟨g₁ + g₂, _, λ x hx, _⟩,
      { convert I.add_mem hI₁ hI₂,
        ext y,
        simp only [coe_add, pi.add_apply, map_add, coe_comp, function.comp_app,
          continuous_map.coe_coe]},
      { rcases hx with (hx | hx),
        simpa only [zero_add] using add_lt_add_of_lt_of_le (hgt₁ x hx) zero_le',
        simpa only [zero_add] using add_lt_add_of_le_of_lt zero_le' (hgt₂ x hx), } },
    { intros x hx,
      replace hx := htI.subset_compl_right hx,
      rw [compl_compl, mem_set_of_ideal] at hx,
      obtain ⟨g, hI, hgx⟩ := hx,
      have := (map_continuous g).continuous_at.eventually_ne hgx,
      refine ⟨{y : X | g y ≠ 0} ∩ t, mem_nhds_within_iff_exists_mem_nhds_inter.mpr
        ⟨_, this, set.subset.rfl⟩, ⟨⟨λ x, ‖g x‖₊ ^ 2, (map_continuous g).nnnorm.pow 2⟩, _,
        λ x hx, pow_pos (norm_pos_iff.mpr hx.1) 2⟩⟩,
      convert I.mul_mem_left (star g) hI,
      ext,
      simp only [comp_apply, coe_mk, algebra_map_clm_coe, map_pow, coe_mul, coe_star,
        pi.mul_apply, pi.star_apply, star_def, continuous_map.coe_coe],
      simpa only [norm_sq_eq_def', conj_mul_eq_norm_sq_left, of_real_pow], }, },
  /- Get the function `g'` which is guaranteed to exist above. By the extreme value theorem and
  compactness of `t`, there is some `0 < c` such that `c ≤ g' x` for all `x ∈ t`. Then by
  `main_lemma_aux` there is some `g` for which `g * g'` is the desired function. -/
  obtain ⟨g', hI', hgt'⟩ := this,
  obtain (⟨c, hc, hgc'⟩ : ∃ c (hc : 0 < c), ∀ y : X, y ∈ t → c ≤ g' y) :=
  t.eq_empty_or_nonempty.elim (λ ht', ⟨1, zero_lt_one, λ y hy, false.elim (by rwa ht' at hy)⟩)
    (λ ht', let ⟨x, hx, hx'⟩ := ht.is_compact.exists_forall_le ht' (map_continuous g').continuous_on
      in ⟨g' x, hgt' x hx, hx'⟩),
  obtain ⟨g, hg, hgc⟩ := exists_mul_le_one_eq_on_ge g' hc,
  refine ⟨g * g', _, hg, hgc.mono hgc'⟩,
  convert I.mul_mem_left ((algebra_map_clm ℝ≥0 𝕜 : C(ℝ≥0, 𝕜)).comp g) hI',
  ext,
  simp only [algebra_map_clm_coe, continuous_map.coe_coe, comp_apply, coe_mul, pi.mul_apply,
    map_mul],
end

lemma ideal_of_set_of_ideal_is_closed {I : ideal C(X, 𝕜)}
  (hI : is_closed (I : set C(X, 𝕜))) : ideal_of_set 𝕜 (set_of_ideal I) = I :=
(ideal_of_set_of_ideal_eq_closure I).trans (ideal.ext $ set.ext_iff.mp hI.closure_eq)

variable (𝕜)

@[simp] lemma set_of_ideal_of_set_eq_interior (s : set X) :
  set_of_ideal (ideal_of_set 𝕜 s) = interior s:=
begin
  refine set.subset.antisymm ((set_of_ideal_open (ideal_of_set 𝕜 s)).subset_interior_iff.mpr
    (λ x hx, let ⟨f, hf, hfx⟩ := mem_set_of_ideal.mp hx
    in set.not_mem_compl_iff.mp (mt (@hf x) hfx))) (λ x hx, _),
  /- If `x ∉ closure sᶜ`, we must produce `f : C(X, 𝕜)` which is zero on `sᶜ` and `f x ≠ 0`. -/
  rw [←compl_compl (interior s), ←closure_compl] at hx,
  simp_rw [mem_set_of_ideal, mem_ideal_of_set],
  haveI : normal_space X := normal_of_compact_t2,
  /- Apply Urysohn's lemma to get `g : C(X, ℝ)` which is zero on `sᶜ` and `g x ≠ 0`, then compose
  with the natural embedding `ℝ ↪ 𝕜` to produce the desired `f`. -/
  obtain ⟨g, hgs, (hgx : set.eq_on g 1 {x}), -⟩ := exists_continuous_zero_one_of_closed
    is_closed_closure is_closed_singleton (set.disjoint_singleton_right.mpr hx),
  exact ⟨⟨λ x, g x, continuous_of_real.comp (map_continuous g)⟩,
    by simpa only [coe_mk, of_real_eq_zero] using λ x hx, hgs (subset_closure hx),
    by simpa only [coe_mk, hgx (set.mem_singleton x), pi.one_apply, is_R_or_C.of_real_one]
      using one_ne_zero⟩,
end

lemma set_of_ideal_of_set_of_is_open {s : set X} (hs : is_open s) :
  set_of_ideal (ideal_of_set 𝕜 s) = s :=
(set_of_ideal_of_set_eq_interior 𝕜 s).trans hs.interior_eq

variable (X)

/-- The Galois insertion `continuous_map.opens_of_ideal : ideal C(X, 𝕜) → opens X` and
`λ s, continuous_map.ideal_of_set ↑s`. -/
@[simps] def ideal_opens_gi :
  galois_insertion (opens_of_ideal : ideal C(X, 𝕜) → opens X) (λ s, ideal_of_set 𝕜 s) :=
{ choice := λ I hI, opens_of_ideal I.closure,
  gc := λ I s, ideal_gc X 𝕜 I s,
  le_l_u := λ s, (set_of_ideal_of_set_of_is_open 𝕜 s.is_open).ge,
  choice_eq := λ I hI, congr_arg _ $ ideal.ext (set.ext_iff.mp (is_closed_of_closure_subset $
    (ideal_of_set_of_ideal_eq_closure I ▸ hI : I.closure ≤ I)).closure_eq) }

variables {X}

lemma ideal_of_set_is_maximal_iff (s : opens X) :
  (ideal_of_set 𝕜 (s : set X)).is_maximal ↔ is_coatom s :=
begin
  rw ideal.is_maximal_def,
  refine (ideal_opens_gi X 𝕜).is_coatom_iff  (λ I hI, _) s,
  rw ←ideal.is_maximal_def at hI,
  resetI,
  exact ideal_of_set_of_ideal_is_closed infer_instance,
end

lemma ideal_of_compl_singleton_is_maximal (x : X) : (ideal_of_set 𝕜 ({x}ᶜ : set X)).is_maximal :=
(ideal_of_set_is_maximal_iff 𝕜 (closeds.singleton x).compl).mpr  $ opens.is_coatom_iff.mpr ⟨x, rfl⟩

variables {𝕜}

lemma set_of_ideal_eq_compl_singleton (I : ideal C(X, 𝕜)) [hI : I.is_maximal] :
  ∃ x : X, set_of_ideal I = {x}ᶜ :=
begin
  have h : (ideal_of_set 𝕜 (set_of_ideal I)).is_maximal, from
    (ideal_of_set_of_ideal_is_closed (infer_instance : is_closed (I : set C(X, 𝕜)))).symm ▸ hI,
  obtain ⟨x, hx⟩ := opens.is_coatom_iff.1 ((ideal_of_set_is_maximal_iff 𝕜 (opens_of_ideal I)).1 h),
  exact ⟨x, congr_arg coe hx⟩,
end

lemma ideal_is_maximal_iff (I : ideal C(X, 𝕜)) [hI : is_closed (I : set C(X, 𝕜))] :
  I.is_maximal ↔ ∃ x : X, ideal_of_set 𝕜 {x}ᶜ = I :=
begin
  refine ⟨_, λ h, let ⟨x, hx⟩ := h in hx ▸ ideal_of_compl_singleton_is_maximal 𝕜 x⟩,
  introI hI',
  obtain ⟨x, hx⟩ := set_of_ideal_eq_compl_singleton I,
  exact ⟨x, by simpa only [ideal_of_set_of_ideal_eq_closure, ideal.closure_eq_of_is_closed]
    using congr_arg (ideal_of_set 𝕜) hx.symm⟩,
end

end is_R_or_C

end continuous_map

namespace weak_dual
namespace character_space

open function continuous_map

variables (X 𝕜 : Type*) [topological_space X]

section continuous_map_eval

variables [locally_compact_space X] [comm_ring 𝕜] [topological_space 𝕜] [topological_ring 𝕜]
variables [nontrivial 𝕜] [no_zero_divisors 𝕜]

/-- The natural continuous map from a locally compact topological space `X` to the
`character_space 𝕜 C(X, 𝕜)` which sends `x : X` to point evaluation at `x`. -/
def continuous_map_eval :
  C(X, character_space 𝕜 C(X, 𝕜)) :=
{ to_fun := λ x, ⟨{ to_fun := λ f, f x, map_add' := λ f g, rfl, map_smul' := λ z f, rfl,
                    cont := continuous_eval_const' x },
                  by { rw character_space.eq_set_map_one_map_mul, exact ⟨rfl, λ f g, rfl⟩ }⟩,
  continuous_to_fun := continuous.subtype_mk (continuous_of_continuous_eval map_continuous) _ }

@[simp] lemma continuous_map_eval_apply_apply (x : X) (f : C(X, 𝕜)) :
  continuous_map_eval X 𝕜 x f = f x := rfl

end continuous_map_eval

variables [compact_space X] [t2_space X] [is_R_or_C 𝕜]

lemma continuous_map_eval_bijective : bijective (continuous_map_eval X 𝕜) :=
begin
  refine ⟨λ x y hxy, _, λ φ, _⟩,
  { contrapose! hxy,
    haveI := @normal_of_compact_t2 X _ _ _,
    rcases exists_continuous_zero_one_of_closed (is_closed_singleton : _root_.is_closed {x})
      (is_closed_singleton : _root_.is_closed {y}) (set.disjoint_singleton.mpr hxy)
      with ⟨f, fx, fy, -⟩,
    rw [←ne.def, fun_like.ne_iff],
    use (⟨coe, is_R_or_C.continuous_of_real⟩ : C(ℝ, 𝕜)).comp f,
    simpa only [continuous_map_eval_apply_apply, continuous_map.comp_apply, coe_mk, ne.def,
      is_R_or_C.of_real_inj] using ((fx (set.mem_singleton x)).symm ▸
      (fy (set.mem_singleton y)).symm ▸ zero_ne_one : f x ≠ f y) },
  { obtain ⟨x, hx⟩ := (ideal_is_maximal_iff (ring_hom.ker φ)).mp infer_instance,
    refine ⟨x, ext_ker $ ideal.ext $ λ f, _⟩,
    simpa only [ring_hom.mem_ker, continuous_map_eval_apply_apply,
      mem_ideal_of_set_compl_singleton, ring_hom.mem_ker] using set_like.ext_iff.mp hx f }
end

/-- This is the natural homeomorphism between a compact Hausdorff space `X` and the
`character_space 𝕜 C(X, 𝕜)`. -/
noncomputable def homeo_eval : X ≃ₜ character_space 𝕜 C(X, 𝕜) :=
@continuous.homeo_of_equiv_compact_to_t2 _ _ _ _ _ _
  { to_fun := (continuous_map_eval X 𝕜),
    .. equiv.of_bijective _ (continuous_map_eval_bijective X 𝕜) }
  (map_continuous (continuous_map_eval X 𝕜))

end character_space
end weak_dual


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

import order.complete_boolean_algebra
import order.cover
import order.modular_lattice
import data.fintype.basic

/-!
# Atoms, Coatoms, and Simple Lattices

This module defines atoms, which are minimal non-`⊥` elements in bounded lattices, simple lattices,
which are lattices with only two elements, and related ideas.

## Main definitions

### Atoms and Coatoms
  * `is_atom a` indicates that the only element below `a` is `⊥`.
  * `is_coatom a` indicates that the only element above `a` is `⊤`.

### Atomic and Atomistic Lattices
  * `is_atomic` indicates that every element other than `⊥` is above an atom.
  * `is_coatomic` indicates that every element other than `⊤` is below a coatom.
  * `is_atomistic` indicates that every element is the `Sup` of a set of atoms.
  * `is_coatomistic` indicates that every element is the `Inf` of a set of coatoms.

### Simple Lattices
  * `is_simple_order` indicates that an order has only two unique elements, `⊥` and `⊤`.
  * `is_simple_order.bounded_order`
  * `is_simple_order.distrib_lattice`
  * Given an instance of `is_simple_order`, we provide the following definitions. These are not
    made global instances as they contain data :
    * `is_simple_order.boolean_algebra`
    * `is_simple_order.complete_lattice`
    * `is_simple_order.complete_boolean_algebra`

## Main results
  * `is_atom_dual_iff_is_coatom` and `is_coatom_dual_iff_is_atom` express the (definitional) duality
   of `is_atom` and `is_coatom`.
  * `is_simple_order_iff_is_atom_top` and `is_simple_order_iff_is_coatom_bot` express the
  connection between atoms, coatoms, and simple lattices
  * `is_compl.is_atom_iff_is_coatom` and `is_compl.is_coatom_if_is_atom`: In a modular
  bounded lattice, a complement of an atom is a coatom and vice versa.
  * ``is_atomic_iff_is_coatomic`: A modular complemented lattice is atomic iff it is coatomic.

-/

variable {α : Type*}

section atoms

section is_atom

/-- An atom of an `order_bot` is an element with no other element between it and `⊥`,
  which is not `⊥`. -/
def is_atom [preorder α] [order_bot α] (a : α) : Prop := a ≠ ⊥ ∧ (∀ b, b < a → b = ⊥)

variables [partial_order α] [order_bot α] {a b x : α}

lemma eq_bot_or_eq_of_le_atom (ha : is_atom a) (hab : b ≤ a) : b = ⊥ ∨ b = a :=
hab.lt_or_eq.imp_left (ha.2 b)

lemma is_atom.Iic (ha : is_atom a) (hax : a ≤ x) : is_atom (⟨a, hax⟩ : set.Iic x) :=
⟨λ con, ha.1 (subtype.mk_eq_mk.1 con), λ ⟨b, hb⟩ hba, subtype.mk_eq_mk.2 (ha.2 b hba)⟩

lemma is_atom.of_is_atom_coe_Iic {a : set.Iic x} (ha : is_atom a) : is_atom (a : α) :=
⟨λ con, ha.1 (subtype.ext con), λ b hba, subtype.mk_eq_mk.1 (ha.2 ⟨b, hba.le.trans a.prop⟩ hba)⟩

@[simp] lemma bot_covers_iff : ⊥ ⋖ a ↔ is_atom a :=
⟨λ h, ⟨h.lt.ne', λ b hba, not_not.1 $ λ hb, h.2 (ne.bot_lt hb) hba⟩,
  λ h, ⟨h.1.bot_lt, λ b hb hba, hb.ne' $ h.2 _ hba⟩⟩

alias bot_covers_iff ↔ covers.is_atom is_atom.bot_covers

end is_atom

section is_coatom

/-- A coatom of an `order_top` is an element with no other element between it and `⊤`,
  which is not `⊤`. -/
def is_coatom [preorder α] [order_top α] (a : α) : Prop := a ≠ ⊤ ∧ (∀ b, a < b → b = ⊤)

variables [partial_order α] [order_top α] {a b x : α}

lemma eq_top_or_eq_of_coatom_le (ha : is_coatom a) (hab : a ≤ b) : b = ⊤ ∨ b = a :=
hab.lt_or_eq.imp (ha.2 b) eq_comm.2

lemma is_coatom.Ici (ha : is_coatom a) (hax : x ≤ a) : is_coatom (⟨a, hax⟩ : set.Ici x) :=
⟨λ con, ha.1 (subtype.mk_eq_mk.1 con), λ ⟨b, hb⟩ hba, subtype.mk_eq_mk.2 (ha.2 b hba)⟩

lemma is_coatom.of_is_coatom_coe_Ici {a : set.Ici x} (ha : is_coatom a) :
  is_coatom (a : α) :=
⟨λ con, ha.1 (subtype.ext con), λ b hba, subtype.mk_eq_mk.1 (ha.2 ⟨b, le_trans a.prop hba.le⟩ hba)⟩

@[simp] lemma covers_top_iff : a ⋖ ⊤ ↔ is_coatom a :=
⟨λ h, ⟨h.ne, λ b hab, not_not.1 $ λ hb, h.2 hab $ ne.lt_top hb⟩,
  λ h, ⟨h.1.lt_top, λ b hab hb, hb.ne $ h.2 _ hab⟩⟩

alias covers_top_iff ↔ covers.is_coatom is_coatom.covers_top

end is_coatom

section pairwise

lemma is_atom.inf_eq_bot_of_ne [semilattice_inf α] [order_bot α] {a b : α}
  (ha : is_atom a) (hb : is_atom b) (hab : a ≠ b) : a ⊓ b = ⊥ :=
or.elim (eq_bot_or_eq_of_le_atom ha inf_le_left) id
  (λ h1, or.elim (eq_bot_or_eq_of_le_atom hb inf_le_right) id
  (λ h2, false.rec _ (hab (le_antisymm (inf_eq_left.mp h1) (inf_eq_right.mp h2)))))

lemma is_atom.disjoint_of_ne [semilattice_inf α] [order_bot α] {a b : α}
  (ha : is_atom a) (hb : is_atom b) (hab : a ≠ b) : disjoint a b :=
disjoint_iff.mpr (is_atom.inf_eq_bot_of_ne ha hb hab)

lemma is_coatom.sup_eq_top_of_ne [semilattice_sup α] [order_top α] {a b : α}
  (ha : is_coatom a) (hb : is_coatom b) (hab : a ≠ b) : a ⊔ b = ⊤ :=
or.elim (eq_top_or_eq_of_coatom_le ha le_sup_left) id
  (λ h1, or.elim (eq_top_or_eq_of_coatom_le hb le_sup_right) id
  (λ h2, false.rec _ (hab (le_antisymm (sup_eq_right.mp h2) (sup_eq_left.mp h1)))))

end pairwise

variables [partial_order α] {a : α}

@[simp]
lemma is_coatom_dual_iff_is_atom [order_bot α] :
  is_coatom (order_dual.to_dual a) ↔ is_atom a :=
iff.rfl

@[simp]
lemma is_atom_dual_iff_is_coatom [order_top α] :
  is_atom (order_dual.to_dual a) ↔ is_coatom a :=
iff.rfl

end atoms

section atomic

variables [partial_order α] (α)

/-- A lattice is atomic iff every element other than `⊥` has an atom below it. -/
class is_atomic [order_bot α] : Prop :=
(eq_bot_or_exists_atom_le : ∀ (b : α), b = ⊥ ∨ ∃ (a : α), is_atom a ∧ a ≤ b)

/-- A lattice is coatomic iff every element other than `⊤` has a coatom above it. -/
class is_coatomic [order_top α] : Prop :=
(eq_top_or_exists_le_coatom : ∀ (b : α), b = ⊤ ∨ ∃ (a : α), is_coatom a ∧ b ≤ a)

export is_atomic (eq_bot_or_exists_atom_le) is_coatomic (eq_top_or_exists_le_coatom)

variable {α}

@[simp] theorem is_coatomic_dual_iff_is_atomic [order_bot α] :
  is_coatomic (order_dual α) ↔ is_atomic α :=
⟨λ h, ⟨λ b, by apply h.eq_top_or_exists_le_coatom⟩, λ h, ⟨λ b, by apply h.eq_bot_or_exists_atom_le⟩⟩

@[simp] theorem is_atomic_dual_iff_is_coatomic [order_top α] :
  is_atomic (order_dual α) ↔ is_coatomic α :=
⟨λ h, ⟨λ b, by apply h.eq_bot_or_exists_atom_le⟩, λ h, ⟨λ b, by apply h.eq_top_or_exists_le_coatom⟩⟩

namespace is_atomic

variables [order_bot α] [is_atomic α]

instance is_coatomic_dual : is_coatomic (order_dual α) :=
is_coatomic_dual_iff_is_atomic.2 ‹is_atomic α›

instance {x : α} : is_atomic (set.Iic x) :=
⟨λ ⟨y, hy⟩, (eq_bot_or_exists_atom_le y).imp subtype.mk_eq_mk.2
  (λ ⟨a, ha, hay⟩, ⟨⟨a, hay.trans hy⟩, ha.Iic (hay.trans hy), hay⟩)⟩

end is_atomic

namespace is_coatomic

variables [order_top α] [is_coatomic α]

instance is_coatomic : is_atomic (order_dual α) :=
is_atomic_dual_iff_is_coatomic.2 ‹is_coatomic α›

instance {x : α} : is_coatomic (set.Ici x) :=
⟨λ ⟨y, hy⟩, (eq_top_or_exists_le_coatom y).imp subtype.mk_eq_mk.2
  (λ ⟨a, ha, hay⟩, ⟨⟨a, le_trans hy hay⟩, ha.Ici (le_trans hy hay), hay⟩)⟩

end is_coatomic

theorem is_atomic_iff_forall_is_atomic_Iic [order_bot α] :
  is_atomic α ↔ ∀ (x : α), is_atomic (set.Iic x) :=
⟨@is_atomic.set.Iic.is_atomic _ _ _, λ h, ⟨λ x, ((@eq_bot_or_exists_atom_le _ _ _ (h x))
  (⊤ : set.Iic x)).imp subtype.mk_eq_mk.1 (exists_imp_exists' coe
  (λ ⟨a, ha⟩, and.imp_left (is_atom.of_is_atom_coe_Iic)))⟩⟩

theorem is_coatomic_iff_forall_is_coatomic_Ici [order_top α] :
  is_coatomic α ↔ ∀ (x : α), is_coatomic (set.Ici x) :=
is_atomic_dual_iff_is_coatomic.symm.trans $ is_atomic_iff_forall_is_atomic_Iic.trans $ forall_congr
  (λ x, is_coatomic_dual_iff_is_atomic.symm.trans iff.rfl)

end atomic

section atomistic

variables (α) [complete_lattice α]

/-- A lattice is atomistic iff every element is a `Sup` of a set of atoms. -/
class is_atomistic : Prop :=
(eq_Sup_atoms : ∀ (b : α), ∃ (s : set α), b = Sup s ∧ ∀ a, a ∈ s → is_atom a)

/-- A lattice is coatomistic iff every element is an `Inf` of a set of coatoms. -/
class is_coatomistic : Prop :=
(eq_Inf_coatoms : ∀ (b : α), ∃ (s : set α), b = Inf s ∧ ∀ a, a ∈ s → is_coatom a)

export is_atomistic (eq_Sup_atoms) is_coatomistic (eq_Inf_coatoms)

variable {α}

@[simp]
theorem is_coatomistic_dual_iff_is_atomistic : is_coatomistic (order_dual α) ↔ is_atomistic α :=
⟨λ h, ⟨λ b, by apply h.eq_Inf_coatoms⟩, λ h, ⟨λ b, by apply h.eq_Sup_atoms⟩⟩

@[simp]
theorem is_atomistic_dual_iff_is_coatomistic : is_atomistic (order_dual α) ↔ is_coatomistic α :=
⟨λ h, ⟨λ b, by apply h.eq_Sup_atoms⟩, λ h, ⟨λ b, by apply h.eq_Inf_coatoms⟩⟩

namespace is_atomistic

instance is_coatomistic_dual [h : is_atomistic α] : is_coatomistic (order_dual α) :=
is_coatomistic_dual_iff_is_atomistic.2 h

variable [is_atomistic α]

@[priority 100]
instance : is_atomic α :=
⟨λ b, by { rcases eq_Sup_atoms b with ⟨s, rfl, hs⟩,
  cases s.eq_empty_or_nonempty with h h,
  { simp [h] },
  { exact or.intro_right _ ⟨h.some, hs _ h.some_spec, le_Sup h.some_spec⟩ } } ⟩

end is_atomistic

section is_atomistic
variables [is_atomistic α]

@[simp]
theorem Sup_atoms_le_eq (b : α) : Sup {a : α | is_atom a ∧ a ≤ b} = b :=
begin
  rcases eq_Sup_atoms b with ⟨s, rfl, hs⟩,
  exact le_antisymm (Sup_le (λ _, and.right)) (Sup_le_Sup (λ a ha, ⟨hs a ha, le_Sup ha⟩)),
end

@[simp]
theorem Sup_atoms_eq_top : Sup {a : α | is_atom a} = ⊤ :=
begin
  refine eq.trans (congr rfl (set.ext (λ x, _))) (Sup_atoms_le_eq ⊤),
  exact (and_iff_left le_top).symm,
end

theorem le_iff_atom_le_imp {a b : α} :
  a ≤ b ↔ ∀ c : α, is_atom c → c ≤ a → c ≤ b :=
⟨λ ab c hc ca, le_trans ca ab, λ h, begin
  rw [← Sup_atoms_le_eq a, ← Sup_atoms_le_eq b],
  exact Sup_le_Sup (λ c hc, ⟨hc.1, h c hc.1 hc.2⟩),
end⟩

end is_atomistic

namespace is_coatomistic

instance is_atomistic_dual [h : is_coatomistic α] : is_atomistic (order_dual α) :=
is_atomistic_dual_iff_is_coatomistic.2 h

variable [is_coatomistic α]

@[priority 100]
instance : is_coatomic α :=
⟨λ b, by { rcases eq_Inf_coatoms b with ⟨s, rfl, hs⟩,
  cases s.eq_empty_or_nonempty with h h,
  { simp [h] },
  { exact or.intro_right _ ⟨h.some, hs _ h.some_spec, Inf_le h.some_spec⟩ } } ⟩

end is_coatomistic
end atomistic

/-- An order is simple iff it has exactly two elements, `⊥` and `⊤`. -/
class is_simple_order (α : Type*) [has_le α] [bounded_order α] extends nontrivial α : Prop :=
(eq_bot_or_eq_top : ∀ (a : α), a = ⊥ ∨ a = ⊤)

export is_simple_order (eq_bot_or_eq_top)

theorem is_simple_order_iff_is_simple_order_order_dual [has_le α] [bounded_order α] :
  is_simple_order α ↔ is_simple_order (order_dual α) :=
begin
  split; intro i; haveI := i,
  { exact { exists_pair_ne := @exists_pair_ne α _,
      eq_bot_or_eq_top := λ a, or.symm (eq_bot_or_eq_top ((order_dual.of_dual a)) : _ ∨ _) } },
  { exact { exists_pair_ne := @exists_pair_ne (order_dual α) _,
      eq_bot_or_eq_top := λ a, or.symm (eq_bot_or_eq_top (order_dual.to_dual a)) } }
end

lemma is_simple_order.bot_ne_top [has_le α] [bounded_order α] [is_simple_order α] :
  (⊥ : α) ≠ (⊤ : α) :=
begin
  obtain ⟨a, b, h⟩ := exists_pair_ne α,
  rcases eq_bot_or_eq_top a with rfl|rfl;
  rcases eq_bot_or_eq_top b with rfl|rfl;
  simpa <|> simpa using h.symm
end

section is_simple_order

variables [partial_order α] [bounded_order α] [is_simple_order α]

instance {α} [has_le α] [bounded_order α] [is_simple_order α] : is_simple_order (order_dual α) :=
is_simple_order_iff_is_simple_order_order_dual.1 (by apply_instance)

/-- A simple `bounded_order` induces a preorder. This is not an instance to prevent loops. -/
protected def is_simple_order.preorder {α} [has_le α] [bounded_order α] [is_simple_order α] :
  preorder α :=
{ le := (≤),
  le_refl := λ a, by rcases eq_bot_or_eq_top a with rfl|rfl; simp,
  le_trans := λ a b c, begin
    rcases eq_bot_or_eq_top a with rfl|rfl,
    { simp },
    { rcases eq_bot_or_eq_top b with rfl|rfl,
      { rcases eq_bot_or_eq_top c with rfl|rfl; simp },
      { simp } }
  end }

/-- A simple partial ordered `bounded_order` induces a linear order.
This is not an instance to prevent loops. -/
protected def is_simple_order.linear_order [decidable_eq α] : linear_order α :=
{ le_total := λ a b, by rcases eq_bot_or_eq_top a with rfl|rfl; simp,
  decidable_le := λ a b, if ha : a = ⊥ then is_true (ha.le.trans bot_le) else
    if hb : b = ⊤ then is_true (le_top.trans hb.ge) else
      is_false (λ H, hb (top_unique
        (le_trans (top_le_iff.mpr (or.resolve_left (eq_bot_or_eq_top a) ha)) H))),
  decidable_eq := by assumption,
  ..(infer_instance : partial_order α) }

@[simp] lemma is_atom_top : is_atom (⊤ : α) :=
⟨top_ne_bot, λ a ha, or.resolve_right (eq_bot_or_eq_top a) (ne_of_lt ha)⟩

@[simp] lemma is_coatom_bot : is_coatom (⊥ : α) := is_atom_dual_iff_is_coatom.1 is_atom_top

lemma bot_covers_top : (⊥ : α) ⋖ ⊤ := is_atom_top.bot_covers

end is_simple_order

namespace is_simple_order
section preorder
variables [preorder α] [bounded_order α] [is_simple_order α] {a b : α} (h : a < b)

lemma eq_bot_of_lt : a = ⊥ := (is_simple_order.eq_bot_or_eq_top _).resolve_right h.ne_top
lemma eq_top_of_lt : b = ⊤ := (is_simple_order.eq_bot_or_eq_top _).resolve_left h.ne_bot

alias eq_bot_of_lt ← has_lt.lt.eq_bot
alias eq_top_of_lt ← has_lt.lt.eq_top

end preorder

section bounded_order

variables [lattice α] [bounded_order α] [is_simple_order α]

/-- A simple partial ordered `bounded_order` induces a lattice.
This is not an instance to prevent loops -/
protected def lattice {α} [decidable_eq α] [partial_order α] [bounded_order α]
  [is_simple_order α] : lattice α :=
@linear_order.to_lattice α (is_simple_order.linear_order)

/-- A lattice that is a `bounded_order` is a distributive lattice.
This is not an instance to prevent loops -/
protected def distrib_lattice : distrib_lattice α :=
{ le_sup_inf := λ x y z, by { rcases eq_bot_or_eq_top x with rfl | rfl; simp },
  .. (infer_instance : lattice α) }

@[priority 100] -- see Note [lower instance priority]
instance : is_atomic α :=
⟨λ b, (eq_bot_or_eq_top b).imp_right (λ h, ⟨⊤, ⟨is_atom_top, ge_of_eq h⟩⟩)⟩

@[priority 100] -- see Note [lower instance priority]
instance : is_coatomic α := is_atomic_dual_iff_is_coatomic.1 is_simple_order.is_atomic

end bounded_order

/- It is important that in this section `is_simple_order` is the last type-class argument. -/
section decidable_eq

variables [decidable_eq α] [partial_order α] [bounded_order α] [is_simple_order α]

/-- Every simple lattice is isomorphic to `bool`, regardless of order. -/
@[simps] def equiv_bool {α} [decidable_eq α] [has_le α] [bounded_order α] [is_simple_order α] :
  α ≃ bool :=
{ to_fun := λ x, x = ⊤,
  inv_fun := λ x, cond x ⊤ ⊥,
  left_inv := λ x, by { rcases (eq_bot_or_eq_top x) with rfl | rfl; simp [bot_ne_top] },
  right_inv := λ x, by { cases x; simp [bot_ne_top] } }

/-- Every simple lattice over a partial order is order-isomorphic to `bool`. -/
def order_iso_bool : α ≃o bool :=
{ map_rel_iff' := λ a b, begin
    rcases (eq_bot_or_eq_top a) with rfl | rfl,
    { simp [bot_ne_top] },
    { rcases (eq_bot_or_eq_top b) with rfl | rfl,
      { simp [bot_ne_top.symm, bot_ne_top, bool.ff_lt_tt] },
      { simp [bot_ne_top] } }
  end,
  ..equiv_bool }

/- It is important that `is_simple_order` is the last type-class argument of this instance,
so that type-class inference fails quickly if it doesn't apply. -/
@[priority 200]
instance {α} [decidable_eq α] [has_le α] [bounded_order α] [is_simple_order α] : fintype α :=
fintype.of_equiv bool equiv_bool.symm

/-- A simple `bounded_order` is also a `boolean_algebra`. -/
protected def boolean_algebra {α} [decidable_eq α] [lattice α] [bounded_order α]
  [is_simple_order α] : boolean_algebra α :=
{ compl := λ x, if x = ⊥ then ⊤ else ⊥,
  sdiff := λ x y, if x = ⊤ ∧ y = ⊥ then ⊤ else ⊥,
  sdiff_eq := λ x y, by rcases eq_bot_or_eq_top x with rfl | rfl;
      simp [bot_ne_top, has_sdiff.sdiff, compl],
  inf_compl_le_bot := λ x, begin
      rcases eq_bot_or_eq_top x with rfl | rfl,
      { simp },
      { simp only [top_inf_eq],
        split_ifs with h h;
        simp [h] }
    end,
  top_le_sup_compl := λ x, by rcases eq_bot_or_eq_top x with rfl | rfl; simp,
  sup_inf_sdiff := λ x y, by rcases eq_bot_or_eq_top x with rfl | rfl;
      rcases eq_bot_or_eq_top y with rfl | rfl; simp [bot_ne_top],
  inf_inf_sdiff := λ x y, begin
      rcases eq_bot_or_eq_top x with rfl | rfl,
      { simpa },
      rcases eq_bot_or_eq_top y with rfl | rfl,
      { simpa },
      { simp only [true_and, top_inf_eq, eq_self_iff_true],
        split_ifs with h h;
        simpa [h] }
    end,
  .. (show bounded_order α, by apply_instance),
  .. is_simple_order.distrib_lattice }

end decidable_eq

variables [lattice α] [bounded_order α] [is_simple_order α]
open_locale classical

/-- A simple `bounded_order` is also complete. -/
protected noncomputable def complete_lattice : complete_lattice α :=
{ Sup := λ s, if ⊤ ∈ s then ⊤ else ⊥,
  Inf := λ s, if ⊥ ∈ s then ⊥ else ⊤,
  le_Sup := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { exact bot_le },
    { rw if_pos h } },
  Sup_le := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { rw if_neg,
      intro con,
      exact bot_ne_top (eq_top_iff.2 (h ⊤ con)) },
    { exact le_top } },
  Inf_le := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { rw if_pos h },
    { exact le_top } },
  le_Inf := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { exact bot_le },
    { rw if_neg,
      intro con,
      exact top_ne_bot (eq_bot_iff.2 (h ⊥ con)) } },
  .. (infer_instance : lattice α),
  .. (infer_instance : bounded_order α) }

/-- A simple `bounded_order` is also a `complete_boolean_algebra`. -/
protected noncomputable def complete_boolean_algebra : complete_boolean_algebra α :=
{ infi_sup_le_sup_Inf := λ x s, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { simp only [bot_sup_eq, ← Inf_eq_infi], exact le_rfl },
    { simp only [top_sup_eq, le_top] }, },
  inf_Sup_le_supr_inf := λ x s, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { simp only [bot_inf_eq, bot_le] },
    { simp only [top_inf_eq, ← Sup_eq_supr], exact le_rfl } },
  .. is_simple_order.complete_lattice,
  .. is_simple_order.boolean_algebra }

end is_simple_order

namespace is_simple_order
variables [complete_lattice α] [is_simple_order α]
set_option default_priority 100

instance : is_atomistic α :=
⟨λ b, (eq_bot_or_eq_top b).elim
  (λ h, ⟨∅, ⟨h.trans Sup_empty.symm, λ a ha, false.elim (set.not_mem_empty _ ha)⟩⟩)
  (λ h, ⟨{⊤}, h.trans Sup_singleton.symm, λ a ha, (set.mem_singleton_iff.1 ha).symm ▸ is_atom_top⟩)⟩

instance : is_coatomistic α := is_atomistic_dual_iff_is_coatomistic.1 is_simple_order.is_atomistic

end is_simple_order
namespace fintype
namespace is_simple_order
variables [partial_order α] [bounded_order α] [is_simple_order α] [decidable_eq α]

lemma univ : (finset.univ : finset α) = {⊤, ⊥} :=
begin
  change finset.map _ (finset.univ : finset bool) = _,
  rw fintype.univ_bool,
  simp only [finset.map_insert, function.embedding.coe_fn_mk, finset.map_singleton],
  refl,
end

lemma card : fintype.card α = 2 :=
(fintype.of_equiv_card _).trans fintype.card_bool

end is_simple_order
end fintype

namespace bool

instance : is_simple_order bool :=
⟨λ a, begin
  rw [← finset.mem_singleton, or.comm, ← finset.mem_insert,
      top_eq_tt, bot_eq_ff, ← fintype.univ_bool],
  apply finset.mem_univ,
end⟩

end bool

theorem is_simple_order_iff_is_atom_top [partial_order α] [bounded_order α] :
  is_simple_order α ↔ is_atom (⊤ : α) :=
⟨λ h, @is_atom_top _ _ _ h, λ h,
  { exists_pair_ne := ⟨⊤, ⊥, h.1⟩,
    eq_bot_or_eq_top := λ a, ((eq_or_lt_of_le le_top).imp_right (h.2 a)).symm }⟩

theorem is_simple_order_iff_is_coatom_bot [partial_order α] [bounded_order α] :
  is_simple_order α ↔ is_coatom (⊥ : α) :=
is_simple_order_iff_is_simple_order_order_dual.trans is_simple_order_iff_is_atom_top

namespace set

theorem is_simple_order_Iic_iff_is_atom [partial_order α] [bounded_order α] {a : α} :
  is_simple_order (Iic a) ↔ is_atom a :=
is_simple_order_iff_is_atom_top.trans $ and_congr (not_congr subtype.mk_eq_mk)
  ⟨λ h b ab, subtype.mk_eq_mk.1 (h ⟨b, le_of_lt ab⟩ ab),
    λ h ⟨b, hab⟩ hbotb, subtype.mk_eq_mk.2 (h b (subtype.mk_lt_mk.1 hbotb))⟩

theorem is_simple_order_Ici_iff_is_coatom [partial_order α] [bounded_order α] {a : α} :
  is_simple_order (Ici a) ↔ is_coatom a :=
is_simple_order_iff_is_coatom_bot.trans $ and_congr (not_congr subtype.mk_eq_mk)
  ⟨λ h b ab, subtype.mk_eq_mk.1 (h ⟨b, le_of_lt ab⟩ ab),
    λ h ⟨b, hab⟩ hbotb, subtype.mk_eq_mk.2 (h b (subtype.mk_lt_mk.1 hbotb))⟩

end set

namespace order_iso

variables {β : Type*}

@[simp] lemma is_atom_iff [partial_order α] [order_bot α] [partial_order β] [order_bot β]
  (f : α ≃o β) (a : α) :
  is_atom (f a) ↔ is_atom a :=
and_congr (not_congr ⟨λ h, f.injective (f.map_bot.symm ▸ h), λ h, f.map_bot ▸ (congr rfl h)⟩)
  ⟨λ h b hb, f.injective ((h (f b) ((f : α ↪o β).lt_iff_lt.2 hb)).trans f.map_bot.symm),
  λ h b hb, f.symm.injective begin
    rw f.symm.map_bot,
    apply h,
    rw [← f.symm_apply_apply a],
    exact (f.symm : β ↪o α).lt_iff_lt.2 hb,
  end⟩

@[simp] lemma is_coatom_iff [partial_order α] [order_top α] [partial_order β] [order_top β]
  (f : α ≃o β) (a : α) :
  is_coatom (f a) ↔ is_coatom a :=
f.dual.is_atom_iff a

lemma is_simple_order_iff [partial_order α] [bounded_order α] [partial_order β] [bounded_order β]
  (f : α ≃o β) :
  is_simple_order α ↔ is_simple_order β :=
by rw [is_simple_order_iff_is_atom_top, is_simple_order_iff_is_atom_top,
  ← f.is_atom_iff ⊤, f.map_top]

lemma is_simple_order [partial_order α] [bounded_order α] [partial_order β] [bounded_order β]
  [h : is_simple_order β] (f : α ≃o β) :
  is_simple_order α :=
f.is_simple_order_iff.mpr h

lemma is_atomic_iff [partial_order α] [order_bot α] [partial_order β] [order_bot β] (f : α ≃o β) :
  is_atomic α ↔ is_atomic β :=
begin
  suffices : (∀ b : α, b = ⊥ ∨ ∃ (a : α), is_atom a ∧ a ≤ b) ↔
    (∀ b : β, b = ⊥ ∨ ∃ (a : β), is_atom a ∧ a ≤ b),
  from ⟨λ ⟨p⟩, ⟨this.mp p⟩, λ ⟨p⟩, ⟨this.mpr p⟩⟩,
  apply f.to_equiv.forall_congr,
  simp_rw [rel_iso.coe_fn_to_equiv],
  intro b, apply or_congr,
  { rw [f.apply_eq_iff_eq_symm_apply, map_bot], },
  { split,
    { exact λ ⟨a, ha⟩, ⟨f a, ⟨(f.is_atom_iff a).mpr ha.1, f.le_iff_le.mpr ha.2⟩⟩, },
    { rintros ⟨b, ⟨hb1, hb2⟩⟩,
      refine ⟨f.symm b, ⟨(f.symm.is_atom_iff b).mpr hb1, _⟩⟩,
      rwa [←f.le_iff_le, f.apply_symm_apply], }, },
end

lemma is_coatomic_iff [partial_order α] [order_top α] [partial_order β] [order_top β] (f : α ≃o β) :
  is_coatomic α ↔ is_coatomic β :=
by { rw [←is_atomic_dual_iff_is_coatomic, ←is_atomic_dual_iff_is_coatomic],
  exact f.dual.is_atomic_iff }

end order_iso

section is_modular_lattice
variables [lattice α] [bounded_order α] [is_modular_lattice α]

namespace is_compl
variables {a b : α} (hc : is_compl a b)
include hc

lemma is_atom_iff_is_coatom : is_atom a ↔ is_coatom b :=
set.is_simple_order_Iic_iff_is_atom.symm.trans $ hc.Iic_order_iso_Ici.is_simple_order_iff.trans
  set.is_simple_order_Ici_iff_is_coatom

lemma is_coatom_iff_is_atom : is_coatom a ↔ is_atom b := hc.symm.is_atom_iff_is_coatom.symm

end is_compl

variables [is_complemented α]

lemma is_coatomic_of_is_atomic_of_is_complemented_of_is_modular [is_atomic α] : is_coatomic α :=
⟨λ x, begin
  rcases exists_is_compl x with ⟨y, xy⟩,
  apply (eq_bot_or_exists_atom_le y).imp _ _,
  { rintro rfl,
    exact eq_top_of_is_compl_bot xy },
  { rintro ⟨a, ha, ay⟩,
    rcases exists_is_compl (xy.symm.Iic_order_iso_Ici ⟨a, ay⟩) with ⟨⟨b, xb⟩, hb⟩,
    refine ⟨↑(⟨b, xb⟩ : set.Ici x), is_coatom.of_is_coatom_coe_Ici _, xb⟩,
    rw [← hb.is_atom_iff_is_coatom, order_iso.is_atom_iff],
    apply ha.Iic }
end⟩

lemma is_atomic_of_is_coatomic_of_is_complemented_of_is_modular [is_coatomic α] : is_atomic α :=
is_coatomic_dual_iff_is_atomic.1 is_coatomic_of_is_atomic_of_is_complemented_of_is_modular

theorem is_atomic_iff_is_coatomic : is_atomic α ↔ is_coatomic α :=
⟨λ h, @is_coatomic_of_is_atomic_of_is_complemented_of_is_modular _ _ _ _ _ h,
  λ h, @is_atomic_of_is_coatomic_of_is_complemented_of_is_modular _ _ _ _ _ h⟩

end is_modular_lattice


#check ∃ x, x > 1
#check ∃ (x y : Nat), x > y
#check ∃ x y : Nat, x > y
#check ∃ (x : Nat) (y : Nat), x > y

theorem ex1 : (∃ x y : Nat, x > y) = (∃ (x : Nat) (y : Nat), x > y) := rfl

abbrev Vector α n := { a : Array α // a.size = n }

#check Σ α n, Vector α n
#check Σ (α : Type) (n : Nat), Vector α n
#check (α : Type) × (n : Nat) × Vector α n

#check Σ' α n, Vector α n
#check Σ' (α : Type) (n : Nat), Vector α n
#check (α : Type) ×' (n : Nat) ×' Vector α n

#check @Vector
#check fun (α : Type) => Sigma fun (n : Nat) => Vector α n