import Lean4_filters.Lattice.Basic
import Lean4_filters.Tactics.Basic

class HasMem (α : outParam $ Type u) (β : Type v) where
    mem : α → β → Prop

infix:50 " ∈ " => HasMem.mem

def Set (α : Type u) := α → Prop

namespace Set

variable {α : Type u}

instance : HasMem α (Set α) := ⟨λ a s => s a⟩

theorem ext {s t : Set α} (h : ∀ x, x ∈ s ↔ x ∈ t) : s = t :=
  funext $ λ x=> propext $ h x

instance : HasLessEq (Set α) := ⟨λ s t => ∀ {x : α}, x ∈ s → x ∈ t⟩

instance : PartialOrder (Set α) where
  refl := λ s x => id
  antisymm := λ s t hst hts => ext $ λ x => ⟨hst, hts⟩
  trans := λ s t u hst htu x hxs => htu $ hst hxs

instance : HasSup (Set α) := ⟨λ s t x => x ∈ s ∨ x ∈ t⟩

instance : HasInf (Set α) := ⟨λ s t x => x ∈ s ∧ x ∈ t⟩

instance : Lattice (Set α) where
  leSupLeft := λ a b x => Or.inl
  leSupRight := λ a b x => Or.inr
  supLe := λ a b c hac hbc x => Or.rec hac hbc
  infLeLeft := λ a b x hx => hx.1
  infLeRight := λ a b x hx => hx.2
  leInf := λ a b c hab hac x hx => ⟨hab hx, hac hx⟩

example : Lattice (Set α) where
  leSupLeft := by
    intros a b x hx;
    left;
    exact hx;
  leSupRight := by
    intros a b x;
    intro hx;
    right;
    exact hx;
  supLe := by
    intros a b c hac hbc x hx;
    cases hx;
      apply hac; assumption
    apply hbc; assumption
  infLeLeft := by
    intros a b x hx;
    cases hx with ha hb;
    exact ha;
  infLeRight := by
    intros _ _ _ hx;
    cases hx with ha hb;
    exact hb;
  leInf := by
    intro a b c hab hac x hx;
    split;
      exact hab hx;
    exact hac hx;

def univ : Set α := λ _ => True

def empty : Set α := λ _ => False

def setOf (p : α → Prop) : Set α := p

declare_syntax_cat index
syntax ident : index
syntax ident ":" term : index
syntax ident "∈" term : index

-- Notation for sets
syntax "{" index "|" term "}" : term

macro_rules
| `({ $x:ident : $t | $p }) => `(setOf (λ ($x:ident : $t) => $p))
| `({ $x:ident | $p }) => `(setOf (λ ($x:ident) => $p))
| `({ $x:ident ∈ $s | $p }) => `(setOf (λ $x => $x ∈ $s → $p))

-- Notation for ∀ x ∈ s, p and ∃ x ∈ s, p
syntax "∀" index "," term : term
syntax "∃" index "," term : term

macro_rules
| `(∀ $x:ident ∈ $s, $p) => `(∀ $x:ident, $x ∈ $s → $p)
| `(∃ $x:ident ∈ $s, $p) => `(∃ $x:ident, $x ∈ $s ∧ $p)

def map (f : α → β) (s : Set α) : Set β := {b : β | ∃ a ∈ s, f a = b }

def comap (f : α → β) (t : Set β) : Set α := {a : α | f a ∈ t }

infix:80 " '' " => Set.map
infix:80 " ⁻¹ " => Set.comap

theorem gc {α β} (f : α → β) : galoisConnection (map f) (comap f) :=
by
  intros s t;
  split_iffs;
  { intro h x hxs;
    apply h;
    refine ⟨x, hxs, rfl⟩ };
  { intro h x hx;
    let ⟨a, has, h2⟩ := hx;
    rw ← h2;
    exact h has }

end Set


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

import number_theory.cyclotomic.primitive_roots
import ring_theory.discriminant

/-!
# Discriminant of cyclotomic fields
We compute the discriminant of a `p ^ n`-th cyclotomic extension.

## Main results
* `is_cyclotomic_extension.discr_odd_prime` : if `p` is an odd prime such that
  `is_cyclotomic_extension {p} K L` and `irreducible (cyclotomic p K)`, then
  `discr K (hζ.power_basis K).basis = (-1) ^ ((p - 1) / 2) * p ^ (p - 2)` for any
  `hζ : is_primitive_root ζ p`.

-/

universes u v

open algebra polynomial nat is_primitive_root power_basis

open_locale polynomial cyclotomic

namespace is_primitive_root

variables {n : ℕ+} {K : Type u} [field K] [char_zero K] {ζ : K}
variables [is_cyclotomic_extension {n} ℚ K]

/-- The discriminant of the power basis given by a primitive root of unity `ζ` is the same as the
discriminant of the power basis given by `ζ - 1`. -/
lemma discr_zeta_eq_discr_zeta_sub_one (hζ : is_primitive_root ζ n) :
  discr ℚ (hζ.power_basis ℚ).basis = discr ℚ (hζ.sub_one_power_basis ℚ).basis :=
begin
  haveI : number_field K := number_field.mk,
  have H₁ : (aeval (hζ.power_basis ℚ).gen) (X - 1 : ℤ[X]) = (hζ.sub_one_power_basis ℚ).gen :=
    by simp,
  have H₂ : (aeval (hζ.sub_one_power_basis ℚ).gen) (X + 1 : ℤ[X]) = (hζ.power_basis ℚ).gen :=
    by simp,
  refine discr_eq_discr_of_to_matrix_coeff_is_integral _
    (λ i j, to_matrix_is_integral H₁ _ _ _ _)
    (λ i j, to_matrix_is_integral H₂ _ _ _ _),
  { exact hζ.is_integral n.pos },
  { refine minpoly.is_integrally_closed_eq_field_fractions' _ (hζ.is_integral n.pos) },
  { exact is_integral_sub (hζ.is_integral n.pos) is_integral_one },
  { refine minpoly.is_integrally_closed_eq_field_fractions' _ _,
    exact is_integral_sub (hζ.is_integral n.pos) is_integral_one }
end

end is_primitive_root

namespace is_cyclotomic_extension

variables {p : ℕ+} {k : ℕ} {K : Type u} {L : Type v} {ζ : L} [field K] [field L]
variables [algebra K L]

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ (k + 1)} K L`, then the discriminant of
`hζ.power_basis K` is `(-1) ^ ((p ^ (k + 1).totient) / 2) * p ^ (p ^ k * ((p - 1) * (k + 1) - 1))`
if `irreducible (cyclotomic (p ^ (k + 1)) K))`, and `p ^ (k + 1) ≠ 2`. -/
lemma discr_prime_pow_ne_two [is_cyclotomic_extension {p ^ (k + 1)} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ ↑(p ^ (k + 1))) (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K))
  (hk : p ^ (k + 1) ≠ 2) :
  discr K (hζ.power_basis K).basis =
  (-1) ^ (((p ^ (k + 1) : ℕ).totient) / 2) * p ^ ((p : ℕ) ^ k * ((p - 1) * (k + 1) - 1)) :=
begin
  haveI hne := is_cyclotomic_extension.ne_zero' (p ^ (k + 1)) K L,
  rw [discr_power_basis_eq_norm, finrank L hirr, hζ.power_basis_gen _,
    ← hζ.minpoly_eq_cyclotomic_of_irreducible hirr, pnat.pow_coe,
    totient_prime_pow hp.out (succ_pos k), succ_sub_one],
  have hp2 : p = 2 → k ≠ 0,
  { unfreezingI { rintro rfl rfl },
    exact absurd rfl hk },
  congr' 1,
  { unfreezingI { rcases eq_or_ne p 2 with rfl | hp2 },
    { unfreezingI { rcases nat.exists_eq_succ_of_ne_zero (hp2 rfl) with ⟨k, rfl⟩ },
      rw [pnat.coe_bit0, pnat.one_coe, succ_sub_succ_eq_sub, tsub_zero,
        mul_one, pow_succ, mul_assoc, nat.mul_div_cancel_left _ zero_lt_two,
        nat.mul_div_cancel_left _ zero_lt_two],
      unfreezingI { cases k },
      { simp },
      { rw [pow_succ, (even_two.mul_right _).neg_one_pow,
          ((even_two.mul_right _).mul_right _).neg_one_pow] } },
    { replace hp2 : (p : ℕ) ≠ 2,
      { rwa [ne.def, ← pnat.one_coe, ← pnat.coe_bit0, pnat.coe_inj] },
      have hpo : odd (p : ℕ) := hp.out.odd_of_ne_two hp2,
      obtain ⟨a, ha⟩ := (hp.out.even_sub_one hp2).two_dvd,
      rw [ha, mul_left_comm, mul_assoc, nat.mul_div_cancel_left _ two_pos,
        nat.mul_div_cancel_left _ two_pos, mul_right_comm, pow_mul, (hpo.pow.mul _).neg_one_pow,
        pow_mul, hpo.pow.neg_one_pow],
      refine nat.even.sub_odd _ (even_two_mul _) odd_one,
      rw [mul_left_comm, ← ha],
      exact one_le_mul (one_le_pow _ _ hp.1.pos) (succ_le_iff.2 $ tsub_pos_of_lt hp.1.one_lt) } },
  { have H := congr_arg derivative (cyclotomic_prime_pow_mul_X_pow_sub_one K p k),
    rw [derivative_mul, derivative_sub, derivative_one, sub_zero, derivative_X_pow, C_eq_nat_cast,
      derivative_sub, derivative_one, sub_zero, derivative_X_pow, C_eq_nat_cast, ← pnat.pow_coe,
      hζ.minpoly_eq_cyclotomic_of_irreducible hirr] at H,
    replace H := congr_arg (λ P, aeval ζ P) H,
    simp only [aeval_add, aeval_mul, minpoly.aeval, zero_mul, add_zero, aeval_nat_cast,
      _root_.map_sub, aeval_one, aeval_X_pow] at H,
    replace H := congr_arg (algebra.norm K) H,
    have hnorm : (norm K) (ζ ^ (p : ℕ) ^ k - 1) = p ^ ((p : ℕ) ^ k),
    { by_cases hp : p = 2,
      { exact hζ.pow_sub_one_norm_prime_pow_of_ne_zero hirr le_rfl (hp2 hp) },
      { exact hζ.pow_sub_one_norm_prime_ne_two hirr le_rfl hp } },
    rw [monoid_hom.map_mul, hnorm, monoid_hom.map_mul, ← map_nat_cast (algebra_map K L),
      algebra.norm_algebra_map, finrank L hirr, pnat.pow_coe, totient_prime_pow hp.out (succ_pos k),
      nat.sub_one, nat.pred_succ, ← hζ.minpoly_eq_cyclotomic_of_irreducible hirr, map_pow,
      hζ.norm_eq_one hk hirr, one_pow, mul_one, cast_pow, ← coe_coe, ← pow_mul, ← mul_assoc,
      mul_comm (k + 1), mul_assoc] at H,
    { have := mul_pos (succ_pos k) (tsub_pos_of_lt hp.out.one_lt),
      rw [← succ_pred_eq_of_pos this, mul_succ, pow_add _ _ ((p : ℕ) ^ k)] at H,
      replace H := (mul_left_inj' (λ h, _)).1 H,
      { simpa only [← pnat.pow_coe, H, mul_comm _ (k + 1)] },
      { replace h := pow_eq_zero h,
        rw [coe_coe] at h,
        simpa using hne.1 } } }
end

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ (k + 1)} K L`, then the discriminant of
`hζ.power_basis K` is `(-1) ^ (p ^ k * (p - 1) / 2) * p ^ (p ^ k * ((p - 1) * (k + 1) - 1))`
if `irreducible (cyclotomic (p ^ (k + 1)) K))`, and `p ^ (k + 1) ≠ 2`. -/
lemma discr_prime_pow_ne_two' [is_cyclotomic_extension {p ^ (k + 1)} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ ↑(p ^ (k + 1))) (hirr : irreducible (cyclotomic (↑(p ^ (k + 1)) : ℕ) K))
  (hk : p ^ (k + 1) ≠ 2) :
  discr K (hζ.power_basis K).basis =
  (-1) ^ (((p : ℕ) ^ k  * (p - 1)) / 2) * p ^ ((p : ℕ) ^ k * ((p - 1) * (k + 1) - 1)) :=
by simpa [totient_prime_pow hp.out (succ_pos k)] using discr_prime_pow_ne_two hζ hirr hk

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ k} K L`, then the discriminant of
`hζ.power_basis K` is `(-1) ^ ((p ^ k).totient / 2) * p ^ (p ^ (k - 1) * ((p - 1) * k - 1))`
if `irreducible (cyclotomic (p ^ k) K))`. Beware that in the cases `p ^ k = 1` and `p ^ k = 2`
the formula uses `1 / 2 = 0` and `0 - 1 = 0`. It is useful only to have a uniform result.
See also `is_cyclotomic_extension.discr_prime_pow_eq_unit_mul_pow`. -/
lemma discr_prime_pow [hcycl : is_cyclotomic_extension {p ^ k} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ ↑(p ^ k)) (hirr : irreducible (cyclotomic (↑(p ^ k) : ℕ) K)) :
  discr K (hζ.power_basis K).basis =
  (-1) ^ (((p ^ k : ℕ).totient) / 2) * p ^ ((p : ℕ) ^ (k - 1) * ((p - 1) * k - 1)) :=
begin
  unfreezingI { cases k },
  { simp only [coe_basis, pow_zero, power_basis_gen, totient_one, mul_zero, mul_one, show 1 / 2 = 0,
      by refl, discr, trace_matrix],
    have hζone : ζ = 1 := by simpa using hζ,
    rw [hζ.power_basis_dim _, hζone, ← (algebra_map K L).map_one,
      minpoly.eq_X_sub_C_of_algebra_map_inj _ (algebra_map K L).injective, nat_degree_X_sub_C],
    simp only [trace_matrix, map_one, one_pow, matrix.det_unique, trace_form_apply, mul_one],
    rw [← (algebra_map K L).map_one, trace_algebra_map, finrank _ hirr],
    { simp },
    { apply_instance },
    { exact hcycl } },
  { by_cases hk : p ^ (k + 1) = 2,
    { have hp : p = 2,
      { rw [← pnat.coe_inj, pnat.coe_bit0, pnat.one_coe, pnat.pow_coe, ← pow_one 2] at hk,
      replace hk := eq_of_prime_pow_eq (prime_iff.1 hp.out) (prime_iff.1 nat.prime_two)
        (succ_pos _) hk,
      rwa [show 2 = ((2 : ℕ+) : ℕ), by simp, pnat.coe_inj] at hk },
      rw [hp, ← pnat.coe_inj, pnat.pow_coe, pnat.coe_bit0, pnat.one_coe] at hk,
      nth_rewrite 1 [← pow_one 2] at hk,
      replace hk := nat.pow_right_injective rfl.le hk,
      rw [add_left_eq_self] at hk,
      simp only [hp, hk, pow_one, pnat.coe_bit0, pnat.one_coe] at hζ,
      simp only [hp, hk, show 1 / 2 = 0, by refl, coe_basis, pow_one, power_basis_gen,
        pnat.coe_bit0, pnat.one_coe, totient_two, pow_zero, mul_one, mul_zero],
      rw [power_basis_dim, hζ.eq_neg_one_of_two_right, show (-1 : L) = algebra_map K L (-1),
        by simp, minpoly.eq_X_sub_C_of_algebra_map_inj _ (algebra_map K L).injective,
        nat_degree_X_sub_C],
      simp only [discr, trace_matrix_apply, matrix.det_unique, fin.default_eq_zero, fin.coe_zero,
        pow_zero, trace_form_apply, mul_one],
      rw [← (algebra_map K L).map_one, trace_algebra_map, finrank _ hirr, hp, hk],
      { simp },
      { apply_instance },
      { exact hcycl } },
    { exact discr_prime_pow_ne_two hζ hirr hk } }
end

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ k} K L`, then there are `u : ℤˣ` and
`n : ℕ` such that the discriminant of `hζ.power_basis K` is `u * p ^ n`. Often this is enough and
less cumbersome to use than `is_cyclotomic_extension.discr_prime_pow`. -/
lemma discr_prime_pow_eq_unit_mul_pow [is_cyclotomic_extension {p ^ k} K L]
  [hp : fact (p : ℕ).prime] (hζ : is_primitive_root ζ ↑(p ^ k))
  (hirr : irreducible (cyclotomic (↑(p ^ k) : ℕ) K)) :
  ∃ (u : ℤˣ) (n : ℕ), discr K (hζ.power_basis K).basis = u * p ^ n :=
