/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.equiv.denumerable
import data.finset.sort

/-!
# Equivalences involving `list`-like types

This file defines some additional constructive equivalences using `encodable` and the pairing
function on `ℕ`.
-/

open nat list

namespace encodable
variables {α : Type*}

section list
variable [encodable α]

/-- Explicit encoding function for `list α` -/
def encode_list : list α → ℕ
| []     := 0
| (a::l) := succ (mkpair (encode a) (encode_list l))

/-- Explicit decoding function for `list α` -/
def decode_list : ℕ → option (list α)
| 0        := some []
| (succ v) := match unpair v, unpair_right_le v with
  | (v₁, v₂), h :=
    have v₂ < succ v, from lt_succ_of_le h,
    (::) <$> decode α v₁ <*> decode_list v₂
  end

/-- If `α` is encodable, then so is `list α`. This uses the `mkpair` and `unpair` functions from
`data.nat.pairing`. -/
instance list : encodable (list α) :=
⟨encode_list, decode_list, λ l,
  by induction l with a l IH; simp [encode_list, decode_list, unpair_mkpair, encodek, *]⟩

@[simp] theorem encode_list_nil : encode (@nil α) = 0 := rfl
@[simp] theorem encode_list_cons (a : α) (l : list α) :
  encode (a :: l) = succ (mkpair (encode a) (encode l)) := rfl

@[simp] theorem decode_list_zero : decode (list α) 0 = some [] :=
show decode_list 0 = some [], by rw decode_list

@[simp] theorem decode_list_succ (v : ℕ) :
  decode (list α) (succ v) =
  (::) <$> decode α v.unpair.1 <*> decode (list α) v.unpair.2 :=
show decode_list (succ v) = _, begin
  cases e : unpair v with v₁ v₂,
  simp [decode_list, e], refl
end

theorem length_le_encode : ∀ (l : list α), length l ≤ encode l
| [] := _root_.zero_le _
| (a :: l) := succ_le_succ $ (length_le_encode l).trans (right_le_mkpair _ _)

end list

section finset
variables [encodable α]

private def enle : α → α → Prop := encode ⁻¹'o (≤)

private lemma enle.is_linear_order : is_linear_order α enle :=
(rel_embedding.preimage ⟨encode, encode_injective⟩ (≤)).is_linear_order

private def decidable_enle (a b : α) : decidable (enle a b) :=
by unfold enle order.preimage; apply_instance

local attribute [instance] enle.is_linear_order decidable_enle

/-- Explicit encoding function for `multiset α` -/
def encode_multiset (s : multiset α) : ℕ :=
encode (s.sort enle)

/-- Explicit decoding function for `multiset α` -/
def decode_multiset (n : ℕ) : option (multiset α) :=
coe <$> decode (list α) n

/-- If `α` is encodable, then so is `multiset α`. -/
instance multiset : encodable (multiset α) :=
⟨encode_multiset, decode_multiset,
 λ s, by simp [encode_multiset, decode_multiset, encodek]⟩

end finset

/-- A listable type with decidable equality is encodable. -/
def encodable_of_list [decidable_eq α] (l : list α) (H : ∀ x, x ∈ l) : encodable α :=
⟨λ a, index_of a l, l.nth, λ a, index_of_nth (H _)⟩

def trunc_encodable_of_fintype (α : Type*) [decidable_eq α] [fintype α] : trunc (encodable α) :=
@@quot.rec_on_subsingleton _
  (λ s : multiset α, (∀ x:α, x ∈ s) → trunc (encodable α)) _
  finset.univ.1
  (λ l H, trunc.mk $ encodable_of_list l H)
  finset.mem_univ

/-- A noncomputable way to arbitrarily choose an ordering on a finite type.
  It is not made into a global instance, since it involves an arbitrary choice.
  This can be locally made into an instance with `local attribute [instance] fintype.encodable`. -/
noncomputable def _root_.fintype.encodable (α : Type*) [fintype α] : encodable α :=
by { classical, exact (encodable.trunc_encodable_of_fintype α).out }

/-- If `α` is encodable, then so is `vector α n`. -/
instance vector [encodable α] {n} : encodable (vector α n) :=
encodable.subtype

/-- If `α` is encodable, then so is `fin n → α`. -/
instance fin_arrow [encodable α] {n} : encodable (fin n → α) :=
of_equiv _ (equiv.vector_equiv_fin _ _).symm

instance fin_pi (n) (π : fin n → Type*) [∀ i, encodable (π i)] : encodable (Π i, π i) :=
of_equiv _ (equiv.pi_equiv_subtype_sigma (fin n) π)

/-- If `α` is encodable, then so is `array n α`. -/
instance array [encodable α] {n} : encodable (array n α) :=
of_equiv _ (equiv.array_equiv_fin _ _)

