/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import data.set.finite
import data.finset.order
import order.well_founded
import order.order_iso_nat
import order.atoms
import order.zorn
import tactic.tfae

/-!
# Compactness properties for complete lattices

For complete lattices, there are numerous equivalent ways to express the fact that the relation `>`
is well-founded. In this file we define three especially-useful characterisations and provide
proofs that they are indeed equivalent to well-foundedness.

## Main definitions
 * `complete_lattice.is_sup_closed_compact`
 * `complete_lattice.is_Sup_finite_compact`
 * `complete_lattice.is_compact_element`
 * `complete_lattice.is_compactly_generated`

## Main results
The main result is that the following four conditions are equivalent for a complete lattice:
 * `well_founded (>)`
 * `complete_lattice.is_sup_closed_compact`
 * `complete_lattice.is_Sup_finite_compact`
 * `∀ k, complete_lattice.is_compact_element k`

This is demonstrated by means of the following four lemmas:
 * `complete_lattice.well_founded.is_Sup_finite_compact`
 * `complete_lattice.is_Sup_finite_compact.is_sup_closed_compact`
 * `complete_lattice.is_sup_closed_compact.well_founded`
 * `complete_lattice.is_Sup_finite_compact_iff_all_elements_compact`

 We also show well-founded lattices are compactly generated
 (`complete_lattice.compactly_generated_of_well_founded`).

## References
- [G. Călugăreanu, *Lattice Concepts of Module Theory*][calugareanu]

## Tags

complete lattice, well-founded, compact
-/

variables {α : Type*} [complete_lattice α]

namespace complete_lattice

variables (α)

/-- A compactness property for a complete lattice is that any `sup`-closed non-empty subset
contains its `Sup`. -/
def is_sup_closed_compact : Prop :=
  ∀ (s : set α) (h : s.nonempty), (∀ a b, a ∈ s → b ∈ s → a ⊔ b ∈ s) → (Sup s) ∈ s

/-- A compactness property for a complete lattice is that any subset has a finite subset with the
same `Sup`. -/
def is_Sup_finite_compact : Prop :=
∀ (s : set α), ∃ (t : finset α), ↑t ⊆ s ∧ Sup s = t.sup id

/-- An element `k` of a complete lattice is said to be compact if any set with `Sup`
above `k` has a finite subset with `Sup` above `k`.  Such an element is also called
"finite" or "S-compact". -/
def is_compact_element {α : Type*} [complete_lattice α] (k : α) :=
∀ s : set α, k ≤ Sup s → ∃ t : finset α, ↑t ⊆ s ∧ k ≤ t.sup id

/-- An element `k` is compact if and only if any directed set with `Sup` above
`k` already got above `k` at some point in the set. -/
theorem is_compact_element_iff_le_of_directed_Sup_le (k : α) :
  is_compact_element k ↔
  ∀ s : set α, s.nonempty → directed_on (≤) s → k ≤ Sup s → ∃ x : α, x ∈ s ∧ k ≤ x :=
begin
  classical,
  split,
  { by_cases hbot : k = ⊥,
    -- Any nonempty directed set certainly has sup above ⊥
    { rintros _ _ ⟨x, hx⟩ _ _, use x, by simp only [hx, hbot, bot_le, and_self], },
    { intros hk s hne hdir hsup,
      obtain ⟨t, ht⟩ := hk s hsup,
      -- If t were empty, its sup would be ⊥, which is not above k ≠ ⊥.
      have tne : t.nonempty,
      { by_contradiction n,
        rw [finset.nonempty_iff_ne_empty, not_not] at n,
        simp only [n, true_and, set.empty_subset, finset.coe_empty,
          finset.sup_empty, le_bot_iff] at ht,
        exact absurd ht hbot, },
      -- certainly every element of t is below something in s, since ↑t ⊆ s.
      have t_below_s : ∀ x ∈ t, ∃ y ∈ s, x ≤ y, from λ x hxt, ⟨x, ht.left hxt, by refl⟩,
      obtain ⟨x, ⟨hxs, hsupx⟩⟩ := finset.sup_le_of_le_directed s hne hdir t t_below_s,
      exact ⟨x, ⟨hxs, le_trans ht.right hsupx⟩⟩, }, },
  { intros hk s hsup,
    -- Consider the set of finite joins of elements of the (plain) set s.
    let S : set α := { x | ∃ t : finset α, ↑t ⊆ s ∧ x = t.sup id },
    -- S is directed, nonempty, and still has sup above k.
    have dir_US : directed_on (≤) S,
    { rintros x ⟨c, hc⟩ y ⟨d, hd⟩,
      use x ⊔ y,
      split,
      { use c ∪ d,
        split,
        { simp only [hc.left, hd.left, set.union_subset_iff, finset.coe_union, and_self], },
        { simp only [hc.right, hd.right, finset.sup_union], }, },
      simp only [and_self, le_sup_left, le_sup_right], },
    have sup_S : Sup s ≤ Sup S,
    { apply Sup_le_Sup,
      intros x hx, use {x},
      simpa only [and_true, id.def, finset.coe_singleton, eq_self_iff_true, finset.sup_singleton,
        set.singleton_subset_iff], },
    have Sne : S.nonempty,
    { suffices : ⊥ ∈ S, from set.nonempty_of_mem this,
      use ∅,
      simp only [set.empty_subset, finset.coe_empty, finset.sup_empty,
        eq_self_iff_true, and_self], },
    -- Now apply the defn of compact and finish.
    obtain ⟨j, ⟨hjS, hjk⟩⟩ := hk S Sne dir_US (le_trans hsup sup_S),
    obtain ⟨t, ⟨htS, htsup⟩⟩ := hjS,
    use t, exact ⟨htS, by rwa ←htsup⟩, },
end

/-- A compact element `k` has the property that any directed set lying strictly below `k` has
its Sup strictly below `k`. -/
lemma is_compact_element.directed_Sup_lt_of_lt {α : Type*} [complete_lattice α] {k : α}
  (hk : is_compact_element k) {s : set α} (hemp : s.nonempty) (hdir : directed_on (≤) s)
  (hbelow : ∀ x ∈ s, x < k) : Sup s < k :=
begin
  rw is_compact_element_iff_le_of_directed_Sup_le at hk,
  by_contradiction,
  have sSup : Sup s ≤ k, from Sup_le (λ s hs, (hbelow s hs).le),
  replace sSup : Sup s = k := eq_iff_le_not_lt.mpr ⟨sSup, h⟩,
  obtain ⟨x, hxs, hkx⟩ := hk s hemp hdir sSup.symm.le,
  obtain hxk := hbelow x hxs,
  exact hxk.ne (hxk.le.antisymm hkx),
end

lemma finset_sup_compact_of_compact {α β : Type*} [complete_lattice α] {f : β → α}
  (s : finset β) (h : ∀ x ∈ s, is_compact_element (f x)) : is_compact_element (s.sup f) :=
begin
  classical,
  rw is_compact_element_iff_le_of_directed_Sup_le,
  intros d hemp hdir hsup,
  change f with id ∘ f, rw ←finset.sup_finset_image,
  apply finset.sup_le_of_le_directed d hemp hdir,
  rintros x hx,
  obtain ⟨p, ⟨hps, rfl⟩⟩ := finset.mem_image.mp hx,
  specialize h p hps,
  rw is_compact_element_iff_le_of_directed_Sup_le at h,
  specialize h d hemp hdir (le_trans (finset.le_sup hps) hsup),
  simpa only [exists_prop],
end

lemma well_founded.is_Sup_finite_compact (h : well_founded ((>) : α → α → Prop)) :
  is_Sup_finite_compact α :=
begin
  intros s,
  let p : set α := { x | ∃ (t : finset α), ↑t ⊆ s ∧ t.sup id = x },
  have hp : p.nonempty, { use [⊥, ∅], simp, },
  obtain ⟨m, ⟨t, ⟨ht₁, ht₂⟩⟩, hm⟩ := well_founded.well_founded_iff_has_max'.mp h p hp,
  use t, simp only [ht₁, ht₂, true_and], apply le_antisymm,
  { apply Sup_le, intros y hy, classical,
    have hy' : (insert y t).sup id ∈ p,
    { use insert y t, simp, rw set.insert_subset, exact ⟨hy, ht₁⟩, },
    have hm' : m ≤ (insert y t).sup id, { rw ← ht₂, exact finset.sup_mono (t.subset_insert y), },
    rw ← hm _ hy' hm', simp, },
  { rw [← ht₂, finset.sup_eq_Sup], exact Sup_le_Sup ht₁, },
end

lemma is_Sup_finite_compact.is_sup_closed_compact (h : is_Sup_finite_compact α) :
  is_sup_closed_compact α :=
begin
  intros s hne hsc, obtain ⟨t, ht₁, ht₂⟩ := h s, clear h,
  cases t.eq_empty_or_nonempty with h h,
  { subst h, rw finset.sup_empty at ht₂, rw ht₂,
    simp [eq_singleton_bot_of_Sup_eq_bot_of_nonempty ht₂ hne], },
  { rw ht₂, exact t.sup_closed_of_sup_closed h ht₁ hsc, },
end

lemma is_sup_closed_compact.well_founded (h : is_sup_closed_compact α) :
  well_founded ((>) : α → α → Prop) :=