begin
  rw [discr_prime_pow hζ hirr],
  by_cases heven : even (((p ^ k : ℕ).totient) / 2),
  { refine ⟨1, (p : ℕ) ^ (k - 1) * ((p - 1) * k - 1), by simp [heven.neg_one_pow]⟩ },
  { exact ⟨-1, (p : ℕ) ^ (k - 1) * ((p - 1) * k - 1),
      by simp [(odd_iff_not_even.2 heven).neg_one_pow]⟩ },
end

/-- If `p` is an odd prime and `is_cyclotomic_extension {p} K L`, then
`discr K (hζ.power_basis K).basis = (-1) ^ ((p - 1) / 2) * p ^ (p - 2)` if
`irreducible (cyclotomic p K)`. -/
lemma discr_odd_prime [is_cyclotomic_extension {p} K L] [hp : fact (p : ℕ).prime]
  (hζ : is_primitive_root ζ p) (hirr : irreducible (cyclotomic p K)) (hodd : p ≠ 2) :
  discr K (hζ.power_basis K).basis = (-1) ^ (((p : ℕ) - 1) / 2) * p ^ ((p : ℕ) - 2) :=
begin
  haveI : is_cyclotomic_extension {p ^ (0 + 1)} K L,
  { rw [zero_add, pow_one],
    apply_instance },
  have hζ' : is_primitive_root ζ ↑(p ^ (0 + 1)) := by simpa using hζ,
  convert discr_prime_pow_ne_two hζ' (by simpa [hirr]) (by simp [hodd]),
  { rw [zero_add, pow_one, totient_prime hp.out] },
  { rw [pow_zero, one_mul, zero_add, mul_one, nat.sub_sub] }
end

end is_cyclotomic_extension


/-
Copyright (c) 2021 Henry Swanson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henry Swanson
-/
import dynamics.fixed_points.basic
import group_theory.perm.option
import logic.equiv.basic
import logic.equiv.option

/-!
# Derangements on types

In this file we define `derangements α`, the set of derangements on a type `α`.

We also define some equivalences involving various subtypes of `perm α` and `derangements α`:
* `derangements_option_equiv_sigma_at_most_one_fixed_point`: An equivalence between
  `derangements (option α)` and the sigma-type `Σ a : α, {f : perm α // fixed_points f ⊆ a}`.
* `derangements_recursion_equiv`: An equivalence between `derangements (option α)` and the
  sigma-type `Σ a : α, (derangements (({a}ᶜ : set α) : Type _) ⊕ derangements α)` which is later
  used to inductively count the number of derangements.

In order to prove the above, we also prove some results about the effect of `equiv.remove_none`
on derangements: `remove_none.fiber_none` and `remove_none.fiber_some`.
-/

open equiv function

/-- A permutation is a derangement if it has no fixed points. -/
def derangements (α : Type*) : set (perm α) := {f : perm α | ∀ x : α, f x ≠ x}

variables {α β : Type*}

lemma mem_derangements_iff_fixed_points_eq_empty {f : perm α} :
  f ∈ derangements α ↔ fixed_points f = ∅ :=
set.eq_empty_iff_forall_not_mem.symm

/-- If `α` is equivalent to `β`, then `derangements α` is equivalent to `derangements β`. -/
def equiv.derangements_congr (e : α ≃ β) : (derangements α ≃ derangements β) :=
e.perm_congr.subtype_equiv $ λ f, e.forall_congr $ by simp

namespace derangements