/-- If `α` is encodable, then so is `finset α`. -/
instance finset [encodable α] : encodable (finset α) :=
by haveI := decidable_eq_of_encodable α; exact
 of_equiv {s : multiset α // s.nodup}
  ⟨λ ⟨a, b⟩, ⟨a, b⟩, λ ⟨a, b⟩, ⟨a, b⟩, λ ⟨a, b⟩, rfl, λ ⟨a, b⟩, rfl⟩

def fintype_arrow (α : Type*) (β : Type*) [decidable_eq α] [fintype α] [encodable β] :
  trunc (encodable (α → β)) :=
(fintype.trunc_equiv_fin α).map $
  λ f, encodable.of_equiv (fin (fintype.card α) → β) $
  equiv.arrow_congr f (equiv.refl _)

def fintype_pi (α : Type*) (π : α → Type*) [decidable_eq α] [fintype α] [∀ a, encodable (π a)] :
  trunc (encodable (Π a, π a)) :=
(encodable.trunc_encodable_of_fintype α).bind $ λ a,
  (@fintype_arrow α (Σa, π a) _ _ (@encodable.sigma _ _ a _)).bind $ λ f,
  trunc.mk $ @encodable.of_equiv _ _ (@encodable.subtype _ _ f _) (equiv.pi_equiv_subtype_sigma α π)

/-- The elements of a `fintype` as a sorted list. -/
def sorted_univ (α) [fintype α] [encodable α] : list α :=
finset.univ.sort (encodable.encode' α ⁻¹'o (≤))

@[simp] theorem mem_sorted_univ {α} [fintype α] [encodable α] (x : α) : x ∈ sorted_univ α :=
(finset.mem_sort _).2 (finset.mem_univ _)

@[simp] theorem length_sorted_univ (α) [fintype α] [encodable α] :
  (sorted_univ α).length = fintype.card α :=
finset.length_sort _

@[simp] theorem sorted_univ_nodup (α) [fintype α] [encodable α] : (sorted_univ α).nodup :=
finset.sort_nodup _ _

@[simp] theorem sorted_univ_to_finset (α) [fintype α] [encodable α] [decidable_eq α] :
  (sorted_univ α).to_finset = finset.univ :=
finset.sort_to_finset _ _

/-- An encodable `fintype` is equivalent to the same size `fin`. -/
def fintype_equiv_fin {α} [fintype α] [encodable α] :
  α ≃ fin (fintype.card α) :=
begin
  haveI : decidable_eq α := encodable.decidable_eq_of_encodable _,
  transitivity,
  { exact ((sorted_univ_nodup α).nth_le_equiv_of_forall_mem_list _ mem_sorted_univ).symm },
  exact equiv.cast (congr_arg _ (length_sorted_univ α))
end

/-- If `α` and `β` are encodable and `α` is a fintype, then `α → β` is encodable as well. -/
instance fintype_arrow_of_encodable {α β : Type*} [encodable α] [fintype α] [encodable β] :
  encodable (α → β) :=
of_equiv (fin (fintype.card α) → β) $ equiv.arrow_congr fintype_equiv_fin (equiv.refl _)

end encodable

namespace denumerable
variables {α : Type*} {β : Type*} [denumerable α] [denumerable β]
open encodable

section list

theorem denumerable_list_aux : ∀ n : ℕ,
  ∃ a ∈ @decode_list α _ n, encode_list a = n
| 0        := by rw decode_list; exact ⟨_, rfl, rfl⟩
| (succ v) := begin
  cases e : unpair v with v₁ v₂,
  have h := unpair_right_le v,
  rw e at h,
  rcases have v₂ < succ v, from lt_succ_of_le h,
    denumerable_list_aux v₂ with ⟨a, h₁, h₂⟩,
  rw option.mem_def at h₁,
  use of_nat α v₁ :: a,
  simp [decode_list, e, h₂, h₁, encode_list, mkpair_unpair' e],
end

/-- If `α` is denumerable, then so is `list α`. -/
instance denumerable_list : denumerable (list α) := ⟨denumerable_list_aux⟩

@[simp] theorem list_of_nat_zero : of_nat (list α) 0 = [] :=
by rw [← @encode_list_nil α, of_nat_encode]

@[simp] theorem list_of_nat_succ (v : ℕ) :
  of_nat (list α) (succ v) =
  of_nat α v.unpair.1 :: of_nat (list α) v.unpair.2 :=
of_nat_of_decode $ show decode_list (succ v) = _,
begin
  cases e : unpair v with v₁ v₂,
  simp [decode_list, e],
  rw [show decode_list v₂ = decode (list α) v₂,
      from rfl, decode_eq_of_nat]; refl
end

end list

section multiset

/-- Outputs the list of differences of the input list, that is
`lower [a₁, a₂, ...] n = [a₁ - n, a₂ - a₁, ...]` -/
def lower : list ℕ → ℕ → list ℕ
| []       n := []
| (m :: l) n := (m - n) :: lower l m

/-- Outputs the list of partial sums of the input list, that is
`raise [a₁, a₂, ...] n = [n + a₁, n + a₁ + a₂, ...]` -/
def raise : list ℕ → ℕ → list ℕ
| []       n := []
| (m :: l) n := (m + n) :: raise l (m + n)

lemma lower_raise : ∀ l n, lower (raise l n) n = l
| []       n := rfl
| (m :: l) n := by rw [raise, lower, add_tsub_cancel_right, lower_raise]

lemma raise_lower : ∀ {l n}, list.sorted (≤) (n :: l) → raise (lower l n) n = l
| []       n h := rfl
| (m :: l) n h :=
  have n ≤ m, from list.rel_of_sorted_cons h _ (l.mem_cons_self _),
  by simp [raise, lower, tsub_add_cancel_of_le this,
           raise_lower (list.sorted_of_sorted_cons h)]

lemma raise_chain : ∀ l n, list.chain (≤) n (raise l n)
| []       n := list.chain.nil
| (m :: l) n := list.chain.cons (nat.le_add_left _ _) (raise_chain _ _)

/-- `raise l n` is an non-decreasing sequence. -/
lemma raise_sorted : ∀ l n, list.sorted (≤) (raise l n)
| []       n := list.sorted_nil
| (m :: l) n := (list.chain_iff_pairwise (@le_trans _ _)).1 (raise_chain _ _)

/-- If `α` is denumerable, then so is `multiset α`. Warning: this is *not* the same encoding as used
in `encodable.multiset`. -/
instance multiset : denumerable (multiset α) := mk' ⟨
  λ s : multiset α, encode $ lower ((s.map encode).sort (≤)) 0,
  λ n, multiset.map (of_nat α) (raise (of_nat (list ℕ) n) 0),
  λ s, by have := raise_lower
      (list.sorted_cons.2 ⟨λ n _, zero_le n, (s.map encode).sort_sorted _⟩);
    simp [-multiset.coe_map, this],
  λ n, by simp [-multiset.coe_map, list.merge_sort_eq_self _ (raise_sorted _ _), lower_raise]⟩

end multiset

section finset

/-- Outputs the list of differences minus one of the input list, that is
`lower' [a₁, a₂, a₃, ...] n = [a₁ - n, a₂ - a₁ - 1, a₃ - a₂ - 1, ...]`. -/
def lower' : list ℕ → ℕ → list ℕ
| []       n := []
| (m :: l) n := (m - n) :: lower' l (m + 1)

/-- Outputs the list of partial sums plus one of the input list, that is
`raise [a₁, a₂, a₃, ...] n = [n + a₁, n + a₁ + a₂ + 1, n + a₁ + a₂ + a₃ + 2, ...]`. Adding one each
time ensures the elements are distinct. -/
def raise' : list ℕ → ℕ → list ℕ
| []       n := []
| (m :: l) n := (m + n) :: raise' l (m + n + 1)

lemma lower_raise' : ∀ l n, lower' (raise' l n) n = l
| []       n := rfl
| (m :: l) n := by simp [raise', lower', add_tsub_cancel_right, lower_raise']

lemma raise_lower' : ∀ {l n}, (∀ m ∈ l, n ≤ m) → list.sorted (<) l → raise' (lower' l n) n = l
| []       n h₁ h₂ := rfl
| (m :: l) n h₁ h₂ :=
  have n ≤ m, from h₁ _ (l.mem_cons_self _),
  by simp [raise', lower', tsub_add_cancel_of_le this, raise_lower'
    (list.rel_of_sorted_cons h₂ : ∀ a ∈ l, m < a) (list.sorted_of_sorted_cons h₂)]

lemma raise'_chain : ∀ l {m n}, m < n → list.chain (<) m (raise' l n)
| []       m n h := list.chain.nil
| (a :: l) m n h := list.chain.cons
  (lt_of_lt_of_le h (nat.le_add_left _ _)) (raise'_chain _ (lt_succ_self _))

/-- `raise' l n` is a strictly increasing sequence. -/
lemma raise'_sorted : ∀ l n, list.sorted (<) (raise' l n)
| []       n := list.sorted_nil
| (m :: l) n := (list.chain_iff_pairwise (@lt_trans _ _)).1
  (raise'_chain _ (lt_succ_self _))

/-- Makes `raise' l n` into a finset. Elements are distinct thanks to `raise'_sorted`. -/
def raise'_finset (l : list ℕ) (n : ℕ) : finset ℕ :=
⟨raise' l n, (raise'_sorted _ _).imp (@ne_of_lt _ _)⟩

/-- If `α` is denumerable, then so is `finset α`. Warning: this is *not* the same encoding as used
in `encodable.finset`. -/
instance finset : denumerable (finset α) := mk' ⟨
  λ s : finset α, encode $ lower' ((s.map (eqv α).to_embedding).sort (≤)) 0,
  λ n, finset.map (eqv α).symm.to_embedding (raise'_finset (of_nat (list ℕ) n) 0),
  λ s, finset.eq_of_veq $ by simp [-multiset.coe_map, raise'_finset,
    raise_lower' (λ n _, zero_le n) (finset.sort_sorted_lt _)],
  λ n, by simp [-multiset.coe_map, finset.map, raise'_finset, finset.sort,
    list.merge_sort_eq_self (≤) ((raise'_sorted _ _).imp (@le_of_lt _ _)),
    lower_raise']⟩

end finset

end denumerable

namespace equiv

/-- The type lists on unit is canonically equivalent to the natural numbers. -/
def list_unit_equiv : list unit ≃ ℕ :=
{ to_fun := list.length,
  inv_fun := list.repeat (),
  left_inv := λ u, list.length_injective (by simp),
  right_inv := λ n, list.length_repeat () n }

/-- `list ℕ` is equivalent to `ℕ`. -/
def list_nat_equiv_nat : list ℕ ≃ ℕ := denumerable.eqv _

/-- If `α` is equivalent to `ℕ`, then `list α` is equivalent to `α`. -/
def list_equiv_self_of_equiv_nat {α : Type} (e : α ≃ ℕ) : list α ≃ α :=
calc list α ≃ list ℕ : list_equiv_of_equiv e
        ... ≃ ℕ      : list_nat_equiv_nat
        ... ≃ α      : e.symm

end equiv


lemma mul_one (m : mynat) : m * 1 = m :=
begin
rw one_eq_succ_zero,
rw mul_succ,
rw mul_zero,
rw zero_add,
refl,
end


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

import algebra.algebra.restrict_scalars
import algebra.algebra.subalgebra.basic
import group_theory.finiteness
import ring_theory.ideal.operations

/-!
# Finiteness conditions in commutative algebra

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

In this file we define a notion of finiteness that is common in commutative algebra.

## Main declarations

- `submodule.fg`, `ideal.fg`
  These express that some object is finitely generated as *submodule* over some base ring.

- `module.finite`, `ring_hom.finite`, `alg_hom.finite`
  all of these express that some object is finitely generated *as module* over some base ring.

## Main results

* `exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul` is Nakayama's lemma, in the following form:
  if N is a finitely generated submodule of an ambient R-module M and I is an ideal of R
  such that N ⊆ IN, then there exists r ∈ 1 + I such that rN = 0.

-/

open function (surjective)
open_locale big_operators

namespace submodule
variables {R : Type*} {M : Type*} [semiring R] [add_comm_monoid M] [module R M]

open set

/-- A submodule of `M` is finitely generated if it is the span of a finite subset of `M`. -/
def fg (N : submodule R M) : Prop := ∃ S : finset M, submodule.span R ↑S = N

theorem fg_def {N : submodule R M} :
  N.fg ↔ ∃ S : set M, S.finite ∧ span R S = N :=
⟨λ ⟨t, h⟩, ⟨_, finset.finite_to_set t, h⟩, begin
  rintro ⟨t', h, rfl⟩,
  rcases finite.exists_finset_coe h with ⟨t, rfl⟩,
  exact ⟨t, rfl⟩
end⟩

lemma fg_iff_add_submonoid_fg (P : submodule ℕ M) :
  P.fg ↔ P.to_add_submonoid.fg :=
⟨λ ⟨S, hS⟩, ⟨S, by simpa [← span_nat_eq_add_submonoid_closure] using hS⟩,
  λ ⟨S, hS⟩, ⟨S, by simpa [← span_nat_eq_add_submonoid_closure] using hS⟩⟩

lemma fg_iff_add_subgroup_fg {G : Type*} [add_comm_group G] (P : submodule ℤ G) :
  P.fg ↔ P.to_add_subgroup.fg :=
⟨λ ⟨S, hS⟩, ⟨S, by simpa [← span_int_eq_add_subgroup_closure] using hS⟩,
  λ ⟨S, hS⟩, ⟨S, by simpa [← span_int_eq_add_subgroup_closure] using hS⟩⟩

lemma fg_iff_exists_fin_generating_family {N : submodule R M} :
  N.fg ↔ ∃ (n : ℕ) (s : fin n → M), span R (range s) = N :=
begin
  rw fg_def,
  split,
  { rintros ⟨S, Sfin, hS⟩,
    obtain ⟨n, f, rfl⟩ := Sfin.fin_embedding,
    exact ⟨n, f, hS⟩, },
  { rintros ⟨n, s, hs⟩,
    refine ⟨range s, finite_range s, hs⟩ },
end

/-- **Nakayama's Lemma**. Atiyah-Macdonald 2.5, Eisenbud 4.7, Matsumura 2.2,
[Stacks 00DV](https://stacks.math.columbia.edu/tag/00DV) -/
theorem exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul {R : Type*} [comm_ring R]
  {M : Type*} [add_comm_group M] [module R M]
  (I : ideal R) (N : submodule R M) (hn : N.fg) (hin : N ≤ I • N) :
  ∃ r : R, r - 1 ∈ I ∧ ∀ n ∈ N, r • n = (0 : M) :=
begin
  rw fg_def at hn, rcases hn with ⟨s, hfs, hs⟩,
  have : ∃ r : R, r - 1 ∈ I ∧ N ≤ (I • span R s).comap (linear_map.lsmul R M r) ∧ s ⊆ N,
  { refine ⟨1, _, _, _⟩,
    { rw sub_self, exact I.zero_mem },
    { rw [hs], intros n hn, rw [mem_comap], change (1:R) • n ∈ I • N, rw one_smul, exact hin hn },
    { rw [← span_le, hs], exact le_refl N } },
  clear hin hs, revert this,
  refine set.finite.dinduction_on hfs (λ H, _) (λ i s his hfs ih H, _),
  { rcases H with ⟨r, hr1, hrn, hs⟩, refine ⟨r, hr1, λ n hn, _⟩, specialize hrn hn,
    rwa [mem_comap, span_empty, smul_bot, mem_bot] at hrn },
  apply ih, rcases H with ⟨r, hr1, hrn, hs⟩,
  rw [← set.singleton_union, span_union, smul_sup] at hrn,
  rw [set.insert_subset] at hs,
  have : ∃ c : R, c - 1 ∈ I ∧ c • i ∈ I • span R s,
  { specialize hrn hs.1, rw [mem_comap, mem_sup] at hrn,
    rcases hrn with ⟨y, hy, z, hz, hyz⟩, change y + z = r • i at hyz,
    rw mem_smul_span_singleton at hy, rcases hy with ⟨c, hci, rfl⟩,
    use r-c, split,
    { rw [sub_right_comm], exact I.sub_mem hr1 hci },
    { rw [sub_smul, ← hyz, add_sub_cancel'], exact hz } },
  rcases this with ⟨c, hc1, hci⟩, refine ⟨c * r, _, _, hs.2⟩,
  { simpa only [mul_sub, mul_one, sub_add_sub_cancel] using I.add_mem (I.mul_mem_left c hr1) hc1 },
  { intros n hn, specialize hrn hn, rw [mem_comap, mem_sup] at hrn,
    rcases hrn with ⟨y, hy, z, hz, hyz⟩, change y + z = r • n at hyz,
    rw mem_smul_span_singleton at hy, rcases hy with ⟨d, hdi, rfl⟩,
    change _ • _ ∈ I • span R s,
    rw [mul_smul, ← hyz, smul_add, smul_smul, mul_comm, mul_smul],
    exact add_mem (smul_mem _ _ hci) (smul_mem _ _ hz) }
end

theorem exists_mem_and_smul_eq_self_of_fg_of_le_smul {R : Type*} [comm_ring R]
  {M : Type*} [add_comm_group M] [module R M]
  (I : ideal R) (N : submodule R M) (hn : N.fg) (hin : N ≤ I • N) :
  ∃ r ∈ I, ∀ n ∈ N, r • n = n :=
begin
  obtain ⟨r, hr, hr'⟩ := N.exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul I hn hin,
  exact ⟨-(r-1), I.neg_mem hr, λ n hn, by simpa [sub_smul] using hr' n hn⟩,
end

theorem fg_bot : (⊥ : submodule R M).fg :=
⟨∅, by rw [finset.coe_empty, span_empty]⟩

lemma _root_.subalgebra.fg_bot_to_submodule {R A : Type*}
  [comm_semiring R] [semiring A] [algebra R A] :
  (⊥ : subalgebra R A).to_submodule.fg :=
⟨{1}, by simp [algebra.to_submodule_bot] ⟩

lemma fg_unit {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]
  (I : (submodule R A)ˣ) : (I : submodule R A).fg :=
begin
  have : (1 : A) ∈ (I * ↑I⁻¹ : submodule R A),
  { rw I.mul_inv, exact one_le.mp le_rfl },
  obtain ⟨T, T', hT, hT', one_mem⟩ := mem_span_mul_finite_of_mem_mul this,
  refine ⟨T, span_eq_of_le _ hT _⟩,
  rw [← one_mul ↑I, ← mul_one (span R ↑T)],
  conv_rhs { rw [← I.inv_mul, ← mul_assoc] },
  refine mul_le_mul_left (le_trans _ $ mul_le_mul_right $ span_le.mpr hT'),
  rwa [one_le, span_mul_span],
end

lemma fg_of_is_unit {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]
  {I : submodule R A} (hI : is_unit I) : I.fg := fg_unit hI.unit

theorem fg_span {s : set M} (hs : s.finite) : fg (span R s) :=
⟨hs.to_finset, by rw [hs.coe_to_finset]⟩

theorem fg_span_singleton (x : M) : fg (R ∙ x) :=
fg_span (finite_singleton x)

theorem fg.sup {N₁ N₂ : submodule R M}
  (hN₁ : N₁.fg) (hN₂ : N₂.fg) : (N₁ ⊔ N₂).fg :=
let ⟨t₁, ht₁⟩ := fg_def.1 hN₁, ⟨t₂, ht₂⟩ := fg_def.1 hN₂ in
fg_def.2 ⟨t₁ ∪ t₂, ht₁.1.union ht₂.1, by rw [span_union, ht₁.2, ht₂.2]⟩

lemma fg_finset_sup {ι : Type*} (s : finset ι) (N : ι → submodule R M) (h : ∀ i ∈ s, (N i).fg) :
  (s.sup N).fg :=
finset.sup_induction fg_bot (λ a ha b hb, ha.sup hb) h

lemma fg_supr {ι : Type*} [finite ι] (N : ι → submodule R M) (h : ∀ i, (N i).fg) :
  (supr N).fg :=
by { casesI nonempty_fintype ι, simpa using fg_bsupr finset.univ N (λ i hi, h i) }

variables {P : Type*} [add_comm_monoid P] [module R P]
variables (f : M →ₗ[R] P)

theorem fg.map {N : submodule R M} (hs : N.fg) : (N.map f).fg :=
let ⟨t, ht⟩ := fg_def.1 hs in fg_def.2 ⟨f '' t, ht.1.image _, by rw [span_image, ht.2]⟩

variables {f}

lemma fg_of_fg_map_injective (f : M →ₗ[R] P) (hf : function.injective f) {N : submodule R M}
  (hfn : (N.map f).fg) : N.fg :=
let ⟨t, ht⟩ := hfn in ⟨t.preimage f $ λ x _ y _ h, hf h,
submodule.map_injective_of_injective hf $ by { rw [f.map_span, finset.coe_preimage,
    set.image_preimage_eq_inter_range, set.inter_eq_self_of_subset_left, ht],
  rw [← linear_map.range_coe, ← span_le, ht, ← map_top], exact map_mono le_top }⟩

lemma fg_of_fg_map {R M P : Type*} [ring R] [add_comm_group M] [module R M]
  [add_comm_group P] [module R P] (f : M →ₗ[R] P) (hf : f.ker = ⊥) {N : submodule R M}
  (hfn : (N.map f).fg) : N.fg :=
fg_of_fg_map_injective f (linear_map.ker_eq_bot.1 hf) hfn

lemma fg_top (N : submodule R M) : (⊤ : submodule R N).fg ↔ N.fg :=
⟨λ h, N.range_subtype ▸ map_top N.subtype ▸ h.map _,
λ h, fg_of_fg_map_injective N.subtype subtype.val_injective $ by rwa [map_top, range_subtype]⟩

lemma fg_of_linear_equiv (e : M ≃ₗ[R] P) (h : (⊤ : submodule R P).fg) :
  (⊤ : submodule R M).fg :=
e.symm.range ▸ map_top (e.symm : P →ₗ[R] M) ▸ h.map _

theorem fg.prod {sb : submodule R M} {sc : submodule R P}
  (hsb : sb.fg) (hsc : sc.fg) : (sb.prod sc).fg :=
let ⟨tb, htb⟩ := fg_def.1 hsb, ⟨tc, htc⟩ := fg_def.1 hsc in
fg_def.2 ⟨linear_map.inl R M P '' tb ∪ linear_map.inr R M P '' tc,
  (htb.1.image _).union (htc.1.image _),
  by rw [linear_map.span_inl_union_inr, htb.2, htc.2]⟩

theorem fg_pi {ι : Type*} {M : ι → Type*} [finite ι] [Π i, add_comm_monoid (M i)]
  [Π i, module R (M i)] {p : Π i, submodule R (M i)} (hsb : ∀ i, (p i).fg) :
  (submodule.pi set.univ p).fg :=
begin
  classical,
  simp_rw fg_def at hsb ⊢,
  choose t htf hts using hsb,
  refine ⟨
    ⋃ i, (linear_map.single i : _ →ₗ[R] _) '' t i, set.finite_Union $ λ i, (htf i).image _, _⟩,
  simp_rw [span_Union, span_image, hts, submodule.supr_map_single],
end

/-- If 0 → M' → M → M'' → 0 is exact and M' and M'' are
finitely generated then so is M. -/
theorem fg_of_fg_map_of_fg_inf_ker {R M P : Type*} [ring R] [add_comm_group M] [module R M]
  [add_comm_group P] [module R P] (f : M →ₗ[R] P)
  {s : submodule R M} (hs1 : (s.map f).fg) (hs2 : (s ⊓ f.ker).fg) : s.fg :=
begin
  haveI := classical.dec_eq R, haveI := classical.dec_eq M, haveI := classical.dec_eq P,
  cases hs1 with t1 ht1, cases hs2 with t2 ht2,
  have : ∀ y ∈ t1, ∃ x ∈ s, f x = y,
  { intros y hy,
    have : y ∈ map f s, { rw ← ht1, exact subset_span hy },
    rcases mem_map.1 this with ⟨x, hx1, hx2⟩,
    exact ⟨x, hx1, hx2⟩ },
  have : ∃ g : P → M, ∀ y ∈ t1, g y ∈ s ∧ f (g y) = y,
  { choose g hg1 hg2,
    existsi λ y, if H : y ∈ t1 then g y H else 0,
    intros y H, split,
    { simp only [dif_pos H], apply hg1 },
    { simp only [dif_pos H], apply hg2 } },
  cases this with g hg, clear this,
  existsi t1.image g ∪ t2,
  rw [finset.coe_union, span_union, finset.coe_image],
  apply le_antisymm,
  { refine sup_le (span_le.2 $ image_subset_iff.2 _) (span_le.2 _),
    { intros y hy, exact (hg y hy).1 },
    { intros x hx, have := subset_span hx,
      rw ht2 at this,
      exact this.1 } },
  intros x hx,
  have : f x ∈ map f s, { rw mem_map, exact ⟨x, hx, rfl⟩ },
  rw [← ht1,← set.image_id ↑t1, finsupp.mem_span_image_iff_total] at this,
  rcases this with ⟨l, hl1, hl2⟩,
  refine mem_sup.2 ⟨(finsupp.total M M R id).to_fun
    ((finsupp.lmap_domain R R g : (P →₀ R) → M →₀ R) l), _,
    x - finsupp.total M M R id ((finsupp.lmap_domain R R g : (P →₀ R) → M →₀ R) l),
    _, add_sub_cancel'_right _ _⟩,
  { rw [← set.image_id (g '' ↑t1), finsupp.mem_span_image_iff_total], refine ⟨_, _, rfl⟩,
    haveI : inhabited P := ⟨0⟩,
    rw [← finsupp.lmap_domain_supported _ _ g, mem_map],
    refine ⟨l, hl1, _⟩,
    refl, },
  rw [ht2, mem_inf], split,
  { apply s.sub_mem hx,
    rw [finsupp.total_apply, finsupp.lmap_domain_apply, finsupp.sum_map_domain_index],
    refine s.sum_mem _,
    { intros y hy, exact s.smul_mem _ (hg y (hl1 hy)).1 },
    { exact zero_smul _ }, { exact λ _ _ _, add_smul _ _ _ } },
  { rw [linear_map.mem_ker, f.map_sub, ← hl2],
    rw [finsupp.total_apply, finsupp.total_apply, finsupp.lmap_domain_apply],
    rw [finsupp.sum_map_domain_index, finsupp.sum, finsupp.sum, f.map_sum],
    rw sub_eq_zero,
    refine finset.sum_congr rfl (λ y hy, _),
    unfold id,
    rw [f.map_smul, (hg y (hl1 hy)).2],
    { exact zero_smul _ }, { exact λ _ _ _, add_smul _ _ _ } }
end

lemma fg_induction (R M : Type*) [semiring R] [add_comm_monoid M] [module R M]
  (P : submodule R M → Prop)
  (h₁ : ∀ x, P (submodule.span R {x})) (h₂ : ∀ M₁ M₂, P M₁ → P M₂ → P (M₁ ⊔ M₂))
  (N : submodule R M) (hN : N.fg) : P N :=
begin
  classical,
  obtain ⟨s, rfl⟩ := hN,
  induction s using finset.induction,
  { rw [finset.coe_empty, submodule.span_empty, ← submodule.span_zero_singleton], apply h₁ },
  { rw [finset.coe_insert, submodule.span_insert], apply h₂; apply_assumption }
end

/-- The kernel of the composition of two linear maps is finitely generated if both kernels are and
the first morphism is surjective. -/
lemma fg_ker_comp {R M N P : Type*} [ring R] [add_comm_group M] [module R M]
  [add_comm_group N] [module R N] [add_comm_group P] [module R P] (f : M →ₗ[R] N)
  (g : N →ₗ[R] P) (hf1 : f.ker.fg) (hf2 : g.ker.fg) (hsur : function.surjective f) :
  (g.comp f).ker.fg :=
begin
  rw linear_map.ker_comp,
  apply fg_of_fg_map_of_fg_inf_ker f,
  { rwa [submodule.map_comap_eq, linear_map.range_eq_top.2 hsur, top_inf_eq] },
  { rwa [inf_of_le_right (show f.ker ≤ (comap f g.ker), from comap_mono bot_le)] }
end

lemma fg_restrict_scalars {R S M : Type*} [comm_semiring R] [semiring S] [algebra R S]
  [add_comm_group M] [module S M] [module R M] [is_scalar_tower R S M] (N : submodule S M)
  (hfin : N.fg) (h : function.surjective (algebra_map R S)) : (submodule.restrict_scalars R N).fg :=
begin
  obtain ⟨X, rfl⟩ := hfin,
  use X,
  exact (submodule.restrict_scalars_span R S h ↑X).symm
end

lemma fg.stablizes_of_supr_eq {M' : submodule R M} (hM' : M'.fg)
  (N : ℕ →o submodule R M) (H : supr N = M') : ∃ n, M' = N n :=
begin
  obtain ⟨S, hS⟩ := hM',
  have : ∀ s : S, ∃ n, (s : M) ∈ N n :=
    λ s, (submodule.mem_supr_of_chain N s).mp
      (by { rw [H, ← hS], exact submodule.subset_span s.2 }),
  choose f hf,
  use S.attach.sup f,
  apply le_antisymm,
  { conv_lhs { rw ← hS },
    rw submodule.span_le,
    intros s hs,
    exact N.2 (finset.le_sup $ S.mem_attach ⟨s, hs⟩) (hf _) },
  { rw ← H, exact le_supr _ _ }
end

/-- Finitely generated submodules are precisely compact elements in the submodule lattice. -/
theorem fg_iff_compact (s : submodule R M) : s.fg ↔ complete_lattice.is_compact_element s :=
begin
  classical,
  -- Introduce shorthand for span of an element
  let sp : M → submodule R M := λ a, span R {a},
  -- Trivial rewrite lemma; a small hack since simp (only) & rw can't accomplish this smoothly.
  have supr_rw : ∀ t : finset M, (⨆ x ∈ t, sp x) = (⨆ x ∈ (↑t : set M), sp x), from λ t, by refl,
  split,
  { rintro ⟨t, rfl⟩,
    rw [span_eq_supr_of_singleton_spans, ←supr_rw, ←(finset.sup_eq_supr t sp)],
    apply complete_lattice.finset_sup_compact_of_compact,
    exact λ n _, singleton_span_is_compact_element n, },
  { intro h,
    -- s is the Sup of the spans of its elements.
    have sSup : s = Sup (sp '' ↑s),
    by rw [Sup_eq_supr, supr_image, ←span_eq_supr_of_singleton_spans, eq_comm, span_eq],
    -- by h, s is then below (and equal to) the sup of the spans of finitely many elements.
    obtain ⟨u, ⟨huspan, husup⟩⟩ := h (sp '' ↑s) (le_of_eq sSup),
    have ssup : s = u.sup id,
    { suffices : u.sup id ≤ s, from le_antisymm husup this,
      rw [sSup, finset.sup_id_eq_Sup], exact Sup_le_Sup huspan, },
    obtain ⟨t, ⟨hts, rfl⟩⟩ := finset.subset_image_iff.mp huspan,
    rw [finset.sup_finset_image, function.comp.left_id, finset.sup_eq_supr, supr_rw,
      ←span_eq_supr_of_singleton_spans, eq_comm] at ssup,
    exact ⟨t, ssup⟩, },
end

end submodule

namespace submodule

section map₂
variables {R M N P : Type*}
variables [comm_semiring R] [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid P]
variables [module R M] [module R N] [module R P]

theorem fg.map₂ (f : M →ₗ[R] N →ₗ[R] P) {p : submodule R M} {q : submodule R N}
  (hp : p.fg) (hq : q.fg) : (map₂ f p q).fg :=
let ⟨sm, hfm, hm⟩ := fg_def.1 hp, ⟨sn, hfn, hn⟩ := fg_def.1 hq in
fg_def.2 ⟨set.image2 (λ m n, f m n) sm sn,
  hfm.image2 _ hfn, map₂_span_span R f sm sn ▸ hm ▸ hn ▸ rfl⟩

end map₂

section mul
variables {R : Type*} {A : Type*} [comm_semiring R] [semiring A] [algebra R A]
variables {M N : submodule R A}

theorem fg.mul (hm : M.fg) (hn : N.fg) : (M * N).fg := hm.map₂ _ hn

lemma fg.pow (h : M.fg) (n : ℕ) : (M ^ n).fg :=
nat.rec_on n
  (⟨{1}, by simp [one_eq_span]⟩)
  (λ n ih, by simpa [pow_succ] using h.mul ih)

end mul

end submodule

namespace ideal

variables {R : Type*} {M : Type*} [semiring R] [add_comm_monoid M] [module R M]

/-- An ideal of `R` is finitely generated if it is the span of a finite subset of `R`.

This is defeq to `submodule.fg`, but unfolds more nicely. -/
def fg (I : ideal R) : Prop := ∃ S : finset R, ideal.span ↑S = I

/-- The image of a finitely generated ideal is finitely generated.

This is the `ideal` version of `submodule.fg.map`. -/
lemma fg.map {R S : Type*} [semiring R] [semiring S] {I : ideal R} (h : I.fg)
  (f : R →+* S) : (I.map f).fg :=
begin
  classical,
  obtain ⟨s, hs⟩ := h,
  refine ⟨s.image f, _⟩,
  rw [finset.coe_image, ←ideal.map_span, hs],
end

lemma fg_ker_comp {R S A : Type*} [comm_ring R] [comm_ring S] [comm_ring A]
  (f : R →+* S) (g : S →+* A) (hf : f.ker.fg) (hg : g.ker.fg) (hsur : function.surjective f) :
  (g.comp f).ker.fg :=
begin
  letI : algebra R S := ring_hom.to_algebra f,
  letI : algebra R A := ring_hom.to_algebra (g.comp f),
  letI : algebra S A := ring_hom.to_algebra g,
  letI : is_scalar_tower R S A := is_scalar_tower.of_algebra_map_eq (λ _, rfl),
  let f₁ := algebra.linear_map R S,
  let g₁ := (is_scalar_tower.to_alg_hom R S A).to_linear_map,
  exact submodule.fg_ker_comp f₁ g₁ hf (submodule.fg_restrict_scalars g.ker hg hsur) hsur
end

lemma exists_radical_pow_le_of_fg {R : Type*} [comm_semiring R] (I : ideal R) (h : I.radical.fg) :
  ∃ n : ℕ, I.radical ^ n ≤ I :=
begin
  have := le_refl I.radical, revert this,
  refine submodule.fg_induction _ _ (λ J, J ≤ I.radical → ∃ n : ℕ, J ^ n ≤ I) _ _ _ h,
  { intros x hx, obtain ⟨n, hn⟩ := hx (subset_span (set.mem_singleton x)),
    exact ⟨n, by rwa [← ideal.span, span_singleton_pow, span_le, set.singleton_subset_iff]⟩ },
  { intros J K hJ hK hJK,
    obtain ⟨n, hn⟩ := hJ (λ x hx, hJK $ ideal.mem_sup_left hx),
    obtain ⟨m, hm⟩ := hK (λ x hx, hJK $ ideal.mem_sup_right hx),
    use n + m,
    rw [← ideal.add_eq_sup, add_pow, ideal.sum_eq_sup, finset.sup_le_iff],
    refine λ i hi, ideal.mul_le_right.trans _,
    obtain h | h := le_or_lt n i,
    { exact ideal.mul_le_right.trans ((ideal.pow_le_pow h).trans hn) },
    { refine ideal.mul_le_left.trans ((ideal.pow_le_pow _).trans hm),
      rw [add_comm, nat.add_sub_assoc h.le], apply nat.le_add_right } },
end

end ideal

section module_and_algebra

variables (R A B M N : Type*)

/-- A module over a semiring is `finite` if it is finitely generated as a module. -/
class module.finite [semiring R] [add_comm_monoid M] [module R M] :
  Prop := (out : (⊤ : submodule R M).fg)

namespace module

variables [semiring R] [add_comm_monoid M] [module R M] [add_comm_monoid N] [module R N]

lemma finite_def {R M} [semiring R] [add_comm_monoid M] [module R M] :
  finite R M ↔ (⊤ : submodule R M).fg := ⟨λ h, h.1, λ h, ⟨h⟩⟩

namespace finite
open _root_.submodule set

lemma iff_add_monoid_fg {M : Type*} [add_comm_monoid M] : module.finite ℕ M ↔ add_monoid.fg M :=
⟨λ h, add_monoid.fg_def.2 $ (fg_iff_add_submonoid_fg ⊤).1 (finite_def.1 h),
  λ h, finite_def.2 $ (fg_iff_add_submonoid_fg ⊤).2 (add_monoid.fg_def.1 h)⟩

lemma iff_add_group_fg {G : Type*} [add_comm_group G] : module.finite ℤ G ↔ add_group.fg G :=
⟨λ h, add_group.fg_def.2 $ (fg_iff_add_subgroup_fg ⊤).1 (finite_def.1 h),
  λ h, finite_def.2 $ (fg_iff_add_subgroup_fg ⊤).2 (add_group.fg_def.1 h)⟩

variables {R M N}

lemma exists_fin [finite R M] : ∃ (n : ℕ) (s : fin n → M), span R (range s) = ⊤ :=
submodule.fg_iff_exists_fin_generating_family.mp out

lemma of_surjective [hM : finite R M] (f : M →ₗ[R] N) (hf : surjective f) :
  finite R N :=
⟨begin
  rw [← linear_map.range_eq_top.2 hf, ← submodule.map_top],
  exact hM.1.map f
end⟩

variables (R)

instance self : finite R R :=
⟨⟨{1}, by simpa only [finset.coe_singleton] using ideal.span_singleton_one⟩⟩

variable (M)

lemma of_restrict_scalars_finite (R A M : Type*) [comm_semiring R] [semiring A] [add_comm_monoid M]
  [module R M] [module A M] [algebra R A] [is_scalar_tower R A M] [hM : finite R M] :
  finite A M :=
begin
  rw [finite_def, fg_def] at hM ⊢,
  obtain ⟨S, hSfin, hSgen⟩ := hM,
  refine ⟨S, hSfin, eq_top_iff.2 _⟩,
  have := submodule.span_le_restrict_scalars R A S,
  rw hSgen at this,
  exact this
end

variables {R M}

instance prod [hM : finite R M] [hN : finite R N] : finite R (M × N) :=
⟨begin
  rw ← submodule.prod_top,
  exact hM.1.prod hN.1
end⟩

instance pi {ι : Type*} {M : ι → Type*} [_root_.finite ι] [Π i, add_comm_monoid (M i)]
  [Π i, module R (M i)] [h : ∀ i, finite R (M i)] : finite R (Π i, M i) :=
⟨begin
  rw ← submodule.pi_top,
  exact submodule.fg_pi (λ i, (h i).1),
end⟩

lemma equiv [hM : finite R M] (e : M ≃ₗ[R] N) : finite R N :=
of_surjective (e : M →ₗ[R] N) e.surjective

section algebra

lemma trans {R : Type*} (A B : Type*) [comm_semiring R] [comm_semiring A] [algebra R A]
  [semiring B] [algebra R B] [algebra A B] [is_scalar_tower R A B] :
  ∀ [finite R A] [finite A B], finite R B
| ⟨⟨s, hs⟩⟩ ⟨⟨t, ht⟩⟩ := ⟨submodule.fg_def.2
  ⟨set.image2 (•) (↑s : set A) (↑t : set B),
    set.finite.image2 _ s.finite_to_set t.finite_to_set,
    by rw [set.image2_smul, submodule.span_smul_of_span_eq_top hs (↑t : set B),
      ht, submodule.restrict_scalars_top]⟩⟩

end algebra

end finite

end module

instance module.finite.base_change [comm_semiring R] [semiring A] [algebra R A]
  [add_comm_monoid M] [module R M] [h : module.finite R M] :
  module.finite A (tensor_product R A M) :=
begin
  classical,
  obtain ⟨s, hs⟩ := h.out,
  refine ⟨⟨s.image (tensor_product.mk R A M 1), eq_top_iff.mpr $ λ x _, _⟩⟩,
  apply tensor_product.induction_on x,
  { exact zero_mem _ },
  { intros x y,
    rw [finset.coe_image, ← submodule.span_span_of_tower R, submodule.span_image, hs,
      submodule.map_top, linear_map.range_coe],
      change _ ∈ submodule.span A (set.range $ tensor_product.mk R A M 1),
    rw [← mul_one x, ← smul_eq_mul, ← tensor_product.smul_tmul'],
    exact submodule.smul_mem _ x (submodule.subset_span $ set.mem_range_self y) },
  { exact λ _ _, submodule.add_mem _ }
end

instance module.finite.tensor_product [comm_semiring R]
  [add_comm_monoid M] [module R M] [add_comm_monoid N] [module R N]
  [hM : module.finite R M] [hN : module.finite R N] : module.finite R (tensor_product R M N) :=
{ out := (tensor_product.map₂_mk_top_top_eq_top R M N).subst (hM.out.map₂ _ hN.out) }

end module_and_algebra

namespace ring_hom
variables {A B C : Type*} [comm_ring A] [comm_ring B] [comm_ring C]

/-- A ring morphism `A →+* B` is `finite` if `B` is finitely generated as `A`-module. -/
def finite (f : A →+* B) : Prop :=
by letI : algebra A B := f.to_algebra; exact module.finite A B

namespace finite

variables (A)

lemma id : finite (ring_hom.id A) := module.finite.self A

variables {A}

lemma of_surjective (f : A →+* B) (hf : surjective f) : f.finite :=
begin
  letI := f.to_algebra,
  exact module.finite.of_surjective (algebra.of_id A B).to_linear_map hf
end

lemma comp {g : B →+* C} {f : A →+* B} (hg : g.finite) (hf : f.finite) : (g.comp f).finite :=
@module.finite.trans A B C _ _ f.to_algebra _ (g.comp f).to_algebra g.to_algebra
begin
  fconstructor,
  intros a b c,
  simp only [algebra.smul_def, ring_hom.map_mul, mul_assoc],
  refl
end
hf hg

lemma of_comp_finite {f : A →+* B} {g : B →+* C} (h : (g.comp f).finite) : g.finite :=
begin
  letI := f.to_algebra,
  letI := g.to_algebra,
  letI := (g.comp f).to_algebra,
  letI : is_scalar_tower A B C := restrict_scalars.is_scalar_tower A B C,
  letI : module.finite A C := h,
  exact module.finite.of_restrict_scalars_finite A B C
end

end finite

end ring_hom

namespace alg_hom

variables {R A B C : Type*} [comm_ring R]
variables [comm_ring A] [comm_ring B] [comm_ring C]
variables [algebra R A] [algebra R B] [algebra R C]

/-- An algebra morphism `A →ₐ[R] B` is finite if it is finite as ring morphism.
In other words, if `B` is finitely generated as `A`-module. -/
def finite (f : A →ₐ[R] B) : Prop := f.to_ring_hom.finite

namespace finite

variables (R A)

lemma id : finite (alg_hom.id R A) := ring_hom.finite.id A

variables {R A}

lemma comp {g : B →ₐ[R] C} {f : A →ₐ[R] B} (hg : g.finite) (hf : f.finite) : (g.comp f).finite :=
ring_hom.finite.comp hg hf

lemma of_surjective (f : A →ₐ[R] B) (hf : surjective f) : f.finite :=
ring_hom.finite.of_surjective f hf

lemma of_comp_finite {f : A →ₐ[R] B} {g : B →ₐ[R] C} (h : (g.comp f).finite) : g.finite :=
ring_hom.finite.of_comp_finite h

end finite

end alg_hom


import data.finset
import data.fintype

open fintype
open finset

variable {n : ℕ}
local notation `X` := fin n

def compress_family (U V : finset X) (𝒜 : finset (finset X)) : finset (finset X) := sorry

def shadow (𝒜 : finset (finset X)) : finset (finset X) := sorry

reserve prefix `∂`:90
notation ∂𝒜 := shadow 𝒜

def is_compressed (U V : finset X) (𝒜 : finset (finset X)) : Prop := compress_family U V 𝒜 = 𝒜

lemma is_compressed_empty (𝒜 : finset (finset X)) : is_compressed ∅ ∅ 𝒜 := sorry

def c_measure (𝒜 : finset (finset X)) : ℕ := sorry

lemma compress_family_idempotent (U V : finset X) (𝒜 : finset (finset X)) : is_compressed U V (compress_family U V 𝒜) := sorry

def gamma : rel (finset X) (finset X) := (λ U V, ∃ (HU : U ≠ ∅), ∃ (HV : V ≠ ∅), disjoint U V ∧ finset.card U = finset.card V ∧ max' U HU < max' V HV)

lemma compression_improved (U V : finset X) (𝒜 : finset (finset X)) (h₁ : gamma U V)
  (h₂ : ∀ U₁ V₁, gamma U₁ V₁ ∧ U₁.card < U.card → is_compressed U₁ V₁ 𝒜) (h₃ : ¬ is_compressed U V 𝒜):
  c_measure (compress_family U V 𝒜) < c_measure 𝒜 ∧ (compress_family U V 𝒜).card = 𝒜.card ∧ (∂ compress_family U V 𝒜).card ≤ (∂𝒜).card := sorry

theorem kruskal_katona_helper (𝒜 : finset (finset X)) :
  ∃ (ℬ : finset (finset X)), 𝒜.card = ℬ.card ∧ (∂ℬ).card ≤ (∂𝒜).card ∧ (∀ U V, gamma U V → is_compressed U V ℬ) :=
sorry


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.polynomial.basic
import Mathlib.algebra.algebra.subalgebra
import Mathlib.PostPort

universes u v w

namespace Mathlib

/-!
# Adjoining elements to form subalgebras

This file develops the basic theory of subalgebras of an R-algebra generated
by a set of elements. A basic interface for `adjoin` is set up, and various
results about finitely-generated subalgebras and submodules are proved.

## Definitions

* `fg (S : subalgebra R A)` : A predicate saying that the subalgebra is finitely-generated
as an A-algebra

## Tags

adjoin, algebra, finitely-generated algebra

-/

namespace algebra

theorem subset_adjoin {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    {s : set A} : s ⊆ ↑(adjoin R s) :=
  set.subset.trans (set.subset_union_right (set.range ⇑(algebra_map R A)) s)
    subsemiring.subset_closure

theorem adjoin_le {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] {s : set A}
    {S : subalgebra R A} (H : s ⊆ ↑S) : adjoin R s ≤ S :=
  iff.mpr subsemiring.closure_le (set.union_subset (subalgebra.range_le S) H)

theorem adjoin_le_iff {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    {s : set A} {S : subalgebra R A} : adjoin R s ≤ S ↔ s ⊆ ↑S :=
  { mp := set.subset.trans subset_adjoin, mpr := adjoin_le }

theorem adjoin_mono {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    {s : set A} {t : set A} (H : s ⊆ t) : adjoin R s ≤ adjoin R t :=
  iff.mpr subsemiring.closure_le
    (set.subset.trans (set.union_subset_union_right (set.range ⇑(algebra_map R A)) H)
      subsemiring.subset_closure)

@[simp] theorem adjoin_empty (R : Type u) (A : Type v) [comm_semiring R] [semiring A]
    [algebra R A] : adjoin R ∅ = ⊥ :=
  iff.mpr eq_bot_iff (adjoin_le (set.empty_subset ↑⊥))

theorem adjoin_eq_span (R : Type u) {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    (s : set A) : ↑(adjoin R s) = submodule.span R (monoid.closure s) :=
  sorry

theorem adjoin_image (R : Type u) {A : Type v} {B : Type w} [comm_semiring R] [semiring A]
    [semiring B] [algebra R A] [algebra R B] (f : alg_hom R A B) (s : set A) :
    adjoin R (⇑f '' s) = subalgebra.map (adjoin R s) f :=
  le_antisymm (adjoin_le (set.image_subset (⇑f) subset_adjoin))
    (iff.mpr subalgebra.map_le (adjoin_le (iff.mp set.image_subset_iff subset_adjoin)))

@[simp] theorem adjoin_insert_adjoin (R : Type u) {A : Type v} [comm_semiring R] [semiring A]
    [algebra R A] (s : set A) (x : A) :
    adjoin R (insert x ↑↑(adjoin R s)) = adjoin R (insert x s) :=
  sorry

theorem adjoin_union (R : Type u) {A : Type v} [comm_semiring R] [comm_semiring A] [algebra R A]
    (s : set A) (t : set A) :
    adjoin R (s ∪ t) = subalgebra.under (adjoin R s) (adjoin (↥(adjoin R s)) t) :=
  sorry

theorem adjoin_eq_range (R : Type u) {A : Type v} [comm_semiring R] [comm_semiring A] [algebra R A]
    (s : set A) : adjoin R s = alg_hom.range (mv_polynomial.aeval coe) :=
  sorry

theorem adjoin_singleton_eq_range (R : Type u) {A : Type v} [comm_semiring R] [comm_semiring A]
    [algebra R A] (x : A) : adjoin R (singleton x) = alg_hom.range (polynomial.aeval x) :=
  sorry

theorem adjoin_singleton_one (R : Type u) {A : Type v} [comm_semiring R] [comm_semiring A]
    [algebra R A] : adjoin R (singleton 1) = ⊥ :=
  iff.mpr eq_bot_iff (adjoin_le (iff.mpr set.singleton_subset_iff (subalgebra.one_mem ⊥)))

theorem adjoin_union_coe_submodule (R : Type u) {A : Type v} [comm_semiring R] [comm_semiring A]
    [algebra R A] (s : set A) (t : set A) : ↑(adjoin R (s ∪ t)) = ↑(adjoin R s) * ↑(adjoin R t) :=
  sorry

theorem adjoin_int {R : Type u} [comm_ring R] (s : set R) :
    adjoin ℤ s = subalgebra_of_is_subring (ring.closure s) :=
  le_antisymm (adjoin_le ring.subset_closure) (ring.closure_subset subset_adjoin)

theorem mem_adjoin_iff {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] {s : set A}
    {x : A} : x ∈ adjoin R s ↔ x ∈ ring.closure (set.range ⇑(algebra_map R A) ∪ s) :=
  sorry

theorem adjoin_eq_ring_closure {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A]
    (s : set A) : ↑(adjoin R s) = ring.closure (set.range ⇑(algebra_map R A) ∪ s) :=
  set.ext fun (x : A) => mem_adjoin_iff

theorem fg_trans {R : Type u} {A : Type v} [comm_ring R] [comm_ring A] [algebra R A] {s : set A}
    {t : set A} (h1 : submodule.fg ↑(adjoin R s)) (h2 : submodule.fg ↑(adjoin (↥(adjoin R s)) t)) :
    submodule.fg ↑(adjoin R (s ∪ t)) :=
  sorry

end algebra

namespace subalgebra

/-- A subalgebra `S` is finitely generated if there exists `t : finset A` such that
`algebra.adjoin R t = S`. -/
def fg {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    (S : subalgebra R A) :=
  ∃ (t : finset A), algebra.adjoin R ↑t = S

theorem fg_adjoin_finset {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    (s : finset A) : fg (algebra.adjoin R ↑s) :=
  Exists.intro s rfl

theorem fg_def {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    {S : subalgebra R A} : fg S ↔ ∃ (t : set A), set.finite t ∧ algebra.adjoin R t = S :=
  sorry

theorem fg_bot {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A] : fg ⊥ :=
  Exists.intro ∅ (algebra.adjoin_empty R A)

theorem fg_of_fg_to_submodule {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    {S : subalgebra R A} : submodule.fg ↑S → fg S :=
  sorry

theorem fg_of_noetherian {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    [is_noetherian R A] (S : subalgebra R A) : fg S :=
  fg_of_fg_to_submodule (is_noetherian.noetherian ↑S)

theorem fg_of_submodule_fg {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    (h : submodule.fg ⊤) : fg ⊤ :=
  sorry

theorem fg_map {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A] [algebra R A]
    [semiring B] [algebra R B] (S : subalgebra R A) (f : alg_hom R A B) (hs : fg S) :
    fg (map S f) :=
  sorry

theorem fg_of_fg_map {R : Type u} {A : Type v} {B : Type w} [comm_semiring R] [semiring A]
    [algebra R A] [semiring B] [algebra R B] (S : subalgebra R A) (f : alg_hom R A B)
    (hf : function.injective ⇑f) (hs : fg (map S f)) : fg S :=
  sorry

theorem fg_top {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    (S : subalgebra R A) : fg ⊤ ↔ fg S :=
  sorry

theorem induction_on_adjoin {R : Type u} {A : Type v} [comm_semiring R] [semiring A] [algebra R A]
    [is_noetherian R A] (P : subalgebra R A → Prop) (base : P ⊥)
    (ih : ∀ (S : subalgebra R A) (x : A), P S → P (algebra.adjoin R (insert x ↑S)))
    (S : subalgebra R A) : P S :=
  sorry

end subalgebra

/-- The image of a Noetherian R-algebra under an R-algebra map is a Noetherian ring. -/
protected instance alg_hom.is_noetherian_ring_range {R : Type u} {A : Type v} {B : Type w}
    [comm_ring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B] (f : alg_hom R A B)
    [is_noetherian_ring A] : is_noetherian_ring ↥(alg_hom.range f) :=
  Mathlib.is_noetherian_ring_range (alg_hom.to_ring_hom f)

theorem is_noetherian_ring_of_fg {R : Type u} {A : Type v} [comm_ring R] [comm_ring A] [algebra R A]
    {S : subalgebra R A} (HS : subalgebra.fg S) [is_noetherian_ring R] : is_noetherian_ring ↥S :=
  sorry

theorem is_noetherian_ring_closure {R : Type u} [comm_ring R] (s : set R) (hs : set.finite s) :
    is_noetherian_ring ↥(ring.closure s) :=
  (fun (this : is_noetherian_ring ↥(subalgebra_of_is_subring (ring.closure s))) => this)
    (algebra.adjoin_int s ▸
      is_noetherian_ring_of_fg
        (iff.mpr subalgebra.fg_def (Exists.intro s { left := hs, right := rfl })))

end Mathlib


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.quadratic_form.isometry

/-! # Quadratic form on product and pi types

## Main definitions

* `quadratic_form.prod Q₁ Q₂`: the quadratic form constructed elementwise on a product
* `quadratic_form.pi Q`: the quadratic form constructed elementwise on a pi type

## Main results

* `quadratic_form.equivalent.prod`, `quadratic_form.equivalent.pi`: quadratic forms are equivalent
  if their components are equivalent
* `quadratic_form.nonneg_prod_iff`, `quadratic_form.nonneg_pi_iff`: quadratic forms are positive-
  semidefinite if and only if their components are positive-semidefinite.
* `quadratic_form.pos_def_prod_iff`, `quadratic_form.pos_def_pi_iff`: quadratic forms are positive-
  definite if and only if their components are positive-definite.

## Implementation notes

Many of the lemmas in this file could be generalized into results about sums of positive and
non-negative elements, and would generalize to any map `Q`  where `Q 0 = 0`, not just quadratic
forms specifically.

-/

universes u v w
variables {ι : Type*} {R : Type*} {M₁ M₂ N₁ N₂ : Type*} {Mᵢ Nᵢ : ι → Type*}
variables [semiring R]
variables [add_comm_monoid M₁] [add_comm_monoid M₂] [add_comm_monoid N₁] [add_comm_monoid N₂]
variables [module R M₁] [module R M₂] [module R N₁] [module R N₂]
variables [Π i, add_comm_monoid (Mᵢ i)] [Π i, add_comm_monoid (Nᵢ i)]
variables [Π i, module R (Mᵢ i)] [Π i, module R (Nᵢ i)]

namespace quadratic_form

/-- Construct a quadratic form on a product of two modules from the quadratic form on each module.
-/
@[simps]
def prod (Q₁ : quadratic_form R M₁) (Q₂ : quadratic_form R M₂) : quadratic_form R (M₁ × M₂) :=
Q₁.comp (linear_map.fst _ _ _) + Q₂.comp (linear_map.snd _ _ _)

/-- An isometry between quadratic forms generated by `quadratic_form.prod` can be constructed
from a pair of isometries between the left and right parts. -/
@[simps to_linear_equiv]
def isometry.prod {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂}
  {Q₁' : quadratic_form R N₁} {Q₂' : quadratic_form R N₂}
  (e₁ : Q₁.isometry Q₁') (e₂ : Q₂.isometry Q₂') : (Q₁.prod Q₂).isometry (Q₁'.prod Q₂'):=
{ map_app' := λ x, congr_arg2 (+) (e₁.map_app x.1) (e₂.map_app x.2),
  to_linear_equiv := linear_equiv.prod e₁.to_linear_equiv e₂.to_linear_equiv}

lemma equivalent.prod {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂}
  {Q₁' : quadratic_form R N₁} {Q₂' : quadratic_form R N₂}
  (e₁ : Q₁.equivalent Q₁') (e₂ : Q₂.equivalent Q₂') : (Q₁.prod Q₂).equivalent (Q₁'.prod Q₂'):=
nonempty.map2 isometry.prod e₁ e₂

/-- If a product is anisotropic then its components must be. The converse is not true. -/
lemma anisotropic_of_prod {R} [ordered_ring R] [module R M₁] [module R M₂]
  {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} (h : (Q₁.prod Q₂).anisotropic) :
  Q₁.anisotropic ∧ Q₂.anisotropic :=
begin
  simp_rw [anisotropic, prod_apply, prod.forall, prod.mk_eq_zero] at h,
  split,
  { intros x hx,
    refine (h x 0 _).1,
    rw [hx, zero_add, map_zero] },
  { intros x hx,
    refine (h 0 x _).2,
    rw [hx, add_zero, map_zero] },
end

lemma nonneg_prod_iff {R} [ordered_ring R] [module R M₁] [module R M₂]
  {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} :
  (∀ x, 0 ≤ (Q₁.prod Q₂) x) ↔ (∀ x, 0 ≤ Q₁ x) ∧ (∀ x, 0 ≤ Q₂ x) :=
begin
  simp_rw [prod.forall, prod_apply],
  split,
  { intro h,
    split,
    { intro x, simpa only [add_zero, map_zero] using h x 0 },
    { intro x, simpa only [zero_add, map_zero] using h 0 x } },
  { rintros ⟨h₁, h₂⟩ x₁ x₂,
    exact add_nonneg (h₁ x₁) (h₂ x₂), },
end

lemma pos_def_prod_iff {R} [ordered_ring R] [module R M₁] [module R M₂]
  {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} :
  (Q₁.prod Q₂).pos_def ↔ Q₁.pos_def ∧ Q₂.pos_def :=
begin
  simp_rw [pos_def_iff_nonneg, nonneg_prod_iff],
  split,
  { rintros ⟨⟨hle₁, hle₂⟩, ha⟩,
    obtain ⟨ha₁, ha₂⟩ := anisotropic_of_prod ha,
    refine ⟨⟨hle₁, ha₁⟩, ⟨hle₂, ha₂⟩⟩, },
  { rintro ⟨⟨hle₁, ha₁⟩, ⟨hle₂, ha₂⟩⟩,
    refine ⟨⟨hle₁, hle₂⟩, _⟩,
    rintro ⟨x₁, x₂⟩ (hx : Q₁ x₁ + Q₂ x₂ = 0),
    rw [add_eq_zero_iff' (hle₁ x₁) (hle₂ x₂), ha₁.eq_zero_iff, ha₂.eq_zero_iff] at hx,
    rwa [prod.mk_eq_zero], }
end

lemma pos_def.prod {R} [ordered_ring R] [module R M₁] [module R M₂]
  {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂}
  (h₁ : Q₁.pos_def) (h₂ : Q₂.pos_def) : (Q₁.prod Q₂).pos_def :=
pos_def_prod_iff.mpr ⟨h₁, h₂⟩

open_locale big_operators

/-- Construct a quadratic form on a family of modules from the quadratic form on each module. -/
def pi [fintype ι] (Q : Π i, quadratic_form R (Mᵢ i)) : quadratic_form R (Π i, Mᵢ i) :=
∑ i, (Q i).comp (linear_map.proj i : _ →ₗ[R] Mᵢ i)

@[simp] lemma pi_apply [fintype ι] (Q : Π i, quadratic_form R (Mᵢ i)) (x : Π i, Mᵢ i) :
  pi Q x = ∑ i, Q i (x i) :=
sum_apply _ _ _

/-- An isometry between quadratic forms generated by `quadratic_form.prod` can be constructed
from a pair of isometries between the left and right parts. -/
@[simps to_linear_equiv]
def isometry.pi [fintype ι] {Q : Π i, quadratic_form R (Mᵢ i)} {Q' : Π i, quadratic_form R (Nᵢ i)}
  (e : Π i, (Q i).isometry (Q' i)) : (pi Q).isometry (pi Q') :=
{ map_app' := λ x, by
    simp only [pi_apply, linear_equiv.Pi_congr_right_apply, linear_equiv.to_fun_eq_coe,
               isometry.coe_to_linear_equiv, isometry.map_app],
  to_linear_equiv := linear_equiv.Pi_congr_right (λ i, (e i : Mᵢ i ≃ₗ[R] Nᵢ i))}

lemma equivalent.pi [fintype ι] {Q : Π i, quadratic_form R (Mᵢ i)}
  {Q' : Π i, quadratic_form R (Nᵢ i)} (e : ∀ i, (Q i).equivalent (Q' i)) :
  (pi Q).equivalent (pi Q') :=
⟨isometry.pi (λ i, classical.choice (e i))⟩

/-- If a family is anisotropic then its components must be. The converse is not true. -/
lemma anisotropic_of_pi [fintype ι] {R} [ordered_ring R] [Π i, module R (Mᵢ i)]
  {Q : Π i, quadratic_form R (Mᵢ i)} (h : (pi Q).anisotropic) :
  ∀ i, (Q i).anisotropic :=
begin
  simp_rw [anisotropic, pi_apply, function.funext_iff, pi.zero_apply] at h,
  intros i x hx,
  classical,
  have := h (pi.single i x) _ i,
  { rw pi.single_eq_same at this,
    exact this, },
  apply finset.sum_eq_zero,
  intros j _,
  by_cases hji : j = i,
  { subst hji, rw [pi.single_eq_same, hx] },
  { rw [pi.single_eq_of_ne hji, map_zero] },
end

lemma nonneg_pi_iff [fintype ι] {R} [ordered_ring R] [Π i, module R (Mᵢ i)]
  {Q : Π i, quadratic_form R (Mᵢ i)} :
  (∀ x, 0 ≤ pi Q x) ↔ (∀ i x, 0 ≤ Q i x) :=
begin
  simp_rw [pi, sum_apply, comp_apply, linear_map.proj_apply],
  dsimp only,
  split,  -- TODO: does this generalize to a useful lemma independent of `quadratic_form`?
  { intros h i x,
    classical,
    convert h (pi.single i x) using 1,
    rw [finset.sum_eq_single_of_mem i (finset.mem_univ _) (λ j _ hji, _), pi.single_eq_same],
    rw [pi.single_eq_of_ne hji, map_zero], },
  { rintros h x,
    exact finset.sum_nonneg (λ i hi, h i (x i)), },
end

lemma pos_def_pi_iff [fintype ι] {R} [ordered_ring R] [Π i, module R (Mᵢ i)]
  {Q : Π i, quadratic_form R (Mᵢ i)} :
  (pi Q).pos_def ↔ (∀ i, (Q i).pos_def) :=
begin
  simp_rw [pos_def_iff_nonneg, nonneg_pi_iff],
  split,
  { rintros ⟨hle, ha⟩,
    intro i,
    exact ⟨hle i, anisotropic_of_pi ha i⟩, },
  { intro h,
    refine ⟨λ i, (h i).1, λ x hx, funext $ λ i, (h i).2 _ _⟩,
    rw [pi_apply, finset.sum_eq_zero_iff_of_nonneg (λ j hj, _)] at hx,
    { exact hx _ (finset.mem_univ _) },
    exact (h j).1 _ }
end

end quadratic_form


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.list.basic

open nat function

universes u v

variables {α : Type u} {β : Type v}

namespace list

/- pairwise relation (generalized no duplicate) -/

mk_iff_of_inductive_prop list.pairwise list.pairwise_iff

variable {R : α → α → Prop}

theorem rel_of_pairwise_cons {a : α} {l : list α}
  (p : pairwise R (a::l)) : ∀ {a'}, a' ∈ l → R a a' :=
(pairwise_cons.1 p).1

theorem pairwise_of_pairwise_cons {a : α} {l : list α}
  (p : pairwise R (a::l)) : pairwise R l :=
(pairwise_cons.1 p).2

theorem pairwise.tail : ∀ {l : list α} (p : pairwise R l), pairwise R l.tail
| [] h := h
| (a :: l) h := pairwise_of_pairwise_cons h

theorem pairwise.imp_of_mem {S : α → α → Prop} {l : list α}
  (H : ∀ {a b}, a ∈ l → b ∈ l → R a b → S a b) (p : pairwise R l) : pairwise S l :=
begin
  induction p with a l r p IH generalizing H; constructor,
  { exact ball.imp_right
      (λ x h, H (mem_cons_self _ _) (mem_cons_of_mem _ h)) r },
  { exact IH (λ a b m m', H
      (mem_cons_of_mem _ m) (mem_cons_of_mem _ m')) }
end

theorem pairwise.imp {S : α → α → Prop}
  (H : ∀ a b, R a b → S a b) {l : list α} : pairwise R l → pairwise S l :=
pairwise.imp_of_mem (λ a b _ _, H a b)

theorem pairwise.and {S : α → α → Prop} {l : list α} :
  pairwise (λ a b, R a b ∧ S a b) l ↔ pairwise R l ∧ pairwise S l :=
⟨λ h, ⟨h.imp (λ a b h, h.1), h.imp (λ a b h, h.2)⟩,
 λ ⟨hR, hS⟩, begin
  clear_, induction hR with a l R1 R2 IH;
  simp only [pairwise.nil, pairwise_cons] at *,
  exact ⟨λ b bl, ⟨R1 b bl, hS.1 b bl⟩, IH hS.2⟩
 end⟩

theorem pairwise.imp₂ {S : α → α → Prop} {T : α → α → Prop}
  (H : ∀ a b, R a b → S a b → T a b) {l : list α}
  (hR : pairwise R l) (hS : pairwise S l) : pairwise T l :=
(pairwise.and.2 ⟨hR, hS⟩).imp $ λ a b, and.rec (H a b)

theorem pairwise.iff_of_mem {S : α → α → Prop} {l : list α}
  (H : ∀ {a b}, a ∈ l → b ∈ l → (R a b ↔ S a b)) : pairwise R l ↔ pairwise S l :=
⟨pairwise.imp_of_mem (λ a b m m', (H m m').1),
 pairwise.imp_of_mem (λ a b m m', (H m m').2)⟩

theorem pairwise.iff {S : α → α → Prop}
  (H : ∀ a b, R a b ↔ S a b) {l : list α} : pairwise R l ↔ pairwise S l :=
pairwise.iff_of_mem (λ a b _ _, H a b)

theorem pairwise_of_forall {l : list α} (H : ∀ x y, R x y) : pairwise R l :=
by induction l; [exact pairwise.nil,
simp only [*, pairwise_cons, forall_2_true_iff, and_true]]

theorem pairwise.and_mem {l : list α} :
  pairwise R l ↔ pairwise (λ x y, x ∈ l ∧ y ∈ l ∧ R x y) l :=
pairwise.iff_of_mem (by simp only [true_and, iff_self, forall_2_true_iff] {contextual := tt})

theorem pairwise.imp_mem {l : list α} :
  pairwise R l ↔ pairwise (λ x y, x ∈ l → y ∈ l → R x y) l :=
pairwise.iff_of_mem
  (by simp only [forall_prop_of_true, iff_self, forall_2_true_iff] {contextual := tt})

theorem pairwise_of_sublist : Π {l₁ l₂ : list α}, l₁ <+ l₂ → pairwise R l₂ → pairwise R l₁
| ._ ._ sublist.slnil h := h
| ._ ._ (sublist.cons l₁ l₂ a s) (pairwise.cons i n) := pairwise_of_sublist s n
| ._ ._ (sublist.cons2 l₁ l₂ a s) (pairwise.cons i n) :=
  (pairwise_of_sublist s n).cons (ball.imp_left s.subset i)

theorem forall_of_forall_of_pairwise (H : symmetric R)
  {l : list α} (H₁ : ∀ x ∈ l, R x x) (H₂ : pairwise R l) :
  ∀ (x ∈ l) (y ∈ l), R x y :=
begin
  induction l with a l IH, { exact forall_mem_nil _ },
  cases forall_mem_cons.1 H₁ with H₁₁ H₁₂,
  cases pairwise_cons.1 H₂ with H₂₁ H₂₂,
  rintro x (rfl | hx) y (rfl | hy),
  exacts [H₁₁, H₂₁ _ hy, H (H₂₁ _ hx), IH H₁₂ H₂₂ _ hx _ hy]
end

lemma forall_of_pairwise (H : symmetric R) {l : list α}
   (hl : pairwise R l) : (∀a∈l, ∀b∈l, a ≠ b → R a b) :=
forall_of_forall_of_pairwise
  (λ a b h hne, H (h hne.symm))
  (λ _ _ h, (h rfl).elim)
  (pairwise.imp (λ _ _ h _, h) hl)

theorem pairwise_singleton (R) (a : α) : pairwise R [a] :=
by simp only [pairwise_cons, mem_singleton, forall_prop_of_false (not_mem_nil _), forall_true_iff,
  pairwise.nil, and_true]

theorem pairwise_pair {a b : α} : pairwise R [a, b] ↔ R a b :=
by simp only [pairwise_cons, mem_singleton, forall_eq, forall_prop_of_false (not_mem_nil _),
  forall_true_iff, pairwise.nil, and_true]

theorem pairwise_append {l₁ l₂ : list α} : pairwise R (l₁++l₂) ↔
  pairwise R l₁ ∧ pairwise R l₂ ∧ ∀ x ∈ l₁, ∀ y ∈ l₂, R x y :=
by induction l₁ with x l₁ IH; [simp only [list.pairwise.nil, forall_prop_of_false (not_mem_nil _),
  forall_true_iff, and_true, true_and, nil_append],
simp only [cons_append, pairwise_cons, forall_mem_append, IH, forall_mem_cons, forall_and_distrib,
  and_assoc, and.left_comm]]

theorem pairwise_append_comm (s : symmetric R) {l₁ l₂ : list α} :
  pairwise R (l₁++l₂) ↔ pairwise R (l₂++l₁) :=
have ∀ l₁ l₂ : list α,
  (∀ (x : α), x ∈ l₁ → ∀ (y : α), y ∈ l₂ → R x y) →
  (∀ (x : α), x ∈ l₂ → ∀ (y : α), y ∈ l₁ → R x y),
from λ l₁ l₂ a x xm y ym, s (a y ym x xm),
by simp only [pairwise_append, and.left_comm]; rw iff.intro (this l₁ l₂) (this l₂ l₁)

theorem pairwise_middle (s : symmetric R) {a : α} {l₁ l₂ : list α} :
  pairwise R (l₁ ++ a::l₂) ↔ pairwise R (a::(l₁++l₂)) :=
show pairwise R (l₁ ++ ([a] ++ l₂)) ↔ pairwise R ([a] ++ l₁ ++ l₂),
by rw [← append_assoc, pairwise_append, @pairwise_append _ _ ([a] ++ l₁), pairwise_append_comm s];
   simp only [mem_append, or_comm]

theorem pairwise_map (f : β → α) :
  ∀ {l : list β}, pairwise R (map f l) ↔ pairwise (λ a b : β, R (f a) (f b)) l
| []     := by simp only [map, pairwise.nil]
| (b::l) :=
  have (∀ a b', b' ∈ l → f b' = a → R (f b) a) ↔ ∀ (b' : β), b' ∈ l → R (f b) (f b'), from
  forall_swap.trans $ forall_congr $ λ a, forall_swap.trans $ by simp only [forall_eq'],
  by simp only [map, pairwise_cons, mem_map, exists_imp_distrib, and_imp, this, pairwise_map]

theorem pairwise_of_pairwise_map {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, S (f a) (f b) → R a b) {l : list α}
  (p : pairwise S (map f l)) : pairwise R l :=
((pairwise_map f).1 p).imp H

theorem pairwise_map_of_pairwise {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, R a b → S (f a) (f b)) {l : list α}
  (p : pairwise R l) : pairwise S (map f l) :=
(pairwise_map f).2 $ p.imp H

theorem pairwise_filter_map (f : β → option α) {l : list β} :
  pairwise R (filter_map f l) ↔ pairwise (λ a a' : β, ∀ (b ∈ f a) (b' ∈ f a'), R b b') l :=
let S (a a' : β) := ∀ (b ∈ f a) (b' ∈ f a'), R b b' in
begin
  simp only [option.mem_def], induction l with a l IH,
  { simp only [filter_map, pairwise.nil] },
  cases e : f a with b,
  { rw [filter_map_cons_none _ _ e, IH, pairwise_cons],
    simp only [e, forall_prop_of_false not_false, forall_3_true_iff, true_and] },
  rw [filter_map_cons_some _ _ _ e],
  simp only [pairwise_cons, mem_filter_map, exists_imp_distrib, and_imp, IH, e, forall_eq'],
  show (∀ (a' : α) (x : β), x ∈ l → f x = some a' → R b a') ∧ pairwise S l ↔
        (∀ (a' : β), a' ∈ l → ∀ (b' : α), f a' = some b' → R b b') ∧ pairwise S l,
  from and_congr ⟨λ h b mb a ma, h a b mb ma, λ h a b mb ma, h b mb a ma⟩ iff.rfl
end

theorem pairwise_filter_map_of_pairwise {S : β → β → Prop} (f : α → option β)
  (H : ∀ (a a' : α), R a a' → ∀ (b ∈ f a) (b' ∈ f a'), S b b') {l : list α}
  (p : pairwise R l) : pairwise S (filter_map f l) :=
(pairwise_filter_map _).2 $ p.imp H

theorem pairwise_filter (p : α → Prop) [decidable_pred p] {l : list α} :
  pairwise R (filter p l) ↔ pairwise (λ x y, p x → p y → R x y) l :=
begin
  rw [← filter_map_eq_filter, pairwise_filter_map],
  apply pairwise.iff, intros, simp only [option.mem_def, option.guard_eq_some, and_imp, forall_eq'],
end

theorem pairwise_filter_of_pairwise (p : α → Prop) [decidable_pred p] {l : list α}
  : pairwise R l → pairwise R (filter p l) :=
pairwise_of_sublist (filter_sublist _)

theorem pairwise_pmap {p : β → Prop} {f : Π b, p b → α} {l : list β} (h : ∀ x ∈ l, p x) :
  pairwise R (l.pmap f h) ↔
    pairwise (λ b₁ b₂, ∀ (h₁ : p b₁) (h₂ : p b₂), R (f b₁ h₁) (f b₂ h₂)) l :=
begin
  induction l with a l ihl, { simp },
  obtain ⟨ha, hl⟩ : p a ∧ ∀ b, b ∈ l → p b, by simpa using h,
  simp only [ihl hl, pairwise_cons, bex_imp_distrib, pmap, and.congr_left_iff, mem_pmap],
  refine λ _, ⟨λ H b hb hpa hpb, H _ _ hb rfl, _⟩,
  rintro H _ b hb rfl,
  exact H b hb _ _
end

theorem pairwise_join {L : list (list α)} : pairwise R (join L) ↔
  (∀ l ∈ L, pairwise R l) ∧ pairwise (λ l₁ l₂, ∀ (x ∈ l₁) (y ∈ l₂), R x y) L :=
begin
  induction L with l L IH,
  {simp only [join, pairwise.nil, forall_prop_of_false (not_mem_nil _), forall_const, and_self]},
  have : (∀ (x : α), x ∈ l → ∀ (y : α) (x_1 : list α), x_1 ∈ L → y ∈ x_1 → R x y) ↔
          ∀ (a' : list α), a' ∈ L → ∀ (x : α), x ∈ l → ∀ (y : α), y ∈ a' → R x y :=
    ⟨λ h a b c d e, h c d e a b, λ h c d e a b, h a b c d e⟩,
  simp only [join, pairwise_append, IH, mem_join, exists_imp_distrib, and_imp, this,
    forall_mem_cons, pairwise_cons],
  simp only [and_assoc, and_comm, and.left_comm],
end

@[simp] theorem pairwise_reverse : ∀ {R} {l : list α},
  pairwise R (reverse l) ↔ pairwise (λ x y, R y x) l :=
suffices ∀ {R l}, @pairwise α R l → pairwise (λ x y, R y x) (reverse l),
from λ R l, ⟨λ p, reverse_reverse l ▸ this p, this⟩,
λ R l p, by induction p with a l h p IH;
  [apply pairwise.nil, simpa only [reverse_cons, pairwise_append, IH,
    pairwise_cons, forall_prop_of_false (not_mem_nil _), forall_true_iff,
    pairwise.nil, mem_reverse, mem_singleton, forall_eq, true_and] using h]

theorem pairwise_iff_nth_le {R} : ∀ {l : list α},
  pairwise R l ↔ ∀ i j (h₁ : j < length l) (h₂ : i < j),
    R (nth_le l i (lt_trans h₂ h₁)) (nth_le l j h₁)
| [] := by simp only [pairwise.nil, true_iff]; exact λ i j h, (not_lt_zero j).elim h
| (a::l) := begin
  rw [pairwise_cons, pairwise_iff_nth_le],
  refine ⟨λ H i j h₁ h₂, _, λ H, ⟨λ a' m, _,
    λ i j h₁ h₂, H _ _ (succ_lt_succ h₁) (succ_lt_succ h₂)⟩⟩,
  { cases j with j, {exact (not_lt_zero _).elim h₂},
    cases i with i,
    { exact H.1 _ (nth_le_mem l _ _) },
    { exact H.2 _ _ (lt_of_succ_lt_succ h₁) (lt_of_succ_lt_succ h₂) } },
  { rcases nth_le_of_mem m with ⟨n, h, rfl⟩,
    exact H _ _ (succ_lt_succ h) (succ_pos _) }
end

theorem pairwise_sublists' {R} : ∀ {l : list α}, pairwise R l →
  pairwise (lex (swap R)) (sublists' l)
| _ pairwise.nil := pairwise_singleton _ _
| _ (@pairwise.cons _ _ a l H₁ H₂) :=
  begin
    simp only [sublists'_cons, pairwise_append, pairwise_map, mem_sublists', mem_map,
      exists_imp_distrib, and_imp],
    have IH := pairwise_sublists' H₂,
    refine ⟨IH, IH.imp (λ l₁ l₂, lex.cons), _⟩,
    intros l₁ sl₁ x l₂ sl₂ e, subst e,
    cases l₁ with b l₁, {constructor},
    exact lex.rel (H₁ _ $ sl₁.subset $ mem_cons_self _ _)
  end

theorem pairwise_sublists {R} {l : list α} (H : pairwise R l) :
  pairwise (λ l₁ l₂, lex R (reverse l₁) (reverse l₂)) (sublists l) :=
by have := pairwise_sublists' (pairwise_reverse.2 H);
   rwa [sublists'_reverse, pairwise_map] at this

/- pairwise reduct -/

variable [decidable_rel R]

@[simp] theorem pw_filter_nil : pw_filter R [] = [] := rfl

@[simp] theorem pw_filter_cons_of_pos {a : α} {l : list α} (h : ∀ b ∈ pw_filter R l, R a b) :
  pw_filter R (a::l) = a :: pw_filter R l := if_pos h

@[simp] theorem pw_filter_cons_of_neg {a : α} {l : list α} (h : ¬ ∀ b ∈ pw_filter R l, R a b) :
  pw_filter R (a::l) = pw_filter R l := if_neg h

theorem pw_filter_map (f : β → α) :
  Π (l : list β), pw_filter R (map f l) = map f (pw_filter (λ x y, R (f x) (f y)) l)
| [] := rfl
| (x :: xs) :=
  if h : ∀ b ∈ pw_filter R (map f xs), R (f x) b
    then have h' : ∀ (b : β), b ∈ pw_filter (λ (x y : β), R (f x) (f y)) xs → R (f x) (f b),
           from λ b hb, h _ (by rw [pw_filter_map]; apply mem_map_of_mem _ hb),
         by rw [map,pw_filter_cons_of_pos h,pw_filter_cons_of_pos h',pw_filter_map,map]
    else have h' : ¬∀ (b : β), b ∈ pw_filter (λ (x y : β), R (f x) (f y)) xs → R (f x) (f b),
           from λ hh, h $ λ a ha,
           by { rw [pw_filter_map,mem_map] at ha, rcases ha with ⟨b,hb₀,hb₁⟩,
                subst a, exact hh _ hb₀, },
         by rw [map,pw_filter_cons_of_neg h,pw_filter_cons_of_neg h',pw_filter_map]

theorem pw_filter_sublist : ∀ (l : list α), pw_filter R l <+ l
| []     := nil_sublist _
| (x::l) := begin
  by_cases (∀ y ∈ pw_filter R l, R x y),
  { rw [pw_filter_cons_of_pos h],
    exact cons_sublist_cons _ (pw_filter_sublist l) },
  { rw [pw_filter_cons_of_neg h],
    exact sublist_cons_of_sublist _ (pw_filter_sublist l) },
end

theorem pw_filter_subset (l : list α) : pw_filter R l ⊆ l :=
(pw_filter_sublist _).subset

theorem pairwise_pw_filter : ∀ (l : list α), pairwise R (pw_filter R l)
| []     := pairwise.nil
| (x::l) := begin
  by_cases (∀ y ∈ pw_filter R l, R x y),
  { rw [pw_filter_cons_of_pos h],
    exact pairwise_cons.2 ⟨h, pairwise_pw_filter l⟩ },
  { rw [pw_filter_cons_of_neg h],
    exact pairwise_pw_filter l },
end

theorem pw_filter_eq_self {l : list α} : pw_filter R l = l ↔ pairwise R l :=
⟨λ e, e ▸ pairwise_pw_filter l, λ p, begin
  induction l with x l IH, {refl},
  cases pairwise_cons.1 p with al p,
  rw [pw_filter_cons_of_pos (ball.imp_left (pw_filter_subset l) al), IH p],
end⟩

@[simp] theorem pw_filter_idempotent {l : list α} :
  pw_filter R (pw_filter R l) = pw_filter R l :=
pw_filter_eq_self.mpr (pairwise_pw_filter l)

theorem forall_mem_pw_filter (neg_trans : ∀ {x y z}, R x z → R x y ∨ R y z)
  (a : α) (l : list α) : (∀ b ∈ pw_filter R l, R a b) ↔ (∀ b ∈ l, R a b) :=
⟨begin
  induction l with x l IH, { exact λ _ _, false.elim },
  simp only [forall_mem_cons],
  by_cases (∀ y ∈ pw_filter R l, R x y); dsimp at h,
  { simp only [pw_filter_cons_of_pos h, forall_mem_cons, and_imp],
    exact λ r H, ⟨r, IH H⟩ },
  { rw [pw_filter_cons_of_neg h],
    refine λ H, ⟨_, IH H⟩,
    cases e : find (λ y, ¬ R x y) (pw_filter R l) with k,
    { refine h.elim (ball.imp_right _ (find_eq_none.1 e)),
      exact λ y _, not_not.1 },
    { have := find_some e,
      exact (neg_trans (H k (find_mem e))).resolve_right this } }
end, ball.imp_left (pw_filter_subset l)⟩

end list


import topology.locally_constant.algebra
import analysis.normed.group.hom

/-!
# Analysis of locally constant maps

This file defines the normed group of locally constant maps from a compact topological
space into a normed group (with the sup norm).

## Main construction

* The instance `locally_constant.normed_add_comm_group`
* `locally_constant.map_hom`: push-forward of locally constant maps as a normed group hom
* `locally_constant.comap_hom`: pull-back of locally constant maps as a normed group hom
-/

noncomputable theory
open_locale nnreal

open set

-- move this
section for_mathlib

lemma real.Sup_mul (r : ℝ) (s : set ℝ) (hr : 0 < r) :
  Sup ({x | ∃ y ∈ s, r * y = x}) = r * Sup s :=
begin
  by_cases hs : s.nonempty, swap,
  { rw not_nonempty_iff_eq_empty at hs, simp [hs], },
  have H : set.nonempty {x : ℝ | ∃ (y : ℝ) (H : y ∈ s), r * y = x},
  { obtain ⟨x, hx⟩ := hs, from ⟨r * x, x, hx, rfl⟩, },
  have aux : bdd_above {x : ℝ | ∃ (y : ℝ) (H : y ∈ s), r * y = x} ↔ bdd_above s,
  { split; rintro ⟨x, hx⟩,
    { refine ⟨x / r, λ y hy, _⟩,
      rw [le_div_iff' hr],
      exact hx ⟨_, hy, rfl⟩, },
    { refine ⟨r * x, _⟩, rintro _ ⟨y, hy, rfl⟩,
      apply mul_le_mul_of_nonneg_left _ hr.le,
      exact hx hy } },
  by_cases s_bdd : bdd_above s, swap,
  { simp only [real.Sup_of_not_bdd_above s_bdd, mul_zero,
    real.Sup_of_not_bdd_above ((not_iff_not_of_iff aux).mpr s_bdd)], },
  apply le_antisymm,
  { apply cSup_le H,
    rintro _ ⟨x, hx, rfl⟩,
    exact mul_le_mul_of_nonneg_left (le_cSup s_bdd hx) hr.le },
  { rw [← le_div_iff' hr],
    refine cSup_le hs _,
    intros x hx,
    rw le_div_iff' hr,
    exact le_cSup (aux.mpr s_bdd) ⟨_, hx, rfl⟩ }
end

end for_mathlib

open set

namespace locally_constant

variables {X Y Z V V₁ V₂ V₃ : Type*} [topological_space X]

/-- The sup norm on locally constant function -/
protected def has_norm [has_norm Y] : has_norm (locally_constant X Y) :=
{ norm := λ f, ⨆ x, ∥f x∥ }

/-- The sup edist on locally constant function -/
protected def has_edist [has_edist Y] : has_edist (locally_constant X Y) :=
{ edist := λ f g, ⨆ x, edist (f x) (g x) }

/-- The sup edist on locally constant function -/
protected def has_dist [has_dist Y] : has_dist (locally_constant X Y) :=
{ dist := λ f g, ⨆ x, dist (f x) (g x) }

local attribute [instance]
  locally_constant.has_norm
  locally_constant.has_edist
  locally_constant.has_dist

lemma edist_apply_le [has_edist Y] (f g : locally_constant X Y) (x : X) :
  edist (f x) (g x) ≤ edist f g :=
le_Sup (set.mem_range_self x)

lemma norm_def [has_norm Y] (f : locally_constant X Y) : ∥f∥ = ⨆ x, ∥f x∥ := rfl

lemma edist_def [has_edist Y] (f g : locally_constant X Y) :
  edist f g = ⨆ x, edist (f x) (g x) := rfl

lemma dist_def [has_dist Y] (f g : locally_constant X Y) : dist f g = ⨆ x, dist (f x) (g x) := rfl

section compact_domain

variables [compact_space X]

lemma norm_apply_le [has_norm Y] (f : locally_constant X Y) (x : X) :
  ∥f x∥ ≤ ∥f∥ :=
begin
  refine le_cSup _ (set.mem_range_self _),
  apply exists_upper_bound_image,
  rw range_comp,
  exact f.range_finite.image _
end

lemma exists_ub_range_dist [has_dist Y] (f g : locally_constant X Y) :
  ∃ x : ℝ, ∀ y : ℝ, y ∈ set.range (λ (x : X), dist (f x) (g x)) → y ≤ x :=
begin
  apply exists_upper_bound_image,
  simp only [← function.uncurry_apply_pair dist],
  rw range_comp,
  apply finite.image,
  apply (f.range_finite.prod g.range_finite).subset,
  apply range_pair_subset,
end

lemma dist_apply_le [has_dist Y] (f g : locally_constant X Y) (x : X) :
  dist (f x) (g x) ≤ dist f g :=
le_cSup (exists_ub_range_dist _ _) (set.mem_range_self x)

-- consider giving the `edist` and the `uniform_space` explicitly
/-- The metric space on locally constant functions on a compact space, with sup distance. -/
protected def pseudo_metric_space [pseudo_metric_space Y] :
  pseudo_metric_space (locally_constant X Y) :=
{ dist_self := λ f, show (⨆ x, dist (f x) (f x)) = 0,
    begin
      simp only [dist_self, supr],
      casesI is_empty_or_nonempty X,
      { rw [set.range_eq_empty, real.Sup_empty] },
      { simp only [set.range_const, cSup_singleton] },
    end,
  dist_comm := λ f g, show Sup _ = Sup _, by { simp only [dist_comm] },
  dist_triangle :=
  begin
    intros f g h,
    casesI is_empty_or_nonempty X,
    { show Sup _ ≤ Sup _ + Sup _, simp only [set.range_eq_empty, real.Sup_empty, add_zero] },
    refine cSup_le _ _,
    { inhabit X, exact ⟨_, set.mem_range_self default⟩ },
    rintro r ⟨x, rfl⟩,
    calc dist (f x) (h x) ≤ dist (f x) (g x) + dist (g x) (h x) : dist_triangle _ _ _
    ... ≤ dist f g + dist g h : add_le_add (dist_apply_le _ _ _) (dist_apply_le _ _ _)
  end,
  .. locally_constant.has_dist }

-- consider giving the `edist` and the `uniform_space` explicitly
/-- The metric space on locally constant functions on a compact space, with sup distance. -/
protected def metric_space [metric_space Y] : metric_space (locally_constant X Y) :=
{ dist_self := λ f, show (⨆ x, dist (f x) (f x)) = 0,
  begin
    simp only [dist_self, supr],
    casesI is_empty_or_nonempty X,
    { rwa [set.range_eq_empty, real.Sup_empty] },
    { simp only [set.range_const, cSup_singleton] }
  end,
  eq_of_dist_eq_zero :=
  begin
    intros f g h,
    ext x,
    apply eq_of_dist_eq_zero,
    apply le_antisymm _ dist_nonneg,
    rw ← h,
    exact dist_apply_le _ _ _
  end,
  dist_comm := λ f g, show Sup _ = Sup _, by { simp only [dist_comm] },
  dist_triangle :=
  begin
    intros f g h,
    casesI is_empty_or_nonempty X,
    { show Sup _ ≤ Sup _ + Sup _, simp only [set.range_eq_empty, real.Sup_empty, add_zero] },
    refine cSup_le _ _,
    { inhabit X, exact ⟨_, set.mem_range_self default⟩ },
    rintro r ⟨x, rfl⟩,
    calc dist (f x) (h x) ≤ dist (f x) (g x) + dist (g x) (h x) : dist_triangle _ _ _
    ... ≤ dist f g + dist g h : add_le_add (dist_apply_le _ _ _) (dist_apply_le _ _ _)
  end,
  .. locally_constant.has_dist }

/--
The seminormed group of locally constant functions from a compact space to a seminormed group.
-/
protected def seminormed_add_comm_group {G : Type*} [seminormed_add_comm_group G] :
  seminormed_add_comm_group (locally_constant X G) :=
{ dist_eq := λ f g, show Sup _ = Sup _,
  by simp only [seminormed_add_comm_group.dist_eq, locally_constant.sub_apply],
  .. locally_constant.has_norm, .. locally_constant.add_comm_group,
  .. locally_constant.pseudo_metric_space }

/-- The normed group of locally constant functions from a compact space to a normed group. -/
protected def normed_add_comm_group {G : Type*} [normed_add_comm_group G] : normed_add_comm_group (locally_constant X G) :=
{ .. locally_constant.seminormed_add_comm_group,
  .. locally_constant.metric_space }

local attribute [instance] locally_constant.seminormed_add_comm_group

section map_hom

variables [seminormed_add_comm_group V] [seminormed_add_comm_group V₁] [seminormed_add_comm_group V₂] [seminormed_add_comm_group V₃]

/-- Push-forward of locally constant maps under a normed group hom, as a normed
group hom between types of locally constant functions. -/
@[simps]
def map_hom (f : normed_add_group_hom V₁ V₂) :
  normed_add_group_hom (locally_constant X V₁) (locally_constant X V₂) :=
{ to_fun := locally_constant.map f,
  map_add' := by { intros x y, ext s, apply f.map_add' },
  bound' :=
  begin
    obtain ⟨C, C_pos, hC⟩ := f.bound,
    use C,
    rintro (g : locally_constant _ _),
    calc Sup (set.range (λ x, ∥f (g x)∥))
        ≤ Sup (set.range (λ x, C * ∥g x∥)) : _
    ... = C * Sup (set.range (λ x, ∥g x∥)) : _,
    { casesI is_empty_or_nonempty X,
      { simp only [set.range_eq_empty, real.Sup_empty] },
      refine cSup_le _ _,
      { inhabit X, exact ⟨_, set.mem_range_self default⟩ },
      rintro _ ⟨x, rfl⟩,
      calc ∥f (g x)∥ ≤ C * ∥g x∥ : hC _
      ... ≤ Sup _ : le_cSup _ _,
      { apply exists_upper_bound_image,
        rw [set.range_comp, set.range_comp],
        exact (g.range_finite.image _).image _ },
      { exact set.mem_range_self _ } },
    { convert real.Sup_mul C _ C_pos using 2,
      ext x,
      simp only [set.mem_range, exists_prop, set.set_of_mem_eq, exists_exists_eq_and],
      simp only [set.mem_set_of_eq] }
  end }

@[simp] lemma map_hom_id :
  @map_hom X _ _ _ _ _ _ (@normed_add_group_hom.id V _) = normed_add_group_hom.id _ :=
by { ext, refl }

@[simp] lemma map_hom_comp (g : normed_add_group_hom V₂ V₃) (f : normed_add_group_hom V₁ V₂) :
  (@map_hom X _ _ _ _ _ _ g).comp (map_hom f) = map_hom (g.comp f) :=
by { ext, refl }

end map_hom

section comap_hom
/-!
### comapping as normed_add_group_hom
-/

variables [topological_space Y] [compact_space Y] [topological_space Z] [compact_space Z]
variables [seminormed_add_comm_group V]

/-- Pull-back of locally constant maps under a normed group hom, as a normed
group hom between types of locally constant functions. -/
@[simps]
def comap_hom (f : X → Y) (hf : continuous f) :
  normed_add_group_hom (locally_constant Y V) (locally_constant X V) :=
add_monoid_hom.mk_normed_add_group_hom
  (add_monoid_hom.mk'
    (locally_constant.comap f)
    (by { intros, ext, simp only [hf, add_apply, function.comp_app, coe_comap] }))
  1
  begin
    assume g,
    rw one_mul,
    show Sup _ ≤ Sup _,
    simp only [hf, function.comp_app, coe_comap, add_monoid_hom.mk'_apply],
    casesI is_empty_or_nonempty X,
    { simp only [set.range_eq_empty, real.Sup_empty],
      casesI is_empty_or_nonempty Y,
      { simp only [set.range_eq_empty, real.Sup_empty] },
      inhabit Y,
      calc 0 ≤ ∥g default∥ : norm_nonneg _
         ... ≤ _ : _,
      apply le_cSup,
      { apply exists_upper_bound_image,
        rw set.range_comp,
        exact g.range_finite.image _ },
      { exact set.mem_range_self _ } },
    resetI,
    refine cSup_le (range_nonempty _) _,
    { rintro _ ⟨x, rfl⟩,
      apply le_cSup,
      { apply exists_upper_bound_image,
        rw set.range_comp,
        exact g.range_finite.image _ },
      { exact set.mem_range_self _ } },
  end

@[simp] lemma comap_hom_id : @comap_hom X X V _ _ _ _ _ id continuous_id = normed_add_group_hom.id _ :=
begin
  ext,
  simp only [comap_id, comap_hom_apply, id.def, normed_add_group_hom.id_apply,
    add_monoid_hom.to_fun_eq_coe, add_monoid_hom.id_apply]
end

@[simp] lemma comap_hom_comp (f : X → Y) (g : Y → Z) (hf : continuous f) (hg : continuous g) :
  (@comap_hom _ _ V _ _ _ _ _ f hf).comp (comap_hom g hg) = (comap_hom (g ∘ f) (hg.comp hf)) :=
begin
  ext φ x,
  -- `[simps]` is producing bad lemmas... I don't know how to trick it into creating good ones
  -- so we use `show` instead, to get into a defeq shape that is usable
  show (comap_hom f hf) ((comap_hom g hg) φ) x = _,
  simp only [hg.comp hf, hf, hg, comap_hom_apply, coe_comap]
end

lemma comap_hom_norm_noninc (f : X → Y) (hf : continuous f) :
  (@comap_hom _ _ V _ _ _ _ _ f hf).norm_noninc :=
normed_add_group_hom.norm_noninc.norm_noninc_iff_norm_le_one.2 $
  normed_add_group_hom.mk_normed_add_group_hom_norm_le _ (zero_le_one) _

end comap_hom

end compact_domain

end locally_constant

#lint- only unused_arguments def_lemma doc_blame


import topology.basic
import topology.algebra.ring
import algebra.group_power
import ring_theory.subring
import tactic.ring

import for_mathlib.topological_rings
import for_mathlib.nonarchimedean.adic_topology

/-!
# Power bounded elements

The theory of topologically nilpotent, bounded, and power-bounded
elements and subsets of topological rings.
-/

local attribute [instance] set.pointwise_mul_semiring

open set

variables {R : Type*} [comm_ring R] [topological_space R]

/- Note: the following definitions are made without assuming
any compatibility between the algebraic and topological structure on R.
Of course, in applications one will assume that R is a topological ring. -/

/--An element r of a topological ring is topologically nilpotent if for all neighbourhouds U of 0,
there exists a natural number N such that r^n ∈ U for all n > N.
See [Wedhorn, Def 5.25, p. 36]. -/
def is_topologically_nilpotent (r : R) : Prop :=
∀ U ∈ (nhds (0 : R)), ∃ N : ℕ, ∀ n : ℕ, n > N → r^n ∈ U

/--A subset T of a topological ring is topologically nilpotent if for all neighbourhouds U of 0,
there exists a natural number N such that r^n ∈ U for all n > N.
(Here T^n is the set {t₁ * t₂ * ⋯ * tₙ | t₁, t₂, …, tₙ ∈ T}.) -/
def is_topologically_nilpotent_subset (T : set R) : Prop :=
∀ U ∈ (nhds (0 : R)), ∃ n : ℕ, T ^ n ⊆ U

/--A subset B of a topological ring is bounded if for all neighbourhoods U of 0 ∈ R,
there exists a neighbourhood V or 0 such that for all v ∈ V and b ∈ B we have v*b ∈ U.
See [Wedhorn, Def 5.27, p. 36]. -/
def is_bounded (B : set R) : Prop :=
∀ U ∈ nhds (0 : R), ∃ V ∈ nhds (0 : R), ∀ v ∈ V, ∀ b ∈ B, v*b ∈ U

/--A subset B of a topological ring is bounded if and only if for all neighbourhoods U of 0 ∈ R,
there exists a neighbourhood V or 0 such that for all v ∈ V and b ∈ B we have V*B ⊆ U.
(Here V*B denotes the set {v * b | v ∈ V, b ∈ B}.) -/
lemma is_bounded_iff (B : set R) :
  is_bounded B ↔ ∀ U ∈ nhds (0 : R), ∃ V ∈ nhds (0 : R), V * B ⊆ U :=
forall_congr $ λ U, imp_congr iff.rfl $ exists_congr $ λ V, exists_congr $ λ hV,
begin
  split,
  { rintros H _ ⟨v, hv, b, hb, rfl⟩, exact H v hv b hb },
  { intros H v hv b hb, exact H ⟨v, hv, b, hb, rfl⟩ }
end

section topological_ring
variables [topological_ring R]

/--A topological ring with adic topology is bounded.-/
lemma is_adic.is_bounded (h : is_adic R) : is_bounded (univ : set R) :=
begin
  intros U hU,
  rw mem_nhds_sets_iff at hU,
  rcases hU with ⟨V, hV₁, ⟨hV₂, h0⟩⟩,
  tactic.unfreeze_local_instances,
  rcases h with ⟨J, hJ⟩,
  rw is_ideal_adic_iff at hJ,
  have H : (∃ (n : ℕ), (J^n).carrier ⊆ V) :=
  begin
    apply hJ.2,
    exact mem_nhds_sets hV₂ h0,
  end,
  rcases H with ⟨n, hn⟩,
  use (J^n).carrier, -- the key step
  split,
  { exact mem_nhds_sets (hJ.1 n) (J^n).zero_mem },
  { rintros a ha b hb,
    apply hV₁,
    exact hn ((J^n).mul_mem_right ha), }
end

section
open submodule topological_add_group

set_option class.instance_max_depth 58

/--A subset B of a nonarchimedean ring is bounded if and only if
for all neighbourhoods U of 0 ∈ R, there exists an open additive subgroup V such that
V * B generates a subgroup contained in U. -/
lemma is_bounded_add_subgroup_iff (hR : nonarchimedean R) (B : set R) :
  is_bounded B ↔ ∀ U ∈ nhds (0:R), ∃ V : open_add_subgroup R,
    (↑((V : set R) • span ℤ B) : set R) ⊆ U :=
begin
  split,
  { rintros H U hU,
    cases hR U hU with W hW,
    rw is_bounded_iff at H,
    rcases H _ W.mem_nhds_zero with ⟨V', hV', H'⟩,
    cases hR V' hV' with V hV,
    use V,
    refine set.subset.trans _ hW,
    change ↑(span _ _ * span _ _) ⊆ _,
    rw [span_mul_span, span_int_eq_add_group_closure, add_group.closure_subset_iff],
    exact set.subset.trans (set.pointwise_mul_subset_mul hV (set.subset.refl B)) H' },
  { intros H,
    rw is_bounded_iff,
    intros U hU,
    cases H U hU with V hV,
    use [V, V.mem_nhds_zero],
    refine set.subset.trans _ hV,
    rintros _ ⟨v, hv, b, hb, rfl⟩,
    exact mul_mem_mul (subset_span hv) (subset_span hb) }
end

/--If J is an ideal in a topological ring whose topology is J-adic,
then J is topologically nilpotent.-/
lemma is_ideal_adic.topologically_nilpotent {J : ideal R} (h : is-J-adic) :
  is_topologically_nilpotent_subset (↑J : set R) :=
begin
  rw is_ideal_adic_iff at h,
  intros U hU,
  cases h.2 U hU with n hn,
  use n,
  exact set.subset.trans (J.pow_subset_pow) hn
end

end

end topological_ring

namespace is_bounded
open topological_add_group

/--A subset of a bounded subset is bounded. See [Wedhorn, Rmk 5.28(2)].-/
lemma subset {S₁ S₂ : set R} (h : S₁ ⊆ S₂) (H : is_bounded S₂) : is_bounded S₁ :=
begin
  intros U hU,
  rcases H U hU with ⟨V, hV₁, hV₂⟩,
  use [V, hV₁],
  intros v hv b hb,
  exact hV₂ _ hv _ (h hb),
end

/--The subgroup generated by a bounded subset of a nonarchimedean ring is bounded.
See [Wedhorn, Prop 5.30(1)].-/
lemma add_group.closure [topological_ring R] (hR : nonarchimedean R) (T : set R)
  (hT : is_bounded T) : is_bounded (add_group.closure T) :=
begin
  intros U hU,
  -- find subgroup U' in U
  rcases hR U hU with ⟨U', hU'⟩,
  -- U' still a nhd
  -- Use boundedness hypo for T with U' to get V
  rcases hT (U' : set R) U'.mem_nhds_zero with ⟨V, hV, hB⟩,
  -- find subgroup V' in V
  rcases hR V hV with ⟨V', hV'⟩,
  -- V' works for our proof
  use [V', V'.mem_nhds_zero],
  intros v hv b hb,
  -- Suffices to prove we're in U'
  apply hU',
  -- Prove the result by induction
  apply add_group.in_closure.rec_on hb,
  { intros t ht,
    exact hB v (hV' hv) t ht },
  { rw mul_zero, exact U'.zero_mem },
  { intros a Ha Hv,
    rwa [←neg_mul_comm, neg_mul_eq_neg_mul_symm, is_add_subgroup.neg_mem_iff] },
  { intros a b ha hb Ha Hb,
    rw [mul_add],
    exact U'.add_mem Ha Hb }
end

end is_bounded

/--An element r of a topological ring is power bounded if the set of all positive powers of r
is a bounded subset. See [Wedhorn, Def 5.27].-/
definition is_power_bounded (r : R) : Prop := is_bounded (powers r)

/--A subset T of a topological ring is power bounded if the submonoid generated by T is bounded.
See [Wedhorn, Def 5.27].-/
definition is_power_bounded_subset (T : set R) : Prop := is_bounded (monoid.closure T)

namespace power_bounded
open topological_add_group

/-- 0 is power bounded.-/
lemma zero : is_power_bounded (0 : R) :=
λ U hU, ⟨U,
begin
  split, {exact hU},
  intros v hv b H,
  induction H with n H,
  induction n ; { simp [H.symm, pow_succ, mem_of_nhds hU], try {assumption} }
end⟩

/-- 1 is power bounded.-/
lemma one : is_power_bounded (1 : R) :=
λ U hU, ⟨U,
begin
  split, {exact hU},
  intros v hv b H,
  cases H with n H,
  simpa [H.symm]
end⟩

/-- An element r is power bounded if and only if the singleton {r} is power bounded.-/
lemma singleton (r : R) : is_power_bounded r ↔ is_power_bounded_subset ({r} : set R) :=
begin
  unfold is_power_bounded,
  unfold is_power_bounded_subset,
  rw monoid.closure_singleton,
end

/-- A subset of a power bounded set is power bounded. See [Wedhorn, Rmk 5.28(2)].-/
lemma subset {B C : set R} (h : B ⊆ C) (hC : is_power_bounded_subset C) :
  is_power_bounded_subset B :=
λ U hU, exists.elim (hC U hU) $
  λ V ⟨hV, hC⟩, ⟨V, hV, λ v hv b hb, hC v hv b $ monoid.closure_mono h hb⟩

/--The union of two power bounded sets is power bounded. See [Wedhorn, Rmk 5.28(3)].-/
lemma union {S T : set R} (hS : is_power_bounded_subset S) (hT : is_power_bounded_subset T) :
  is_power_bounded_subset (S ∪ T) :=
begin
  intros U hU,
  rcases hT U hU with ⟨V, hV, hVU⟩,
  rcases hS V hV with ⟨W, hW, hWV⟩,
  use [W, hW],
  intros v hv b hb,
  rw monoid.mem_closure_union_iff at hb,
  rcases hb with ⟨y, hy, z, hz, rfl⟩,
  rw [←mul_assoc],
  apply hVU _ _ _ hz,
  exact hWV _ hv _ hy,
end

/--The monoid generated by a power bounded subset is power bounded.-/
lemma monoid.closure {T : set R}
  (hT : is_power_bounded_subset T) : is_power_bounded_subset (monoid.closure T) :=
begin
  refine is_bounded.subset _ hT,
  apply monoid.closure_subset,
  refl
end

/--The product of two power bounded elements is power bounded.-/
lemma mul (a b : R)
  (ha : is_power_bounded a) (hb : is_power_bounded b) :
  is_power_bounded (a * b) :=
begin
  rw singleton at ha hb ⊢,
  refine subset _ (monoid.closure (union ha hb)),
  rw [set.singleton_subset_iff, monoid.mem_closure_union_iff],
  refine ⟨a, _, b, _, rfl⟩; exact monoid.subset_closure (set.mem_singleton _)
end

section topological_ring
variables [topological_ring R]

/--The subgroup generated by a power bounded subset of a nonarchimedean ring is power bounded.
See [Wedhorn, Prop 5.30(1)].-/
lemma add_group.closure (hR : nonarchimedean R) {T : set R}
  (hT : is_power_bounded_subset T) : is_power_bounded_subset (add_group.closure T) :=
begin
  refine is_bounded.subset _ (is_bounded.add_group.closure hR _ hT),
  intros a ha,
  apply monoid.in_closure.rec_on ha,
  { apply add_group.closure_mono,
    exact monoid.subset_closure },
  { apply add_group.mem_closure,
    exact monoid.in_closure.one _ },
  { intros a b ha hb Ha Hb,
    show a * b ∈ ring.closure T,
    exact is_submonoid.mul_mem Ha Hb }
end

/--The subring generated by a power bounded subset of a nonarchimedean ring is power bounded.
See [Wedhorn, Prop 5.30(2)].-/
lemma ring.closure (hR : nonarchimedean R) (T : set R)
  (hT : is_power_bounded_subset T) : is_power_bounded_subset (ring.closure T) :=
add_group.closure hR $ monoid.closure hT

/--The subring generated by a power bounded subset of a nonarchimedean ring is bounded.-/
lemma ring.closure' (hR : nonarchimedean R) (T : set R)
  (hT : is_power_bounded_subset T) : is_bounded (_root_.ring.closure T) :=
is_bounded.subset monoid.subset_closure (ring.closure hR _ hT)

/--The sum of two power bounded elements of a nonarchimedean ring is power bounded.-/
lemma add (hR : nonarchimedean R) (a b : R)
  (ha : is_power_bounded a) (hb : is_power_bounded b) :
  is_power_bounded (a + b) :=
begin
  rw singleton at ha hb ⊢,
  refine subset _ (add_group.closure hR (union ha hb)),
  rw set.singleton_subset_iff,
  apply is_add_submonoid.add_mem;
    apply add_group.subset_closure; simp
end

end topological_ring

end power_bounded

variable (R)

/-- The subring of power bounded elements.
(Note that this definition makes sense for all R,
but this subset is only a subring for certain rings, such as non-archimedean rings.) -/
definition power_bounded_subring := {r : R | is_power_bounded r}

variable {R}

namespace power_bounded_subring
open topological_add_group

/--The coercion from the power bounded subring to the ambient ring.-/
instance : has_coe (power_bounded_subring R) R := ⟨subtype.val⟩

lemma zero_mem : (0 : R) ∈ power_bounded_subring R := power_bounded.zero

lemma one_mem : (1 : R) ∈ power_bounded_subring R := power_bounded.one

lemma mul_mem :
  ∀ ⦃a b : R⦄, a ∈ power_bounded_subring R → b ∈ power_bounded_subring R →
  a * b ∈ power_bounded_subring R :=
power_bounded.mul

/--The subset of power bounded elements of a topological ring is a submonoid.-/
instance : is_submonoid (power_bounded_subring R) :=
{ one_mem := one_mem,
  mul_mem := mul_mem }

section topological_ring
variables [topological_ring R]

lemma add_mem (h : nonarchimedean R) ⦃a b : R⦄
  (ha : a ∈ power_bounded_subring R) (hb : b ∈ power_bounded_subring R) :
  a + b ∈ power_bounded_subring R :=
power_bounded.add h a b ha hb

lemma neg_mem : ∀ ⦃a : R⦄, a ∈ power_bounded_subring R → -a ∈ power_bounded_subring R :=
λ a ha U hU,
begin
  let Usymm := U ∩ {u | -u ∈ U},
  have hUsymm : Usymm ∈ (nhds (0 : R)) :=
  begin
    apply filter.inter_mem_sets hU,
    apply continuous.tendsto (topological_add_group.continuous_neg R) 0,
    simpa
  end,
  rcases ha Usymm hUsymm with ⟨V, ⟨V_nhd, hV⟩⟩,
  use [V, V_nhd],
  rintros v hv _ ⟨n, rfl⟩,
  rw show v * (-a)^n = ((-1)^n * v) * a^n,
  by { rw [neg_eq_neg_one_mul, mul_pow], ring },
  suffices H : (-1)^n * v * a^n ∈ Usymm,
  { exact H.left },
  have H := hV v hv (a^n) ⟨n, rfl⟩,
  cases (@neg_one_pow_eq_or R _ n) with h h;
    simpa [h, H.1, H.2] using H
end

/--The subset of power bounded elements of a nonarchimedean ring is a subgroup.-/
instance (hR : nonarchimedean R) : is_add_subgroup (power_bounded_subring R) :=
{ zero_mem := zero_mem,
  add_mem := add_mem hR,
  neg_mem := neg_mem  }

/--The subset of power bounded elements of a nonarchimedean ring is a subring.-/
instance (hR : nonarchimedean R) : is_subring (power_bounded_subring R) :=
{ ..power_bounded_subring.is_submonoid,
  ..power_bounded_subring.is_add_subgroup hR }

end topological_ring

variable (R)

/--A topological ring is uniform if the subset of power bounded elements is bounded.-/
definition is_uniform : Prop := is_bounded (power_bounded_subring R)

end power_bounded_subring


/-
Copyright (c) 2022 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis
-/

import topology.algebra.module.weak_dual
import algebra.algebra.spectrum
import topology.continuous_function.algebra

/-!
# Character space of a topological algebra

The character space of a topological algebra is the subset of elements of the weak dual that
are also algebra homomorphisms. This space is used in the Gelfand transform, which gives an
isomorphism between a commutative C⋆-algebra and continuous functions on the character space
of the algebra. This, in turn, is used to construct the continuous functional calculus on
C⋆-algebras.

## Implementation notes

We define `character_space 𝕜 A` as a subset of the weak dual, which automatically puts the
correct topology on the space. We then define `to_alg_hom` which provides the algebra homomorphism
corresponding to any element. We also provide `to_clm` which provides the element as a
continuous linear map. (Even though `weak_dual 𝕜 A` is a type copy of `A →L[𝕜] 𝕜`, this is
often more convenient.)

## Tags

character space, Gelfand transform, functional calculus

-/

namespace weak_dual

/-- The character space of a topological algebra is the subset of elements of the weak dual that
are also algebra homomorphisms. -/
def character_space (𝕜 : Type*) (A : Type*) [comm_semiring 𝕜] [topological_space 𝕜]
  [has_continuous_add 𝕜] [has_continuous_const_smul 𝕜 𝕜]
  [non_unital_non_assoc_semiring A] [topological_space A] [module 𝕜 A] :=
  {φ : weak_dual 𝕜 A | (φ ≠ 0) ∧ (∀ (x y : A), φ (x * y) = (φ x) * (φ y))}

variables {𝕜 : Type*} {A : Type*}

namespace character_space

section non_unital_non_assoc_semiring

variables [comm_semiring 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜]
  [has_continuous_const_smul 𝕜 𝕜] [non_unital_non_assoc_semiring A] [topological_space A]
  [module 𝕜 A]

@[simp, norm_cast, protected]
lemma coe_coe (φ : character_space 𝕜 A) : ⇑(φ : weak_dual 𝕜 A) = φ := rfl

/-- Elements of the character space are continuous linear maps. -/
instance : continuous_linear_map_class (character_space 𝕜 A) 𝕜 A 𝕜 :=
{ coe := λ φ, (φ : A → 𝕜),
  coe_injective' := λ φ ψ h, by { ext, exact congr_fun h x },
  map_smulₛₗ := λ φ, (φ : weak_dual 𝕜 A).map_smul,
  map_add := λ φ, (φ : weak_dual 𝕜 A).map_add,
  map_continuous := λ φ, (φ : weak_dual 𝕜 A).cont }

@[ext] lemma ext {φ ψ : character_space 𝕜 A} (h : ∀ x, φ x = ψ x) : φ = ψ := fun_like.ext _ _ h

/-- An element of the character space, as a continuous linear map. -/
def to_clm (φ : character_space 𝕜 A) : A →L[𝕜] 𝕜 := (φ : weak_dual 𝕜 A)

@[simp]

/-- Elements of the character space are non-unital algebra homomorphisms. -/
instance : non_unital_alg_hom_class (character_space 𝕜 A) 𝕜 A 𝕜 :=
{ map_smul := λ φ, map_smul φ,
  map_zero := λ φ, map_zero φ,
  map_mul := λ φ, φ.prop.2,
  .. character_space.continuous_linear_map_class }

/-- An element of the character space, as an non-unital algebra homomorphism. -/
def to_non_unital_alg_hom (φ : character_space 𝕜 A) : A →ₙₐ[𝕜] 𝕜 :=
{ to_fun := (φ : A → 𝕜),
  map_mul' := map_mul φ,
  map_smul' := map_smul φ,
  map_zero' := map_zero φ,
  map_add' := map_add φ }

@[simp]
lemma coe_to_non_unital_alg_hom (φ : character_space 𝕜 A) : ⇑(to_non_unital_alg_hom φ) = φ := rfl

instance [subsingleton A] : is_empty (character_space 𝕜 A) :=
⟨λ φ, φ.prop.1 $ continuous_linear_map.ext (λ x, by simp only [subsingleton.elim x 0, map_zero])⟩

variables (𝕜 A)

lemma union_zero :
  character_space 𝕜 A ∪ {0} = {φ : weak_dual 𝕜 A | ∀ (x y : A), φ (x * y) = (φ x) * (φ y)} :=
le_antisymm
  (by { rintros φ (hφ | h₀), { exact hφ.2 }, { exact λ x y, by simp [set.eq_of_mem_singleton h₀] }})
  (λ φ hφ, or.elim (em $ φ = 0) (λ h₀, or.inr h₀) (λ h₀, or.inl ⟨h₀, hφ⟩))

/-- The `character_space 𝕜 A` along with `0` is always a closed set in `weak_dual 𝕜 A`. -/
lemma union_zero_is_closed [t2_space 𝕜] [has_continuous_mul 𝕜] :
  is_closed (character_space 𝕜 A ∪ {0}) :=
begin
  simp only [union_zero, set.set_of_forall],
  exact is_closed_Inter (λ x, is_closed_Inter $ λ y, is_closed_eq (eval_continuous _) $
    (eval_continuous _).mul (eval_continuous _))
end

end non_unital_non_assoc_semiring

section unital

variables [comm_ring 𝕜] [no_zero_divisors 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜]
  [has_continuous_const_smul 𝕜 𝕜] [topological_space A] [semiring A] [algebra 𝕜 A]

/-- In a unital algebra, elements of the character space are algebra homomorphisms. -/
instance : alg_hom_class (character_space 𝕜 A) 𝕜 A 𝕜 :=
have map_one' : ∀ φ : character_space 𝕜 A, φ 1 = 1 := λ φ,
begin
  have h₁ : (φ 1) * (1 - φ 1) = 0 := by rw [mul_sub, sub_eq_zero, mul_one, ←map_mul φ, one_mul],
  rcases mul_eq_zero.mp h₁ with h₂ | h₂,
  { have : ∀ a, φ (a * 1) = 0 := λ a, by simp only [map_mul φ, h₂, mul_zero],
    exact false.elim (φ.prop.1 $ continuous_linear_map.ext $ by simpa only [mul_one] using this) },
  { exact (sub_eq_zero.mp h₂).symm },
end,
{ map_one := map_one',
  commutes := λ φ r,
  begin
  { rw [algebra.algebra_map_eq_smul_one, algebra.id.map_eq_id, ring_hom.id_apply],
    change ((φ : weak_dual 𝕜 A) : A →L[𝕜] 𝕜) (r • 1) = r,
    rw [map_smul, algebra.id.smul_eq_mul, character_space.coe_coe, map_one' φ, mul_one] },
  end,
  .. character_space.non_unital_alg_hom_class }

/-- An element of the character space of a unital algebra, as an algebra homomorphism. -/
@[simps] def to_alg_hom (φ : character_space 𝕜 A) : A →ₐ[𝕜] 𝕜 :=
{ map_one' := map_one φ,
  commutes' := alg_hom_class.commutes φ,
  ..to_non_unital_alg_hom φ }

lemma eq_set_map_one_map_mul [nontrivial 𝕜] : character_space 𝕜 A =
  {φ : weak_dual 𝕜 A | (φ 1 = 1) ∧ (∀ (x y : A), φ (x * y) = (φ x) * (φ y))} :=
begin
  ext x,
  refine ⟨λ h, ⟨map_one (⟨x, h⟩ : character_space 𝕜 A), h.2⟩, λ h, ⟨_, h.2⟩⟩,
  rintro rfl,
  simpa using h.1,
end

/-- under suitable mild assumptions on `𝕜`, the character space is a closed set in
`weak_dual 𝕜 A`. -/
protected lemma is_closed [nontrivial 𝕜] [t2_space 𝕜] [has_continuous_mul 𝕜] :
  is_closed (character_space 𝕜 A) :=
begin
  rw [eq_set_map_one_map_mul, set.set_of_and],
  refine is_closed.inter (is_closed_eq (eval_continuous _) continuous_const) _,
  simpa only [(union_zero 𝕜 A).symm] using union_zero_is_closed _ _,
end

end unital

section ring

variables [comm_ring 𝕜] [no_zero_divisors 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜]
  [has_continuous_const_smul 𝕜 𝕜] [topological_space A] [ring A] [algebra 𝕜 A]

lemma apply_mem_spectrum [nontrivial 𝕜] (φ : character_space 𝕜 A) (a : A) : φ a ∈ spectrum 𝕜 a :=
alg_hom.apply_mem_spectrum φ a

lemma ext_ker {φ ψ : character_space 𝕜 A} (h : ring_hom.ker φ = ring_hom.ker ψ) : φ = ψ :=
begin
  ext,
  have : x - algebra_map 𝕜 A (ψ x) ∈ ring_hom.ker φ,
  { simpa only [h, ring_hom.mem_ker, map_sub, alg_hom_class.commutes] using sub_self (ψ x) },
  { rwa [ring_hom.mem_ker, map_sub, alg_hom_class.commutes, sub_eq_zero] at this, }
end

end ring

end character_space

section kernel

variables [field 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜] [has_continuous_const_smul 𝕜 𝕜]
variables [ring A] [topological_space A] [algebra 𝕜 A]

/-- The `ring_hom.ker` of `φ : character_space 𝕜 A` is maximal. -/
instance ker_is_maximal (φ : character_space 𝕜 A) : (ring_hom.ker φ).is_maximal :=
ring_hom.ker_is_maximal_of_surjective φ $ λ z, ⟨algebra_map 𝕜 A z,
  by simp only [alg_hom_class.commutes, algebra.id.map_eq_id, ring_hom.id_apply]⟩

end kernel

section gelfand_transform

open continuous_map

variables (𝕜 A) [comm_ring 𝕜] [no_zero_divisors 𝕜] [topological_space 𝕜]
  [topological_ring 𝕜] [topological_space A] [semiring A] [algebra 𝕜 A]

/-- The **Gelfand transform** is an algebra homomorphism (over `𝕜`) from a topological `𝕜`-algebra
`A` into the `𝕜`-algebra of continuous `𝕜`-valued functions on the `character_space 𝕜 A`.
The character space itself consists of all algebra homomorphisms from `A` to `𝕜`.  -/
@[simps] def gelfand_transform : A →ₐ[𝕜] C(character_space 𝕜 A, 𝕜) :=
{ to_fun := λ a,
  { to_fun := λ φ, φ a,
    continuous_to_fun := (eval_continuous a).comp continuous_induced_dom },
    map_one' := by {ext, simp only [coe_mk, coe_one, pi.one_apply, map_one a] },
    map_mul' := λ a b, by {ext, simp only [map_mul, coe_mk, coe_mul, pi.mul_apply] },
    map_zero' := by {ext, simp only [map_zero, coe_mk, coe_mul, coe_zero, pi.zero_apply], },
    map_add' :=  λ a b, by {ext, simp only [map_add, coe_mk, coe_add, pi.add_apply] },
    commutes' := λ k, by {ext, simp only [alg_hom_class.commutes, algebra.id.map_eq_id,
      ring_hom.id_apply, coe_mk, algebra_map_apply, algebra.id.smul_eq_mul, mul_one] } }

end gelfand_transform

end weak_dual