begin
  rw rel_embedding.well_founded_iff_no_descending_seq, rintros ⟨a⟩,
  suffices : Sup (set.range a) ∈ set.range a,
  { obtain ⟨n, hn⟩ := set.mem_range.mp this,
    have h' : Sup (set.range a) < a (n+1), { change _ > _, simp [← hn, a.map_rel_iff], },
    apply lt_irrefl (a (n+1)), apply lt_of_le_of_lt _ h', apply le_Sup, apply set.mem_range_self, },
  apply h (set.range a),
  { use a 37, apply set.mem_range_self, },
  { rintros x y ⟨m, hm⟩ ⟨n, hn⟩, use m ⊔ n, rw [← hm, ← hn], apply a.to_rel_hom.map_sup, },
end

lemma is_Sup_finite_compact_iff_all_elements_compact :
  is_Sup_finite_compact α ↔ (∀ k : α, is_compact_element k) :=
begin
  split,
  { intros h k s hs,
    obtain ⟨t, ⟨hts, htsup⟩⟩ := h s,
    use [t, hts],
    rwa ←htsup, },
  { intros h s,
    obtain ⟨t, ⟨hts, htsup⟩⟩ := h (Sup s) s (by refl),
    have : Sup s = t.sup id,
    { suffices : t.sup id ≤ Sup s, by { apply le_antisymm; assumption },
      simp only [id.def, finset.sup_le_iff],
      intros x hx,
      apply le_Sup, exact hts hx, },
    use [t, hts], assumption, },
end

lemma well_founded_characterisations :
  tfae [well_founded ((>) : α → α → Prop),
        is_Sup_finite_compact α,
        is_sup_closed_compact α,
        ∀ k : α, is_compact_element k] :=
begin
  tfae_have : 1 → 2, by { exact well_founded.is_Sup_finite_compact α, },
  tfae_have : 2 → 3, by { exact is_Sup_finite_compact.is_sup_closed_compact α, },
  tfae_have : 3 → 1, by { exact is_sup_closed_compact.well_founded α, },
  tfae_have : 2 ↔ 4, by { exact is_Sup_finite_compact_iff_all_elements_compact α },
  tfae_finish,
end

lemma well_founded_iff_is_Sup_finite_compact :
  well_founded ((>) : α → α → Prop) ↔ is_Sup_finite_compact α :=
(well_founded_characterisations α).out 0 1

lemma is_Sup_finite_compact_iff_is_sup_closed_compact :
  is_Sup_finite_compact α ↔ is_sup_closed_compact α :=
(well_founded_characterisations α).out 1 2

lemma is_sup_closed_compact_iff_well_founded :
  is_sup_closed_compact α ↔ well_founded ((>) : α → α → Prop) :=
(well_founded_characterisations α).out 2 0

alias well_founded_iff_is_Sup_finite_compact ↔ _ is_Sup_finite_compact.well_founded
alias is_Sup_finite_compact_iff_is_sup_closed_compact ↔
      _ is_sup_closed_compact.is_Sup_finite_compact
alias is_sup_closed_compact_iff_well_founded ↔ _ well_founded.is_sup_closed_compact

end complete_lattice

/-- A complete lattice is said to be compactly generated if any
element is the `Sup` of compact elements. -/
class is_compactly_generated (α : Type*) [complete_lattice α] : Prop :=
(exists_Sup_eq :
  ∀ (x : α), ∃ (s : set α), (∀ x ∈ s, complete_lattice.is_compact_element x) ∧ Sup s = x)

section
variables {α} [is_compactly_generated α] {a b : α} {s : set α}

@[simp]
lemma Sup_compact_le_eq (b) : Sup {c : α | complete_lattice.is_compact_element c ∧ c ≤ b} = b :=
begin
  rcases is_compactly_generated.exists_Sup_eq b with ⟨s, hs, rfl⟩,
  exact le_antisymm (Sup_le (λ c hc, hc.2)) (Sup_le_Sup (λ c cs, ⟨hs c cs, le_Sup cs⟩)),
end

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

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

/-- This property is sometimes referred to as `α` being upper continuous. -/
theorem inf_Sup_eq_of_directed_on (h : directed_on (≤) s):
  a ⊓ Sup s = ⨆ b ∈ s, a ⊓ b :=
le_antisymm (begin
  rw le_iff_compact_le_imp,
  by_cases hs : s.nonempty,
  { intros c hc hcinf,
    rw le_inf_iff at hcinf,
    rw complete_lattice.is_compact_element_iff_le_of_directed_Sup_le at hc,
    rcases hc s hs h hcinf.2 with ⟨d, ds, cd⟩,
    exact (le_inf hcinf.1 cd).trans (le_bsupr d ds) },
  { rw set.not_nonempty_iff_eq_empty at hs,
    simp [hs] }
end) supr_inf_le_inf_Sup

/-- This property is equivalent to `α` being upper continuous. -/
theorem inf_Sup_eq_supr_inf_sup_finset :
  a ⊓ Sup s = ⨆ (t : finset α) (H : ↑t ⊆ s), a ⊓ (t.sup id) :=
le_antisymm (begin
  rw le_iff_compact_le_imp,
  intros c hc hcinf,
  rw le_inf_iff at hcinf,
  rcases hc s hcinf.2 with ⟨t, ht1, ht2⟩,
  exact (le_inf hcinf.1 ht2).trans (le_bsupr t ht1),
end) (supr_le $ λ t, supr_le $ λ h, inf_le_inf_left _ ((finset.sup_eq_Sup t).symm ▸ (Sup_le_Sup h)))

theorem complete_lattice.set_independent_iff_finite {s : set α} :
  complete_lattice.set_independent s ↔
    ∀ t : finset α, ↑t ⊆ s → complete_lattice.set_independent (↑t : set α) :=
⟨λ hs t ht, hs.mono ht, λ h a ha, begin
  rw [disjoint_iff, inf_Sup_eq_supr_inf_sup_finset, supr_eq_bot],
  intro t,
  rw [supr_eq_bot, finset.sup_eq_Sup],
  intro ht,
  classical,
  have h' := (h (insert a t) _ (t.mem_insert_self a)).eq_bot,
  { rwa [finset.coe_insert, set.insert_diff_self_of_not_mem] at h',
    exact λ con, ((set.mem_diff a).1 (ht con)).2 (set.mem_singleton a) },
  { rw [finset.coe_insert, set.insert_subset],
    exact ⟨ha, set.subset.trans ht (set.diff_subset _ _)⟩ }
end⟩

lemma complete_lattice.set_independent_Union_of_directed {η : Type*}
  {s : η → set α} (hs : directed (⊆) s)
  (h : ∀ i, complete_lattice.set_independent (s i)) :
  complete_lattice.set_independent (⋃ i, s i) :=
begin
  by_cases hη : nonempty η,
  { resetI,
    rw complete_lattice.set_independent_iff_finite,
    intros t ht,
    obtain ⟨I, fi, hI⟩ := set.finite_subset_Union t.finite_to_set ht,
    obtain ⟨i, hi⟩ := hs.finset_le fi.to_finset,
    exact (h i).mono (set.subset.trans hI $ set.bUnion_subset $
      λ j hj, hi j (fi.mem_to_finset.2 hj)) },
  { rintros a ⟨_, ⟨i, _⟩, _⟩,
    exfalso, exact hη ⟨i⟩, },
end

lemma complete_lattice.independent_sUnion_of_directed {s : set (set α)}
  (hs : directed_on (⊆) s)
  (h : ∀ a ∈ s, complete_lattice.set_independent a) :
  complete_lattice.set_independent (⋃₀ s) :=
by rw set.sUnion_eq_Union; exact
  complete_lattice.set_independent_Union_of_directed hs.directed_coe (by simpa using h)

end

namespace complete_lattice

lemma compactly_generated_of_well_founded (h : well_founded ((>) : α → α → Prop)) :
  is_compactly_generated α :=
begin
  rw [well_founded_iff_is_Sup_finite_compact, is_Sup_finite_compact_iff_all_elements_compact] at h,
  -- x is the join of the set of compact elements {x}
  exact ⟨λ x, ⟨{x}, ⟨λ x _, h x, Sup_singleton⟩⟩⟩,
end

/-- A compact element `k` has the property that any `b < `k lies below a "maximal element below
`k`", which is to say `[⊥, k]` is coatomic. -/
theorem Iic_coatomic_of_compact_element {k : α} (h : is_compact_element k) :
  is_coatomic (set.Iic k) :=
⟨λ ⟨b, hbk⟩, begin
  by_cases htriv : b = k,
  { left, ext, simp only [htriv, set.Iic.coe_top, subtype.coe_mk], },
  right,
  rcases zorn.zorn_nonempty_partial_order₀ (set.Iio k) _ b (lt_of_le_of_ne hbk htriv)
    with ⟨a, a₀, ba, h⟩,
  { refine ⟨⟨a, le_of_lt a₀⟩, ⟨ne_of_lt a₀, λ c hck, by_contradiction $ λ c₀, _⟩, ba⟩,
    cases h c.1 (lt_of_le_of_ne c.2 (λ con, c₀ (subtype.ext con))) hck.le,
    exact lt_irrefl _ hck, },
  { intros S SC cC I IS,
    by_cases hS : S.nonempty,
    { exact ⟨Sup S, h.directed_Sup_lt_of_lt hS cC.directed_on SC, λ _, le_Sup⟩, },
    exact ⟨b, lt_of_le_of_ne hbk htriv, by simp only [set.not_nonempty_iff_eq_empty.mp hS,
      set.mem_empty_eq, forall_const, forall_prop_of_false, not_false_iff]⟩, },
end⟩

lemma coatomic_of_top_compact (h : is_compact_element (⊤ : α)) : is_coatomic α :=
(@order_iso.Iic_top α _).is_coatomic_iff.mp (Iic_coatomic_of_compact_element h)

end complete_lattice

section
variables [is_modular_lattice α] [is_compactly_generated α]

@[priority 100]
instance is_atomic_of_is_complemented [is_complemented α] : is_atomic α :=
⟨λ b, begin
  by_cases h : {c : α | complete_lattice.is_compact_element c ∧ c ≤ b} ⊆ {⊥},
  { left,
    rw [← Sup_compact_le_eq b, Sup_eq_bot],
    exact h },
  { rcases set.not_subset.1 h with ⟨c, ⟨hc, hcb⟩, hcbot⟩,
    right,
    have hc' := complete_lattice.Iic_coatomic_of_compact_element hc,
    rw ← is_atomic_iff_is_coatomic at hc',
    haveI := hc',
    obtain con | ⟨a, ha, hac⟩ := eq_bot_or_exists_atom_le (⟨c, le_refl c⟩ : set.Iic c),
    { exfalso,
      apply hcbot,
      simp only [subtype.ext_iff, set.Iic.coe_bot, subtype.coe_mk] at con,
      exact con },
    rw [← subtype.coe_le_coe, subtype.coe_mk] at hac,
    exact ⟨a, ha.of_is_atom_coe_Iic, hac.trans hcb⟩ },
end⟩

/-- See Lemma 5.1, Călugăreanu -/
@[priority 100]
instance is_atomistic_of_is_complemented [is_complemented α] : is_atomistic α :=
⟨λ b, ⟨{a | is_atom a ∧ a ≤ b}, begin
  symmetry,
  have hle : Sup {a : α | is_atom a ∧ a ≤ b} ≤ b := (Sup_le $ λ _, and.right),
  apply (lt_or_eq_of_le hle).resolve_left (λ con, _),
  obtain ⟨c, hc⟩ := exists_is_compl (⟨Sup {a : α | is_atom a ∧ a ≤ b}, hle⟩ : set.Iic b),
  obtain rfl | ⟨a, ha, hac⟩ := eq_bot_or_exists_atom_le c,
  { exact ne_of_lt con (subtype.ext_iff.1 (eq_top_of_is_compl_bot hc)) },
  { apply ha.1,
    rw eq_bot_iff,
    apply le_trans (le_inf _ hac) hc.1,
    rw [← subtype.coe_le_coe, subtype.coe_mk],
    exact le_Sup ⟨ha.of_is_atom_coe_Iic, a.2⟩ }
end, λ _, and.left⟩⟩

/-- See Theorem 6.6, Călugăreanu -/
theorem is_complemented_of_Sup_atoms_eq_top (h : Sup {a : α | is_atom a} = ⊤) : is_complemented α :=
⟨λ b, begin
  obtain ⟨s, ⟨s_ind, b_inf_Sup_s, s_atoms⟩, s_max⟩ := zorn.zorn_subset
    {s : set α | complete_lattice.set_independent s ∧ b ⊓ Sup s = ⊥ ∧ ∀ a ∈ s, is_atom a} _,
  { refine ⟨Sup s, le_of_eq b_inf_Sup_s, _⟩,
    rw [← h, Sup_le_iff],
    intros a ha,
    rw ← inf_eq_left,
    refine (eq_bot_or_eq_of_le_atom ha inf_le_left).resolve_left (λ con, ha.1 _),
    rw [eq_bot_iff, ← con],
    refine le_inf (le_refl a) ((le_Sup _).trans le_sup_right),
    rw ← disjoint_iff at *,
    have a_dis_Sup_s : disjoint a (Sup s) := con.mono_right le_sup_right,
    rw ← s_max (s ∪ {a}) ⟨λ x hx, _, ⟨_, λ x hx, _⟩⟩ (set.subset_union_left _ _),
    { exact set.mem_union_right _ (set.mem_singleton _) },
    { rw [set.mem_union, set.mem_singleton_iff] at hx,
      by_cases xa : x = a,
      { simp only [xa, set.mem_singleton, set.insert_diff_of_mem, set.union_singleton],
        exact con.mono_right (le_trans (Sup_le_Sup (set.diff_subset s {a})) le_sup_right) },
      { have h : (s ∪ {a}) \ {x} = (s \ {x}) ∪ {a},
        { simp only [set.union_singleton],
          rw set.insert_diff_of_not_mem,
          rw set.mem_singleton_iff,
          exact ne.symm xa },
        rw [h, Sup_union, Sup_singleton],
        apply (s_ind (hx.resolve_right xa)).disjoint_sup_right_of_disjoint_sup_left
          (a_dis_Sup_s.mono_right _).symm,
        rw [← Sup_insert, set.insert_diff_singleton,
          set.insert_eq_of_mem (hx.resolve_right xa)] } },
    { rw [Sup_union, Sup_singleton, ← disjoint_iff],
      exact b_inf_Sup_s.disjoint_sup_right_of_disjoint_sup_left con.symm },
    { rw [set.mem_union, set.mem_singleton_iff] at hx,
      cases hx,
      { exact s_atoms x hx },
      { rw hx,
        exact ha } } },
  { intros c hc1 hc2,
    refine ⟨⋃₀ c, ⟨complete_lattice.independent_sUnion_of_directed hc2.directed_on
      (λ s hs, (hc1 hs).1), _, λ a ha, _⟩, λ _, set.subset_sUnion_of_mem⟩,
    { rw [Sup_sUnion, ← Sup_image, inf_Sup_eq_of_directed_on, supr_eq_bot],
      { intro i,
        rw supr_eq_bot,
        intro hi,
        obtain ⟨x, xc, rfl⟩ := (set.mem_image _ _ _).1 hi,
        exact (hc1 xc).2.1 },
      { rw directed_on_image,
        refine hc2.directed_on.mono (λ s t, Sup_le_Sup) } },
    { rcases set.mem_sUnion.1 ha with ⟨s, sc, as⟩,
      exact (hc1 sc).2.2 a as } }
end⟩

/-- See Theorem 6.6, Călugăreanu -/
theorem is_complemented_of_is_atomistic [is_atomistic α] : is_complemented α :=
is_complemented_of_Sup_atoms_eq_top Sup_atoms_eq_top

theorem is_complemented_iff_is_atomistic : is_complemented α ↔ is_atomistic α :=
begin
  split; introsI,
  { exact is_atomistic_of_is_complemented },
  { exact is_complemented_of_is_atomistic }
end

end


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

! This file was ported from Lean 3 source module data.countable.basic
! leanprover-community/mathlib commit 1f0096e6caa61e9c849ec2adbd227e960e9dff58
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Logic.Equiv.Nat
import Mathlib.Logic.Equiv.Fin
import Mathlib.Data.Countable.Defs

/-!
# Countable types

In this file we provide basic instances of the `Countable` typeclass defined elsewhere.
-/

universe u v w

open Function

instance : Countable ℤ :=
  Countable.of_equiv ℕ Equiv.intEquivNat.symm

/-!
### Definition in terms of `Function.Embedding`
-/

section Embedding

variable {α : Sort u} {β : Sort v}

theorem countable_iff_nonempty_embedding : Countable α ↔ Nonempty (α ↪ ℕ) :=
  ⟨fun ⟨⟨f, hf⟩⟩ => ⟨⟨f, hf⟩⟩, fun ⟨f⟩ => ⟨⟨f, f.2⟩⟩⟩
#align countable_iff_nonempty_embedding countable_iff_nonempty_embedding

theorem nonempty_embedding_nat (α) [Countable α] : Nonempty (α ↪ ℕ) :=
  countable_iff_nonempty_embedding.1 ‹_›
#align nonempty_embedding_nat nonempty_embedding_nat

protected theorem Function.Embedding.countable [Countable β] (f : α ↪ β) : Countable α :=
  f.injective.countable
#align function.embedding.countable Function.Embedding.countable

end Embedding

/-!
### Operations on `Type _`s
-/

section type

variable {α : Type u} {β : Type v} {π : α → Type w}

instance [Countable α] [Countable β] : Countable (Sum α β) := by
  rcases exists_injective_nat α with ⟨f, hf⟩
  rcases exists_injective_nat β with ⟨g, hg⟩
  exact (Equiv.natSumNatEquivNat.injective.comp <| hf.sum_map hg).countable

instance [Countable α] : Countable (Option α) :=
  Countable.of_equiv _ (Equiv.optionEquivSumPUnit.{_, 0} α).symm

instance [Countable α] [Countable β] : Countable (α × β) := by
  rcases exists_injective_nat α with ⟨f, hf⟩
  rcases exists_injective_nat β with ⟨g, hg⟩
  exact (Nat.pairEquiv.injective.comp <| hf.Prod_map hg).countable

instance [Countable α] [∀ a, Countable (π a)] : Countable (Sigma π) := by
  rcases exists_injective_nat α with ⟨f, hf⟩
  choose g hg using fun a => exists_injective_nat (π a)
  exact ((Equiv.sigmaEquivProd ℕ ℕ).injective.comp <| hf.sigma_map hg).countable

end type

section sort

variable {α : Sort u} {β : Sort v} {π : α → Sort w}

/-!
### Operations on `Sort _`s
-/

instance (priority := 500) SetCoe.countable {α} [Countable α] (s : Set α) : Countable s :=
  Subtype.countable
#align set_coe.countable SetCoe.countable

instance [Countable α] [Countable β] : Countable (PSum α β) :=
  Countable.of_equiv (Sum (PLift α) (PLift β)) (Equiv.plift.sumPSum Equiv.plift)

instance [Countable α] [Countable β] : Countable (PProd α β) :=
  Countable.of_equiv (PLift α × PLift β) (Equiv.plift.prodPProd Equiv.plift)

instance [Countable α] [∀ a, Countable (π a)] : Countable (PSigma π) :=
  Countable.of_equiv (Σa : PLift α, PLift (π a.down)) (Equiv.psigmaEquivSigmaPLift π).symm

instance [Finite α] [∀ a, Countable (π a)] : Countable (∀ a, π a) := by
  have : ∀ n, Countable (Fin n → ℕ) := by
    intro n
    induction' n with n ihn
    · change Countable (Fin 0 → ℕ); infer_instance
    · haveI := ihn
      exact Countable.of_equiv (ℕ × (Fin n → ℕ)) (Equiv.piFinSucc _ _).symm
  rcases Finite.exists_equiv_fin α with ⟨n, ⟨e⟩⟩
  have f := fun a => (nonempty_embedding_nat (π a)).some
  exact ((Embedding.piCongrRight f).trans (Equiv.piCongrLeft' _ e).toEmbedding).countable

end sort


-- #2

variables (α : Type*) (p q : α → Prop)
variable r : Prop

example : α → ((∀ x : α, r) ↔ r) :=
assume a: α, show (∀ x : α, r) ↔ r, from
iff.intro
(assume h: ∀ x : α, r, show r, from h a)
(assume hr: r, show ∀ x : α, r, from
  assume w: α, hr
)

open classical

example : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r :=
iff.intro
(assume h: ∀ x, p x ∨ r, show (∀ x, p x) ∨ r, from
  or.elim (em r)
  (assume hr: r, show (∀ x, p x) ∨ r, from or.inr hr)
  (assume hnr: ¬r,
    have hap: ∀ x, p x :=
    (assume a: α,
      have hpar: p a ∨ r := h a,
      show p a,
      from or.elim hpar
      (assume hpa: p a, hpa)
      (assume hr: r, absurd hr hnr)
    ),
    show (∀ x, p x) ∨ r,
    from or.inl hap
  )
)
(assume h: (∀ x, p x) ∨ r, show ∀ x, p x ∨ r, from
  or.elim h
  (assume hap: ∀ x, p x, show ∀ x, p x ∨ r, from
    assume a: α, show p a ∨ r, from or.inl (hap a)
  )
  (assume hr: r, show ∀ x, p x ∨ r, from
    assume a: α, show p a ∨ r, from or.inr hr
  )
)

example : (∀ x, r → p x) ↔ (r → ∀ x, p x) :=
iff.intro
(assume h: ∀ x, r → p x, show r → ∀ x, p x, from
  (assume hr: r, show ∀ x, p x, from
    assume a: α,
    have hrpa: r → p a := h a,
    show p a,
    from hrpa hr
  )
)
(assume h: r → ∀ x, p x, show ∀ x, r → p x, from
  assume a: α, show r → p a, from
  assume hr: r, show p a, from h hr a
)


import data.mv_polynomial.basic
import data.mv_polynomial.comm_ring
import data.zmod.basic
import ring_theory.ideal.operations

open mv_polynomial
open_locale big_operators
noncomputable theory

section
-- trying to work with a 2xn matrix.

parameter n : ℕ
abbreviation R := mv_polynomial (zmod (2*n)) (zmod 101)
-- abbreviation R := mv_polynomial (fin n ⊕ fin n) (zmod 101)
#check R

def f : (zmod (2*n)) → R := λ i, (X i)*(X (i+n))
-- def f : fin n ⊕ fin n → R := λ i, (X i)*(X (sum.swap i))

#check f
#check f 0

def g1 := ∏ r (X 0)*(X 1)*(X 2)

end

section
-- column sum of a 4x4 matrix of variables
def S1 := mv_polynomial (zmod 4 × zmod 4) (zmod 101)
def h1 : zmod 4 → S1 := λ i, ∑ j in (zmod 4), X (i, j)
-- unexpected token
#check S1

#check h1
-- unknown identifier "h"
end

section
-- column sum of an nxn matrix of variables  using zmod

parameter n : ℕ

abbreviation S := mv_polynomial (zmod n × zmod n) (zmod 101)
#check S
-- OK.

def h : zmod n →  zmod n → S := λ i, λ j, X (i,j)
#check h
-- OK
#check h 3
-- zmod n → S. OK.

-- specific column
def h3 := h 3
#check h3

-- arbitrary column
parameter i : zmod n
def hi := h i
#check hi

def g3 := ∑ j in zmod n, h3
def gi : zmod n → S := ∑ j in zmod n, hi

#check gi
#check g3

def s := finset (zmod n)
#check s
#check finset.sum
#check finset.sum s
#check finset.sum s g3

#check s
def g : S := ∑ j in s, g3
#check zmod
#check zmod 4
#check zmod n

--λ i, ∑ j in zmod n, (h i)

--∑ j in zmod n, X (i,j)
-- unexpected token at ∑
#check h
-- unknown identifier "h"

end

section
-- column sum of an nxn matrix of variables  using fin

parameter n : ℕ

abbreviation S2 := mv_polynomial (fin n × fin n) (zmod 101)
#check S
-- OK.

def h : fin n → S2 := λ i, ∑  j in fin n X (i,j)
-- unexpected token at ∑
#check h
-- unknown identifier "h"

end

section
-- trial-and-error type checking

variables n : nat
variables a : fin n
#check fin
#check fin n
#check fin n ⊕ fin n

end

section
-- from p. 99 of Theorem proving in Lean.

def sum_example (s : nat ⊕ nat) : nat :=
  sum.cases_on s (λ n, 2 * n) (λ n, 2 * n + 1)
#reduce ((sum.inl 3), (sum.inr 4))
#reduce sum_example (sum.inl 3)
#reduce sum_example (sum.inr 3)

#check nat × nat
end


/-
Copyright (c) 2022 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import ideles_number_field
import number_theory.zsqrtd.gaussian_int

/-!
# Examples
We instantiate some concrete examples of the definitions formalized in this project:
- We compute the `2`-adic valuation of some elements of `ℤ` and `ℚ`.
- We define the finite adèle ring and finite idèle group of the Dedekind domains `ℤ` and `ℤ[i]`.
- We define the (finite) adèle ring and (finite) idèle group of the number field `ℚ`.
-/

noncomputable theory

/-- The ideal generated by `2`, as a maximal ideal of `ℤ`. -/
def v2 : maximal_spectrum ℤ :=
{ as_ideal := ideal.span{(2 : ℤ)},
  is_prime := (ideal.span_singleton_prime (@two_ne_zero ℤ _ _)).mpr int.prime_two,
  ne_bot   := by {simp only [ne.def, ideal.span_singleton_eq_bot, two_ne_zero, not_false_iff] }}

/-- The `2`-adic valuation on `ℤ`. -/
def v2_int_adic_valuation : valuation ℤ (with_zero (multiplicative ℤ)) := v2.int_valuation

open_locale classical

example : v2_int_adic_valuation (4 : ℤ) = multiplicative.of_add (-2 : ℤ) :=
begin
  have hv2 : v2.as_ideal = ideal.span{(2 : ℤ)} := rfl,
  have h_irr : irreducible (associates.mk v2.as_ideal) := v2.associates_irreducible,
  have h_ne_0 : associates.mk (ideal.span {(2 : ℤ)} : ideal ℤ) ≠ 0,
  { exact associates.mk_ne_zero.mpr v2.ne_bot},
  have : (4 : ℤ) = 2^2 := rfl,
  simp only [v2_int_adic_valuation, v2.int_valuation_apply, v2.int_valuation_def_if_neg
    four_ne_zero, ideal.zero_eq_bot, ne.def, ideal.span_singleton_eq_bot,
    bit0_eq_zero, one_ne_zero, not_false_iff, of_add_neg, inv_inj, with_zero.coe_inj,
    embedding_like.apply_eq_iff_eq],
  rw [this, ← ideal.span_singleton_pow],
  norm_cast,
  rw [associates.mk_pow, associates.count_pow h_ne_0 h_irr],
  conv_rhs{rw ← mul_one 2},
  rw hv2 at h_irr ⊢,
  rw associates.count_self h_irr,
end

/-- The `2`-adic valuation on `ℚ`. -/
def v2_adic_valuation : valuation ℚ (with_zero (multiplicative ℤ )) := v2.valuation

example : v2_adic_valuation (3/2 : ℚ) = multiplicative.of_add (1 : ℤ) :=
begin
  have hv2 : v2.as_ideal = ideal.span{(2 : ℤ)} := rfl,
  have h_irr : irreducible (associates.mk v2.as_ideal) := v2.associates_irreducible,
  have h_ne_0 : associates.mk (ideal.span {(2 : ℤ)} : ideal ℤ) ≠ 0,
  { exact associates.mk_ne_zero.mpr v2.ne_bot},
  have h2 : (2 : ℤ) ∈ non_zero_divisors ℤ := mem_non_zero_divisors_iff_ne_zero.mpr two_ne_zero,
  have : (3/2 : ℚ) = is_localization.mk' ℚ (3 : ℤ) (⟨2, h2⟩ : non_zero_divisors ℤ),
  { rw [is_fraction_ring.mk'_eq_div, set_like.coe_mk, ring_hom.eq_int_cast, ring_hom.eq_int_cast,
      int.cast_two, int.cast_bit1, int.cast_one] },
  have h_irr3 : irreducible (associates.mk (ideal.span {(3 : ℤ)} : ideal ℤ)),
  { rw [associates.irreducible_mk _, unique_factorization_monoid.irreducible_iff_prime,
      ideal.prime_iff_is_prime],
    exact (ideal.span_singleton_prime (@three_ne_zero ℤ _ _)).mpr int.prime_three,
    simp only [ne.def, ideal.span_singleton_eq_bot, three_ne_zero, not_false_iff] ,},
  have h_ne : associates.mk (ideal.span {(2 : ℤ)} : ideal ℤ) ≠
    associates.mk (ideal.span {(3 : ℤ)} : ideal ℤ),
  { rw [ne.def, associates.mk_eq_mk_iff_associated,  associated_iff_eq,
      ideal.span_singleton_eq_span_singleton, int.associated_iff],
    apply not_or; linarith,},
  simp only [v2_adic_valuation, v2.valuation_apply, this, maximal_spectrum.valuation_of_mk',
    set_like.coe_mk, v2.int_valuation_def_if_neg two_ne_zero,
    v2.int_valuation_def_if_neg three_ne_zero],
  norm_cast,
  rw hv2 at h_irr ⊢,
  simp only [associates.count_self h_irr, of_add_neg, int.coe_nat_succ, int.coe_nat_zero, zero_add,
    inv_div_inv, div_eq_self, of_add_eq_one, int.coe_nat_eq_zero],
  apply associates.count_eq_zero_of_ne h_irr h_irr3 h_ne,
end

/-- The finite adèle ring of `ℤ`.-/
def finite_adeles_Z := finite_adele_ring' ℤ ℚ
instance : inhabited (finite_adeles_Z) := ⟨inj_K ℤ ℚ 0⟩

/-- The finite idèle group of `ℤ`.-/
def finite_ideles_Z := finite_idele_group' ℤ ℚ
instance : inhabited (finite_ideles_Z) := ⟨inj_units_K ℤ ℚ 1⟩

/-- The finite adèle ring of `ℚ`.-/
def finite_adeles_Q := number_field.A_K_f ℚ
instance : inhabited (finite_adeles_Q) := ⟨number_field.inj_K_f ℚ 0⟩

/-- The adèle ring of `ℚ`.-/
def adeles_Q := number_field.A_K ℚ
instance : inhabited (adeles_Q) := ⟨number_field.inj_K ℚ 0⟩

/-- The finite idèle group of `ℚ`.-/
def finite_ideles_Q := number_field.I_K_f ℚ
instance : inhabited (finite_ideles_Q) := ⟨number_field.inj_units_K_f ℚ 1⟩

/-- The idèle group of `ℚ`.-/
def ideles_Q := number_field.I_K ℚ
instance : inhabited (ideles_Q) := ⟨number_field.inj_units_K ℚ 1⟩

/-- The finite adèle ring of `ℤ[i]`.-/
def finite_adeles_Zi := finite_adele_ring' gaussian_int (fraction_ring gaussian_int)
instance : inhabited (finite_adeles_Zi) := ⟨inj_K gaussian_int (fraction_ring gaussian_int) 0⟩

/-- The finite idèle group of `ℤ[i]`.-/
def finite_ideles_Zi := finite_idele_group' gaussian_int (fraction_ring gaussian_int)
instance : inhabited (finite_ideles_Zi) := ⟨inj_units_K gaussian_int (fraction_ring gaussian_int) 1⟩


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

! This file was ported from Lean 3 source module analysis.convex.stone_separation
! leanprover-community/mathlib commit 6ca1a09bc9aa75824bf97388c9e3b441fc4ccf3f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Convex.Join

/-!
# Stone's separation theorem

This file prove Stone's separation theorem. This tells us that any two disjoint convex sets can be
separated by a convex set whose complement is also convex.

In locally convex real topological vector spaces, the Hahn-Banach separation theorems provide
stronger statements: one may find a separating hyperplane, instead of merely a convex set whose
complement is convex.
-/

open Set

open BigOperators

variable {𝕜 E ι : Type _} [LinearOrderedField 𝕜] [AddCommGroup E] [Module 𝕜 E] {s t : Set E}

/-- In a tetrahedron with vertices `x`, `y`, `p`, `q`, any segment `[u, v]` joining the opposite
edges `[x, p]` and `[y, q]` passes through any triangle of vertices `p`, `q`, `z` where
`z ∈ [x, y]`. -/
theorem not_disjoint_segment_convexHull_triple {p q u v x y z : E} (hz : z ∈ segment 𝕜 x y)
    (hu : u ∈ segment 𝕜 x p) (hv : v ∈ segment 𝕜 y q) :
    ¬Disjoint (segment 𝕜 u v) (convexHull 𝕜 {p, q, z}) :=
  by
  rw [not_disjoint_iff]
  obtain ⟨az, bz, haz, hbz, habz, rfl⟩ := hz
  obtain rfl | haz' := haz.eq_or_lt
  · rw [zero_add] at habz
    rw [zero_smul, zero_add, habz, one_smul]
    refine' ⟨v, right_mem_segment _ _ _, segment_subset_convexHull _ _ hv⟩ <;> simp
  obtain ⟨av, bv, hav, hbv, habv, rfl⟩ := hv
  obtain rfl | hav' := hav.eq_or_lt
  · rw [zero_add] at habv
    rw [zero_smul, zero_add, habv, one_smul]
    exact ⟨q, right_mem_segment _ _ _, subset_convexHull _ _ <| by simp⟩
  obtain ⟨au, bu, hau, hbu, habu, rfl⟩ := hu
  have hab : 0 < az * av + bz * au :=
    add_pos_of_pos_of_nonneg (mul_pos haz' hav') (mul_nonneg hbz hau)
  refine'
    ⟨(az * av / (az * av + bz * au)) • (au • x + bu • p) +
        (bz * au / (az * av + bz * au)) • (av • y + bv • q),
      ⟨_, _, _, _, _, rfl⟩, _⟩
  · exact div_nonneg (mul_nonneg haz hav) hab.le
  · exact div_nonneg (mul_nonneg hbz hau) hab.le
  · rw [← add_div, div_self hab.ne']
  rw [smul_add, smul_add, add_add_add_comm, add_comm, ← mul_smul, ← mul_smul]
  classical
    let w : Fin 3 → 𝕜 := ![az * av * bu, bz * au * bv, au * av]
    let z : Fin 3 → E := ![p, q, az • x + bz • y]
    have hw₀ : ∀ i, 0 ≤ w i := by
      rintro i
      fin_cases i
      · exact mul_nonneg (mul_nonneg haz hav) hbu
      · exact mul_nonneg (mul_nonneg hbz hau) hbv
      · exact mul_nonneg hau hav
    have hw : (∑ i, w i) = az * av + bz * au :=
      by
      trans az * av * bu + (bz * au * bv + au * av)
      · simp [w, Fin.sum_univ_succ, Fin.sum_univ_zero]
      rw [← one_mul (au * av), ← habz, add_mul, ← add_assoc, add_add_add_comm, mul_assoc, ← mul_add,
        mul_assoc, ← mul_add, mul_comm av, ← add_mul, ← mul_add, add_comm bu, add_comm bv, habu,
        habv, one_mul, mul_one]
    have hz : ∀ i, z i ∈ ({p, q, az • x + bz • y} : Set E) :=
      by
      rintro i
      fin_cases i <;> simp [z]
    convert Finset.centerMass_mem_convexHull (Finset.univ : Finset (Fin 3)) (fun i _ => hw₀ i)
        (by rwa [hw]) fun i _ => hz i
    rw [Finset.centerMass]
    simp_rw [div_eq_inv_mul, hw, mul_assoc, mul_smul (az * av + bz * au)⁻¹, ← smul_add, add_assoc, ←
      mul_assoc]
    congr 3
    rw [← mul_smul, ← mul_rotate, mul_right_comm, mul_smul, ← mul_smul _ av, mul_rotate,
      mul_smul _ bz, ← smul_add]
    simp only [List.map, List.pmap, Nat.add_def, add_zero, Fin.mk_bit0, Fin.mk_one, List.foldr_cons,
      List.foldr_nil]
    rfl
#align not_disjoint_segment_convex_hull_triple not_disjoint_segment_convexHull_triple

/-- **Stone's Separation Theorem** -/
theorem exists_convex_convex_compl_subset (hs : Convex 𝕜 s) (ht : Convex 𝕜 t) (hst : Disjoint s t) :
    ∃ C : Set E, Convex 𝕜 C ∧ Convex 𝕜 (Cᶜ) ∧ s ⊆ C ∧ t ⊆ Cᶜ :=
  by
  let S : Set (Set E) := { C | Convex 𝕜 C ∧ Disjoint C t }
  obtain ⟨C, hC, hsC, hCmax⟩ :=
    zorn_subset_nonempty S
      (fun c hcS hc ⟨t, ht⟩ =>
        ⟨⋃₀ c,
          ⟨hc.directed_on.convex_sUnion fun s hs => (hcS hs).1,
            disjoint_sUnion_left.2 fun c hc => (hcS hc).2⟩,
          fun s => subset_sUnion_of_mem⟩)
      s ⟨hs, hst⟩
  refine'
    ⟨C, hC.1, convex_iff_segment_subset.2 fun x hx y hy z hz hzC => _, hsC, hC.2.subset_compl_left⟩
  suffices h : ∀ c ∈ Cᶜ, ∃ a ∈ C, (segment 𝕜 c a ∩ t).Nonempty
  · obtain ⟨p, hp, u, hu, hut⟩ := h x hx
    obtain ⟨q, hq, v, hv, hvt⟩ := h y hy
    refine'
      not_disjoint_segment_convexHull_triple hz hu hv
        (hC.2.symm.mono (ht.segment_subset hut hvt) <| convexHull_min _ hC.1)
    simp [insert_subset, hp, hq, singleton_subset_iff.2 hzC]
  rintro c hc
  by_contra' h
  suffices h : Disjoint (convexHull 𝕜 (insert c C)) t
  · rw [←
      hCmax _ ⟨convex_convexHull _ _, h⟩ ((subset_insert _ _).trans <| subset_convexHull _ _)] at hc
    exact hc (subset_convexHull _ _ <| mem_insert _ _)
  rw [convexHull_insert ⟨z, hzC⟩, convexJoin_singleton_left]
  refine' disjoint_Union₂_left.2 fun a ha => disjoint_iff_inf_le.mpr fun b hb => h a _ ⟨b, hb⟩
  rwa [← hC.1.convexHull_eq]
#align exists_convex_convex_compl_subset exists_convex_convex_compl_subset


section
  variable (α : Type) (p q : α → Prop)

  example : (∀ x, p x ∧ q x) ↔ (∀ x, p x) ∧ (∀ x, q x) :=
    Iff.intro
    (
      fun h : ∀ x, p x ∧ q x =>
        have hl := fun x => (h x).left
        have hr := fun x => (h x).right
        And.intro hl hr
    )
    (
      fun h : (∀ x, p x) ∧ (∀ x, q x) =>
        fun x =>
          have hpx := h.left x
          have hqx := h.right x
          And.intro hpx hqx
    )

  example : (∀ x, p x → q x) → (∀ x, p x) → (∀ x, q x) :=
    fun hpq : ∀ x, p x → q x =>
      fun hp : ∀ x, p x =>
        fun x =>
          have hpx := hp x
          have hpxqx := hpq x
          hpxqx hpx

  example : (∀ x, p x) ∨ (∀ x, q x) → ∀ x, p x ∨ q x :=
    fun h : (∀ x, p x) ∨ (∀ x, q x) =>
      Or.elim h
      (
        fun hp =>
          fun x => Or.inl <| hp x
      )
      (
        fun hq =>
          fun x => Or.inr <| hq x
      )

end

section
  open Classical

  variable (α : Type) (p q : α → Prop)
  variable (r : Prop)

  example : α → ((∀ _ : α, r) ↔ r) :=
    fun a : α =>
      Iff.intro
      (
        fun h : ∀ _ : α, r =>
          h a
      )
      (
        fun hr : r =>
          fun _ : α => hr
      )

  example : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r :=
    Iff.intro
    (
      fun h =>
        Or.elim (em r)
        (
          fun hr =>
            Or.inr hr
        )
        (
          fun hnr =>
            have hp :=
              fun x =>
                have pxr := h x
                Or.elim pxr
                (
                  fun hpx =>
                    hpx
                )
                (
                  fun hr =>
                    absurd hr hnr
                )
            Or.inl hp
        )

    )
    (
      fun h =>
        Or.elim h
        (
          fun hp =>
            fun x =>
              Or.inl <| hp x
        )
        (
          fun hr =>
            fun _ =>
              Or.inr <| hr
        )
    )

  example : (∀ x, r → p x) ↔ (r → ∀ x, p x) :=
    Iff.intro
    (
      fun h : ∀ x, r → p x =>
        fun hr : r =>
          fun x =>
            h x hr
    )
    (
      fun h : r → ∀ x, p x =>
        fun x =>
          fun r =>
            h r x
    )

end

section
  variable (men : Type) (barber : men)
  variable (shaves : men → men → Prop)

  example (h : ∀ x : men, shaves barber x ↔ ¬ shaves x x) : False :=
    have hbarber := h barber
    have hnsbb :=
      fun hsbb => hbarber.mp hsbb hsbb
    have hsbb := hbarber.mpr hnsbb
    hnsbb hsbb
end

section
  def even (n : Nat) : Prop :=
    ∃ k : Nat, n = 2 * k

  def prime (n : Nat) : Prop :=
    let divides (x y : Nat) : Prop :=
      ∃ k : Nat, k * x = y
    ∀ m : Nat, divides m n → m = 1 ∨ m = n

  def infinitely_many_primes : Prop :=
    ∀ n : Nat, (∃ p : Nat, prime p ∧ p > n)

  def Fermat_prime (n : Nat) : Prop :=
    ∃ k : Nat, prime n ∧ n = 2 ^ k + 1

  def infinitely_many_Fermat_primes : Prop :=
    ∀ n : Nat, (∃ p : Nat, Fermat_prime p ∧ p > n)

  def goldbach_conjecture : Prop :=
    ∀ n : Nat,
      (∃ p q : Nat,
        prime p ∧ prime q ∧
        (even n ∧ n > 2 → n = p + q))

  def Goldbach's_weak_conjecture : Prop :=
    ∀ n : Nat,
      (∃ p q r : Nat, prime p ∧ prime q ∧ prime r ∧
      (¬ even n ∧ n > 5 → n = p + q + r))

  def Fermat's_last_theorem : Prop :=
    ∀ n a b c : Nat, n > 2 → a ^ n + b ^ n ≠ c ^ n

end

section
  open Classical

  variable (α : Type) (p q : α → Prop)
  variable (r : Prop)

  example : (∃ _ : α, r) → r :=
    fun h =>
      match h with
      | ⟨_, hr⟩ => hr

  example (a : α) : r → (∃ _ : α, r) :=
    fun hr => ⟨a, hr⟩

  example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r :=
    Iff.intro
    (
      fun h =>
        match h with
        | ⟨w, hpxr⟩ => ⟨⟨w, hpxr.left⟩, hpxr.right⟩
    )
    (
      fun h =>
        match h.left with
        | ⟨w, hpx⟩ => ⟨w, ⟨hpx, h.right⟩⟩
    )

  example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) :=
    Iff.intro
    (
      fun h =>
        match h with
        | ⟨w, hpwqw⟩ =>
            Or.elim hpwqw
            (
              fun hpw =>
                Or.inl ⟨w, hpw⟩
            )
            (
              fun hqw =>
                Or.inr ⟨w, hqw⟩
            )
    )
    (
      fun h =>
        Or.elim h
        (
          fun hp : ∃ x, p x =>
            match hp with
            | ⟨w, hpw⟩ => ⟨w, Or.inl hpw⟩
        )
        (
          fun hq : ∃ x, q x =>
            match hq with
            | ⟨w, hqw⟩ => ⟨w, Or.inr hqw⟩
        )

    )

  example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) :=
    Iff.intro
    (
      fun h : ∀ x, p x =>
        fun hnp : ∃ x, ¬ p x =>
          match hnp with
          | ⟨w, hnpw⟩ =>
              let hpw := h w
              absurd hpw hnpw
    )
    (
      fun h : ¬ (∃ x, ¬ p x) =>
        fun x =>
          Or.elim (em $ p x)
          (
            fun hpx : p x =>
              hpx
          )
          (
            fun hnpx : ¬ p x =>
              have hnp := ⟨x, hnpx⟩
              absurd hnp h
          )
    )

  example : (∃ x, p x) ↔ ¬ (∀ x, ¬ p x) :=
    Iff.intro
    (
      fun hExpx =>
        fun hAxnpx =>
          match hExpx with
          | ⟨w, pw⟩ => hAxnpx w pw

    )
    (
      fun hnAxnpx =>
        byContradiction
        (
          fun hnExpx =>
            have hAxnpx :=
              fun x =>
                fun hpx =>
                  have hExpx := ⟨x, hpx⟩
                  absurd hExpx hnExpx
            absurd hAxnpx hnAxnpx
        )

    )

  example :¬ (∃ x, p x) ↔ (∀ x, ¬ p x) :=
    Iff.intro
    (
      fun hnExpx : ¬ (∃ x, p x) =>
        fun x =>
          Or.elim (em $ p x)
          (
            fun hpx =>
              have hExpx := ⟨x, hpx⟩
              absurd hExpx hnExpx
          )
          (
            fun hnpx =>
              hnpx
          )
    )
    (
      fun hAxnpx =>
        fun hExpx =>
          match hExpx with
          | ⟨w, hpw⟩ =>
              hAxnpx w hpw
    )

  example : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) :=
    Iff.intro
    (
      fun hnAxpx : ¬(∀ x, p x) =>
        Or.elim (em $ ∃ x, ¬ p x)
        (
          fun hExnpx : ∃ x, ¬ p x =>
            hExnpx
        )
        (
          fun hnExnpx : ¬ ∃ x, ¬ p x =>
            have hAxpx : ∀ x, p x :=
              fun x =>
                show p x from
                  Or.elim (em $ p x)
                  (
                    fun hpx : p x => hpx
                  )
                  (
                    fun hnpx : ¬ p x =>
                      have hExnpx :∃ x, ¬ p x := ⟨x, hnpx⟩
                      absurd hExnpx hnExnpx
                  )
            absurd hAxpx hnAxpx
        )
      /-
      fun hnAxpx =>
        byContradiction
          fun hnExnpx =>
            have hAxpx :=
              fun x =>
                byContradiction
                  fun hnpx =>
                    have hExnpx := ⟨x, hnpx⟩
                    absurd hExnpx hnExnpx
            absurd hAxpx hnAxpx
      -/
    )
    (
      fun Exnpx =>
        match Exnpx with

        | ⟨w, hnpw⟩ =>
            fun hAxpx =>
              hnpw <| hAxpx w
    )

  example : (∀ x, p x → r) ↔ (∃ x, p x) → r :=
    Iff.intro
    (
      fun hAxpxr =>
        fun hExpx =>
          match hExpx with
          | ⟨w, hpw⟩ =>
            have hpwr := hAxpxr w
            have hr := hpwr hpw
            hr
    )
    (
      fun hExpxr : (∃ x, p x) → r =>
        show ∀ x, p x → r from
          fun x =>
            show p x → r from
              fun hpx : p x =>
                show r from
                  have hExpx : ∃ x, p x := ⟨x, hpx⟩
                  have hr := hExpxr hExpx
                  hr
    )

  example (a : α) : (∃ x, p x → r) ↔ (∀ x, p x) → r :=
    Iff.intro
    (
      fun hExpxr =>
        fun hApx =>
          match hExpxr with
          | ⟨w, hpwr⟩ =>
            have hpw := hApx w
            hpwr hpw
    )
    (
      fun hAxpxr : (∀ x, p x) → r =>
        show ∃ x, p x → r from
          byContradiction
            fun hnExpxr : ¬ ∃ x, p x → r =>
              have hAxnpxr : ∀ x, ¬ (p x → r) :=
                fun x =>
                  Or.elim (em $ p x → r)
                  (
                    fun pxr =>
                      have hExnpxr : ∃ x, p x → r := ⟨x, pxr⟩
                      absurd hExnpxr hnExpxr
                  )
                  (
                    fun hnpxr => hnpxr
                  )
              have hnAxpxr : ¬ ((∀ x, p x) → r) := sorry
              absurd hAxpxr hnAxpxr
    )

  example (a : α) : (∃ x, r → p x) ↔ (r → ∃ x, p x) :=
    Iff.intro
    (
      fun hExrpx =>
        match hExrpx with
        | ⟨w, hrpw⟩ =>
          fun hr =>
            have hpw := hrpw hr
            ⟨w, hpw⟩
    )
    (
      fun hrExpx : r → ∃ x, p x =>
        show ∃ x, r → p x from
          sorry
    )

end


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.big_operators.basic
import data.set.pointwise.basic

/-!
# Results about pointwise operations on sets and big operators.

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

namespace set

section big_operators
open_locale big_operators pointwise
open function

variables {α : Type*} {ι : Type*} [comm_monoid α]

/-- The n-ary version of `set.mem_mul`. -/
@[to_additive /-" The n-ary version of `set.mem_add`. "-/]
lemma mem_finset_prod (t : finset ι) (f : ι → set α) (a : α) :
  a ∈ ∏ i in t, f i ↔ ∃ (g : ι → α) (hg : ∀ {i}, i ∈ t → g i ∈ f i), ∏ i in t, g i = a :=
begin
  classical,
  induction t using finset.induction_on with i is hi ih generalizing a,
  { simp_rw [finset.prod_empty, set.mem_one],
    exact ⟨λ h, ⟨λ i, a, λ i, false.elim, h.symm⟩, λ ⟨f, _, hf⟩, hf.symm⟩ },
  rw [finset.prod_insert hi, set.mem_mul],
  simp_rw [finset.prod_insert hi],
  simp_rw ih,
  split,
  { rintro ⟨x, y, hx, ⟨g, hg, rfl⟩, rfl⟩,
    refine ⟨function.update g i x, λ j hj, _, _⟩,
    obtain rfl | hj := finset.mem_insert.mp hj,
    { rw function.update_same, exact hx },
    { rw update_noteq (ne_of_mem_of_not_mem hj hi), exact hg hj, },
    rw [finset.prod_update_of_not_mem hi, function.update_same], },
  { rintro ⟨g, hg, rfl⟩,
    exact ⟨g i, is.prod g, hg (is.mem_insert_self _),
      ⟨g, λ i hi, hg (finset.mem_insert_of_mem hi), rfl⟩, rfl⟩ },
end

/-- A version of `set.mem_finset_prod` with a simpler RHS for products over a fintype. -/
@[to_additive /-" A version of `set.mem_finset_sum` with a simpler RHS for sums over a fintype. "-/]
lemma mem_fintype_prod [fintype ι] (f : ι → set α) (a : α) :
  a ∈ ∏ i, f i ↔ ∃ (g : ι → α) (hg : ∀ i, g i ∈ f i), ∏ i, g i = a :=
by { rw mem_finset_prod, simp }

/-- An n-ary version of `set.mul_mem_mul`. -/
@[to_additive /-" An n-ary version of `set.add_mem_add`. "-/]
lemma list_prod_mem_list_prod (t : list ι) (f : ι → set α)
  (g : ι → α) (hg : ∀ i ∈ t, g i ∈ f i) :
  (t.map g).prod ∈ (t.map f).prod :=
begin
  induction t with h tl ih,
  { simp_rw [list.map_nil, list.prod_nil, set.mem_one] },
  { simp_rw [list.map_cons, list.prod_cons],
    exact mul_mem_mul
      (hg h $ list.mem_cons_self _ _) (ih $ λ i hi, hg i $ list.mem_cons_of_mem _ hi) }
end

/-- An n-ary version of `set.mul_subset_mul`. -/
@[to_additive /-" An n-ary version of `set.add_subset_add`. "-/]
lemma list_prod_subset_list_prod (t : list ι) (f₁ f₂ : ι → set α) (hf : ∀ i ∈ t, f₁ i ⊆ f₂ i) :
  (t.map f₁).prod ⊆ (t.map f₂).prod :=
begin
  induction t with h tl ih,
  { refl, },
  { simp_rw [list.map_cons, list.prod_cons],
    exact mul_subset_mul
      (hf h $ list.mem_cons_self _ _) (ih $ λ i hi, hf i $ list.mem_cons_of_mem _ hi) }
end

@[to_additive]
lemma list_prod_singleton {M : Type*} [comm_monoid M] (s : list M) :
  (s.map $ λ i, ({i} : set M)).prod = {s.prod} :=
(map_list_prod (singleton_monoid_hom : M →* set M) _).symm

/-- An n-ary version of `set.mul_mem_mul`. -/
@[to_additive /-" An n-ary version of `set.add_mem_add`. "-/]
lemma multiset_prod_mem_multiset_prod (t : multiset ι) (f : ι → set α)
  (g : ι → α) (hg : ∀ i ∈ t, g i ∈ f i) :
  (t.map g).prod ∈ (t.map f).prod :=
begin
  induction t using quotient.induction_on,
  simp_rw [multiset.quot_mk_to_coe, multiset.coe_map, multiset.coe_prod],
  exact list_prod_mem_list_prod _ _ _ hg,
end

/-- An n-ary version of `set.mul_subset_mul`. -/
@[to_additive /-" An n-ary version of `set.add_subset_add`. "-/]
lemma multiset_prod_subset_multiset_prod (t : multiset ι) (f₁ f₂ : ι → set α)
  (hf : ∀ i ∈ t, f₁ i ⊆ f₂ i) :
  (t.map f₁).prod ⊆ (t.map f₂).prod :=
begin
  induction t using quotient.induction_on,
  simp_rw [multiset.quot_mk_to_coe, multiset.coe_map, multiset.coe_prod],
  exact list_prod_subset_list_prod _ _ _ hf,
end

@[to_additive]
lemma multiset_prod_singleton {M : Type*} [comm_monoid M] (s : multiset M) :
  (s.map $ λ i, ({i} : set M)).prod = {s.prod} :=
(map_multiset_prod (singleton_monoid_hom : M →* set M) _).symm

/-- An n-ary version of `set.mul_mem_mul`. -/
@[to_additive /-" An n-ary version of `set.add_mem_add`. "-/]
lemma finset_prod_mem_finset_prod (t : finset ι) (f : ι → set α)
  (g : ι → α) (hg : ∀ i ∈ t, g i ∈ f i) :
  ∏ i in t, g i ∈ ∏ i in t, f i :=
multiset_prod_mem_multiset_prod _ _ _ hg

/-- An n-ary version of `set.mul_subset_mul`. -/
@[to_additive /-" An n-ary version of `set.add_subset_add`. "-/]
lemma finset_prod_subset_finset_prod (t : finset ι) (f₁ f₂ : ι → set α)
  (hf : ∀ i ∈ t, f₁ i ⊆ f₂ i) :
  ∏ i in t, f₁ i ⊆ ∏ i in t, f₂ i :=
multiset_prod_subset_multiset_prod _ _ _ hf

@[to_additive]
lemma finset_prod_singleton {M ι : Type*} [comm_monoid M] (s : finset ι) (I : ι → M) :
  ∏ (i : ι) in s, ({I i} : set M) = {∏ (i : ι) in s, I i} :=
(map_prod (singleton_monoid_hom : M →* set M) _ _).symm

/-! TODO: define `decidable_mem_finset_prod` and `decidable_mem_finset_sum`. -/

end big_operators

end set


/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel

! This file was ported from Lean 3 source module logic.nontrivial
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Prod.Basic
import Mathbin.Data.Subtype
import Mathbin.Logic.Function.Basic
import Mathbin.Logic.Unique

/-!
# Nontrivial types

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

A type is *nontrivial* if it contains at least two elements. This is useful in particular for rings
(where it is equivalent to the fact that zero is different from one) and for vector spaces
(where it is equivalent to the fact that the dimension is positive).

We introduce a typeclass `nontrivial` formalizing this property.
-/

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

open Classical

#print Nontrivial /-
/-- Predicate typeclass for expressing that a type is not reduced to a single element. In rings,
this is equivalent to `0 ≠ 1`. In vector spaces, this is equivalent to positive dimension. -/
class Nontrivial (α : Type _) : Prop where
  exists_pair_ne : ∃ x y : α, x ≠ y
#align nontrivial Nontrivial
-/

#print nontrivial_iff /-
theorem nontrivial_iff : Nontrivial α ↔ ∃ x y : α, x ≠ y :=
  ⟨fun h => h.exists_pair_ne, fun h => ⟨h⟩⟩
#align nontrivial_iff nontrivial_iff
-/

#print exists_pair_ne /-
theorem exists_pair_ne (α : Type _) [Nontrivial α] : ∃ x y : α, x ≠ y :=
  Nontrivial.exists_pair_ne
#align exists_pair_ne exists_pair_ne
-/

#print Decidable.exists_ne /-
-- See Note [decidable namespace]
protected theorem Decidable.exists_ne [Nontrivial α] [DecidableEq α] (x : α) : ∃ y, y ≠ x :=
  by
  rcases exists_pair_ne α with ⟨y, y', h⟩
  by_cases hx : x = y
  · rw [← hx] at h
    exact ⟨y', h.symm⟩
  · exact ⟨y, Ne.symm hx⟩
#align decidable.exists_ne Decidable.exists_ne
-/

#print exists_ne /-
theorem exists_ne [Nontrivial α] (x : α) : ∃ y, y ≠ x := by classical exact Decidable.exists_ne x
#align exists_ne exists_ne
-/

#print nontrivial_of_ne /-
-- `x` and `y` are explicit here, as they are often needed to guide typechecking of `h`.
theorem nontrivial_of_ne (x y : α) (h : x ≠ y) : Nontrivial α :=
  ⟨⟨x, y, h⟩⟩
#align nontrivial_of_ne nontrivial_of_ne
-/

#print nontrivial_of_lt /-
-- `x` and `y` are explicit here, as they are often needed to guide typechecking of `h`.
theorem nontrivial_of_lt [Preorder α] (x y : α) (h : x < y) : Nontrivial α :=
  ⟨⟨x, y, ne_of_lt h⟩⟩
#align nontrivial_of_lt nontrivial_of_lt
-/

#print exists_pair_lt /-
theorem exists_pair_lt (α : Type _) [Nontrivial α] [LinearOrder α] : ∃ x y : α, x < y :=
  by
  rcases exists_pair_ne α with ⟨x, y, hxy⟩
  cases lt_or_gt_of_ne hxy <;> exact ⟨_, _, h⟩
#align exists_pair_lt exists_pair_lt
-/

#print nontrivial_iff_lt /-
theorem nontrivial_iff_lt [LinearOrder α] : Nontrivial α ↔ ∃ x y : α, x < y :=
  ⟨fun h => @exists_pair_lt α h _, fun ⟨x, y, h⟩ => nontrivial_of_lt x y h⟩
#align nontrivial_iff_lt nontrivial_iff_lt
-/

#print nontrivial_iff_exists_ne /-
theorem nontrivial_iff_exists_ne (x : α) : Nontrivial α ↔ ∃ y, y ≠ x :=
  ⟨fun h => @exists_ne α h x, fun ⟨y, hy⟩ => nontrivial_of_ne _ _ hy⟩
#align nontrivial_iff_exists_ne nontrivial_iff_exists_ne
-/

#print Subtype.nontrivial_iff_exists_ne /-
theorem Subtype.nontrivial_iff_exists_ne (p : α → Prop) (x : Subtype p) :
    Nontrivial (Subtype p) ↔ ∃ (y : α)(hy : p y), y ≠ x := by
  simp only [nontrivial_iff_exists_ne x, Subtype.exists, Ne.def, Subtype.ext_iff, Subtype.coe_mk]
#align subtype.nontrivial_iff_exists_ne Subtype.nontrivial_iff_exists_ne
-/

instance : Nontrivial Prop :=
  ⟨⟨True, False, true_ne_false⟩⟩

#print Nontrivial.to_nonempty /-
/-- See Note [lower instance priority]

Note that since this and `nonempty_of_inhabited` are the most "obvious" way to find a nonempty
instance if no direct instance can be found, we give this a higher priority than the usual `100`.
-/
instance (priority := 500) Nontrivial.to_nonempty [Nontrivial α] : Nonempty α :=
  let ⟨x, _⟩ := exists_pair_ne α
  ⟨x⟩
#align nontrivial.to_nonempty Nontrivial.to_nonempty
-/

attribute [instance] instNonempty

#print nontrivialPSumUnique /-
/-- An inhabited type is either nontrivial, or has a unique element. -/
noncomputable def nontrivialPSumUnique (α : Type _) [Inhabited α] :
    PSum (Nontrivial α) (Unique α) :=
  if h : Nontrivial α then PSum.inl h
  else
    PSum.inr
      { default := default
        uniq := fun x : α => by
          change x = default
          contrapose! h
          use x, default }
#align nontrivial_psum_unique nontrivialPSumUnique
-/

#print subsingleton_iff /-
theorem subsingleton_iff : Subsingleton α ↔ ∀ x y : α, x = y :=
  ⟨by
    intro h
    exact Subsingleton.elim, fun h => ⟨h⟩⟩
#align subsingleton_iff subsingleton_iff
-/

#print not_nontrivial_iff_subsingleton /-
theorem not_nontrivial_iff_subsingleton : ¬Nontrivial α ↔ Subsingleton α :=
  by
  rw [nontrivial_iff, subsingleton_iff]
  push_neg
  rfl
#align not_nontrivial_iff_subsingleton not_nontrivial_iff_subsingleton
-/

#print not_nontrivial /-
theorem not_nontrivial (α) [Subsingleton α] : ¬Nontrivial α := fun ⟨⟨x, y, h⟩⟩ =>
  h <| Subsingleton.elim x y
#align not_nontrivial not_nontrivial
-/

#print not_subsingleton /-
theorem not_subsingleton (α) [h : Nontrivial α] : ¬Subsingleton α :=
  let ⟨⟨x, y, hxy⟩⟩ := h
  fun ⟨h'⟩ => hxy <| h' x y
#align not_subsingleton not_subsingleton
-/

#print subsingleton_or_nontrivial /-
/-- A type is either a subsingleton or nontrivial. -/
theorem subsingleton_or_nontrivial (α : Type _) : Subsingleton α ∨ Nontrivial α :=
  by
  rw [← not_nontrivial_iff_subsingleton, or_comm']
  exact Classical.em _
#align subsingleton_or_nontrivial subsingleton_or_nontrivial
-/

#print false_of_nontrivial_of_subsingleton /-
theorem false_of_nontrivial_of_subsingleton (α : Type _) [Nontrivial α] [Subsingleton α] : False :=
  let ⟨x, y, h⟩ := exists_pair_ne α
  h <| Subsingleton.elim x y
#align false_of_nontrivial_of_subsingleton false_of_nontrivial_of_subsingleton
-/

#print Option.nontrivial /-
instance Option.nontrivial [Nonempty α] : Nontrivial (Option α) :=
  by
  inhabit α
  use none, some default
#align option.nontrivial Option.nontrivial
-/

/- warning: function.injective.nontrivial -> Function.Injective.nontrivial is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Nontrivial.{u1} α] {f : α -> β}, (Function.Injective.{succ u1, succ u2} α β f) -> (Nontrivial.{u2} β)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Nontrivial.{u2} α] {f : α -> β}, (Function.Injective.{succ u2, succ u1} α β f) -> (Nontrivial.{u1} β)
Case conversion may be inaccurate. Consider using '#align function.injective.nontrivial Function.Injective.nontrivialₓ'. -/
/-- Pushforward a `nontrivial` instance along an injective function. -/
protected theorem Function.Injective.nontrivial [Nontrivial α] {f : α → β}
    (hf : Function.Injective f) : Nontrivial β :=
  let ⟨x, y, h⟩ := exists_pair_ne α
  ⟨⟨f x, f y, hf.Ne h⟩⟩