/-- Derangements on a subtype are equivalent to permutations on the original type where points are
fixed iff they are not in the subtype. -/
protected def subtype_equiv (p : α → Prop) [decidable_pred p] :
  derangements (subtype p) ≃ {f : perm α // ∀ a, ¬p a ↔ a ∈ fixed_points f} :=
calc
  derangements (subtype p)
      ≃ {f : {f : perm α // ∀ a, ¬p a → a ∈ fixed_points f} // ∀ a, a ∈ fixed_points f → ¬p a}
      : begin
        refine (perm.subtype_equiv_subtype_perm p).subtype_equiv (λ f, ⟨λ hf a hfa ha, _, _⟩),
        { refine hf ⟨a, ha⟩ (subtype.ext _),
          rwa [mem_fixed_points, is_fixed_pt, perm.subtype_equiv_subtype_perm, @coe_fn_coe_base',
               equiv.coe_fn_mk, subtype.coe_mk, equiv.perm.of_subtype_apply_of_mem]
            at hfa },
        rintro hf ⟨a, ha⟩ hfa,
        refine hf _ _ ha,
        change perm.subtype_equiv_subtype_perm p f a = a,
        rw [perm.subtype_equiv_subtype_perm_apply_of_mem f ha, hfa, subtype.coe_mk],
      end
  ... ≃ {f : perm α // ∃ (h : ∀ a, ¬p a → a ∈ fixed_points f), ∀ a, a ∈ fixed_points f → ¬p a}
      : subtype_subtype_equiv_subtype_exists _ _
  ... ≃ {f : perm α // ∀ a, ¬p a ↔ a ∈ fixed_points f}
      : subtype_equiv_right (λ f, by simp_rw [exists_prop, ←forall_and_distrib,
        ←iff_iff_implies_and_implies])

/-- The set of permutations that fix either `a` or nothing is equivalent to the sum of:
    - derangements on `α`
    - derangements on `α` minus `a`. -/
def at_most_one_fixed_point_equiv_sum_derangements [decidable_eq α] (a : α) :
  {f : perm α // fixed_points f ⊆ {a}} ≃ (derangements ({a}ᶜ : set α)) ⊕ derangements α :=
calc
  {f : perm α // fixed_points f ⊆ {a}}
      ≃ {f : {f : perm α // fixed_points f ⊆ {a}} // a ∈ fixed_points f}
        ⊕ {f : {f : perm α // fixed_points f ⊆ {a}} // a ∉ fixed_points f}
      : (equiv.sum_compl _).symm
  ... ≃ {f : perm α // fixed_points f ⊆ {a} ∧ a ∈ fixed_points f}
        ⊕ {f : perm α // fixed_points f ⊆ {a} ∧ a ∉ fixed_points f}
      : begin
        refine equiv.sum_congr _ _;
        { convert subtype_subtype_equiv_subtype_inter _ _, ext f, refl }
      end
  ... ≃ {f : perm α // fixed_points f = {a}} ⊕ {f : perm α // fixed_points f = ∅}
      : begin
        refine equiv.sum_congr (subtype_equiv_right $ λ f, _) (subtype_equiv_right $ λ f, _),
        { rw [set.eq_singleton_iff_unique_mem, and_comm],
          refl },
        { rw set.eq_empty_iff_forall_not_mem,
          refine ⟨λ h x hx, h.2 (h.1 hx ▸ hx), λ h, ⟨λ x hx, (h _ hx).elim, h _⟩⟩ }
      end
  ... ≃ (derangements ({a}ᶜ : set α)) ⊕ derangements α
      : begin
        refine equiv.sum_congr ((derangements.subtype_equiv _).trans $ subtype_equiv_right $ λ x,
          _).symm (subtype_equiv_right $ λ f, mem_derangements_iff_fixed_points_eq_empty.symm),
        rw [eq_comm, set.ext_iff],
        simp_rw [set.mem_compl_iff, not_not],
      end

namespace equiv
variables [decidable_eq α]

/-- The set of permutations `f` such that the preimage of `(a, f)` under
    `equiv.perm.decompose_option` is a derangement. -/
def remove_none.fiber (a : option α) : set (perm α) :=
  {f : perm α | (a, f) ∈ equiv.perm.decompose_option '' derangements (option α)}

lemma remove_none.mem_fiber (a : option α) (f : perm α) :
  f ∈ remove_none.fiber a ↔
  ∃ F : perm (option α), F ∈ derangements (option α) ∧ F none = a ∧ remove_none F = f :=
by simp [remove_none.fiber, derangements]

lemma remove_none.fiber_none : remove_none.fiber (@none α) = ∅ :=
begin
  rw set.eq_empty_iff_forall_not_mem,
  intros f hyp,
  rw remove_none.mem_fiber at hyp,
  rcases hyp with ⟨F, F_derangement, F_none, _⟩,
  exact F_derangement none F_none
end

/-- For any `a : α`, the fiber over `some a` is the set of permutations
    where `a` is the only possible fixed point. -/
lemma remove_none.fiber_some (a : α) :
  (remove_none.fiber (some a)) = {f : perm α | fixed_points f ⊆ {a}} :=
begin
  ext f,
  split,
  { rw remove_none.mem_fiber,
    rintro ⟨F, F_derangement, F_none, rfl⟩ x x_fixed,
    rw mem_fixed_points_iff at x_fixed,
    apply_fun some at x_fixed,
    cases Fx : F (some x) with y,
    { rwa [remove_none_none F Fx, F_none, option.some_inj, eq_comm] at x_fixed },
    { exfalso, rw remove_none_some F ⟨y, Fx⟩ at x_fixed, exact F_derangement _ x_fixed } },
  { intro h_opfp,
    use equiv.perm.decompose_option.symm (some a, f),
    split,
    { intro x,
      apply_fun (swap none (some a)),
      simp only [perm.decompose_option_symm_apply, swap_apply_self, perm.coe_mul],
      cases x,
      { simp },
      simp only [equiv.option_congr_apply, option.map_some'],
      by_cases x_vs_a : x = a,
      { rw [x_vs_a, swap_apply_right], apply option.some_ne_none },
      have ne_1 : some x ≠ none := option.some_ne_none _,
      have ne_2 : some x ≠ some a := (option.some_injective α).ne_iff.mpr x_vs_a,
      rw [swap_apply_of_ne_of_ne ne_1 ne_2, (option.some_injective α).ne_iff],
      intro contra,
      exact x_vs_a (h_opfp contra) },
    { rw apply_symm_apply } }
end

end equiv

section option
variables [decidable_eq α]

/-- The set of derangements on `option α` is equivalent to the union over `a : α`
    of "permutations with `a` the only possible fixed point". -/
def derangements_option_equiv_sigma_at_most_one_fixed_point :
  derangements (option α) ≃ Σ a : α, {f : perm α | fixed_points f ⊆ {a}} :=
begin
  have fiber_none_is_false : (equiv.remove_none.fiber (@none α)) -> false,
  { rw equiv.remove_none.fiber_none, exact is_empty.false },

  calc derangements (option α)
      ≃ equiv.perm.decompose_option '' derangements (option α) : equiv.image _ _
  ... ≃ Σ (a : option α), ↥(equiv.remove_none.fiber a)         : set_prod_equiv_sigma _
  ... ≃ Σ (a : α), ↥(equiv.remove_none.fiber (some a))
          : sigma_option_equiv_of_some _ fiber_none_is_false
  ... ≃ Σ (a : α), {f : perm α | fixed_points f ⊆ {a}}
          : by simp_rw equiv.remove_none.fiber_some,
end

/-- The set of derangements on `option α` is equivalent to the union over all `a : α` of
    "derangements on `α` ⊕ derangements on `{a}ᶜ`". -/
def derangements_recursion_equiv :
  derangements (option α) ≃ Σ a : α, (derangements (({a}ᶜ : set α) : Type _) ⊕ derangements α) :=
derangements_option_equiv_sigma_at_most_one_fixed_point.trans (sigma_congr_right
  at_most_one_fixed_point_equiv_sum_derangements)

end option

end derangements


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

import algebra.algebra.tower
import data.polynomial.algebra_map

/-!
# Algebra towers for polynomial

This file defines the algebra tower structure for the type `polynomial R`,
and proves some basic results.
-/

universes u v w u₁

variables (R : Type u) (S : Type v) (A : Type w) (B : Type u₁)

namespace is_scalar_tower

section semiring
variables [comm_semiring R] [comm_semiring S] [semiring A] [semiring B]
variables [algebra R S] [algebra S A] [algebra S B] [algebra R A] [algebra R B]
variables [is_scalar_tower R S A] [is_scalar_tower R S B]

variables (R) {S A B}

instance polynomial : is_scalar_tower R S (polynomial A) :=
of_algebra_map_eq $ λ x, congr_arg polynomial.C $ algebra_map_apply R S A x

variables (R S A)
theorem aeval_apply (x : A) (p : polynomial R) : polynomial.aeval x p =
  polynomial.aeval x (polynomial.map (algebra_map R S) p) :=
by rw [polynomial.aeval_def, polynomial.aeval_def, polynomial.eval₂_map, algebra_map_eq R S A]

end semiring

section comm_semiring
variables [comm_semiring R] [comm_semiring A] [comm_semiring B]
variables [algebra R A] [algebra A B] [algebra R B] [is_scalar_tower R A B]

lemma algebra_map_aeval (x : A) (p : polynomial R) :
  algebra_map A B (polynomial.aeval x p) = polynomial.aeval (algebra_map A B x) p :=
by rw [polynomial.aeval_def, polynomial.aeval_def, polynomial.hom_eval₂,
  ←is_scalar_tower.algebra_map_eq]

lemma aeval_eq_zero_of_aeval_algebra_map_eq_zero {x : A} {p : polynomial R}
  (h : function.injective (algebra_map A B)) (hp : polynomial.aeval (algebra_map A B x) p = 0) :
  polynomial.aeval x p = 0 :=
begin
  rw [← algebra_map_aeval, ← (algebra_map A B).map_zero] at hp,
  exact h hp,
end

lemma aeval_eq_zero_of_aeval_algebra_map_eq_zero_field {R A B : Type*} [comm_semiring R] [field A]
  [comm_semiring B] [nontrivial B] [algebra R A] [algebra R B] [algebra A B] [is_scalar_tower R A B]
  {x : A} {p : polynomial R} (h : polynomial.aeval (algebra_map A B x) p = 0) :
  polynomial.aeval x p = 0 :=
aeval_eq_zero_of_aeval_algebra_map_eq_zero R A B (algebra_map A B).injective h

end comm_semiring

end is_scalar_tower

namespace subalgebra

open is_scalar_tower

section comm_semiring

variables (R) {S A} [comm_semiring R] [comm_semiring S] [comm_semiring A]
variables [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A]

@[simp]

end comm_semiring

end subalgebra


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.geometry.manifold.times_cont_mdiff
import Mathlib.PostPort

universes u_2 u_3 u_4 u_5 l u_6 u_7 u_8 u_1

namespace Mathlib

/-!
# Smooth monoid
A smooth monoid is a monoid that is also a smooth manifold, in which multiplication is a smooth map
of the product manifold `G` × `G` into `G`.

In this file we define the basic structures to talk about smooth monoids: `has_smooth_mul` and its
additive counterpart `has_smooth_add`. These structures are general enough to also talk about smooth
semigroups.
-/

/-- Basic hypothesis to talk about a smooth (Lie) additive monoid or a smooth additive
semigroup. A smooth additive monoid over `α`, for example, is obtained by requiring both the
instances `add_monoid α` and `has_smooth_add α`. -/
class has_smooth_add {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {H : Type u_3} [topological_space H] {E : Type u_4} [normed_group E] [normed_space 𝕜 E] (I : model_with_corners 𝕜 E H) (G : Type u_5) [Add G] [topological_space G] [has_continuous_add G] [charted_space H G]
extends smooth_manifold_with_corners I G
where
  smooth_add : smooth (model_with_corners.prod I I) I fun (p : G × G) => prod.fst p + prod.snd p

/-- Basic hypothesis to talk about a smooth (Lie) monoid or a smooth semigroup.
A smooth monoid over `G`, for example, is obtained by requiring both the instances `monoid G`
and `has_smooth_mul I G`. -/
class has_smooth_mul {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {H : Type u_3} [topological_space H] {E : Type u_4} [normed_group E] [normed_space 𝕜 E] (I : model_with_corners 𝕜 E H) (G : Type u_5) [Mul G] [topological_space G] [has_continuous_mul G] [charted_space H G]
extends smooth_manifold_with_corners I G
where
  smooth_mul : smooth (model_with_corners.prod I I) I fun (p : G × G) => prod.fst p * prod.snd p

theorem smooth_mul {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {H : Type u_3} [topological_space H] {E : Type u_4} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H} {G : Type u_5} [Mul G] [topological_space G] [has_continuous_mul G] [charted_space H G] [has_smooth_mul I G] : smooth (model_with_corners.prod I I) I fun (p : G × G) => prod.fst p * prod.snd p :=
  has_smooth_mul.smooth_mul

theorem smooth.mul {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {H : Type u_3} [topological_space H] {E : Type u_4} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H} {G : Type u_5} [Mul G] [topological_space G] [has_continuous_mul G] [charted_space H G] [has_smooth_mul I G] {E' : Type u_6} [normed_group E'] [normed_space 𝕜 E'] {H' : Type u_7} [topological_space H'] {I' : model_with_corners 𝕜 E' H'} {M : Type u_8} [topological_space M] [charted_space H' M] [smooth_manifold_with_corners I' M] {f : M → G} {g : M → G} (hf : smooth I' I f) (hg : smooth I' I g) : smooth I' I (f * g) :=
  times_cont_mdiff.comp smooth_mul (smooth.prod_mk hf hg)

theorem smooth_add_left {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {H : Type u_3} [topological_space H] {E : Type u_4} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H} {G : Type u_5} [Add G] [topological_space G] [has_continuous_add G] [charted_space H G] [has_smooth_add I G] {a : G} : smooth I I fun (b : G) => a + b :=
  times_cont_mdiff.comp smooth_add (smooth.prod_mk smooth_const smooth_id)

theorem smooth_add_right {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {H : Type u_3} [topological_space H] {E : Type u_4} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H} {G : Type u_5} [Add G] [topological_space G] [has_continuous_add G] [charted_space H G] [has_smooth_add I G] {a : G} : smooth I I fun (b : G) => b + a :=
  times_cont_mdiff.comp smooth_add (smooth.prod_mk smooth_id smooth_const)

theorem smooth_on.add {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {H : Type u_3} [topological_space H] {E : Type u_4} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E H} {G : Type u_5} [Add G] [topological_space G] [has_continuous_add G] [charted_space H G] [has_smooth_add I G] {E' : Type u_6} [normed_group E'] [normed_space 𝕜 E'] {H' : Type u_7} [topological_space H'] {I' : model_with_corners 𝕜 E' H'} {M : Type u_8} [topological_space M] [charted_space H' M] [smooth_manifold_with_corners I' M] {f : M → G} {g : M → G} {s : set M} (hf : smooth_on I' I f s) (hg : smooth_on I' I g s) : smooth_on I' I (f + g) s :=
  smooth.comp_smooth_on smooth_add (smooth_on.prod_mk hf hg)

/- Instance of product -/

protected instance has_smooth_add.sum {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {H : Type u_3} [topological_space H] (I : model_with_corners 𝕜 E H) (G : Type u_4) [topological_space G] [charted_space H G] [Add G] [has_continuous_add G] [has_smooth_add I G] {E' : Type u_5} [normed_group E'] [normed_space 𝕜 E'] {H' : Type u_6} [topological_space H'] (I' : model_with_corners 𝕜 E' H') (G' : Type u_7) [topological_space G'] [charted_space H' G'] [Add G'] [has_continuous_add G'] [has_smooth_add I' G'] : has_smooth_add (model_with_corners.prod I I') (G × G') :=
  has_smooth_add.mk smooth_manifold_with_corners.compatible
    (smooth.prod_mk
      (smooth.add (times_cont_mdiff.smooth (times_cont_mdiff.comp smooth_fst smooth_fst))
        (times_cont_mdiff.comp smooth_fst smooth_snd))
      (smooth.add (times_cont_mdiff.smooth (times_cont_mdiff.comp smooth_snd smooth_fst))
        (times_cont_mdiff.comp smooth_snd smooth_snd)))

/-- Morphism of additive smooth monoids. -/
structure smooth_add_monoid_morphism {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {E' : Type u_4} [normed_group E'] [normed_space 𝕜 E'] (I : model_with_corners 𝕜 E E) (I' : model_with_corners 𝕜 E' E') (G : Type u_5) [topological_space G] [charted_space E G] [add_monoid G] [has_continuous_add G] [has_smooth_add I G] (G' : Type u_6) [topological_space G'] [charted_space E' G'] [add_monoid G'] [has_continuous_add G'] [has_smooth_add I' G']
extends G →+ G'
where
  smooth_to_fun : smooth I I' (add_monoid_hom.to_fun _to_add_monoid_hom)

/-- Morphism of smooth monoids. -/
structure smooth_monoid_morphism {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {E' : Type u_4} [normed_group E'] [normed_space 𝕜 E'] (I : model_with_corners 𝕜 E E) (I' : model_with_corners 𝕜 E' E') (G : Type u_5) [topological_space G] [charted_space E G] [monoid G] [has_continuous_mul G] [has_smooth_mul I G] (G' : Type u_6) [topological_space G'] [charted_space E' G'] [monoid G'] [has_continuous_mul G'] [has_smooth_mul I' G']
extends G →* G'
where
  smooth_to_fun : smooth I I' (monoid_hom.to_fun _to_monoid_hom)

protected instance smooth_add_monoid_morphism.has_zero {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {E' : Type u_4} [normed_group E'] [normed_space 𝕜 E'] {I : model_with_corners 𝕜 E E} {I' : model_with_corners 𝕜 E' E'} {G : Type u_5} [topological_space G] [charted_space E G] [add_monoid G] [has_continuous_add G] [has_smooth_add I G] {G' : Type u_6} [topological_space G'] [charted_space E' G'] [add_monoid G'] [has_continuous_add G'] [has_smooth_add I' G'] : HasZero (smooth_add_monoid_morphism I I' G G') :=
  { zero := smooth_add_monoid_morphism.mk (add_monoid_hom.mk (add_monoid_hom.to_fun 0) sorry sorry) sorry }

protected instance smooth_monoid_morphism.inhabited {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {E' : Type u_4} [normed_group E'] [normed_space 𝕜 E'] {I : model_with_corners 𝕜 E E} {I' : model_with_corners 𝕜 E' E'} {G : Type u_5} [topological_space G] [charted_space E G] [monoid G] [has_continuous_mul G] [has_smooth_mul I G] {G' : Type u_6} [topological_space G'] [charted_space E' G'] [monoid G'] [has_continuous_mul G'] [has_smooth_mul I' G'] : Inhabited (smooth_monoid_morphism I I' G G') :=
  { default := 1 }

protected instance smooth_add_monoid_morphism.has_coe_to_fun {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {E' : Type u_4} [normed_group E'] [normed_space 𝕜 E'] {I : model_with_corners 𝕜 E E} {I' : model_with_corners 𝕜 E' E'} {G : Type u_5} [topological_space G] [charted_space E G] [add_monoid G] [has_continuous_add G] [has_smooth_add I G] {G' : Type u_6} [topological_space G'] [charted_space E' G'] [add_monoid G'] [has_continuous_add G'] [has_smooth_add I' G'] : has_coe_to_fun (smooth_add_monoid_morphism I I' G G') :=
  has_coe_to_fun.mk (fun (a : smooth_add_monoid_morphism I I' G G') => G → G')
    fun (a : smooth_add_monoid_morphism I I' G G') =>
      add_monoid_hom.to_fun (smooth_add_monoid_morphism.to_add_monoid_hom a)

/-- Sometimes one might want to define a smooth additive monoid `G` without having proved previously
that `G` is a topological additive monoid. In such case it is possible to use `has_smooth_add_core`
that does not require such instance, and then get a smooth additive monoid by invoking
`to_has_smooth_add`. -/
structure has_smooth_add_core {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {H : Type u_3} [topological_space H] {E : Type u_4} [normed_group E] [normed_space 𝕜 E] (I : model_with_corners 𝕜 E H) (G : Type u_5) [Add G] [topological_space G] [charted_space H G]
extends smooth_manifold_with_corners I G
where
  smooth_add : smooth (model_with_corners.prod I I) I fun (p : G × G) => prod.fst p + prod.snd p

/-- Sometimes one might want to define a smooth monoid `G` without having proved previously that `G`
is a topological monoid. In such case it is possible to use `has_smooth_mul_core` that does not
require such instance, and then get a smooth monoid by invoking `to_has_smooth_mul`. -/
structure has_smooth_mul_core {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {H : Type u_3} [topological_space H] {E : Type u_4} [normed_group E] [normed_space 𝕜 E] (I : model_with_corners 𝕜 E H) (G : Type u_5) [Mul G] [topological_space G] [charted_space H G]
extends smooth_manifold_with_corners I G
where
  smooth_mul : smooth (model_with_corners.prod I I) I fun (p : G × G) => prod.fst p * prod.snd p

namespace has_smooth_mul_core

protected theorem to_has_continuous_mul {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E E} {G : Type u_5} [topological_space G] [charted_space E G] [group G] (c : has_smooth_mul_core I G) : has_continuous_mul G :=
  has_continuous_mul.mk (times_cont_mdiff.continuous (smooth_mul c))

protected theorem Mathlib.has_smooth_add_core.to_has_smooth_add {𝕜 : Type u_2} [nondiscrete_normed_field 𝕜] {E : Type u_3} [normed_group E] [normed_space 𝕜 E] {I : model_with_corners 𝕜 E E} {G : Type u_5} [topological_space G] [charted_space E G] [add_group G] (c : has_smooth_add_core I G) : has_smooth_add I G :=
  has_smooth_add.mk smooth_manifold_with_corners.compatible (has_smooth_add_core.smooth_add c)


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import algebra.big_operators.order

/-!
# Double countings

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

This file gathers a few double counting arguments.

## Bipartite graphs

In a bipartite graph (considered as a relation `r : α → β → Prop`), we can bound the number of edges
between `s : finset α` and `t : finset β` by the minimum/maximum of edges over all `a ∈ s` times the
the size of `s`. Similarly for `t`. Combining those two yields inequalities between the sizes of `s`
and `t`.

* `bipartite_below`: `s.bipartite_below r b` are the elements of `s` below `b` wrt to `r`. Its size
  is the number of edges of `b` in `s`.
* `bipartite_above`: `t.bipartite_above r a` are the elements of `t` above `a` wrt to `r`. Its size
  is the number of edges of `a` in `t`.
* `card_mul_le_card_mul`, `card_mul_le_card_mul'`: Double counting the edges of a bipartite graph
  from below and from above.
* `card_mul_eq_card_mul`: Equality combination of the previous.
-/

open finset function relator
open_locale big_operators

variables {α β : Type*}

/-! ### Bipartite graph -/

namespace finset
section bipartite
variables (r : α → β → Prop) (s : finset α) (t : finset β) (a a' : α) (b b' : β)
  [decidable_pred (r a)] [Π a, decidable (r a b)] {m n : ℕ}

/-- Elements of `s` which are "below" `b` according to relation `r`. -/
def bipartite_below : finset α := s.filter (λ a, r a b)

/-- Elements of `t` which are "above" `a` according to relation `r`. -/
def bipartite_above : finset β := t.filter (r a)

lemma bipartite_below_swap : t.bipartite_below (swap r) a = t.bipartite_above r a := rfl
lemma bipartite_above_swap : s.bipartite_above (swap r) b = s.bipartite_below r b := rfl

@[simp, norm_cast] lemma coe_bipartite_below : (s.bipartite_below r b : set α) = {a ∈ s | r a b} :=
coe_filter _ _

@[simp, norm_cast] lemma coe_bipartite_above : (t.bipartite_above r a : set β) = {b ∈ t | r a b} :=
coe_filter _ _

variables {s t a a' b b'}

@[simp] lemma mem_bipartite_below {a : α} : a ∈ s.bipartite_below r b ↔ a ∈ s ∧ r a b := mem_filter
@[simp] lemma mem_bipartite_above {b : β} : b ∈ t.bipartite_above r a ↔ b ∈ t ∧ r a b := mem_filter

lemma sum_card_bipartite_above_eq_sum_card_bipartite_below [Π a b, decidable (r a b)] :
  ∑ a in s, (t.bipartite_above r a).card = ∑ b in t, (s.bipartite_below r b).card :=
by { simp_rw [card_eq_sum_ones, bipartite_above, bipartite_below, sum_filter], exact sum_comm }

/-- Double counting argument. Considering `r` as a bipartite graph, the LHS is a lower bound on the
number of edges while the RHS is an upper bound. -/
lemma card_mul_le_card_mul [Π a b, decidable (r a b)]
  (hm : ∀ a ∈ s, m ≤ (t.bipartite_above r a).card)
  (hn : ∀ b ∈ t, (s.bipartite_below r b).card ≤ n) :
  s.card * m ≤ t.card * n :=
calc
    _ ≤ ∑ a in s, (t.bipartite_above r a).card : s.card_nsmul_le_sum _ _ hm
  ... = ∑ b in t, (s.bipartite_below r b).card
      : sum_card_bipartite_above_eq_sum_card_bipartite_below _
  ... ≤ _ : t.sum_le_card_nsmul _ _ hn

lemma card_mul_le_card_mul' [Π a b, decidable (r a b)]
  (hn : ∀ b ∈ t, n ≤ (s.bipartite_below r b).card)
  (hm : ∀ a ∈ s, (t.bipartite_above r a).card ≤ m) :
  t.card * n ≤ s.card * m :=
card_mul_le_card_mul (swap r) hn hm

lemma card_mul_eq_card_mul [Π a b, decidable (r a b)]
  (hm : ∀ a ∈ s, (t.bipartite_above r a).card = m)
  (hn : ∀ b ∈ t, (s.bipartite_below r b).card = n) :
  s.card * m = t.card * n :=
(card_mul_le_card_mul _ (λ a ha, (hm a ha).ge) $ λ b hb, (hn b hb).le).antisymm $
  card_mul_le_card_mul' _ (λ a ha, (hn a ha).ge) $ λ b hb, (hm b hb).le

lemma card_le_card_of_forall_subsingleton
  (hs : ∀ a ∈ s, ∃ b, b ∈ t ∧ r a b) (ht : ∀ b ∈ t, ({a ∈ s | r a b} : set α).subsingleton) :
  s.card ≤ t.card :=
by classical; simpa using card_mul_le_card_mul _ (λ a h, card_pos.2 $
  (by { rw [←coe_nonempty, coe_bipartite_above], exact hs _ h } : (t.bipartite_above r a).nonempty))
  (λ b h, card_le_one.2 $ by { simp_rw mem_bipartite_below, exact ht _ h })

lemma card_le_card_of_forall_subsingleton'
  (ht : ∀ b ∈ t, ∃ a, a ∈ s ∧ r a b) (hs : ∀ a ∈ s, ({b ∈ t | r a b} : set β).subsingleton) :
  t.card ≤ s.card :=
card_le_card_of_forall_subsingleton (swap r) ht hs

end bipartite
end finset

open finset

namespace fintype
variables [fintype α] [fintype β] {r : α → β → Prop}

lemma card_le_card_of_left_total_unique (h₁ : left_total r) (h₂ : left_unique r) :
  fintype.card α ≤ fintype.card β :=
card_le_card_of_forall_subsingleton r (by simpa using h₁) $ λ b _ a₁ ha₁ a₂ ha₂, h₂ ha₁.2 ha₂.2

lemma card_le_card_of_right_total_unique (h₁ : right_total r) (h₂ : right_unique r) :
  fintype.card β ≤ fintype.card α :=
card_le_card_of_forall_subsingleton' r (by simpa using h₁) $ λ b _ a₁ ha₁ a₂ ha₂, h₂ ha₁.2 ha₂.2

end fintype


/-
Copyright 2020 Google LLC

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

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

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

lemma int.coe_lt {a b:ℕ}:a < b ↔ (a:ℤ) < (b:ℤ) :=
begin
  split;intros A1,
  {
    simp,
    apply A1,
  },
  {
    simp at A1,
    apply A1,
  },
end

lemma int.coe_le {a b:ℕ}:a ≤ b ↔ (a:ℤ) ≤ (b:ℤ) :=
begin
  split;intros A1,
  {
    simp,
    apply A1,
  },
  {
    simp at A1,
    apply A1,
  },
end

lemma int.coe_succ {a:ℕ}:((a.succ):int) = (a:int).succ :=
begin
  apply int.nat_succ_eq_int_succ,
end

lemma int.neg_succ_def {x:ℕ}:
  int.neg_succ_of_nat x = -(x.succ) := rfl

lemma int.neg_succ_le_zero {x:ℕ}:(int.neg_succ_of_nat x).succ ≤ 0 :=
begin
  rw int.neg_succ_def,
  rw ← int.neg_pred,
  rw int.nat_succ_eq_int_succ,
  simp,
  have A2:(x:int).succ.pred = x,
  {
    rw int.pred_succ,
  },-- := sorry,
  rw A2,
  have A1:(0:int) = ((0:nat):int) := rfl,
  rw A1,
  rw ← int.coe_le,
  simp,
end

lemma int.neg_succ_le_int_of_nat (a b:ℕ): (int.neg_succ_of_nat b) ≤ (int.of_nat a) :=
begin
  apply @int.le.intro_sub _ _ (a + b + 1),
  rw sub_eq_add_neg,
  rw int.neg_neg_of_nat_succ,
  refl,
end

lemma int.not_int_of_nat_lt_neg_succ (a b:ℕ):(int.of_nat a) < (int.neg_succ_of_nat b) → false :=
begin
  intros A1,
  have A2:=int.neg_succ_le_int_of_nat a b,
  apply not_lt_of_ge A2,
  apply A1,
end

--This is the hard part. The converse is trivial,
--and once we have this, all other variants can be
--proven.
lemma int.succ_le_of_lt {x y:ℤ}:x < y → x.succ ≤ y :=
begin
  intro A1,
  cases x;cases y,
  {
    have B1:int.of_nat x = x := rfl,
    rw B1,
    rw ← int.nat_succ_eq_int_succ,
    have B2:int.of_nat y = y := rfl,
    rw B2,
    rw ← int.coe_le,
    apply nat.succ_le_of_lt,
    rw B1 at A1,
    rw B2 at A1,
    rw ← int.coe_lt at A1,
    apply A1,
  },
  {
    exfalso,
    simp at A1,
    apply int.not_int_of_nat_lt_neg_succ,
    apply A1,
  },
  {
    rw int.neg_succ_def,
    rw ← int.neg_pred,
    rw int.nat_succ_eq_int_succ,
    rw int.pred_succ,
    simp,
    have D1:0 ≤ (y:ℤ),
    {
      have D1A:((@has_zero.zero ℕ _):ℤ) = 0 := rfl,
      rw ← D1A,
      rw ← int.coe_le,
      simp,
    },
    have D2:(-(x:ℤ))≤ 0,
    {
      simp,
    },
    apply le_trans D2 D1,
  },
  {
    rw int.neg_succ_def,
    rw ← int.neg_pred,
    rw int.nat_succ_eq_int_succ,
    rw int.pred_succ,
    rw int.neg_succ_def at A1,
    rw int.neg_succ_def at A1,
    rw int.neg_succ_def,
    apply neg_le_neg,
    simp at A1,
    rw ← int.coe_le,
    apply nat.succ_le_of_lt A1,
  },
end

lemma one_le_of_zero_lt {x:ℤ}:0 < x → 1 ≤ x :=
begin
  intro A0,
  have A1:(1:ℤ) = (0:ℤ).succ := rfl,
  rw A1,
  apply int.succ_le_of_lt A0,
end

lemma int.succ_def {a:int}:a.succ = a + 1 := rfl
lemma int.pred_def {a:int}:a.pred = a - 1 := rfl

lemma int.succ_le_iff {x y:ℤ}:x.succ ≤ y ↔ x < y :=
begin
  split;intros A1,
  {
    rw int.succ_def at A1,
    have B1:x + 0 < x + 1,
    {
      simp,
      apply zero_lt_one,
    },
    rw add_zero at B1,
    apply lt_of_lt_of_le B1 A1,
  },
  {
    apply int.succ_le_of_lt A1,
  },
end

lemma int.succ_lt_succ_iff {a b:int}:a.succ < b.succ ↔ a < b :=
begin
  repeat {rw int.succ_def},
  split;intros B3A,
  {
    simp at B3A,
    apply B3A,
  },
  {
    simp,
    apply B3A,
  },
end

lemma int.pred_succ_iff {a b:int}:a.pred = b ↔ a = b.succ :=
begin
  split;intros A1,
  {
    rw ← A1,
    rw int.succ_pred,
  },
  {
    rw A1,
    rw int.pred_succ,
  },
end

lemma int.lt_succ_iff {a b:int}:a < b.succ ↔ a ≤ b :=
begin
  let c := a.pred,
  begin
    have B1:c = a.pred := rfl,
    have B2:a = c.succ := int.pred_succ_iff.mp B1,
    rw B2,
    apply iff.trans (@int.succ_lt_succ_iff c b),
    symmetry,
    apply @int.succ_le_iff c b,
  end
end

lemma int.pred_lt_pred_iff {a b:int}:a.pred < b.pred ↔ a < b :=
begin
  repeat {rw int.pred_def},
  split;intros A1,
  {
    simp at A1,
    apply A1,
  },
  {
    simp,
    apply A1,
  },
end

lemma int.pred_lt_iff {a b:int}:a.pred < b ↔ a ≤ b :=
begin
  let c := a.pred,
  begin
    have B1:c = a.pred:= rfl,
    have B2:a = c.succ := int.pred_succ_iff.mp B1,
    rw ← B1,
    rw B2,
    symmetry,
    apply @int.succ_le_iff c b,
  end
end

lemma int.pred_lt_self {a:int}:a.pred < a :=
begin
  rw int.pred_lt_iff,
end

def monoid_hom_nat_int:monoid_hom nat int := {
  to_fun := int.of_nat,
  map_mul' := begin
    intros x y,
    simp,
  end,
  map_one' := rfl,
}

def add_monoid_hom_nat_int:add_monoid_hom nat int := {
  to_fun := int.of_nat,
  map_add' := begin
    intros x y,
    simp,
  end,
  map_zero' := rfl,
}

def ring_hom_nat_int:ring_hom nat int := {
  ..monoid_hom_nat_int,
  ..add_monoid_hom_nat_int,
}

lemma ring_hom_nat_int_to_fun_def {n:ℕ}:
    ring_hom_nat_int.to_fun n = n := rfl

lemma int.coe_nat_eq_coe_nat {a b:ℕ}:(a:ℤ) = (b:ℤ) ↔ a = b :=
begin

  split;intros A1,
  {
    simp at A1,
    apply A1,
  },
  {
    simp,
    apply A1,
  },
end

lemma ring_hom_nat_int_eq {a b:ℕ}:(ring_hom_nat_int.to_fun a)=(ring_hom_nat_int.to_fun b) ↔ a = b :=
begin
  repeat {rw ring_hom_nat_int_to_fun_def},
  rw int.coe_nat_eq_coe_nat,
end


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

! This file was ported from Lean 3 source module topology.metric_space.equicontinuity
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.MetricSpace.Basic
import Mathlib.Topology.UniformSpace.Equicontinuity

/-!
# Equicontinuity in metric spaces

This files contains various facts about (uniform) equicontinuity in metric spaces. Most
importantly, we prove the usual characterization of equicontinuity of `F` at `x₀` in the case of
(pseudo) metric spaces: `∀ ε > 0, ∃ δ > 0, ∀ x, dist x x₀ < δ → ∀ i, dist (F i x₀) (F i x) < ε`,
and we prove that functions sharing a common (local or global) continuity modulus are
(locally or uniformly) equicontinuous.

## Main statements

* `Metric.equicontinuousAt_iff`: characterization of equicontinuity for families of functions
  between (pseudo) metric spaces.
* `Metric.equicontinuousAt_of_continuity_modulus`: convenient way to prove equicontinuity at a
  point of a family of functions to a (pseudo) metric space by showing that they share a common
  *local* continuity modulus.
* `Metric.uniformEquicontinuous_of_continuity_modulus`: convenient way to prove uniform
  equicontinuity of a family of functions to a (pseudo) metric space by showing that they share a
  common *global* continuity modulus.

## Tags

equicontinuity, continuity modulus
-/

open Filter Topology Uniformity

variable {α β ι : Type _} [PseudoMetricSpace α]

namespace Metric

/-- Characterization of equicontinuity for families of functions taking values in a (pseudo) metric
space. -/
theorem equicontinuousAt_iff_right {ι : Type _} [TopologicalSpace β] {F : ι → β → α} {x₀ : β} :
    EquicontinuousAt F x₀ ↔ ∀ ε > 0, ∀ᶠ x in 𝓝 x₀, ∀ i, dist (F i x₀) (F i x) < ε :=
  uniformity_basis_dist.equicontinuousAt_iff_right
#align metric.equicontinuous_at_iff_right Metric.equicontinuousAt_iff_right

/-- Characterization of equicontinuity for families of functions between (pseudo) metric spaces. -/
theorem equicontinuousAt_iff {ι : Type _} [PseudoMetricSpace β] {F : ι → β → α} {x₀ : β} :
    EquicontinuousAt F x₀ ↔ ∀ ε > 0, ∃ δ > 0, ∀ x, dist x x₀ < δ → ∀ i, dist (F i x₀) (F i x) < ε :=
  nhds_basis_ball.equicontinuousAt_iff uniformity_basis_dist
#align metric.equicontinuous_at_iff Metric.equicontinuousAt_iff

/-- Reformulation of `equicontinuousAt_iff_pair` for families of functions taking values in a
(pseudo) metric space. -/
protected theorem equicontinuousAt_iff_pair {ι : Type _} [TopologicalSpace β] {F : ι → β → α}
    {x₀ : β} :
    EquicontinuousAt F x₀ ↔
      ∀ ε > 0, ∃ U ∈ 𝓝 x₀, ∀ x ∈ U, ∀ x' ∈ U, ∀ i, dist (F i x) (F i x') < ε := by
  rw [equicontinuousAt_iff_pair]
  constructor <;> intro H
  · intro ε hε
    exact H _ (dist_mem_uniformity hε)
  · intro U hU
    rcases mem_uniformity_dist.mp hU with ⟨ε, hε, hεU⟩
    refine' Exists.imp (fun V => And.imp_right fun h => _) (H _ hε)
    exact fun x hx x' hx' i => hεU (h _ hx _ hx' i)
#align metric.equicontinuous_at_iff_pair Metric.equicontinuousAt_iff_pair

/-- Characterization of uniform equicontinuity for families of functions taking values in a
(pseudo) metric space. -/
theorem uniformEquicontinuous_iff_right {ι : Type _} [UniformSpace β] {F : ι → β → α} :
    UniformEquicontinuous F ↔ ∀ ε > 0, ∀ᶠ xy : β × β in 𝓤 β, ∀ i, dist (F i xy.1) (F i xy.2) < ε :=
  uniformity_basis_dist.uniformEquicontinuous_iff_right
#align metric.uniform_equicontinuous_iff_right Metric.uniformEquicontinuous_iff_right

/-- Characterization of uniform equicontinuity for families of functions between
(pseudo) metric spaces. -/
theorem uniformEquicontinuous_iff {ι : Type _} [PseudoMetricSpace β] {F : ι → β → α} :
    UniformEquicontinuous F ↔
      ∀ ε > 0, ∃ δ > 0, ∀ x y, dist x y < δ → ∀ i, dist (F i x) (F i y) < ε :=
  uniformity_basis_dist.uniformEquicontinuous_iff uniformity_basis_dist
#align metric.uniform_equicontinuous_iff Metric.uniformEquicontinuous_iff

/-- For a family of functions to a (pseudo) metric spaces, a convenient way to prove
equicontinuity at a point is to show that all of the functions share a common *local* continuity
modulus. -/
theorem equicontinuousAt_of_continuity_modulus {ι : Type _} [TopologicalSpace β] {x₀ : β}
    (b : β → ℝ) (b_lim : Tendsto b (𝓝 x₀) (𝓝 0)) (F : ι → β → α)
    (H : ∀ᶠ x in 𝓝 x₀, ∀ i, dist (F i x₀) (F i x) ≤ b x) : EquicontinuousAt F x₀ := by
  rw [Metric.equicontinuousAt_iff_right]
  intro ε ε0
  -- porting note: Lean 3 didn't need `Filter.mem_map.mp` here
  filter_upwards [Filter.mem_map.mp <| b_lim (Iio_mem_nhds ε0), H] using
    fun x hx₁ hx₂ i => (hx₂ i).trans_lt hx₁
#align metric.equicontinuous_at_of_continuity_modulus Metric.equicontinuousAt_of_continuity_modulus

/-- For a family of functions between (pseudo) metric spaces, a convenient way to prove
uniform equicontinuity is to show that all of the functions share a common *global* continuity
modulus. -/
theorem uniformEquicontinuous_of_continuity_modulus {ι : Type _} [PseudoMetricSpace β] (b : ℝ → ℝ)
    (b_lim : Tendsto b (𝓝 0) (𝓝 0)) (F : ι → β → α)
    (H : ∀ (x y : β) (i), dist (F i x) (F i y) ≤ b (dist x y)) : UniformEquicontinuous F := by
  rw [Metric.uniformEquicontinuous_iff]
  intro ε ε0
  rcases tendsto_nhds_nhds.1 b_lim ε ε0 with ⟨δ, δ0, hδ⟩
  refine' ⟨δ, δ0, fun x y hxy i => _⟩
  calc
    dist (F i x) (F i y) ≤ b (dist x y) := H x y i
    _ ≤ |b (dist x y)| := (le_abs_self _)
    _ = dist (b (dist x y)) 0 := by simp [Real.dist_eq]
    _ < ε := hδ (by simpa only [Real.dist_eq, tsub_zero, abs_dist] using hxy)
#align metric.uniform_equicontinuous_of_continuity_modulus
  Metric.uniformEquicontinuous_of_continuity_modulus

/-- For a family of functions between (pseudo) metric spaces, a convenient way to prove
equicontinuity is to show that all of the functions share a common *global* continuity modulus. -/
theorem equicontinuous_of_continuity_modulus {ι : Type _} [PseudoMetricSpace β] (b : ℝ → ℝ)
    (b_lim : Tendsto b (𝓝 0) (𝓝 0)) (F : ι → β → α)
    (H : ∀ (x y : β) (i), dist (F i x) (F i y) ≤ b (dist x y)) : Equicontinuous F :=
  (uniformEquicontinuous_of_continuity_modulus b b_lim F H).equicontinuous
#align metric.equicontinuous_of_continuity_modulus Metric.equicontinuous_of_continuity_modulus

end Metric


import topology.nhds_set

variables {α : Type*} [topological_space α] {s t s₁ s₂ t₁ t₂ : set α} {x : α}

open filter
open_locale filter topology

lemma is_open.nhds_set_eq_principal {s : set α} (h : is_open s) : 𝓝ˢ s = 𝓟 s :=
begin
  apply le_antisymm _ principal_le_nhds_set,
  rw [filter.le_principal_iff, h.mem_nhds_set]
end

lemma is_open.forall_near_mem_of_subset {s t : set α} (h : is_open s) (ht : t ⊆ s) : ∀ᶠ x in 𝓝ˢ t, x ∈ s :=
begin
  apply eventually.filter_mono (nhds_set_mono ht),
  rw [h.nhds_set_eq_principal, eventually_principal],
  exact λ x, id
end

/-
In the next lemma, the inequality cannot be improved to an equality. For instance,
if α has two elements and the coarse topology and s and t are distinct singletons then
𝓝ˢ (s ∩ t) = ⊥ while 𝓝ˢ s ⊓ 𝓝ˢ t = ⊤ and those are different.
-/
lemma nhds_set_inter_le (s t : set α) : 𝓝ˢ (s ∩ t) ≤  𝓝ˢ s ⊓ 𝓝ˢ t :=
(@monotone_nhds_set α _).map_inf_le s t

lemma sup_Sup {α : Type*} [complete_lattice α] {s : set α} {a : α} : a ⊔ (Sup s) = Sup (s ∪ {a}) :=
by simp only [set.union_singleton, Sup_insert]

lemma Sup_sup {α : Type*} [complete_lattice α] {s : set α} {a : α} : (Sup s) ⊔ a = Sup (s ∪ {a}) :=
by simp only [sup_Sup, sup_comm]

lemma is_closed.nhds_set_le_sup {t : set α} (h : is_closed t) (s : set α) :
  𝓝ˢ s ≤ 𝓝ˢ (s ∩ t) ⊔ 𝓟 tᶜ :=
calc 𝓝ˢ s = 𝓝ˢ ((s ∩ t) ∪ (s ∩ tᶜ)) : by rw set.inter_union_compl s t
... = 𝓝ˢ (s ∩ t) ⊔ 𝓝ˢ (s ∩ tᶜ) : by rw nhds_set_union
... ≤ 𝓝ˢ (s ∩ t) ⊔ 𝓝ˢ tᶜ : sup_le_sup_left (monotone_nhds_set (s.inter_subset_right tᶜ)) _
... = 𝓝ˢ (s ∩ t) ⊔ 𝓟 tᶜ : by rw (is_open_compl_iff.mpr h).nhds_set_eq_principal

lemma is_closed.nhds_set_le_sup' {t : set α} (h : is_closed t) (s : set α) :
  𝓝ˢ s ≤ 𝓝ˢ (t ∩ s) ⊔ 𝓟 tᶜ :=
by {rw set.inter_comm, exact h.nhds_set_le_sup s }

lemma eventually_nhds_set_iff {p : α → Prop} : (∀ᶠ x in 𝓝ˢ s, p x) ↔ (∀ x ∈ s, ∀ᶠ y in 𝓝 x, p y) :=
by rw [nhds_set, eventually_Sup, set.ball_image_iff]

lemma filter.eventually.eventually_nhds_set {p : α → Prop} (h : ∀ᶠ y in 𝓝ˢ s, p y) :
  ∀ᶠ y in 𝓝ˢ s, ∀ᶠ x in 𝓝 y, p x :=
eventually_nhds_set_iff.mpr (λ x x_in, (eventually_nhds_set_iff.mp h x x_in).eventually_nhds)

lemma filter.eventually.on_set {p : α → Prop} (h : ∀ᶠ y in 𝓝ˢ s, p y) : ∀ x ∈ s, p x :=
eventually_principal.mp $ eventually.filter_mono principal_le_nhds_set h

lemma filter.eventually_nhds_set_union {p : α → Prop} :
  (∀ᶠ x in 𝓝ˢ (s ∪ t), p x) ↔ (∀ᶠ x in 𝓝ˢ s, p x) ∧ ∀ᶠ x in 𝓝ˢ t, p x :=
begin
  rw [nhds_set_union, eventually_sup]
end

lemma filter.eventually.union {p : α → Prop} (hs : ∀ᶠ x in 𝓝ˢ s, p x) (ht : ∀ᶠ x in 𝓝ˢ t, p x) :
  ∀ᶠ x in 𝓝ˢ (s ∪ t), p x :=
filter.eventually_nhds_set_union.mpr ⟨hs, ht⟩

lemma eventually_nhds_set_Union₂ {α ι : Type*} [topological_space α] {p : ι → Prop} {s : ι → set α}
  {P : α → Prop} : (∀ᶠ x in 𝓝ˢ (⋃ i (hi : p i), s i), P x) ↔ ∀ i, p i → ∀ᶠ x in 𝓝ˢ (s i), P x :=
begin
  simp_rw [eventually_nhds_set_iff, set.mem_Union₂],
  split,
  exact λ h i hi x hx, h x ⟨i,hi, hx⟩,
  rintros h x ⟨i, hi, hx⟩,
  exact h i hi x hx
end

lemma eventually_nhds_set_Union {α ι : Type*} [topological_space α] {s : ι → set α}
  {P : α → Prop} : (∀ᶠ x in 𝓝ˢ (⋃ i, s i), P x) ↔ ∀ i, ∀ᶠ x in 𝓝ˢ (s i), P x :=
by simpa using @eventually_nhds_set_Union₂ _ _ _ (λ i, true) s P

-- This lemma goes to filter.basic, after filter.eventually_principal
lemma filter.eventually.forall_mem {α : Type*} {f : filter α} {s : set α} {P : α → Prop}
  (hP : ∀ᶠ x in f, P x) (hf : 𝓟 s ≤ f) : ∀ x ∈ s, P x :=
filter.eventually_principal.mp (hP.filter_mono hf)

lemma filter.eventually.nhds_set_forall_mem {α : Type*} [topological_space α]
  {s : set α} {P : α → Prop}
  (hP : ∀ᶠ x in nhds_set s, P x) : ∀ x ∈ s, P x :=
hP.forall_mem principal_le_nhds_set

lemma subset_of_mem_nhds_set {α : Type*} [topological_space α] {s t : set α} (h : t ∈ 𝓝ˢ s) : s ⊆ t :=
λ x hx, mem_of_mem_nhds $ mem_nhds_set_iff_forall.mp h x hx


import .love05_inductive_predicates_demo
import data.real.cardinality

/-! # LoVe Demo 11: Logical Foundations of Mathematics

We dive deeper into the logical foundations of Lean. Most of the features
described here are especially relevant for defining mathematical objects and
proving theorems about them. -/

set_option pp.beta true
set_option pp.generalized_field_notation false
open_locale cardinal

namespace LoVe

/-! ## Universes

Not only terms have a type, but also types have a type. For example, by the PAT
principle:

    `@and.intro : ∀(a b : Prop), a → b → a ∧ b`

Moreover:

    `∀(a b : Prop), a → b → a ∧ b : Prop`

Now, what is the type of `Prop`? `Prop` has the same type as virtually all other
types we have constructed so far:

    `Prop : Type`

What is the type of `Type`? The typing `Type : Type` would lead to a
contradiction, called **Girard's paradox**, resembling Russell's paradox.
Instead:

    `Type   : Type 1`
    `Type 1 : Type 2`
    `Type 2 : Type 3`
    ⋮

Aliases:

    `Type`   := `Type 0`
    `Prop`   := `Sort 0`
    `Type u` := `Sort (u + 1)`

The types of types (`Sort u`, `Type u`, and `Prop`) are called __universes__.
The `u` in `Sort u` is a __universe level__.

The hierarchy is captured by the following typing judgment:

    ————————————————————————— Sort
    C ⊢ Sort u : Sort (u + 1) -/

#check @and.intro
#check ∀a b : Prop, a → b → a ∧ b
#check Prop
#check ℕ
#check Type
#check Type 1
#check Type 2

universe variables u v

#check Type u

#check Sort 0
#check Sort 1
#check Sort 2
#check Sort u

#check Type*

#check ulift

/-
### Girard's Paradox

References:
Hurkens, *A simplification of Girard's Paradox* (https://www.cs.cmu.edu/~kw/scans/hurkens95tlca.pdf)
Watkins, implemented in LF (http://www.cs.cmu.edu/~kw/research/hurkens95tlca.elf)
Carneiro, implemented in Lean (https://github.com/leanprover-community/mathlib/blob/master/counterexamples/girard.lean)

What happens if we have `Type u : Type u` for some `u`?

We can't axiomatize this directly. But we can still explore.

First, consider the normal Π operator.
-/

#check Π T : Type, T × T
#check λ T : Type, T × T

/-
Given a function like `f := λ T : Type, T × T : Type → Type`,
`Π f` has type `Type 1`.
In a sense, the "type" of `Π` is `(Type → Type) → Type 1`, or more generally,
`(Type u → Type v) → Type (1 + max u v)`.

If we collapsed the universe hierarchy, though, it would have type
`(Type → Type) → Type`.
-/

namespace girard
section

parameter pi   : (Type → Type) → Type
parameter lam  : Π {A : Type → Type}, (Π x, A x) → pi A
parameter app  : Π {A : Type → Type}, pi A → Π x, A x
parameter beta : Π {A : Type → Type} (f : Π x, A x) (x : Type), app (lam f) x = f x

/-
As long as we have such a `pi` operator and a smaller universe `Prop < Type`,
we can derive false.
-/

/--
F X is a particular function type.
We have `F : Type → Type`.
-/
def F (X : Type) : Type :=
(set (set X) → X) → set (set X)

/--
U is the type of functions that take in a type `X` and produce a function of type `F X`.
This will be our "paradoxical type."
-/
def U : Type :=
pi F

#check Π X, F X
#check U

def G (T : set (set U)) (X : Type) : F X :=
λ f : set (set X) → X,
  { s : set X |
      {x : U | f (app x X f) ∈ s} ∈ T
  }

/--
τ is a function of type `𝒫𝒫U → U`.
-/
def τ (T : set (set U)) : U :=
lam (G T)

#check τ

/--
σ is a function of type `U → 𝒫𝒫U`.
-/
def σ (S : U) : set (set U) :=
app S U τ

lemma σ_τ_spec : ∀ {s : set U} {S : set (set U)},
  s ∈ σ (τ S) ↔ {x | τ (σ x) ∈ s} ∈ S :=
λ s S, iff_of_eq (congr_arg (λ f : F U, s ∈ f τ) (beta (G S) U) : _)

/- a set `p` is in `ω` if for every `x : U` such that `p ∈ σ x`, `x ∈ p`. -/
def ω : set (set U) :=
{p : set U | ∀ x : U, p ∈ σ x → x ∈ p}

/-
`δ S` is true iff every `p ∈ S` contains `τ S`.
-/
def δ (S : set (set U)) : Prop :=
∀ p : set U, p ∈ S → τ S ∈ p

lemma δ_ω_spec : δ ω :=
λ p d, d (τ ω) (σ_τ_spec.2 (λ x h, d (τ (σ x)) (σ_τ_spec.2 h)))

def bad_set : set U :=
{y : U | ¬ δ (σ y)}

theorem girard : false :=
have h1 : ∀ p : set U, p ∈ ω → τ ω ∈ p := δ_ω_spec,
have h2 : bad_set ∈ ω → τ ω ∈ bad_set := h1 bad_set,
have h3 : bad_set ∈ ω := λ x e f, f _ e (λ p h, f _ (σ_τ_spec.1 h)),
have h4 : τ ω ∈ bad_set := h2 h3,
have h5 : ¬ δ (σ (τ ω)) := h4,
have h6 : δ (σ (τ ω)) := λ p h, δ_ω_spec _ (σ_τ_spec.1 h),
show false, from h5 h6

end
end girard

/-! ## The Peculiarities of Prop

`Prop` is different from the other universes in many respects.

### Impredicativity

The function type `σ → τ` is put into the larger one of the universes that
`σ` and `τ` live in:

    C ⊢ σ : Type u    C ⊢ τ : Type v
    ————————————————————————————————— Arrow-Type
    C ⊢ σ → τ : Type (max u v)

For dependent types, this generalizes to

    C ⊢ σ : Type u    C, x : σ ⊢ τ[x] : Type v
    ——————————————————————————————————————————— Forall-Type
    C ⊢ (∀x : σ, τ[x]) : Type (max u v)

This behavior of the universes `Type v` is called __predicativity__.

To force expressions such as `∀a : Prop, a → a` to be of type `Prop` anyway, we
need a special typing rule for `Prop`:

    C ⊢ σ : Sort u    x : σ ⊢ τ[x] : Prop
    —————————————————————————————————————— Forall-Prop
    C ⊢ (∀x : σ, τ[x]) : Prop

This behavior of `Prop` is called __impredicativity__.

The rules `Forall-Type` and `Forall-Prop` can be generalized into a single rule:

    C ⊢ σ : Sort u    C, x : σ ⊢ τ[x] : Sort v
    ——————————————————————————————————————————— Forall
    C ⊢ (∀x : σ, τ[x]) : Sort (imax u v)

where

    `imax u 0       = 0`
    `imax u (v + 1) = max u (v + 1)` -/

#check λ(α : Type u) (β : Type v), α → β
#check ∀a : Prop, a → a

/-! ### Proof Irrelevance

A second difference between `Prop` and `Type u` is __proof irrelevance__:

    `∀(a : Prop) (h₁ h₂ : a), h₁ = h₂`

This makes reasoning about dependent types easier.

When viewing a proposition as a type and a proof as an element of that type,
proof irrelevance means that a proposition is either an empty type or has
exactly one inhabitant.

Proof irrelevance can be proved `by refl`. -/

#check proof_irrel

lemma proof_irrel {a : Prop} (h₁ h₂ : a) :
  h₁ = h₂ :=
by refl

/-! ### No Large Elimination

A further difference between `Prop` and `Type u` is that `Prop` does not allow
__large elimination__, meaning that it impossible to extract data from a proof
of a proposition.

This is necessary to allow proof irrelevance. -/

#check 0

-- fails
def unsquare (i : ℤ) (hsq : ∃j, i = j * j) : ℤ :=
match hsq with
| Exists.intro j _ := j
end

/-! If the above were accepted, we could derive `false` as follows.

Let

    `hsq₁` := `Exists.intro 3 (by linarith)`
    `hsq₂` := `Exists.intro (-3) (by linarith)`

be two proofs of `∃j, (9 : ℤ) = j * j`. Then

    `unsquare 9 hsq₁ = 3`
    `unsquare 9 hsq₂ = -3`

However, by proof irrelevance, `hsq₁ = hsq₂`. Hence

    `unsquare 9 hsq₂ = 3`

Thus

    `3 = -3`

a contradiction.

As a compromise, Lean allows __small elimination__. It is called small
elimination because it eliminate only into `Prop`, whereas large elimination can
eliminate into an arbitrary large universe `Sort u`. This means we can use
`match` to analyze the structure of a proof, extract existential witnesses, and
so on, as long as the `match` expression is itself a proof. We have seen several
examples of this in lecture 5.

As a further compromise, Lean allows large elimination for
__syntactic subsingletons__: types in `Prop` for which it can be established
syntactically that they have cardinality 0 or 1. These are propositions such as
`false` and `a ∧ b` that can be proved in at most one way.
-/

/-
### Impredicative, proof-irrelevant Prop

Coquand has recently shown that impredicative Prop + proof-irrelevant =
leads to a failure of strong normalization.
<https://arxiv.org/pdf/1911.08174.pdf>

Lean code adapted from Mario Carneiro.
-/

namespace no_sn

def false' : Prop :=
∀ p : Prop, p

def true' : Prop :=
false' → false'

theorem omega : (∀ (A B : Prop), A = B) → false' :=
λ h A, @cast true' _ (h true' A) (λ z: false', z true' z)

theorem Omega : (∀ (A B : Prop), A = B) → false' :=
λ h, omega h true' (omega h)

-- #reduce Omega -- timeout

example (h : ∀ A B : Prop, A = B) : Omega h = Omega h :=
calc Omega h = omega h true' (omega h) : rfl
         ... = @cast true' true' (h true' true') (λ z: false', z true' z) (omega h) : rfl
         ... = (λ z: false', z true' z) (omega h) : rfl
         ... = (omega h) true' (omega h) : rfl
         ... = Omega h : rfl

end no_sn

/-
## The Axiom of Choice

Lean's logic includes the axiom of choice, which makes it possible to obtain an
arbitrary element from any nonempty type.

Consider Lean's `nonempty` inductive predicate: -/

#print nonempty

/-! The predicate states that `α` has at least one element.

To prove `nonempty α`, we must provide an `α` value to `nonempty.intro`: -/

lemma nat.nonempty :
  nonempty ℕ :=
nonempty.intro 0

/-! Since `nonempty` lives in `Prop`, large elimination is not available, and
thus we cannot extract the element that was used from a proof of `nonempty α`.

The axiom of choice allows us to obtain some element of type `α` if we can show
`nonempty α`: -/

#print classical.choice

/-! It will just give us an arbitrary element of `α`; we have no way of knowing
whether this is the element that was used to prove `nonempty α`.

The constant `classical.choice` is noncomputable, one of the reasons why some
logicians prefer to work without this axiom. -/

#eval classical.choice nat.nonempty     -- fails
#reduce classical.choice nat.nonempty   -- result: classical.choice _

/-! The axiom of choice is only an axiom in Lean's core library, giving users
the freedom to work with or without it.

Definitions using it must be marked as `noncomputable`: -/

noncomputable def arbitrary_nat : ℕ :=
classical.choice nat.nonempty

/-! The following tools rely on choice.

### Law of Excluded Middle -/

#check classical.em
#check classical.by_contradiction

/-! ### Hilbert Choice -/

#print classical.some
#print classical.some_spec

#check λ(p : ℕ → Prop) (h : ∃n : ℕ, p n), classical.some h
#check λ(p : ℕ → Prop) (h : ∃n : ℕ, p n), classical.some_spec h

/-! ### Set-Theoretic Axiom of Choice -/

#print classical.axiom_of_choice

/-! ## Consistency

If we can construct a closed term `p : false` (or `p : empty`), we can prove
any proposition. Hopefully this is not the case.

*Theorem* (consistency): there is no closed term `p : false`.

This can be interpreted in two ways:
* Theoretical: abstractly, the inference rules are consistent
* Applied: the actual implementation is consistent

We'll focus on the theoretical side.

Where would we even begin to prove something like theoretical consistency?

We used semantic arguments to prove meta-properties about PL.
*Model* the abstract syntax of the language in some other system,
and show that this interpretation preserves all of the axioms, properties,
etc. of the original system.

If the semantic domain is consistent, then the original system is too.

Carneiro, 2019:
<https://github.com/digama0/lean-type-theory/releases/download/v1.0/main.pdf>

"... [we] construct the expected set-theoretic model, from which we derive
consistency of Lean relative to ZFC + {there are n inaccessible cardinals | n < ω}"

Types -> sets, propositions -> true/false.

There's more we can do with this notion of modeling.
What propositions are provable in Lean?
Those that are true in *every* model.
-/

section
local infixr ^ := @has_pow.pow cardinal cardinal cardinal.has_pow

example : ℕ ≠ ℤ :=
begin
  sorry
end

example : ℕ ≠ ℝ :=
begin
  have nat_card : #ℕ = cardinal.omega := cardinal.mk_nat,
  have real_card : #ℝ = 2 ^ cardinal.omega := cardinal.mk_real,
  intro h,
  cases' h,
  rw nat_card at real_card,
  have card_lt : cardinal.omega < 2 ^ cardinal.omega := cardinal.cantor cardinal.omega,
  exact ne_of_lt card_lt real_card
end

end

/-!

### Consistency of implementation

Modeling the abstract logical rules doesn't tell us anything about the actual implementation.
There could still be bugs: in elaboration, tactics, type checking, ...

This is now an engineering issue!
The trusted code base only needs to answer one question:
"Given two fully elaborated terms `t` and `T`, does `t` have type `T`?"

Engineering task: minimize and simplify the code needed to answer this question.
All the work done by tactics, etc will be checked by this small (~8k loc) kernel.

Even better, you can write a totally independent type checker to check the kernel's work.

-/

/-! ## Subtypes

Subtyping is a mechanism to create new types from existing ones.

Given a predicate on the elements of the base type, the __subtype__ contains
only those elements of the base type that fulfill this property. More precisely,
the subtype contains element–proof pairs that combine an element of the base
type and a proof that it fulfills the property.

Subtyping is useful for those types that cannot be defined as an inductive
type. For example, any attempt at defining the type of finite sets along the
following lines is doomed to fail: -/

inductive finset (α : Type) : Type
| empty  : finset
| insert : α → finset → finset

/-! Given a base type and a property, the subtype has the syntax

    `{` _variable_ `:` _base-type_ `//` _property-applied-to-variable_ `}`

Example:

    `{i : ℕ // i ≤ n}`

Alias:

    `{x : τ // P[x]}` := `@subtype τ (λx, P[x])`

### First Example: Full Binary Trees -/

#check subtype

#check btree
#check is_full
#check mirror
#check is_full_mirror
#check mirror_mirror

def full_btree (α : Type) : Type :=
{t : btree α // is_full t}

#print subtype
#check subtype.mk

/-! To define elements of `full_btree`, we must provide a `btree` and a proof
that it is full: -/

def empty_full_btree : full_btree ℕ :=
subtype.mk btree.empty is_full.empty

def full_btree_6 : full_btree ℕ :=
subtype.mk (btree.node 6 btree.empty btree.empty)
  begin
    apply is_full.node,
    apply is_full.empty,
    apply is_full.empty,
    refl
  end

#reduce subtype.val full_btree_6
#check subtype.property full_btree_6

/-! We can lift existing operations on `btree` to `full_btree`: -/

def full_btree.mirror {α : Type} (t : full_btree α) :
  full_btree α :=
subtype.mk (mirror (subtype.val t))
  begin
    apply is_full_mirror,
    apply subtype.property t
  end

#reduce subtype.val (full_btree.mirror full_btree_6)

/-! And of course we can prove lemmas about the lifted operations: -/

lemma full_btree.mirror_mirror {α : Type} (t : full_btree α) :
  (full_btree.mirror (full_btree.mirror t)) = t :=
begin
  apply subtype.eq,
  simp [full_btree.mirror],
  apply mirror_mirror
end

#check subtype.eq

/-! ### Second Example: Vectors -/

#check vector

def vector (α : Type) (n : ℕ) : Type :=
{xs : list α // list.length xs = n}

def vector_123 : vector ℤ 3 :=
subtype.mk [1, 2, 3] (by refl)

def vector.neg {n : ℕ} (v : vector ℤ n) : vector ℤ n :=
subtype.mk (list.map int.neg (subtype.val v))
  begin
    rw list.length_map,
    exact subtype.property v
  end

lemma vector.neg_neg (n : ℕ) (v : vector ℤ n) :
  vector.neg (vector.neg v) = v :=
begin
  apply subtype.eq,
  simp [vector.neg]
end

#check finset

/-! ## Quotient Types

Quotients are a powerful construction in mathematics used to construct `ℤ`, `ℚ`,
`ℝ`, and many other types.

Like subtyping, quotienting constructs a new type from an existing type. Unlike
a subtype, a quotient type contains all of the elements of the base type, but
some elements that were different in the base type are considered equal in the
quotient type. In mathematical terms, the quotient type is isomorphic to a
partition of the base type.

To define a quotient type, we need to provide a type that it is derived from and
a equivalence relation on it that determines which elements are considered
equal. -/

#check quotient
#print setoid

#print equivalence

#check quotient.mk
#check quotient.sound
#check quotient.exact

#check quotient.lift
#check quotient.lift₂
#check quotient.induction_on

/-! ## First Example: Integers

Let us build the integers `ℤ` as a quotient over pairs of natural numbers
`ℕ × ℕ`.

A pair `(p, n)` of natural numbers represents the integer `p - n`. Nonnegative
integers `p` can be represented by `(p, 0)`. Negative integers `-n` can be
represented by `(0, n)`. However, many representations of the same integer are
possible; e.g., `(7, 0)`, `(8, 1)`, `(9, 2)`, and `(10, 3)` all represent the
integer `7`.

Which equivalence relation can we use?

We want two pairs `(p₁, n₁)` and `(p₂, n₂)` to be equal if `p₁ - n₁ = p₂ - n₂`.
However, this does not work because subtraction on `ℕ` is ill-behaved (e.g.,
`0 - 1 = 0`). Instead, we use `p₁ + n₂ = p₂ + n₁`. -/

@[instance] def int.rel : setoid (ℕ × ℕ) :=
{ r     :=
    λpn₁ pn₂ : ℕ × ℕ,
      prod.fst pn₁ + prod.snd pn₂ = prod.fst pn₂ + prod.snd pn₁,
  iseqv :=
    begin
      repeat { apply and.intro },
      { intro pn,
        refl },
      { intros pn₁ pn₂ h,
        rw h },
      { intros pn₁ pn₂ pn₃ h₁₂ h₂₃,
        linarith }
    end }

lemma int.rel_iff (pn₁ pn₂ : ℕ × ℕ) :
  pn₁ ≈ pn₂ ↔
  prod.fst pn₁ + prod.snd pn₂ = prod.fst pn₂ + prod.snd pn₁ :=
by refl

def int : Type :=
quotient int.rel

def int.zero : int :=
⟦(0, 0)⟧

lemma int.zero_eq (m : ℕ) :
  int.zero = ⟦(m, m)⟧ :=
begin
  rw int.zero,
  apply quotient.sound,
  rw int.rel_iff,
  simp
end

def int.add : int → int → int :=
quotient.lift₂
  (λpn₁ pn₂ : ℕ × ℕ,
     ⟦(prod.fst pn₁ + prod.fst pn₂,
       prod.snd pn₁ + prod.snd pn₂)⟧)
  begin
    intros pn₁ pn₂ pn₁' pn₂' h₁ h₂,
    apply quotient.sound,
    rw int.rel_iff at *,
    linarith
  end

lemma int.add_eq (p₁ n₁ p₂ n₂ : ℕ) :
  int.add ⟦(p₁, n₁)⟧ ⟦(p₂, n₂)⟧ = ⟦(p₁ + p₂, n₁ + n₂)⟧ :=
by refl

lemma int.add_zero (i : int) :
  int.add int.zero i = i :=
begin
  apply quotient.induction_on i,
  intro pn,
  rw int.zero,
  cases' pn with p n,
  rw int.add_eq,
  apply quotient.sound,
  simp
end

/-! This definitional syntax would be nice: -/

-- fails
def int.add : int → int → int
| ⟦(p₁, n₁)⟧ ⟦(p₂, n₂)⟧ := ⟦(p₁ + p₂, n₁ + n₂)⟧

/-! But it would be dangerous: -/

-- fails
def int.fst : int → ℕ
| ⟦(p, n)⟧ := p

/-! Using `int.fst`, we could derive `false`. First, we have

    `int.fst ⟦(0, 0)⟧ = 0`
    `int.fst ⟦(1, 1)⟧ = 1`

But since `⟦(0, 0)⟧ = ⟦(1, 1)⟧`, we get

    `0 = 1` -/

/-! ### Second Example: Unordered Pairs

__Unordered pairs__ are pairs for which no distinction is made between the first
and second components. They are usually written `{a, b}`.

We will introduce the type `upair` of unordered pairs as the quotient of pairs
`(a, b)` with respect to the relation "contains the same elements as". -/

@[instance] def upair.rel (α : Type) : setoid (α × α) :=
{ r     := λab₁ ab₂ : α × α,
    ({prod.fst ab₁, prod.snd ab₁} : set α) =
    ({prod.fst ab₂, prod.snd ab₂} : set α),
  iseqv := by repeat { apply and.intro }; finish }

-- needed for technical reasons, to deprioritize `upair.rel` w.r.t. `int.rel`
attribute [instance, priority 999] upair.rel

lemma upair.rel_iff {α : Type} (ab₁ ab₂ : α × α) :
  ab₁ ≈ ab₂ ↔
  ({prod.fst ab₁, prod.snd ab₁} : set α) =
  ({prod.fst ab₂, prod.snd ab₂} : set α) :=
by refl

def upair (α : Type) : Type :=
quotient (upair.rel α)

def upair.mk {α : Type} (a b : α) : upair α :=
⟦(a, b)⟧

/-! It is easy to prove that the `upair.mk` constructor is symmetric: -/

lemma upair.mk_symm {α : Type} (a b : α) :
  upair.mk a b = upair.mk b a :=
begin
  unfold upair.mk,
  apply quotient.sound,
  rw upair.rel_iff,
  apply set.union_comm
end

/-! Another representation of unordered pairs is as sets of cardinality 1 or 2.
The following operation converts `upair` to that representation: -/

def set_of_upair {α : Type} : upair α → set α :=
quotient.lift (λab : α × α, {prod.fst ab, prod.snd ab})
  begin
    intros ab₁ ab₂ h,
    rw upair.rel_iff at *,
    exact h
  end

/-! ### Alternative Definitions via Normalization and Subtyping

Each element of a quotient type correspond to an `≈`-equivalence class.
If there exists a systematic way to obtain a **canonical representative** for
each class, we can use a subtype instead of a quotient, keeping only the
canonical representatives.

Consider the quotient type `int` above. We could say that a pair `(p, n)` is
__canonical__ if `p` or `n` is `0`. -/

namespace alternative

inductive int.is_canonical : ℕ × ℕ → Prop
| nonpos {n : ℕ} : int.is_canonical (0, n)
| nonneg {p : ℕ} : int.is_canonical (p, 0)

def int : Type :=
{pn : ℕ × ℕ // int.is_canonical pn}

/-! **Normalizing** pairs of natural numbers is easy: -/

def int.normalize : ℕ × ℕ → ℕ × ℕ
| (p, n) := if p ≥ n then (p - n, 0) else (0, n - p)

lemma int.is_canonical_normalize (pn : ℕ × ℕ) :
  int.is_canonical (int.normalize pn) :=
begin
  cases' pn with p n,
  simp [int.normalize],
  split_ifs,
  { exact int.is_canonical.nonneg },
  { exact int.is_canonical.nonpos }
end

/-! For unordered pairs, there is no obvious normal form, except to always put
the smaller element first (or last). This requires a linear order `≤` on `α`. -/

def upair.is_canonical {α : Type} [linear_order α] :
  α × α → Prop
| (a, b) := a ≤ b

def upair (α : Type) [linear_order α] : Type :=
{ab : α × α // upair.is_canonical ab}

end alternative

end LoVe


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.algebra.tower
import linear_algebra.prod
import linear_algebra.finsupp

/-!
# 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.

## Tags

adjoin, algebra

-/

universes u v w

open_locale pointwise
open submodule subsemiring

variables {R : Type u} {A : Type v} {B : Type w}

namespace algebra

section semiring
variables [comm_semiring R] [semiring A] [semiring B]
variables [algebra R A] [algebra R B] {s t : set A}

theorem subset_adjoin : s ⊆ adjoin R s :=
algebra.gc.le_u_l s

theorem adjoin_le {S : subalgebra R A} (H : s ⊆ S) : adjoin R s ≤ S :=
algebra.gc.l_le H

lemma adjoin_eq_Inf : adjoin R s = Inf {p | s ⊆ p} :=
le_antisymm (le_Inf (λ _ h, adjoin_le h)) (Inf_le subset_adjoin)

theorem adjoin_le_iff {S : subalgebra R A} : adjoin R s ≤ S ↔ s ⊆ S:=
algebra.gc _ _

theorem adjoin_eq_of_le (S : subalgebra R A) (h₁ : s ⊆ S) (h₂ : S ≤ adjoin R s) : adjoin R s = S :=
le_antisymm (adjoin_le h₁) h₂

theorem adjoin_eq (S : subalgebra R A) : adjoin R ↑S = S :=
adjoin_eq_of_le _ (set.subset.refl _) subset_adjoin

lemma adjoin_Union {α : Type*} (s : α → set A) :
  adjoin R (set.Union s) = ⨆ (i : α), adjoin R (s i) :=
(@algebra.gc R A _ _ _).l_supr

lemma adjoin_attach_bUnion [decidable_eq A] {α : Type*} {s : finset α} (f : s → finset A) :
  adjoin R (s.attach.bUnion f : set A) = ⨆ x, adjoin R (f x) :=
by simpa [adjoin_Union]

@[elab_as_eliminator] theorem adjoin_induction {p : A → Prop} {x : A} (h : x ∈ adjoin R s)
  (Hs : ∀ x ∈ s, p x)
  (Halg : ∀ r, p (algebra_map R A r))
  (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
let S : subalgebra R A :=
{ carrier := p, mul_mem' := Hmul, add_mem' := Hadd, algebra_map_mem' := Halg } in
adjoin_le (show s ≤ S, from Hs) h

/-- The difference with `algebra.adjoin_induction` is that this acts on the subtype. -/
lemma adjoin_induction' {p : adjoin R s → Prop} (Hs : ∀ x (h : x ∈ s), p ⟨x, subset_adjoin h⟩)
  (Halg : ∀ r, p (algebra_map R _ r)) (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hmul : ∀ x y, p x → p y → p (x * y)) (x : adjoin R s) : p x :=
subtype.rec_on x $ λ x hx, begin
  refine exists.elim _ (λ (hx : x ∈ adjoin R s) (hc : p ⟨x, hx⟩), hc),
  exact adjoin_induction hx (λ x hx, ⟨subset_adjoin hx, Hs x hx⟩)
    (λ r, ⟨subalgebra.algebra_map_mem _ r, Halg r⟩)
    (λ x y hx hy, exists.elim hx $ λ hx' hx, exists.elim hy $ λ hy' hy,
    ⟨subalgebra.add_mem _ hx' hy', Hadd _ _ hx hy⟩) (λ x y hx hy, exists.elim hx $ λ hx' hx,
    exists.elim hy $ λ hy' hy, ⟨subalgebra.mul_mem _ hx' hy', Hmul _ _ hx hy⟩),
end

@[simp] lemma adjoin_adjoin_coe_preimage {s : set A} :
  adjoin R ((coe : adjoin R s → A) ⁻¹' s) = ⊤ :=
begin
  refine eq_top_iff.2 (λ x, adjoin_induction' (λ a ha, _) (λ r, _) (λ _ _, _) (λ _ _, _) x),
  { exact subset_adjoin ha },
  { exact subalgebra.algebra_map_mem _ r },
  { exact subalgebra.add_mem _ },
  { exact subalgebra.mul_mem _ }
end

lemma adjoin_union (s t : set A) : adjoin R (s ∪ t) = adjoin R s ⊔ adjoin R t :=
(algebra.gc : galois_connection _ (coe : subalgebra R A → set A)).l_sup

variables (R A)
@[simp] theorem adjoin_empty : adjoin R (∅ : set A) = ⊥ :=
show adjoin R ⊥ = ⊥, by { apply galois_connection.l_bot, exact algebra.gc }

@[simp] theorem adjoin_univ : adjoin R (set.univ : set A) = ⊤ :=
eq_top_iff.2 $ λ x, subset_adjoin $ set.mem_univ _

variables (R) {A} (s)

theorem adjoin_eq_span : (adjoin R s).to_submodule = span R (submonoid.closure s) :=
begin
  apply le_antisymm,
  { intros r hr, rcases subsemiring.mem_closure_iff_exists_list.1 hr with ⟨L, HL, rfl⟩, clear hr,
    induction L with hd tl ih, { exact zero_mem _ },
    rw list.forall_mem_cons at HL,
    rw [list.map_cons, list.sum_cons],
    refine submodule.add_mem _ _ (ih HL.2),
    replace HL := HL.1, clear ih tl,
    suffices : ∃ z r (hr : r ∈ submonoid.closure s), has_scalar.smul z r = list.prod hd,
    { rcases this with ⟨z, r, hr, hzr⟩, rw ← hzr,
      exact smul_mem _ _ (subset_span hr) },
    induction hd with hd tl ih, { exact ⟨1, 1, (submonoid.closure s).one_mem', one_smul _ _⟩ },
    rw list.forall_mem_cons at HL,
    rcases (ih HL.2) with ⟨z, r, hr, hzr⟩, rw [list.prod_cons, ← hzr],
    rcases HL.1 with ⟨hd, rfl⟩ | hs,
    { refine ⟨hd * z, r, hr, _⟩,
      rw [algebra.smul_def, algebra.smul_def, (algebra_map _ _).map_mul, _root_.mul_assoc] },
    { exact ⟨z, hd * r, submonoid.mul_mem _ (submonoid.subset_closure hs) hr,
        (mul_smul_comm _ _ _).symm⟩ } },
  refine span_le.2 _,
  change submonoid.closure s ≤ (adjoin R s).to_subsemiring.to_submonoid,
  exact submonoid.closure_le.2 subset_adjoin
end

lemma span_le_adjoin (s : set A) : span R s ≤ (adjoin R s).to_submodule :=
span_le.mpr subset_adjoin

lemma adjoin_to_submodule_le {s : set A} {t : submodule R A} :
  (adjoin R s).to_submodule ≤ t ↔ ↑(submonoid.closure s) ⊆ (t : set A) :=
by rw [adjoin_eq_span, span_le]

lemma adjoin_eq_span_of_subset {s : set A} (hs : ↑(submonoid.closure s) ⊆ (span R s : set A)) :
  (adjoin R s).to_submodule = span R s :=
le_antisymm ((adjoin_to_submodule_le R).mpr hs) (span_le_adjoin R s)

lemma adjoin_image (f : A →ₐ[R] B) (s : set A) :
  adjoin R (f '' s) = (adjoin R s).map f :=
le_antisymm (adjoin_le $ set.image_subset _ subset_adjoin) $
subalgebra.map_le.2 $ adjoin_le $ set.image_subset_iff.1 subset_adjoin

@[simp] lemma adjoin_insert_adjoin (x : A) :
  adjoin R (insert x ↑(adjoin R s)) = adjoin R (insert x s) :=
le_antisymm
  (adjoin_le (set.insert_subset.mpr
    ⟨subset_adjoin (set.mem_insert _ _), adjoin_mono (set.subset_insert _ _)⟩))
  (algebra.adjoin_mono (set.insert_subset_insert algebra.subset_adjoin))

lemma adjoin_prod_le (s : set A) (t : set B) :
  adjoin R (s ×ˢ t) ≤ (adjoin R s).prod (adjoin R t) :=
adjoin_le $ set.prod_mono subset_adjoin subset_adjoin

lemma mem_adjoin_of_map_mul {s} {x : A} {f : A →ₗ[R] B} (hf : ∀ a₁ a₂, f(a₁ * a₂) = f a₁ * f a₂)
  (h : x ∈ adjoin R s) : f x ∈ adjoin R (f '' (s ∪ {1})) :=
begin
  refine @adjoin_induction R A _ _ _ _ (λ a, f a ∈ adjoin R (f '' (s ∪ {1}))) x h
    (λ a ha, subset_adjoin ⟨a, ⟨set.subset_union_left _ _ ha, rfl⟩⟩)
    (λ r, _)
    (λ y z hy hz, by simpa [hy, hz] using subalgebra.add_mem _ hy hz)
    (λ y z hy hz, by simpa [hy, hz, hf y z] using subalgebra.mul_mem _ hy hz),
  have : f 1 ∈ adjoin R (f '' (s ∪ {1})) :=
  subset_adjoin ⟨1, ⟨set.subset_union_right _ _ $ set.mem_singleton 1, rfl⟩⟩,
  replace this := subalgebra.smul_mem (adjoin R (f '' (s ∪ {1}))) this r,
  convert this,
  rw algebra_map_eq_smul_one,
  exact f.map_smul _ _
end

lemma adjoin_inl_union_inr_eq_prod (s) (t) :
  adjoin R (linear_map.inl R A B '' (s ∪ {1}) ∪ linear_map.inr R A B '' (t ∪ {1})) =
    (adjoin R s).prod (adjoin R t) :=
begin
  apply le_antisymm,
  { simp only [adjoin_le_iff, set.insert_subset, subalgebra.zero_mem, subalgebra.one_mem,
      subset_adjoin, -- the rest comes from `squeeze_simp`
      set.union_subset_iff, linear_map.coe_inl, set.mk_preimage_prod_right,
      set.image_subset_iff, set_like.mem_coe, set.mk_preimage_prod_left, linear_map.coe_inr,
      and_self, set.union_singleton, subalgebra.coe_prod] },
  { rintro ⟨a, b⟩ ⟨ha, hb⟩,
    let P := adjoin R (linear_map.inl R A B '' (s ∪ {1}) ∪ linear_map.inr R A B '' (t ∪ {1})),
    have Ha : (a, (0 : B)) ∈ adjoin R ((linear_map.inl R A B) '' (s ∪ {1})) :=
      mem_adjoin_of_map_mul R (linear_map.inl_map_mul) ha,
    have Hb : ((0 : A), b) ∈ adjoin R ((linear_map.inr R A B) '' (t ∪ {1})) :=
      mem_adjoin_of_map_mul R (linear_map.inr_map_mul) hb,
    replace Ha : (a, (0 : B)) ∈ P := adjoin_mono (set.subset_union_left _ _) Ha,
    replace Hb : ((0 : A), b) ∈ P := adjoin_mono (set.subset_union_right _ _) Hb,
    simpa using subalgebra.add_mem _ Ha Hb }
end

end semiring

section comm_semiring
variables [comm_semiring R] [comm_semiring A]
variables [algebra R A] {s t : set A}

variables (R s t)
theorem adjoin_union_eq_adjoin_adjoin :
  adjoin R (s ∪ t) = (adjoin (adjoin R s) t).restrict_scalars R :=
le_antisymm
  (closure_mono $ set.union_subset
    (set.range_subset_iff.2 $ λ r, or.inl ⟨algebra_map R (adjoin R s) r, rfl⟩)
    (set.union_subset_union_left _ $ λ x hxs, ⟨⟨_, subset_adjoin hxs⟩, rfl⟩))
  (closure_le.2 $ set.union_subset
    (set.range_subset_iff.2 $ λ x, adjoin_mono (set.subset_union_left _ _) x.2)
    (set.subset.trans (set.subset_union_right _ _) subset_adjoin))

lemma adjoin_singleton_one : adjoin R ({1} : set A) = ⊥ :=
eq_bot_iff.2 $ adjoin_le $ set.singleton_subset_iff.2 $ set_like.mem_coe.2 $ one_mem _

theorem adjoin_union_coe_submodule : (adjoin R (s ∪ t)).to_submodule =
  (adjoin R s).to_submodule * (adjoin R t).to_submodule :=
begin
  rw [adjoin_eq_span, adjoin_eq_span, adjoin_eq_span, span_mul_span],
  congr' 1 with z, simp [submonoid.closure_union, submonoid.mem_sup, set.mem_mul]
end

lemma pow_smul_mem_adjoin_smul (r : R) (s : set A) {x : A} (hx : x ∈ adjoin R s) :
  ∃ n₀ : ℕ, ∀ n ≥ n₀, r ^ n • x ∈ adjoin R (r • s) :=
begin
  change x ∈ (adjoin R s).to_submodule at hx,
  rw [adjoin_eq_span, finsupp.mem_span_iff_total] at hx,
  rcases hx with ⟨l, rfl : l.sum (λ (i : submonoid.closure s) (c : R), c • ↑i) = x⟩,
  choose n₁ n₂ using (λ x : submonoid.closure s, submonoid.pow_smul_mem_closure_smul r s x.prop),
  use l.support.sup n₁,
  intros n hn,
  rw finsupp.smul_sum,
  refine (adjoin R (r • s)).to_submodule.sum_mem _,
  intros a ha,
  have : n ≥ n₁ a := le_trans (finset.le_sup ha) hn,
  dsimp only,
  rw [← tsub_add_cancel_of_le this, pow_add, ← smul_smul, smul_smul _ (l a), mul_comm,
    ← smul_smul, adjoin_eq_span],
  refine submodule.smul_mem _ _ _,
  exact submodule.smul_mem _ _ (submodule.subset_span (n₂ a))
end

end comm_semiring

section ring
variables [comm_ring R] [ring A]
variables [algebra R A] {s t : set A}
variables {R s t}

theorem adjoin_int (s : set R) : adjoin ℤ s = subalgebra_of_subring (subring.closure s) :=
le_antisymm (adjoin_le subring.subset_closure)
  (subring.closure_le.2 subset_adjoin : subring.closure s ≤ (adjoin ℤ s).to_subring)

theorem mem_adjoin_iff {s : set A} {x : A} :
  x ∈ adjoin R s ↔ x ∈ subring.closure (set.range (algebra_map R A) ∪ s) :=
⟨λ hx, subsemiring.closure_induction hx subring.subset_closure (subring.zero_mem _)
  (subring.one_mem _) (λ _ _, subring.add_mem _) ( λ _ _, subring.mul_mem _),
  suffices subring.closure (set.range ⇑(algebra_map R A) ∪ s) ≤ (adjoin R s).to_subring,
    from @this x, subring.closure_le.2 subsemiring.subset_closure⟩

theorem adjoin_eq_ring_closure (s : set A) :
  (adjoin R s).to_subring = subring.closure (set.range (algebra_map R A) ∪ s) :=
subring.ext $ λ x, mem_adjoin_iff

end ring

end algebra

open algebra subalgebra

namespace alg_hom

variables [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B]

lemma map_adjoin (φ : A →ₐ[R] B) (s : set A) :
  (adjoin R s).map φ = adjoin R (φ '' s) :=
(adjoin_image _ _ _).symm

lemma adjoin_le_equalizer (φ₁ φ₂ : A →ₐ[R] B) {s : set A} (h : s.eq_on φ₁ φ₂) :
  adjoin R s ≤ φ₁.equalizer φ₂ :=
adjoin_le h

lemma ext_of_adjoin_eq_top {s : set A} (h : adjoin R s = ⊤) ⦃φ₁ φ₂ : A →ₐ[R] B⦄
  (hs : s.eq_on φ₁ φ₂) : φ₁ = φ₂ :=
ext $ λ x, adjoin_le_equalizer φ₁ φ₂ hs $ h.symm ▸ trivial

end alg_hom


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import order.conditionally_complete_lattice
import algebra.big_operators.basic
import algebra.group.prod
import algebra.group.pi
import algebra.module.pi

/-!
# Support of a function

In this file we define `function.support f = {x | f x ≠ 0}` and prove its basic properties.
We also define `function.mul_support f = {x | f x ≠ 1}`.
-/

open set
open_locale big_operators
namespace function

variables {α β A B M N P R S G M₀ G₀ : Type*} {ι : Sort*}

section has_one

variables [has_one M] [has_one N] [has_one P]

/-- `support` of a function is the set of points `x` such that `f x ≠ 0`. -/
def support [has_zero A] (f : α → A) : set α := {x | f x ≠ 0}

/-- `mul_support` of a function is the set of points `x` such that `f x ≠ 1`. -/
@[to_additive] def mul_support (f : α → M) : set α := {x | f x ≠ 1}

@[to_additive] lemma mul_support_eq_preimage (f : α → M) : mul_support f = f ⁻¹' {1}ᶜ := rfl

@[to_additive] lemma nmem_mul_support {f : α → M} {x : α} :
  x ∉ mul_support f ↔ f x = 1 :=
not_not

@[to_additive] lemma compl_mul_support {f : α → M} :
  (mul_support f)ᶜ = {x | f x = 1} :=
ext $ λ x, nmem_mul_support

@[simp, to_additive] lemma mem_mul_support {f : α → M} {x : α} :
  x ∈ mul_support f ↔ f x ≠ 1 :=
iff.rfl

@[simp, to_additive] lemma mul_support_subset_iff {f : α → M} {s : set α} :
  mul_support f ⊆ s ↔ ∀ x, f x ≠ 1 → x ∈ s :=
iff.rfl

@[to_additive] lemma mul_support_subset_iff' {f : α → M} {s : set α} :
  mul_support f ⊆ s ↔ ∀ x ∉ s, f x = 1 :=
forall_congr $ λ x, not_imp_comm

@[simp, to_additive] lemma mul_support_eq_empty_iff {f : α → M} :
  mul_support f = ∅ ↔ f = 1 :=
by { simp_rw [← subset_empty_iff, mul_support_subset_iff', funext_iff], simp }

@[simp, to_additive] lemma mul_support_one' : mul_support (1 : α → M) = ∅ :=
mul_support_eq_empty_iff.2 rfl

@[simp, to_additive] lemma mul_support_one : mul_support (λ x : α, (1 : M)) = ∅ :=
mul_support_one'

@[to_additive]

@[to_additive] lemma mul_support_binop_subset (op : M → N → P) (op1 : op 1 1 = 1)
  (f : α → M) (g : α → N) :
  mul_support (λ x, op (f x) (g x)) ⊆ mul_support f ∪ mul_support g :=
λ x hx, classical.by_cases
  (λ hf : f x = 1, or.inr $ λ hg, hx $ by simp only [hf, hg, op1])
  or.inl

@[to_additive] lemma mul_support_sup [semilattice_sup M] (f g : α → M) :
  mul_support (λ x, f x ⊔ g x) ⊆ mul_support f ∪ mul_support g :=
mul_support_binop_subset (⊔) sup_idem f g

@[to_additive] lemma mul_support_inf [semilattice_inf M] (f g : α → M) :
  mul_support (λ x, f x ⊓ g x) ⊆ mul_support f ∪ mul_support g :=
mul_support_binop_subset (⊓) inf_idem f g

@[to_additive] lemma mul_support_max [linear_order M] (f g : α → M) :
  mul_support (λ x, max (f x) (g x)) ⊆ mul_support f ∪ mul_support g :=
mul_support_sup f g

@[to_additive] lemma mul_support_min [linear_order M] (f g : α → M) :
  mul_support (λ x, min (f x) (g x)) ⊆ mul_support f ∪ mul_support g :=
mul_support_inf f g

@[to_additive] lemma mul_support_supr [conditionally_complete_lattice M] [nonempty ι]
  (f : ι → α → M) :
  mul_support (λ x, ⨆ i, f i x) ⊆ ⋃ i, mul_support (f i) :=
begin
  rw mul_support_subset_iff',
  simp only [mem_Union, not_exists, nmem_mul_support],
  intros x hx,
  simp only [hx, csupr_const]
end

@[to_additive] lemma mul_support_infi [conditionally_complete_lattice M] [nonempty ι]
  (f : ι → α → M) :
  mul_support (λ x, ⨅ i, f i x) ⊆ ⋃ i, mul_support (f i) :=
@mul_support_supr _ (order_dual M) ι ⟨(1:M)⟩ _ _ f

@[to_additive] lemma mul_support_comp_subset {g : M → N} (hg : g 1 = 1) (f : α → M) :
  mul_support (g ∘ f) ⊆ mul_support f :=
λ x, mt $ λ h, by simp only [(∘), *]

@[to_additive] lemma mul_support_subset_comp {g : M → N} (hg : ∀ {x}, g x = 1 → x = 1)
  (f : α → M) :
  mul_support f ⊆ mul_support (g ∘ f) :=
λ x, mt hg

@[to_additive] lemma mul_support_comp_eq (g : M → N) (hg : ∀ {x}, g x = 1 ↔ x = 1)
  (f : α → M) :
  mul_support (g ∘ f) = mul_support f :=
set.ext $ λ x, not_congr hg

@[to_additive] lemma mul_support_comp_eq_preimage (g : β → M) (f : α → β) :
  mul_support (g ∘ f) = f ⁻¹' mul_support g :=
rfl

@[to_additive support_prod_mk] lemma mul_support_prod_mk (f : α → M) (g : α → N) :
  mul_support (λ x, (f x, g x)) = mul_support f ∪ mul_support g :=
set.ext $ λ x, by simp only [mul_support, not_and_distrib, mem_union_eq, mem_set_of_eq,
  prod.mk_eq_one, ne.def]

@[to_additive support_prod_mk'] lemma mul_support_prod_mk' (f : α → M × N) :
  mul_support f = mul_support (λ x, (f x).1) ∪ mul_support (λ x, (f x).2) :=
by simp only [← mul_support_prod_mk, prod.mk.eta]

@[to_additive] lemma mul_support_along_fiber_subset (f : α × β → M) (a : α) :
  mul_support (λ b, f (a, b)) ⊆ (mul_support f).image prod.snd :=
by tidy

@[simp, to_additive] lemma mul_support_along_fiber_finite_of_finite
  (f : α × β → M) (a : α) (h : (mul_support f).finite) :
  (mul_support (λ b, f (a, b))).finite :=
(h.image prod.snd).subset (mul_support_along_fiber_subset f a)

end has_one

@[to_additive] lemma mul_support_mul [monoid M] (f g : α → M) :
  mul_support (λ x, f x * g x) ⊆ mul_support f ∪ mul_support g :=
mul_support_binop_subset (*) (one_mul _) f g

@[simp, to_additive] lemma mul_support_inv [group G] (f : α → G) :
  mul_support (λ x, (f x)⁻¹) = mul_support f :=
set.ext $ λ x, not_congr inv_eq_one

@[simp, to_additive] lemma mul_support_inv' [group G] (f : α → G) :
  mul_support (f⁻¹) = mul_support f :=
mul_support_inv f

@[simp] lemma mul_support_inv₀ [group_with_zero G₀] (f : α → G₀) :
  mul_support (λ x, (f x)⁻¹) = mul_support f :=
set.ext $ λ x, not_congr inv_eq_one₀

@[to_additive] lemma mul_support_mul_inv [group G] (f g : α → G) :
  mul_support (λ x, f x * (g x)⁻¹) ⊆ mul_support f ∪ mul_support g :=
mul_support_binop_subset (λ a b, a * b⁻¹) (by simp) f g

@[to_additive support_sub] lemma mul_support_group_div [group G] (f g : α → G) :
  mul_support (λ x, f x / g x) ⊆ mul_support f ∪ mul_support g :=
mul_support_binop_subset (/) (by simp only [one_div, one_inv]) f g

lemma mul_support_div [group_with_zero G₀] (f g : α → G₀) :
  mul_support (λ x, f x / g x) ⊆ mul_support f ∪ mul_support g :=
mul_support_binop_subset (/) (by simp only [div_one]) f g

@[simp] lemma support_mul [mul_zero_class R] [no_zero_divisors R] (f g : α → R) :
  support (λ x, f x * g x) = support f ∩ support g :=
set.ext $ λ x, by simp only [mem_support, mul_ne_zero_iff, mem_inter_eq, not_or_distrib]

lemma support_smul_subset_right [add_monoid A] [monoid B] [distrib_mul_action B A]
  (b : B) (f : α → A) :
  support (b • f) ⊆ support f :=
λ x hbf hf, hbf $ by rw [pi.smul_apply, hf, smul_zero]

lemma support_smul_subset_left [semiring R] [add_comm_monoid M] [module R M]
  (f : α → R) (g : α → M) :
  support (f • g) ⊆ support f :=
λ x hfg hf, hfg $ by rw [pi.smul_apply', hf, zero_smul]

lemma support_smul [semiring R] [add_comm_monoid M] [module R M]
  [no_zero_smul_divisors R M] (f : α → R) (g : α → M) :
  support (f • g) = support f ∩ support g :=
ext $ λ x, smul_ne_zero

@[simp] lemma support_inv [group_with_zero G₀] (f : α → G₀) :
  support (λ x, (f x)⁻¹) = support f :=
set.ext $ λ x, not_congr inv_eq_zero

@[simp] lemma support_div [group_with_zero G₀] (f g : α → G₀) :
  support (λ x, f x / g x) = support f ∩ support g :=
by simp [div_eq_mul_inv]

@[to_additive] lemma mul_support_prod [comm_monoid M] (s : finset α) (f : α → β → M) :
  mul_support (λ x, ∏ i in s, f i x) ⊆ ⋃ i ∈ s, mul_support (f i) :=
begin
  rw mul_support_subset_iff',
  simp only [mem_Union, not_exists, nmem_mul_support],
  exact λ x, finset.prod_eq_one
end

lemma support_prod_subset [comm_monoid_with_zero A] (s : finset α) (f : α → β → A) :
  support (λ x, ∏ i in s, f i x) ⊆ ⋂ i ∈ s, support (f i) :=
λ x hx, mem_bInter_iff.2 $ λ i hi H, hx $ finset.prod_eq_zero hi H

lemma support_prod [comm_monoid_with_zero A] [no_zero_divisors A] [nontrivial A]
  (s : finset α) (f : α → β → A) :
  support (λ x, ∏ i in s, f i x) = ⋂ i ∈ s, support (f i) :=
set.ext $ λ x, by
  simp only [support, ne.def, finset.prod_eq_zero_iff, mem_set_of_eq, set.mem_Inter, not_exists]

lemma mul_support_one_add [has_one R] [add_left_cancel_monoid R] (f : α → R) :
  mul_support (λ x, 1 + f x) = support f :=
set.ext $ λ x, not_congr add_right_eq_self

lemma mul_support_one_add' [has_one R] [add_left_cancel_monoid R] (f : α → R) :
  mul_support (1 + f) = support f :=
mul_support_one_add f

lemma mul_support_add_one [has_one R] [add_right_cancel_monoid R] (f : α → R) :
  mul_support (λ x, f x + 1) = support f :=
set.ext $ λ x, not_congr add_left_eq_self

lemma mul_support_add_one' [has_one R] [add_right_cancel_monoid R] (f : α → R) :
  mul_support (f + 1) = support f :=
mul_support_add_one f

lemma mul_support_one_sub' [has_one R] [add_group R] (f : α → R) :
  mul_support (1 - f) = support f :=
by rw [sub_eq_add_neg, mul_support_one_add', support_neg']

lemma mul_support_one_sub [has_one R] [add_group R] (f : α → R) :
  mul_support (λ x, 1 - f x) = support f :=
mul_support_one_sub' f

end function

namespace set

open function

variables {α β M : Type*} [has_one M] {f : α → M}

@[to_additive] lemma image_inter_mul_support_eq {s : set β} {g : β → α} :
  (g '' s ∩ mul_support f) = g '' (s ∩ mul_support (f ∘ g)) :=
by rw [mul_support_comp_eq_preimage f g, image_inter_preimage]

end set

namespace pi
variables {A : Type*} {B : Type*} [decidable_eq A] [has_zero B] {a : A} {b : B}

lemma support_single_zero : function.support (pi.single a (0 : B)) = ∅ := by simp

@[simp] lemma support_single_of_ne (h : b ≠ 0) :
  function.support (pi.single a b) = {a} :=
begin
  ext,
  simp only [mem_singleton_iff, ne.def, function.mem_support],
  split,
  { contrapose!,
    exact λ h', single_eq_of_ne h' b },
  { rintro rfl,
    rw single_eq_same,
    exact h }
end

lemma support_single [decidable_eq B] :
  function.support (pi.single a b) = if b = 0 then ∅ else {a} := by { split_ifs with h; simp [h] }

lemma support_single_subset : function.support (pi.single a b) ⊆ {a} :=
begin
  classical,
  rw support_single,
  split_ifs; simp
end

lemma support_single_disjoint {b' : B} (hb : b ≠ 0) (hb' : b' ≠ 0) {i j : A} :
  disjoint (function.support (single i b)) (function.support (single j b')) ↔ i ≠ j :=
by rw [support_single_of_ne hb, support_single_of_ne hb', disjoint_singleton]

end pi