#align function.injective.nontrivial Function.Injective.nontrivial

#print Function.Surjective.nontrivial /-
/-- Pullback a `nontrivial` instance along a surjective function. -/
protected theorem Function.Surjective.nontrivial [Nontrivial β] {f : α → β}
    (hf : Function.Surjective f) : Nontrivial α :=
  by
  rcases exists_pair_ne β with ⟨x, y, h⟩
  rcases hf x with ⟨x', hx'⟩
  rcases hf y with ⟨y', hy'⟩
  have : x' ≠ y' := by
    contrapose! h
    rw [← hx', ← hy', h]
  exact ⟨⟨x', y', this⟩⟩
#align function.surjective.nontrivial Function.Surjective.nontrivial
-/

/- warning: function.injective.exists_ne -> Function.Injective.exists_ne is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Nontrivial.{u1} α] {f : α -> β}, (Function.Injective.{succ u1, succ u2} α β f) -> (forall (y : β), Exists.{succ u1} α (fun (x : α) => Ne.{succ u2} β (f x) y))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Nontrivial.{u2} α] {f : α -> β}, (Function.Injective.{succ u2, succ u1} α β f) -> (forall (y : β), Exists.{succ u2} α (fun (x : α) => Ne.{succ u1} β (f x) y))
Case conversion may be inaccurate. Consider using '#align function.injective.exists_ne Function.Injective.exists_neₓ'. -/
/-- An injective function from a nontrivial type has an argument at
which it does not take a given value. -/
protected theorem Function.Injective.exists_ne [Nontrivial α] {f : α → β}
    (hf : Function.Injective f) (y : β) : ∃ x, f x ≠ y :=
  by
  rcases exists_pair_ne α with ⟨x₁, x₂, hx⟩
  by_cases h : f x₂ = y
  · exact ⟨x₁, (hf.ne_iff' h).2 hx⟩
  · exact ⟨x₂, h⟩
#align function.injective.exists_ne Function.Injective.exists_ne

#print nontrivial_prod_right /-
instance nontrivial_prod_right [Nonempty α] [Nontrivial β] : Nontrivial (α × β) :=
  Prod.snd_surjective.Nontrivial
#align nontrivial_prod_right nontrivial_prod_right
-/

#print nontrivial_prod_left /-
instance nontrivial_prod_left [Nontrivial α] [Nonempty β] : Nontrivial (α × β) :=
  Prod.fst_surjective.Nontrivial
#align nontrivial_prod_left nontrivial_prod_left
-/

namespace Pi

variable {I : Type _} {f : I → Type _}

#print Pi.nontrivial_at /-
/-- A pi type is nontrivial if it's nonempty everywhere and nontrivial somewhere. -/
theorem nontrivial_at (i' : I) [inst : ∀ i, Nonempty (f i)] [Nontrivial (f i')] :
    Nontrivial (∀ i : I, f i) := by
  classical exact (Function.update_injective (fun i => Classical.choice (inst i)) i').Nontrivial
#align pi.nontrivial_at Pi.nontrivial_at
-/

#print Pi.nontrivial /-
/-- As a convenience, provide an instance automatically if `(f default)` is nontrivial.

If a different index has the non-trivial type, then use `haveI := nontrivial_at that_index`.
-/
instance nontrivial [Inhabited I] [inst : ∀ i, Nonempty (f i)] [Nontrivial (f default)] :
    Nontrivial (∀ i : I, f i) :=
  nontrivial_at default
#align pi.nontrivial Pi.nontrivial
-/

end Pi

#print Function.nontrivial /-
instance Function.nontrivial [h : Nonempty α] [Nontrivial β] : Nontrivial (α → β) :=
  h.elim fun a => Pi.nontrivial_at a
#align function.nontrivial Function.nontrivial
-/

/- failed to parenthesize: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
[PrettyPrinter.parenthesize.input] (Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr
     [(Command.docComment "/--" "Simp lemmas for `nontriviality` tactic -/")]
     "register_simp_attr"
     `nontriviality)-/-- failed to format: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
/-- Simp lemmas for `nontriviality` tactic -/ register_simp_attr nontriviality

#print Subsingleton.le /-
protected theorem Subsingleton.le [Preorder α] [Subsingleton α] (x y : α) : x ≤ y :=
  le_of_eq (Subsingleton.elim x y)
#align subsingleton.le Subsingleton.le
-/

attribute [nontriviality] eq_iff_true_of_subsingleton Subsingleton.le

namespace Bool

instance : Nontrivial Bool :=
  ⟨⟨true, false, Bool.true_eq_false_eq_False⟩⟩

end Bool


import tactic
import young_diagram

/-

Semistandard Young tableaux

A semistandard Young tableau is a filling of a Young diagram μ by natural
numbers, i.e. a function from μ.cells → ℕ. It is represented below as a
function ℕ → ℕ → ℕ, which is required to be zero for (i, j) ∉ μ.

The filling is required to be weakly increasing along rows (i.e. for fixed i)
and strictly increasing along columns (i.e. for fixed j).

An example of an SSYT T of shape μ = [4, 2, 1] is

1 1 1 3
2 2
3

(See example 0 in [rsk.lean/rsk.ex0_R].)

This file contains:
  - definition and basic properties of ssyt (μ : young_diagram), including
    weight and a string representation for #eval
  - a fintype instance for ssyts of fixed shape and bounded entries
      [ssyt_bounded.fintype]
  - functions for replacing an entry, or adding an entry in an outer_corner
      [ssyt.legal]
      [ssyt.legal.replace]
      [ssyt.legal.add]
  - special examples
      [T_empty]
      [young_diagram.highest_ssyt]
      [young_diagram.lowest_ssyt]

-/

section ssyt

@[ext]
structure ssyt (μ : young_diagram) :=
  (entry : ℕ → ℕ → ℕ)
  (row_weak : ∀ {i j1 j2 : ℕ}, j1 < j2 → (i, j2) ∈ μ →
    entry i j1 ≤ entry i j2)
  (col_strict : ∀ {i1 i2 j: ℕ}, i1 < i2 → (i2, j) ∈ μ →
    entry i1 j < entry i2 j)
  (zeros' : ∀ {i j}, (i, j) ∉ μ → entry i j = 0)

instance ssyt.to_fun {μ : young_diagram} :
  has_coe_to_fun (ssyt μ) (λ T, ℕ → ℕ → ℕ) :=
{ coe := λ T i j, T.entry i j }

lemma ssyt.to_entry {μ : young_diagram} (T : ssyt μ) (i j : ℕ) :
  T.entry i j = T i j := rfl

def ssyt.copy {μ ν : young_diagram} (T : ssyt μ) (h_eq : μ = ν) :
ssyt ν :=
{ entry := T.entry,
  row_weak := h_eq ▸ T.row_weak,
  col_strict := h_eq ▸ T.col_strict,
  zeros' := h_eq ▸ T.zeros' }

lemma ssyt.copy_entry {μ ν : young_diagram} (T : ssyt μ) {h_eq : μ = ν}
  {i j : ℕ} : T.copy h_eq i j = T i j := rfl

lemma ssyt.zeros {μ : young_diagram} (T : ssyt μ)
  {i j : ℕ} (not_cell : (i, j) ∉ μ) : T i j = 0 := T.zeros' not_cell

lemma ssyt.row_weak' {μ : young_diagram} (T : ssyt μ) {i j1 j2 : ℕ}
  (hj : j1 ≤ j2) (cell : (i, j2) ∈ μ) : T i j1 ≤ T i j2 :=
by {cases eq_or_lt_of_le hj, subst h, exact T.row_weak h cell}

lemma ssyt.col_weak {μ : young_diagram} (T : ssyt μ) {i1 i2 j : ℕ}
  (hi : i1 ≤ i2) (cell : (i2, j) ∈ μ) : T i1 j ≤ T i2 j :=
by {cases eq_or_lt_of_le hi, subst h, exact le_of_lt (T.col_strict h cell)}

def ssyt.to_fun_cells {μ : young_diagram} (T : ssyt μ) (cc : μ.cells) : ℕ :=
  T cc.val.1 cc.val.2

end ssyt

section ssyt_bounded

-- fintype instance for ssyts with bounded entries
-- method is to express as a subtype of (μ.cells → fin m)

def ssyt_bounded (μ : young_diagram) (m : ℕ) :=
  {T : ssyt μ // ∀ {i j}, (i, j) ∈ μ → T i j < m}

def ssyt'_bounded (μ : young_diagram) (m : ℕ) :=
  {entry : μ.cells → fin m //
   (∀ {c c' : μ.cells},
    c.val.1 = c'.val.1 → c.val.2 < c'.val.2 → entry c ≤ entry c')
   ∧ (∀ {c c' : μ.cells},
    c.val.1 < c'.val.1 → c.val.2 = c'.val.2 → entry c < entry c') }

def ssyt_bounded.to_ssyt'_bounded {μ : young_diagram} {m : ℕ}
  (TT : ssyt_bounded μ m) : ssyt'_bounded μ m :=
{ val := λ c, ⟨TT.val.to_fun_cells c,
               begin apply TT.prop, convert c.prop, ext; refl, end⟩,
  property := ⟨
    λ c c' hi hj, begin
    cases c with c hc, cases c with i1 j1,
    cases c' with c' hc', cases c' with i2 j2,
    dsimp only at *, subst i2,
    apply TT.val.row_weak hj hc',
  end,
  λ c c' hi hj, begin
    cases c with c hc, cases c with i1 j1,
    cases c' with c' hc', cases c' with i2 j2,
    dsimp only at *, subst j2,
    apply TT.val.col_strict hi hc',
  end⟩
}

def ssyt'_bounded.to_ssyt_bounded {μ : young_diagram} {m : ℕ}
  (T' : ssyt'_bounded μ m) : ssyt_bounded μ m :=
⟨{ entry := λ i j, dite ((i, j) ∈ μ) (λ h, T'.val ⟨(i, j), h⟩) (λ _, 0),
  row_weak := λ i j1 j2 hj hcell, begin
    split_ifs,
    apply T'.prop.1, refl, exact hj,
    apply nat.zero_le,
  end,
  col_strict := λ i1 i2 j hi hcell, begin
    rw [dif_pos hcell, dif_pos (μ.nw_of (le_of_lt hi) (le_refl j) hcell)],
    apply T'.prop.2, exact hi, refl,
  end,
  zeros' := λ i j h, dif_neg h
},
begin
  intros i j h, change dite _ _ _ < _, rw dif_pos h,
  exact (T'.val _).prop,
end⟩

def ssyt.bounded_equiv (μ : young_diagram) (m : ℕ) :
  ssyt_bounded μ m ≃ ssyt'_bounded μ m :=
{ to_fun := λ T, T.to_ssyt'_bounded,
  inv_fun := λ T', T'.to_ssyt_bounded,
  left_inv := λ T, begin
    ext i j,
    change dite _ _ _ = _, split_ifs,
    refl, exact (T.val.zeros' h).symm,
  end,
  right_inv := λ T', begin
    ext ⟨⟨i, j⟩, hcell⟩,
    change dite _ _ _ = _, rw dif_pos, refl,
  end,
}

instance ssyt'_bounded.fintype {μ : young_diagram} {m : ℕ} :
  fintype (ssyt'_bounded μ m) := subtype.fintype _

instance ssyt_bounded.fintype {μ : young_diagram} {m : ℕ} :
  fintype (ssyt_bounded μ m) :=
  fintype.of_equiv _ (ssyt.bounded_equiv μ m).symm

end ssyt_bounded

section legal_replace_add

structure ssyt.legal {μ : young_diagram} (T : ssyt μ) :=
  (i j val : ℕ)
  (cell_left : ∀ {j'}, j' < j → (i, j') ∈ μ)
  (cell_up : ∀ {i'}, i' < i → (i', j) ∈ μ)
  (left : ∀ {j'}, j' < j → T i j' ≤ val)
  (up : ∀ {i'}, i' < i → T i' j < val)
  (right : ∀ {j'}, j < j' → (i, j') ∈ μ → val ≤ T i j')
  (down : ∀ {i'}, i < i' → (i', j) ∈ μ → val < T i' j)

def ssyt.legal.replace {μ : young_diagram} {T : ssyt μ}
  (h : T.legal) (cell : (h.i, h.j) ∈ μ) : ssyt μ :=
{ entry := λ i j, ite ((i, j) = (h.i, h.j)) h.val (T i j),
  row_weak := λ i j1 j2 hj cell, begin
    split_ifs,
    { refl },
    { cases h_1, apply h.right hj cell, },
    { cases h_2, apply h.left hj, },
    { exact T.row_weak hj cell }
  end,
  col_strict := λ i1 i2 j hi cell, begin
    split_ifs,
    { cases h_1, cases h_2, exact false.rec _ ((lt_self_iff_false _).mp hi) },
    { cases h_1, apply h.down hi cell },
    { cases h_2, apply h.up hi },
    { exact T.col_strict hi cell }
  end,
  zeros' := λ i j not_cell, begin
    rw [if_neg, T.zeros not_cell],
    exact λ h_eq, (h_eq ▸ not_cell) cell,
  end,
}

def ssyt.legal.to_outer {μ : young_diagram} {T : ssyt μ}
  (h : T.legal) (not_cell : (h.i, h.j) ∉ μ):
  μ.outer_corner :=
{ i := h.i,
  j := h.j,
  not_cell := not_cell,
  cell_left := h.cell_left,
  cell_up := h.cell_up }

def ssyt.legal.add {μ : young_diagram} {T : ssyt μ}
  (h : T.legal) (not_cell : (h.i, h.j) ∉ μ) : ssyt (h.to_outer not_cell).add :=
{ entry := λ i j, ite ((i, j) = (h.i, h.j)) h.val (T i j),
  row_weak := λ i j1 j2 hj cell, begin
    rw young_diagram.outer_corner.mem_add at cell,
    split_ifs,
    { refl },
    { cases h_1, cases cell, exact false.rec _ (h_2 cell),
      apply h.right hj cell },
    { cases h_2, apply h.left hj },
    { cases cell, exact false.rec _ (h_2 cell),
      exact T.row_weak hj cell }
  end,
  col_strict := λ i1 i2 j hi cell, begin
    rw young_diagram.outer_corner.mem_add at cell,
    split_ifs,
    { rw prod.mk.inj_iff at h_1, rw prod.mk.inj_iff at h_2,
      rw [h_1.1, h_2.1, lt_self_iff_false] at hi,
      exact false.rec _ hi },
    { cases h_1, cases cell, exact false.rec _ (h_2 cell),
      apply h.down hi cell },
    { cases h_2, apply h.up hi },
    { cases cell, exact false.rec _ (h_2 cell),
      exact T.col_strict hi cell }
  end,
  zeros' := λ i j not_cell, begin
    rw young_diagram.outer_corner.mem_add at not_cell, push_neg at not_cell,
    rw [if_neg, T.zeros not_cell.2], exact not_cell.1,
  end,
}

lemma ssyt.legal.entry_replace {μ : young_diagram} {T : ssyt μ}
  (h : T.legal) (cell : (h.i, h.j) ∈ μ) (i j : ℕ) :
  (h.replace cell) i j = ite ((i, j) = (h.i, h.j)) h.val (T i j) := rfl

lemma ssyt.legal.entry_add {μ : young_diagram} {T : ssyt μ}
  (h : T.legal) (not_cell : (h.i, h.j) ∉ μ) (i j : ℕ) :
  (h.add not_cell) i j = ite ((i, j) = (h.i, h.j)) h.val (T i j) := rfl

section delete_entry

def ssyt.del {μ : young_diagram} (T : ssyt μ) (c : μ.inner_corner) : ssyt c.del :=
{ entry := λ i j, ite ((i, j) = (c.i, c.j)) 0 (T i j),
  row_weak := λ i j1 j2 hj cell, begin
    rw [if_neg (c.mem_del.mp cell).1, if_neg],
    exact T.row_weak hj (c.mem_del.mp cell).2,
    rintro ⟨⟩, exact c.cell_right hj (c.mem_del.mp cell).2,
  end,
  col_strict := λ i1 i2 j hi cell, begin
    rw [if_neg (c.mem_del.mp cell).1, if_neg],
    exact T.col_strict hi (c.mem_del.mp cell).2,
    rintro ⟨⟩, exact c.cell_down hi (c.mem_del.mp cell).2,
  end,
  zeros' := λ i j not_cell, begin
    rw c.mem_del at not_cell, push_neg at not_cell,
    split_ifs, refl, exact T.zeros (not_cell h),
  end
}

lemma ssyt.del_entry {μ : young_diagram} (T : ssyt μ) (c : μ.inner_corner)
  (i j : ℕ) : T.del c i j = ite ((i, j) = (c.i, c.j)) 0 (T i j) := rfl

lemma ssyt.del_entry_eq_of_ne_row {μ : young_diagram} (T : ssyt μ)
  {c : μ.inner_corner} {i j : ℕ} (hi : i ≠ c.i) :
T.del c i j = T i j :=
begin
  rw [T.del_entry, if_neg], rintro ⟨⟩, exact hi rfl,
end

def ssyt.legal_of_del {μ : young_diagram} (T : ssyt μ) (c : μ.inner_corner) :
  (T.del c).legal :=
{ i := c.i, j := c.j, val := T c.i c.j,
  cell_left := λ j' hj', c.mem_del.mpr
                  ⟨λ h, ne_of_lt hj' (prod.mk.inj_left c.i h),
                   μ.nw_of (by refl) (le_of_lt hj') c.cell⟩,
  cell_up := λ i' hi', c.mem_del.mpr
                ⟨λ h, ne_of_lt hi' (prod.mk.inj_right c.j h),
                 μ.nw_of (le_of_lt hi') (by refl) c.cell⟩,
  left := λ j' hj', begin
    rw ssyt.del_entry, split_ifs, apply nat.zero_le,
    exact T.row_weak hj' c.cell,
  end,
  right := λ j' hj' cell', begin
    rw c.mem_del at cell',
    exact false.rec _ (c.cell_right hj' cell'.2),
  end,
  up := λ i' hi', begin
    rw T.del_entry_eq_of_ne_row (ne_of_lt hi'), exact T.col_strict hi' c.cell,
  end,
  down := λ i' hi' cell', begin
    rw c.mem_del at cell',
    exact false.rec _ (c.cell_down hi' cell'.2),
  end,
}

end delete_entry

end legal_replace_add

section weight

def ssyt.strip {μ : young_diagram} (T : ssyt μ) (val : ℕ) : finset (ℕ × ℕ) :=
  μ.cells.filter (λ c, T c.fst c.snd = val)
@[simp] lemma ssyt.mem_strip {μ : young_diagram} (T : ssyt μ) {val i j : ℕ} :
  (i, j) ∈ T.strip val ↔ (i, j) ∈ μ ∧ T i j = val :=
by { rw [ssyt.strip, finset.mem_filter], refl }

def ssyt.wt {μ : young_diagram} (T : ssyt μ) (val : ℕ) : ℕ :=
  (T.strip val).card

lemma ssyt.strip_add {μ : young_diagram} (T : ssyt μ) (val : ℕ)
  (h : T.legal) (not_cell : (h.i, h.j) ∉ μ) :
  (h.add not_cell).strip val =
  ite (val = h.val) (insert (h.i, h.j) (T.strip val)) (T.strip val) :=
begin
  ext ⟨i, j⟩,
  rw [ssyt.mem_strip, young_diagram.outer_corner.mem_add, ssyt.legal.entry_add],
  split_ifs; try {rw finset.mem_insert}; rw ssyt.mem_strip,
  { cases h_1, cases h_2,
    simp only [not_cell, or_false, eq_self_iff_true, and_true, false_and, iff_true],
    refl, },
  { cases h_1, simp only [not_cell, ne.symm h_2, and_false, false_and] },
  { cases h_2, rw [or_iff_right, or_iff_right]; exact h_1 },
  { rw or_iff_right, exact h_1, }
end

lemma ssyt.wt_add {μ : young_diagram} (T : ssyt μ) (val : ℕ)
  (h : T.legal) (not_cell : (h.i, h.j) ∉ μ) :
  (h.add not_cell).wt val = T.wt val + ite (val = h.val) 1 0 :=
begin
  rw [ssyt.wt, ssyt.wt, ssyt.strip_add, apply_ite finset.card],
  split_ifs,
  { rw finset.card_insert_of_not_mem,
    rw ssyt.mem_strip,
    simp only [not_cell, false_and, not_false_iff] },
  { rw add_zero }
end

lemma ssyt.strip_replace {μ : young_diagram} (T : ssyt μ) (val : ℕ)
  (h : T.legal) (cell : (h.i, h.j) ∈ μ) :
  ite (val = T h.i h.j)
    (insert (h.i, h.j) ((h.replace cell).strip val))
    ((h.replace cell).strip val) =
  ite (val = h.val)
    (insert (h.i, h.j) (T.strip val))
    (T.strip val) :=
begin
  ext ⟨i, j⟩,
  split_ifs,
  all_goals {
    try { rw finset.mem_insert }, try { rw finset.mem_insert },
    rw [ssyt.mem_strip, ssyt.mem_strip, h.entry_replace],
  },
  { split_ifs, cases h_3,
    simp only [eq_self_iff_true, true_or],
    simp only [h_3] },
  { split_ifs, cases h_3,
    simp only [eq_self_iff_true, true_or, true_iff], exact ⟨cell, h_1.symm⟩,
    rw or_iff_right h_3 },
  { cases h_2, split_ifs, cases h_3,
    simp only [eq_self_iff_true, and_true, true_or, iff_true], exact cell,
    rw or_iff_right h_3 },
  { rw and.congr_right_iff, intro hij,
    split_ifs, cases h_3, simp only [ne.symm h_1, ne.symm h_2], refl },
end

-- (new strip of k's) + (box if T h.i h.j = k) =
-- (old strip of k's) + (box if h.val = k)
lemma ssyt.wt_replace {μ : young_diagram} (T : ssyt μ) (val : ℕ)
  (h : T.legal) (cell : (h.i, h.j) ∈ μ) :
  (h.replace cell).wt val + ite (val = T h.i h.j) 1 0 =
  T.wt val + ite (val = h.val) 1 0 :=
begin
  have key := T.strip_replace val h cell,
  rw [ssyt.wt, ssyt.wt],
  split_ifs; split_ifs at key,
  { rw [finset.insert_eq_of_mem, finset.insert_eq_of_mem] at key, rw key,
    rw ssyt.mem_strip, exact ⟨cell, h_1.symm⟩,
    rw [ssyt.mem_strip, h.entry_replace, if_pos rfl], exact ⟨cell, h_2.symm⟩ },
  { rw [add_zero, ← key, finset.card_insert_of_not_mem],
    rw [ssyt.mem_strip, ssyt.legal.entry_replace, if_pos rfl],
    exact λ h, ne.symm h_2 h.2 },
  { rw [key, add_zero, finset.card_insert_of_not_mem],
    rw ssyt.mem_strip,
    exact λ h, ne.symm h_1 h.2 },
  { rw [key, add_zero] },
end

end weight

section T_empty

instance ssyt.has_emptyc : has_emptyc (ssyt ∅) :=
{ emptyc := {
  entry := λ _ _, 0,
  row_weak := λ _ _ _ _ cell, false.rec _ cell,
  col_strict := λ _ _ _ _ cell, false.rec _ cell,
  zeros' := λ _ _ _, rfl } }

def T_empty := (∅ : ssyt ∅)

@[simp] lemma T_empty_wt (val : ℕ) : T_empty.wt val = 0 := rfl

end T_empty

section repr

def ssyt.repr {μ : young_diagram} (T : ssyt μ) : string :=
string.intercalate "\n" $
  ("shape: " ++ μ.repr) ::
    list.map (λ i, string.intercalate ", " $
      list.map (λ j, (T i j).repr) (list.range $ μ.row_len i))
        (list.range $ μ.col_len 0)

instance ssyt.has_repr {μ : young_diagram} : has_repr (ssyt μ) :=
{ repr := ssyt.repr }

end repr

section examples

def young_diagram.highest_ssyt (μ : young_diagram) : ssyt μ :=
{ entry := λ i j, ite ((i, j) ∈ μ) i 0,
  row_weak := λ i j1 j2 hj hcell, begin
    rw if_pos hcell, rw if_pos (μ.nw_of (le_refl _) (le_of_lt hj) hcell),
  end,
  col_strict := λ i1 i2 j hi hcell, begin
    rw if_pos hcell, rwa if_pos (μ.nw_of (le_of_lt hi) (le_refl _) hcell),
  end,
  zeros' := λ i j hij, by rw if_neg hij,
}

def young_diagram.lowest_ssyt (μ : young_diagram) : ssyt μ :=
{ entry := λ i j, ite ((i, j) ∈ μ) (i + μ.col_len 0 - μ.col_len j) 0,
  row_weak := λ i j1 j2 hj hcell, begin
    rw [if_pos hcell, if_pos (μ.nw_of (le_refl _) (le_of_lt hj) hcell)],
    apply nat.sub_le_sub_left,
    apply young_diagram.col_len_decr,
    exact le_of_lt hj,
  end,
  col_strict := λ i1 i2 j hi hcell, begin
    rw [if_pos hcell, if_pos (μ.nw_of (le_of_lt hi) (le_refl _) hcell)],
    apply nat.sub_mono_left_strict _ (add_lt_add_right hi _),
    exact (μ.col_len_decr (nat.zero_le j)).trans le_add_self,
  end,
  zeros' := λ i j not_cell, by rw if_neg not_cell
}

end examples


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Yury Kudryashov

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

/-!
# `Gδ` sets

In this file we define `Gδ` sets and prove their basic properties.

## Main definitions

* `IsGδ`: a set `s` is a `Gδ` set if it can be represented as an intersection
  of countably many open sets;

* `residual`: the filter of residual sets. A set `s` is called *residual* if it includes a dense
  `Gδ` set. In a Baire space (e.g., in a complete (e)metric space), residual sets form a filter.

  For technical reasons, we define `residual` in any topological space but the definition agrees
  with the description above only in Baire spaces.

## Main results

We prove that finite or countable intersections of Gδ sets is a Gδ set. We also prove that the
continuity set of a function from a topological space to an (e)metric space is a Gδ set.

## Tags

Gδ set, residual set
-/

noncomputable section

open Topology TopologicalSpace Filter Encodable Set

variable {α β γ ι : Type _}

set_option linter.uppercaseLean3 false

section IsGδ

variable [TopologicalSpace α]

/-- A Gδ set is a countable intersection of open sets. -/
def IsGδ (s : Set α) : Prop :=
  ∃ T : Set (Set α), (∀ t ∈ T, IsOpen t) ∧ T.Countable ∧ s = ⋂₀ T
#align is_Gδ IsGδ

/-- An open set is a Gδ set. -/
theorem IsOpen.isGδ {s : Set α} (h : IsOpen s) : IsGδ s :=
  ⟨{s}, by simp [h], countable_singleton _, (Set.interₛ_singleton _).symm⟩
#align is_open.is_Gδ IsOpen.isGδ

@[simp]
theorem isGδ_empty : IsGδ (∅ : Set α) :=
  isOpen_empty.isGδ
#align is_Gδ_empty isGδ_empty

@[simp]
theorem isGδ_univ : IsGδ (univ : Set α) :=
  isOpen_univ.isGδ
#align is_Gδ_univ isGδ_univ

theorem isGδ_binterᵢ_of_open {I : Set ι} (hI : I.Countable) {f : ι → Set α}
    (hf : ∀ i ∈ I, IsOpen (f i)) : IsGδ (⋂ i ∈ I, f i) :=
  ⟨f '' I, by rwa [ball_image_iff], hI.image _, by rw [interₛ_image]⟩
#align is_Gδ_bInter_of_open isGδ_binterᵢ_of_open

-- porting note: TODO: generalize to `Sort _` + `Countable _`
theorem isGδ_interᵢ_of_open [Encodable ι] {f : ι → Set α} (hf : ∀ i, IsOpen (f i)) :
    IsGδ (⋂ i, f i) :=
  ⟨range f, by rwa [forall_range_iff], countable_range _, by rw [interₛ_range]⟩
#align is_Gδ_Inter_of_open isGδ_interᵢ_of_open

-- porting note: TODO: generalize to `Sort _` + `Countable _`
/-- The intersection of an encodable family of Gδ sets is a Gδ set. -/
theorem isGδ_interᵢ [Encodable ι] {s : ι → Set α} (hs : ∀ i, IsGδ (s i)) : IsGδ (⋂ i, s i) := by
  choose T hTo hTc hTs using hs
  obtain rfl : s = fun i => ⋂₀ T i := funext hTs
  refine' ⟨⋃ i, T i, _, countable_unionᵢ hTc, (interₛ_unionᵢ _).symm⟩
  simpa [@forall_swap ι] using hTo
#align is_Gδ_Inter isGδ_interᵢ

theorem isGδ_binterᵢ {s : Set ι} (hs : s.Countable) {t : ∀ i ∈ s, Set α}
    (ht : ∀ (i) (hi : i ∈ s), IsGδ (t i hi)) : IsGδ (⋂ i ∈ s, t i ‹_›) := by
  rw [binterᵢ_eq_interᵢ]
  haveI := hs.toEncodable
  exact isGδ_interᵢ fun x => ht x x.2
#align is_Gδ_bInter isGδ_binterᵢ

/-- A countable intersection of Gδ sets is a Gδ set. -/
theorem isGδ_interₛ {S : Set (Set α)} (h : ∀ s ∈ S, IsGδ s) (hS : S.Countable) : IsGδ (⋂₀ S) := by
  simpa only [interₛ_eq_binterᵢ] using isGδ_binterᵢ hS h
#align is_Gδ_sInter isGδ_interₛ

theorem IsGδ.inter {s t : Set α} (hs : IsGδ s) (ht : IsGδ t) : IsGδ (s ∩ t) := by
  rw [inter_eq_interᵢ]
  exact isGδ_interᵢ (Bool.forall_bool.2 ⟨ht, hs⟩)
#align is_Gδ.inter IsGδ.inter

/-- The union of two Gδ sets is a Gδ set. -/
theorem IsGδ.union {s t : Set α} (hs : IsGδ s) (ht : IsGδ t) : IsGδ (s ∪ t) := by
  rcases hs with ⟨S, Sopen, Scount, rfl⟩
  rcases ht with ⟨T, Topen, Tcount, rfl⟩
  rw [interₛ_union_interₛ]
  apply isGδ_binterᵢ_of_open (Scount.prod Tcount)
  rintro ⟨a, b⟩ ⟨ha, hb⟩
  exact (Sopen a ha).union (Topen b hb)
#align is_Gδ.union IsGδ.union

-- porting note: TODO: add `unionᵢ` and `unionₛ` versions
/-- The union of finitely many Gδ sets is a Gδ set. -/
theorem isGδ_bunionᵢ {s : Set ι} (hs : s.Finite) {f : ι → Set α} (h : ∀ i ∈ s, IsGδ (f i)) :
    IsGδ (⋃ i ∈ s, f i) := by
  refine' Finite.induction_on hs (by simp) _ h
  simp only [ball_insert_iff, bunionᵢ_insert]
  exact fun _ _ ihs H => H.1.union (ihs H.2)
#align is_Gδ_bUnion isGδ_bunionᵢ

-- Porting note: Did not recognize notation 𝓤 α, needed to replace with uniformity α
theorem IsClosed.isGδ {α} [UniformSpace α] [IsCountablyGenerated (uniformity α)] {s : Set α}
    (hs : IsClosed s) : IsGδ s := by
  rcases(@uniformity_hasBasis_open α _).exists_antitone_subbasis with ⟨U, hUo, hU, -⟩
  rw [← hs.closure_eq, ← hU.binterᵢ_bunionᵢ_ball]
  refine' isGδ_binterᵢ (to_countable _) fun n _ => IsOpen.isGδ _
  exact isOpen_bunionᵢ fun x _ => UniformSpace.isOpen_ball _ (hUo _).2
#align is_closed.is_Gδ IsClosed.isGδ

section T1Space

variable [T1Space α]

theorem isGδ_compl_singleton (a : α) : IsGδ ({a}ᶜ : Set α) :=
  isOpen_compl_singleton.isGδ
#align is_Gδ_compl_singleton isGδ_compl_singleton

theorem Set.Countable.isGδ_compl {s : Set α} (hs : s.Countable) : IsGδ (sᶜ) := by
  rw [← bunionᵢ_of_singleton s, compl_unionᵢ₂]
  exact isGδ_binterᵢ hs fun x _ => isGδ_compl_singleton x
#align set.countable.is_Gδ_compl Set.Countable.isGδ_compl

theorem Set.Finite.isGδ_compl {s : Set α} (hs : s.Finite) : IsGδ (sᶜ) :=
  hs.countable.isGδ_compl
#align set.finite.is_Gδ_compl Set.Finite.isGδ_compl

theorem Set.Subsingleton.isGδ_compl {s : Set α} (hs : s.Subsingleton) : IsGδ (sᶜ) :=
  hs.finite.isGδ_compl
#align set.subsingleton.is_Gδ_compl Set.Subsingleton.isGδ_compl

theorem Finset.isGδ_compl (s : Finset α) : IsGδ (sᶜ : Set α) :=
  s.finite_toSet.isGδ_compl
#align finset.is_Gδ_compl Finset.isGδ_compl

variable [FirstCountableTopology α]

theorem isGδ_singleton (a : α) : IsGδ ({a} : Set α) := by
  rcases (nhds_basis_opens a).exists_antitone_subbasis with ⟨U, hU, h_basis⟩
  rw [← binterᵢ_basis_nhds h_basis.toHasBasis]
  exact isGδ_binterᵢ (to_countable _) fun n _ => (hU n).2.isGδ
#align is_Gδ_singleton isGδ_singleton

theorem Set.Finite.isGδ {s : Set α} (hs : s.Finite) : IsGδ s :=
  Finite.induction_on hs isGδ_empty fun _ _ hs => (isGδ_singleton _).union hs
#align set.finite.is_Gδ Set.Finite.isGδ

end T1Space

end IsGδ

section ContinuousAt

variable [TopologicalSpace α]

/-- The set of points where a function is continuous is a Gδ set. -/
theorem isGδ_setOf_continuousAt [UniformSpace β] [IsCountablyGenerated (uniformity β)] (f : α → β) :
    IsGδ { x | ContinuousAt f x } := by
  obtain ⟨U, _, hU⟩ := (@uniformity_hasBasis_open_symmetric β _).exists_antitone_subbasis
  simp only [Uniform.continuousAt_iff_prod, nhds_prod_eq]
  simp only [(nhds_basis_opens _).prod_self.tendsto_iff hU.toHasBasis, forall_prop_of_true,
    setOf_forall, id]
  refine' isGδ_interᵢ fun k => IsOpen.isGδ <| isOpen_iff_mem_nhds.2 fun x => _
  rintro ⟨s, ⟨hsx, hso⟩, hsU⟩
  filter_upwards [IsOpen.mem_nhds hso hsx]with _ hy using⟨s, ⟨hy, hso⟩, hsU⟩
#align is_Gδ_set_of_continuous_at isGδ_setOf_continuousAt

end ContinuousAt

/-- A set `s` is called *residual* if it includes a dense `Gδ` set. If `α` is a Baire space
(e.g., a complete metric space), then residual sets form a filter, see `mem_residual`.

For technical reasons we define the filter `residual` in any topological space but in a non-Baire
space it is not useful because it may contain some non-residual sets. -/
def residual (α : Type _) [TopologicalSpace α] : Filter α :=
  ⨅ (t) (_ht : IsGδ t) (_ht' : Dense t), 𝓟 t
#align residual residual


import G_module.basic

variables (G : Type*) [group G]
variables (M : Type*) [add_comm_group M] [G_module G M]
variables (N : Type*) [add_comm_group N] [G_module G N]

structure G_module_hom :=
(f : M →+ N)
(smul : ∀ g : G, ∀ m : M, f (g • m) = g • (f m))

instance : has_coe (G_module_hom G M N) (add_group_hom M N) := ⟨G_module_hom.f⟩

notation M ` →[`:25 G:25 `] `:0 N:0 := G_module_hom G M N

namespace G_module_hom

variables {G} {M} {N}

def zero : M →[G] N := sorry

def id : M →[G] M := sorry

variables {P : Type*} [add_comm_group P] [G_module G P]

def comp (α : M →[G] N) (β : N →[G] P) : M →[G] P := sorry

lemma id_comp {α : M →[G] N} : comp id α = α := sorry

lemma comp_id {α : M →[G] N} : comp α id = α := sorry

variables {Q : Type*} [add_comm_group Q] [G_module G Q]

lemma comp_assoc {α : M →[G] N} {β : N →[G] P} {γ : P →[G] Q} :
  comp (comp α β) γ = comp α (comp β γ) := sorry

-- could do zero_comp, comp_zero

variable (α : M →[G] N)

example : ⇑α = α.f.to_fun := rfl

lemma map_add {m n : M} : (α : M → N) (m + n) = (α : M → N) m + (α : M → N) n :=
add_monoid_hom.map_add (α.f) m n

lemma map_smul {g : G} {m : M} : (α : M → N) (g • m) = g • ((α : M → N) m) :=
G_module_hom.smul α g m

lemma map_sum (I : Type*) (φ : I → M) (s : finset I) :
    α (finset.sum s φ) = finset.sum s (λ (x : I), α (φ x)) :=
add_monoid_hom.map_sum α.f φ s

end G_module_hom


/-
Copyright (c) 2021 Yourong Zang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yourong Zang
-/
import analysis.complex.isometry
import analysis.normed_space.conformal_linear_map

/-!
# Conformal maps between complex vector spaces

We prove the sufficient and necessary conditions for a real-linear map between complex vector spaces
to be conformal.

## Main results

* `is_conformal_map_complex_linear`: a nonzero complex linear map into an arbitrary complex
                                     normed space is conformal.
* `is_conformal_map_complex_linear_conj`: the composition of a nonzero complex linear map with
                                          `conj` is complex linear.
* `is_conformal_map_iff_is_complex_or_conj_linear`: a real linear map between the complex
                                                            plane is conformal iff it's complex
                                                            linear or the composition of
                                                            some complex linear map and `conj`.

## Warning

Antiholomorphic functions such as the complex conjugate are considered as conformal functions in
this file.
-/

noncomputable theory

open complex continuous_linear_map
open_locale complex_conjugate

lemma is_conformal_map_conj : is_conformal_map (conj_lie : ℂ →L[ℝ] ℂ) :=
conj_lie.to_linear_isometry.is_conformal_map

section conformal_into_complex_normed

variables {E : Type*} [normed_group E] [normed_space ℝ E] [normed_space ℂ E]
  {z : ℂ} {g : ℂ →L[ℝ] E} {f : ℂ → E}

lemma is_conformal_map_complex_linear
  {map : ℂ →L[ℂ] E} (nonzero : map ≠ 0) : is_conformal_map (map.restrict_scalars ℝ) :=
begin
  have minor₁ : ∥map 1∥ ≠ 0,
  { simpa [ext_ring_iff] using nonzero },
  refine ⟨∥map 1∥, minor₁, ⟨∥map 1∥⁻¹ • map, _⟩, _⟩,
  { intros x,
    simp only [linear_map.smul_apply],
    have : x = x • 1 := by rw [smul_eq_mul, mul_one],
    nth_rewrite 0 [this],
    rw [_root_.coe_coe map, linear_map.coe_coe_is_scalar_tower],
    simp only [map.coe_coe, map.map_smul, norm_smul, normed_field.norm_inv, norm_norm],
    field_simp [minor₁], },
  { ext1,
    rw [← linear_isometry.coe_to_linear_map],
    simp [minor₁], },
end

lemma is_conformal_map_complex_linear_conj
  {map : ℂ →L[ℂ] E} (nonzero : map ≠ 0) :
  is_conformal_map ((map.restrict_scalars ℝ).comp (conj_cle : ℂ →L[ℝ] ℂ)) :=
(is_conformal_map_complex_linear nonzero).comp is_conformal_map_conj

end conformal_into_complex_normed

section conformal_into_complex_plane

open continuous_linear_map

variables {f : ℂ → ℂ} {z : ℂ} {g : ℂ →L[ℝ] ℂ}

lemma is_conformal_map.is_complex_or_conj_linear (h : is_conformal_map g) :
  (∃ (map : ℂ →L[ℂ] ℂ), map.restrict_scalars ℝ = g) ∨
  (∃ (map : ℂ →L[ℂ] ℂ), map.restrict_scalars ℝ = g ∘L ↑conj_cle) :=
begin
  rcases h with ⟨c, hc, li, hg⟩,
  rcases linear_isometry_complex (li.to_linear_isometry_equiv rfl) with ⟨a, ha⟩,
  let rot := c • (a : ℂ) • continuous_linear_map.id ℂ ℂ,
  cases ha,
  { refine or.intro_left _ ⟨rot, _⟩,
    ext1,
    simp only [coe_restrict_scalars', hg, ← li.coe_to_linear_isometry_equiv, ha,
               pi.smul_apply, continuous_linear_map.smul_apply, rotation_apply,
               continuous_linear_map.id_apply, smul_eq_mul], },
  { refine or.intro_right _ ⟨rot, _⟩,
    ext1,
    rw [continuous_linear_map.coe_comp', hg, ← li.coe_to_linear_isometry_equiv, ha],
    simp only [coe_restrict_scalars', function.comp_app, pi.smul_apply,
               linear_isometry_equiv.coe_trans, conj_lie_apply,
               rotation_apply, continuous_linear_equiv.coe_apply, conj_cle_apply],
    simp only [continuous_linear_map.smul_apply, continuous_linear_map.id_apply,
               smul_eq_mul, conj_conj], },
end

/-- A real continuous linear map on the complex plane is conformal if and only if the map or its
    conjugate is complex linear, and the map is nonvanishing. -/
lemma is_conformal_map_iff_is_complex_or_conj_linear:
  is_conformal_map g ↔
  ((∃ (map : ℂ →L[ℂ] ℂ), map.restrict_scalars ℝ = g) ∨
   (∃ (map : ℂ →L[ℂ] ℂ), map.restrict_scalars ℝ = g ∘L ↑conj_cle)) ∧ g ≠ 0 :=
begin
  split,
  { exact λ h, ⟨h.is_complex_or_conj_linear, h.ne_zero⟩, },
  { rintros ⟨⟨map, rfl⟩ | ⟨map, hmap⟩, h₂⟩,
    { refine is_conformal_map_complex_linear _,
      contrapose! h₂ with w,
      simp [w] },
    { have minor₁ : g = (map.restrict_scalars ℝ) ∘L ↑conj_cle,
      { ext1,
        simp [hmap] },
      rw minor₁ at ⊢ h₂,
      refine is_conformal_map_complex_linear_conj _,
      contrapose! h₂ with w,
      simp [w] } }
end

end conformal_into_complex_plane


constant myint: Type

namespace myint

constant zero: myint
constant succ: myint -> myint
constant pred: myint -> myint
constant add: myint -> myint -> myint
constant mul: myint -> myint -> myint
constant neg: myint -> myint

noncomputable def has_add: has_add myint :=
⟨add⟩

-- def has_add: has_add myint := sorry

notation `O` := zero
notation `S` := succ
notation `P` := pred
reserve infixl ` ++ `:65
reserve infixl ` ** `:67
notation a `++` b := add a b
notation a `**` b := mul a b
notation `neg` := neg

axiom succ_of_pred: forall x, S (P x) = x
axiom pred_of_succ: forall x, P (S x) = x
axiom add_of_zero: forall x: myint, add x zero = x
axiom add_of_succ: forall x y, add x (S y) = S (add x y)
axiom add_of_pred: forall x y, add x (P y) = P (add x y)

axiom neg_of_zero: neg zero = zero
axiom neg_of_succ: forall x, neg (S x) = P (neg x)
axiom neg_of_pred: forall x, neg (P x) = S (neg x)

axiom mul_of_zero: forall x, x ** zero = zero
axiom mul_of_succ: forall x y, x ** S y = add (x ** y) x
axiom mul_of_pred: forall x y, x ** P y = add (x ** y) (neg x)

axiom rec: forall Q: myint -> Prop,
  Q zero -> (forall x, Q x -> Q (S x)) -> (forall x, Q x -> Q (P x)) -> forall x, Q x

@[simp]
lemma succ_of_pred_simp: forall x, S (P x) = x := succ_of_pred
@[simp]
lemma pred_of_succ_simp: forall x, P (S x) = x := pred_of_succ
@[simp]
lemma add_of_zero_simp: forall x, x ++ O = x := add_of_zero
@[simp]
lemma add_of_succ_simp: forall x y, x ++ S y = S (x ++ y) := add_of_succ
@[simp]
lemma add_of_pred_simp: forall x y, x ++ P y = P (x ++ y) := add_of_pred

@[simp]
lemma neg_of_zero_simp: neg O = O := neg_of_zero
@[simp]
lemma neg_of_succ_simp: forall x, neg (S x) = P (neg x) := neg_of_succ
@[simp]
lemma neg_of_pred_simp: forall x, neg (P x) = S (neg x) := neg_of_pred

@[simp]
lemma mul_of_zero_simp: forall x, x ** O = O := mul_of_zero
@[simp]
lemma mul_of_succ_simp: forall x y, x ** S y = x ** y ++ x := mul_of_succ
@[simp]
lemma mul_of_pred_simp: forall x y, x ** P y = x ** y ++ neg x := mul_of_pred

lemma add_comm: forall x y: myint, add x y = add y x :=
begin
  intro x,
  induction x with x' ih x' ih,
  intro y,
  induction y with y' ih2 y' ih2,
  reflexivity,
  rw add_of_succ,
  rw ih2,
  simp,
  rw add_of_pred,
  rw ih2,
  simp,

  intro y,
  induction y with y' ih2 y' ih2,
  rw add_of_zero,
  simp,
  rw <- ih O,
  simp,
  simp,
  rw ih2,
  rw <- ih,
  simp,
  rw ih,
  simp,
  rw ih2,
  rw <- ih,
  simp,
  rw ih,

  intro y,
  induction y with y' ih2 y' ih2,
  simp,
  rw <- ih,
  simp,
  simp [ih2],
  rw <- ih, rw <- ih,
  simp,
  simp [ih2],
  rw <- ih, rw <- ih,
  simp,
end

lemma add_assoc: forall x y z: myint, (x ++ y) ++ z = x ++ (y ++ z) :=
fun x y z,
begin
  induction z with z' ih z' ih;
  { simp [ih] <|> simp },
end

@[simp]
lemma add_of_neg: forall x, x ++ neg x = O :=
fun x,
begin
  induction x with _ a _ a,
  simp,
  simp,
  rw add_comm,
  simp,
  rw add_comm,
  rw a,
  simp,
  rw add_comm,
  simp,
  rw add_comm,
  rw a,
end

@[simp]
lemma neg_of_neg {x: myint}: neg (neg x) = x :=
begin
  induction x with x' ih x' ih;
  { simp [ih] <|> simp },
end

lemma neg_of_add {x y: myint}: neg x ++ neg y = neg (x ++ y) :=
begin
  induction y with y' ih y' ih;
  { simp [ih] <|> simp },
end

lemma mul_comm {x y: myint}: x ** y = y ** x :=
begin
  revert y,
  induction x with x' ih x' ih; intro y,
  induction y with y' ih y' ih;
  { simp [ih] <|> simp },

  all_goals {
    induction y with y' ih2 y' ih2,
    simp,
    rw <- ih,
    simp,
    all_goals {
      simp,
      rw ih2,
      simp,
      rw <- ih,
      rw <- ih,
      simp,
      repeat { rw add_assoc },
      repeat { apply congr_arg },
      rw add_comm,
    },
  },
end

lemma mul_add_dist_right {x y z: myint}: x ** z ++ y ** z = (x ++ y) ** z :=
begin
  induction z with z' ih z' ih,
  simp,
  all_goals {
    simp,
    rw <- ih,
    repeat { rw add_assoc },
    rw <- add_assoc _ (y ** z'),
    rw add_comm _ (y ** z'),
    rw add_assoc (y ** z'),
  },
  repeat { apply congr_arg },
  apply neg_of_add,
end

lemma mul_add_dist_left {x y z: myint}: x ** y ++ x ** z = x ** (y ++ z) :=
begin
  repeat { rw @mul_comm x },
  exact mul_add_dist_right,
end

@[simp]
lemma mul_neg {x y: myint}: x ** neg y = neg (x ** y) :=
begin
  induction y with y' ih y' ih; simp,
  rw ih,
  rw neg_of_add,
  rw ih,
  rw <- neg_of_add,
  simp,
end

lemma mul_assoc {x y z: myint}: x ** y ** z = x ** (y ** z) :=
begin
  induction z with z' ih z' ih,
  simp,
  simp [ih],
  rw mul_add_dist_left,
  simp [ih],
  rw <- mul_add_dist_left,
  simp,
end

end myint


import function.bijection
import data.fin.misc
universes u v
open function

class equipotent (α : Sort u) (β : Sort v) :=
  (map : α → β)
  (bijection : bijection map)

namespace equipotent
variables {α : Sort u} {β : Sort v}

@[refl]
instance rfl : equipotent α α :=
  {
      map := id,
      bijection := bijection.of_id
  }

@[symm]
instance symm (eqv : equipotent α β) : equipotent β α :=
 {
     map := eqv.bijection.inv,
     bijection := eqv.bijection.inverse
 }

instance equipotent_of_inhabited_subsingletons [inhabited α][subsingleton α ][inhabited β][subsingleton β] : equipotent α β
:=
{
  map := λ a, default β,
  bijection := {
    inv := λ b, default α,
    left_inverse_of_inv := λ a, subsingleton.elim _ a,
    right_inverse_of_inv := λ b, subsingleton.elim _ b,
  }
}
 universe w
 variable {γ : Sort w}
 @[trans]
 instance trans (eqv₁ : equipotent α β) (eqv₂ : equipotent β γ) : equipotent α γ :=
 {
     map := eqv₂.map ∘ eqv₁.map,
     bijection := bijection.comp eqv₁.bijection eqv₂.bijection
 }

end equipotent

def is_equipotent (α : Sort u) (β : Sort v) := ∃ f : α → β, has_bijection f

namespace is_equipotent
variables {α : Sort u}{β : Sort v}

@[refl]
def rfl : is_equipotent α α := exists.intro id (exists.intro id (and.intro (take x, rfl) (take x, rfl)))

@[symm]
def symm : is_equipotent α β → is_equipotent β α :=
  assume Heqv,
  exists.elim Heqv (λ f ex, exists.elim ex (λ g h, exists.intro g (exists.intro f (and.intro h.right h.left))))

universe w
variable {γ : Sort w}

@[trans]
def trans : is_equipotent α β → is_equipotent β γ → is_equipotent α γ :=
  begin
  intros Hab Hbc,
  cases Hab with f f_has_bijection,
  cases Hbc with g g_has_bijection,
  apply exists.intro,
  apply has_bijection.trans,
  exact f_has_bijection,
  exact g_has_bijection
  end

def is_equipotent_iff_iff {α : Prop} {β : Prop} : (α ↔ β) ↔ is_equipotent α β :=
  begin
    apply iff.intro,
      {
          intro H,
          apply (exists.intro (iff.elim_left H)),
          apply (exists.intro (iff.elim_right H)),
          apply and.intro,
          intro p, apply proof_irrel,
          intro p, apply proof_irrel
      },
      {
          intro H,
          cases H with p ex,
          cases ex with q h,
          apply iff.intro,
          assumption, assumption
      }
  end
end is_equipotent

def is_finitary (α : Sort u) n := is_equipotent α (fin n)

namespace is_finitary

lemma eq_size_of_fin {m n} : is_finitary (fin m) n → m = n :=
   assume ⟨f, Hhas_bijection⟩,

   if Heq  : m = n then
     Heq
   else if Hlt : m < n then
     exists.elim Hhas_bijection (take g, assume Hg,
       have Hinj : injective g, from injective_of_left_inverse Hg.right,
       absurd Hinj (fin.not_injective_of_gt g Hlt)
       )
   else
     have Hinj : injective f, from has_bijection.injective_of_has_bijection Hhas_bijection,
     have m > n, from lt_of_le_of_ne (le_of_not_gt Hlt) (ne.symm Heq),
     absurd Hinj (fin.not_injective_of_gt f this)

theorem eq_of_size {m n}{α : Sort u} : is_finitary α m → is_finitary α n → m = n :=
  assume Hm Hn,
  have is_finitary (fin m) n, from is_equipotent.trans (is_equipotent.symm Hm) Hn,
  eq_size_of_fin this

end is_finitary


axiom Person : Type
axioms (Nice: Person → Prop) (Old : Person → Prop)

example :   (∃ (p : Person), Nice p ∨ Old p) →
            (∃ (p : Person), Nice p) ∨
            (∃ (p : Person), Old p) :=
λ pno,
    match pno with
    | exists.intro fred pf_fred_either_nice_or_old :=
        match pf_fred_either_nice_or_old with
        | or.inl n := or.inl (exists.intro fred n)
        | or.inr o := _
        end
    end

example : (∃ (n : ℕ), n > 0) → true :=
λ h,
    match h with
    | exists.intro v pf := _    -- not meant to be finished
    end