import group_theory.quotient_group
import group_theory.order_of_element
import .simple_group .quotient_group

namespace subgroup
variables {G : Type*} [group G] [fintype G]

@[to_additive]
lemma card_pos : fintype.card G > 0 := fintype.card_pos_iff.mpr ⟨1⟩

variables {H : subgroup G} [decidable_pred (λ h, h ∈ H)]

@[to_additive]
lemma card_lt : H ≠ ⊤ → fintype.card H < fintype.card G :=
begin
  contrapose!, intro h, apply eq_top_of_card_eq H (le_antisymm _ h),
  apply fintype.card_subtype_le,
end

lemma eq_bot_of_card_eq_one : fintype.card H = 1 → H = ⊥ :=
λ h, le_antisymm (λ x hx, begin
  rcases fintype.card_eq_one_iff.mp h with ⟨y, hy⟩, rw mem_bot,
  simpa using (hy ⟨x, hx⟩).trans (hy ⟨(1 : G), H.one_mem⟩).symm,
end) bot_le

end subgroup

namespace add_subgroup

variables {G : Type*} [add_group G] [fintype G]
variables {H : add_subgroup G} [decidable_pred (λ h, h ∈ H)]

/- The to_additive attribute doesn't work in this case because it also changes the 1
in the conclusion to a 0 -/
lemma eq_bot_of_card_eq_one : fintype.card H = 1 → H = ⊥ :=
λ h, le_antisymm (λ x hx, begin
  rcases fintype.card_eq_one_iff.mp h with ⟨y, hy⟩, rw mem_bot,
  simpa using (hy ⟨x, hx⟩).trans (hy ⟨(0 : G), H.zero_mem⟩).symm,
end) bot_le

end add_subgroup

attribute [to_additive add_subgroup.eq_bot_of_card_eq_one] subgroup.eq_bot_of_card_eq_one

section add_lagrange

open add_subgroup

variables {α : Type*} [add_group α] [fintype α]

lemma card_eq_card_quotient_mul_card_add_subgroup (s : add_subgroup α) [fintype s]
  [decidable_pred (λ a, a ∈ s)] :
  fintype.card α = fintype.card (quotient_add_group.quotient s) * fintype.card s :=
by rw ← fintype.card_prod;
  exact fintype.card_congr (add_subgroup.add_group_equiv_quotient_times_add_subgroup)

attribute [to_additive card_eq_card_quotient_mul_card_add_subgroup] card_eq_card_quotient_mul_card_subgroup

lemma card_add_subgroup_dvd_card (s : add_subgroup α) [fintype s] :
  fintype.card s ∣ fintype.card α :=
by haveI := classical.prop_decidable; simp [card_eq_card_quotient_mul_card_add_subgroup s]
attribute [to_additive] card_subgroup_dvd_card

end add_lagrange

namespace quotient_add_group

open add_subgroup

variables {G : Type*} [add_group G] [fintype G]
variables {N : add_subgroup G} [add_subgroup.normal N]
  [decidable_pred (λ a, a ∈ N)] [decidable_pred N.carrier]

lemma eq_bot_of_card_quotient_eq : fintype.card (quotient N) = fintype.card G → N = ⊥ :=
begin
  intro h, rw card_eq_card_quotient_mul_card_add_subgroup N at h,
  conv_lhs at h { rw ←nat.mul_one (fintype.card (quotient N)) },
  apply add_subgroup.eq_bot_of_card_eq_one,
  apply nat.eq_of_mul_eq_mul_left add_subgroup.card_pos h.symm,
end

end quotient_add_group

namespace quotient_group

variables {G : Type*} [group G] [fintype G]
variables {N : subgroup G} [subgroup.normal N] [decidable_pred (λ a, a ∈ N)] [decidable_pred N.carrier]

@[to_additive]
lemma eq_bot_of_card_quotient_eq : fintype.card (quotient N) = fintype.card G → N = ⊥ :=
begin
  intro h, rw card_eq_card_quotient_mul_card_subgroup N at h,
  conv_lhs at h { rw ←nat.mul_one (fintype.card (quotient N)) },
  apply subgroup.eq_bot_of_card_eq_one,
  apply nat.eq_of_mul_eq_mul_left subgroup.card_pos h.symm,
end

@[to_additive]
lemma card_quotient_lt :
  N ≠ ⊥ → fintype.card (quotient N) < fintype.card G :=
begin
  contrapose!, intro h, apply eq_bot_of_card_quotient_eq (le_antisymm _ h),
  apply fintype.card_quotient_le,
end

end quotient_group

namespace fingroup

open fintype

@[to_additive add_fingroup.strong_rec_on_card]
def strong_rec_on_card (G : Type*) [group G] [fintype G]
  {p : Π (G : Type*) [group G] [fintype G], Sort _} :
  (Π (G : Type*) [group G] [fintype G],
    (Π (H : Type*) [group H] [fintype H], by exactI card H < card G → p H) →
    by exactI p G) →
  p G :=
λ ih, suffices h : ∀ (n : ℕ) (G : Type*) [group G] [fintype G], by exactI card G = n → p G,
  from h (card G) G rfl,
λ n, n.strong_rec_on $ begin
  intros n ih' G, introsI _ _, intro hn,
  apply ih G,
  intro H, introsI _ _, intro hH,
  exact ih' (card H) (hn ▸ hH) H rfl,
end

@[to_additive add_fingroup.strong_rec_on_card']
def strong_rec_on_card' (G : Group) [fintype G]
  {p : Π (G : Group) [fintype G], Sort _} :
  (Π (G : Group) [fintype G],
    (Π (H : Group) [fintype H], by exactI card H < card G → p H) →
    by exactI p G) →
  p G :=
λ ih, suffices h : ∀ (n : ℕ) (G : Group) [fintype G], by exactI card G = n → p G,
  from h (card G) G rfl,
λ n, n.strong_rec_on $ begin
  intros n ih' G, introI, intro hn,
  apply ih G, intro H, introI, intro hH,
  exact ih' (card H) (hn ▸ hH) H rfl,
end

end fingroup

open add_subgroup

lemma add_subgroup.not_subsingleton_of_prime_card {G : Type*} [add_group G] [fintype G] :
  nat.prime (fintype.card G) → ¬ subsingleton G :=
λ h1 h2,
have h : fintype.card G = 1 := fintype.card_eq_one_iff.mpr ⟨0, λ g, @subsingleton.elim _ h2 g 0⟩,
by { rw [h] at h1, exact nat.not_prime_one h1 }

local attribute [instance] classical.prop_decidable

lemma add_subgroup.is_simple_of_prime_card {G : Type*} [add_group G] [fintype G] :
  nat.prime (fintype.card G) → is_simple_add G :=
λ h N _, begin
  have hp := card_add_subgroup_dvd_card N,
  rw nat.dvd_prime h at hp,
  cases hp,
  { left, exact eq_bot_of_card_eq_one hp },
  right, exact not_not.mp (not_imp_not.mpr card_lt (not_lt_of_ge $ ge_of_eq hp)),
end

namespace subgroup

open quotient_group

variables {G : Type*} [group G]

@[to_additive]
lemma not_subsingleton_of_prime_card [fintype G] : nat.prime (fintype.card G) → ¬ subsingleton G :=
λ h1 h2,
have h : fintype.card G = 1 := fintype.card_eq_one_iff.mpr ⟨1, λ g, @subsingleton.elim _ h2 g 1⟩,
by { rw [h] at h1, exact nat.not_prime_one h1 }

local attribute [instance] classical.prop_decidable

@[to_additive]
lemma is_simple_of_prime_card [fintype G] : nat.prime (fintype.card G) → is_simple G :=
λ h N _, begin
  have hp := card_subgroup_dvd_card N,
  rw nat.dvd_prime h at hp,
  cases hp,
  { left, exact eq_bot_of_card_eq_one hp },
  right, exact not_not.mp (not_imp_not.mpr card_lt (not_lt_of_ge $ ge_of_eq hp)),
end

@[to_additive]
lemma exists_maximal_normal_subgroup [fintype G] :
  ¬ subsingleton G → ∃ (N : subgroup G), maximal_normal_subgroup N :=
fingroup.strong_rec_on_card G begin
  clear _inst_1 _inst_2 G, intro G, introsI _ _, intros ih hG,
  by_cases h : is_simple G,
  { use [⊥, subgroup.bot_normal, λ h, hG (subsingleton_iff.mpr $ subsingleton_of_bot_eq_top h),
      λ N hN _, h N hN] },
  rcases not_is_simple.mp h with ⟨N, hN, hN'⟩, haveI := hN,
  rcases ih (quotient N) (card_quotient_lt hN'.1)
    (λ h, hN'.2 $ subsingleton_quotient_iff.mp h) with ⟨K, hK, hKtop, hKmax⟩,
  use [comap (mk' N) K, hK.comap _,
    comap_top (mk' N) ▸ (comap_injective (mk'_surjective N)).ne hKtop],
  intro L, introI hL, intro hLK,
  have hLK' := map_mono hLK, rw map_comap_eq (mk'_surjective N) at hLK',
  have hNL : N ≤ L := le_trans le_comap_mk' hLK,
  exact (@hKmax (map (mk' N) L) (map_mk'_normal hNL) hLK').imp
    (λ h, le_antisymm ((gc_map_comap (mk' N)).le_u $ le_of_eq h) hLK)
    (λ h, (map_mk'_eq_top hNL).mp h),
end

open quotient_group

@[to_additive]
lemma maximal_normal_subgroup_iff (N : subgroup G) [N.normal] :
  maximal_normal_subgroup N ↔
  is_simple (quotient N) ∧ ¬ subsingleton (quotient N) :=
⟨λ hN, ⟨begin
  intro K, introI,
  have : N ≤ comap (mk' N) K, { simp only [←ker_mk N], exact ker_le_comap },
  refine (hN.2.2 (comap (mk' N) K) this).imp (λ h, _) (λ h, _),
  { conv_rhs at h { rw [←ker_mk N] }, exact comap_injective (mk'_surjective N) h },
  { rw [←comap_top (mk' N)] at h, exact comap_injective (mk'_surjective N) h },
end,
  λ h, hN.2.1 (subsingleton_quotient_iff.mp h)⟩,
λ ⟨h1, h2⟩, ⟨infer_instance, λ h, h2 (subsingleton_quotient_iff.mpr h), begin
    intro K, introI, intro hNK,
    refine (h1 _ (map_mk'_normal hNK)).imp (λ h, _) (λ h, _),
    { exact le_antisymm (ker_mk N ▸ le_ker_iff_map.mpr h)  hNK },
    { exact (map_mk'_eq_top hNK).mp h },
end⟩⟩

end subgroup


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Minchao Wu
-/
import order.synonym

/-!
# Lexicographic order

This file defines the lexicographic relation for pairs of orders, partial orders and linear orders.

## Main declarations

* `prod.lex.<pre/partial_/linear_>order`: Instances lifting the orders on `α` and `β` to `α ×ₗ β`.

## Notation

* `α ×ₗ β`: `α × β` equipped with the lexicographic order

## See also

Related files are:
* `data.finset.colex`: Colexicographic order on finite sets.
* `data.list.lex`: Lexicographic order on lists.
* `data.pi.lex`: Lexicographic order on `Πₗ i, α i`.
* `data.psigma.order`: Lexicographic order on `Σ' i, α i`.
* `data.sigma.order`: Lexicographic order on `Σ i, α i`.
-/

variables {α β γ : Type*}

namespace prod.lex

notation α ` ×ₗ `:35 β:34 := lex (prod α β)

meta instance [has_to_format α] [has_to_format β] : has_to_format (α ×ₗ β) :=
prod.has_to_format

instance decidable_eq (α β : Type*) [decidable_eq α] [decidable_eq β] : decidable_eq (α ×ₗ β) :=
prod.decidable_eq

instance inhabited (α β : Type*) [inhabited α] [inhabited β] : inhabited (α ×ₗ β) :=
prod.inhabited

/-- Dictionary / lexicographic ordering on pairs.  -/
instance has_le (α β : Type*) [has_lt α] [has_le β] : has_le (α ×ₗ β) :=
{ le := prod.lex (<) (≤) }

instance has_lt (α β : Type*) [has_lt α] [has_lt β] : has_lt (α ×ₗ β) :=
{ lt := prod.lex (<) (<) }

lemma le_iff [has_lt α] [has_le β] (a b : α × β) :
  to_lex a ≤ to_lex b ↔ a.1 < b.1 ∨ a.1 = b.1 ∧ a.2 ≤ b.2 := prod.lex_def (<) (≤)

lemma lt_iff [has_lt α] [has_lt β] (a b : α × β) :
  to_lex a < to_lex b ↔ a.1 < b.1 ∨ a.1 = b.1 ∧ a.2 < b.2 := prod.lex_def (<) (<)

/-- Dictionary / lexicographic preorder for pairs. -/
instance preorder (α β : Type*) [preorder α] [preorder β] : preorder (α ×ₗ β) :=
{ le_refl := by
  { haveI : is_refl β (≤) := ⟨le_refl⟩,
    exact refl_of (prod.lex _ _), },
  le_trans := λ _ _ _, by
  { haveI : is_trans α (<) := ⟨λ _ _ _, lt_trans⟩,
    haveI : is_trans β (≤) := ⟨λ _ _ _, le_trans⟩,
    exact trans_of (prod.lex _ _) },
  lt_iff_le_not_le := λ x₁ x₂, match x₁, x₂ with
  | to_lex (a₁, b₁), to_lex (a₂, b₂) := begin
      split,
      { rintros (⟨_, _, _, _, hlt⟩ | ⟨_, _, _, hlt⟩),
        { split,
          { left, assumption },
          { rintro ⟨l,r⟩,
            { apply lt_asymm hlt, assumption },
            { apply lt_irrefl _ hlt } } },
        { split,
          { right, rw lt_iff_le_not_le at hlt, exact hlt.1 },
          { rintro ⟨l,r⟩,
            { apply lt_irrefl a₁, assumption },
            { rw lt_iff_le_not_le at hlt, apply hlt.2, assumption } } } },
      { rintros ⟨⟨h₁ll, h₁lr⟩, h₂r⟩,
        { left, assumption },
        { right, rw lt_iff_le_not_le, split,
          { assumption },
          { intro h, apply h₂r, right, exact h } } }
    end
  end,
  .. prod.lex.has_le α β,
  .. prod.lex.has_lt α β }

/-- Dictionary / lexicographic partial_order for pairs. -/
instance partial_order (α β : Type*) [partial_order α] [partial_order β] : partial_order (α ×ₗ β) :=
{ le_antisymm := by
  { haveI : is_strict_order α (<) := { irrefl := lt_irrefl, trans := λ _ _ _, lt_trans },
    haveI : is_antisymm β (≤) := ⟨λ _ _, le_antisymm⟩,
    exact @antisymm _ (prod.lex _ _) _, },
  .. prod.lex.preorder α β }

/-- Dictionary / lexicographic linear_order for pairs. -/
instance linear_order (α β : Type*) [linear_order α] [linear_order β] : linear_order (α ×ₗ β) :=
{ le_total := total_of (prod.lex _ _),
  decidable_le := prod.lex.decidable _ _,
  decidable_lt := prod.lex.decidable _ _,
  decidable_eq := lex.decidable_eq _ _,
  .. prod.lex.partial_order α β }

end prod.lex


-- 5.8 Exercises
-- #1

-- 3.7 Exercises
-- #2

open classical

variables p q r s : Prop

example : (p → r ∨ s) → ((p → r) ∨ (p → s)) :=
begin
  intro h,
  cases (em r) with hr hnr,
    left,
    intro hp,
    assumption,
  cases (em s) with hs hns,
    right,
    intro hp,
    assumption,
  cases (em p) with hp hnp,
    have hrs : r ∨ s := h hp,
    cases hrs with hr hs,
      left,
      intro hp',
      assumption,
    right,
    intro hp',
    assumption,
  left,
  intro hp,
  exfalso,
  apply hnp,
  assumption,
end

example : ¬(p ∧ q) → ¬p ∨ ¬q :=
begin
  intro h,
  cases (em p) with hp hnp,
    cases (em q) with hq hnq,
      exfalso,
      exact h ⟨hp, hq⟩,
    right,
    assumption,
  left,
  assumption,
end

example : ¬(p → q) → p ∧ ¬q :=
begin
  intro h,
  cases (em p) with hp hnp,
    cases (em q) with hq hnq,
      exfalso,
      apply h,
      intro hp',
      assumption,
    exact ⟨hp, hnq⟩,
  exfalso,
  apply h,
  intro hp',
  contradiction,
end

example : (p → q) → (¬p ∨ q) :=
begin
  intro h,
  cases (em q) with hq hnq,
    right,
    assumption,
  cases (em p) with hp hnp,
    right,
    apply h,
    assumption,
  left,
  assumption,
end

example : (¬q → ¬p) → (p → q) :=
begin
  intros h hp,
  cases (em q) with hq hnq,
    assumption,
    have hnp : ¬ p := h hnq,
    contradiction,
end

example : p ∨ ¬p :=
begin
  exact em p,
end

example : (((p → q) → p) → p) :=
begin
  intro h,
  cases (em p) with hp hnp,
    assumption,
  apply h,
  intro hp,
  contradiction,
end


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import algebra.algebra.pi
import topology.locally_constant.basic

/-!
# Algebraic structure on locally constant functions

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

This file puts algebraic structure (`add_group`, etc)
on the type of locally constant functions.

-/

namespace locally_constant

variables {X Y : Type*} [topological_space X]

@[to_additive] instance [has_one Y] : has_one (locally_constant X Y) :=
{ one := const X 1 }

@[simp, to_additive] lemma coe_one [has_one Y] : ⇑(1 : locally_constant X Y) = (1 : X → Y) := rfl

@[to_additive] lemma one_apply [has_one Y] (x : X) : (1 : locally_constant X Y) x = 1 := rfl

@[to_additive] instance [has_inv Y] : has_inv (locally_constant X Y) :=
{ inv := λ f, ⟨f⁻¹ , f.is_locally_constant.inv⟩ }

@[simp, to_additive] lemma coe_inv [has_inv Y] (f : locally_constant X Y) : ⇑(f⁻¹) = f⁻¹ := rfl

@[to_additive]

@[to_additive] instance [has_mul Y] : has_mul (locally_constant X Y) :=
{ mul := λ f g, ⟨f * g, f.is_locally_constant.mul g.is_locally_constant⟩ }

@[simp, to_additive] lemma coe_mul [has_mul Y] (f g : locally_constant X Y) :
  ⇑(f * g) = f * g :=
rfl

@[to_additive] lemma mul_apply [has_mul Y] (f g : locally_constant X Y) (x : X) :
  (f * g) x = f x * g x := rfl

@[to_additive] instance [mul_one_class Y] : mul_one_class (locally_constant X Y) :=
{ one_mul := by { intros, ext, simp only [mul_apply, one_apply, one_mul] },
  mul_one := by { intros, ext, simp only [mul_apply, one_apply, mul_one] },
  .. locally_constant.has_one,
  .. locally_constant.has_mul }

/-- `coe_fn` is a `monoid_hom`. -/
@[to_additive "`coe_fn` is an `add_monoid_hom`.", simps]
def coe_fn_monoid_hom [mul_one_class Y] : locally_constant X Y →* (X → Y) :=
{ to_fun   := coe_fn,
  map_one' := rfl,
  map_mul' := λ _ _, rfl }

/-- The constant-function embedding, as a multiplicative monoid hom. -/
@[to_additive "The constant-function embedding, as an additive monoid hom.", simps]
def const_monoid_hom [mul_one_class Y] : Y →* locally_constant X Y :=
{ to_fun   := const X,
  map_one' := rfl,
  map_mul' := λ _ _, rfl, }

instance [mul_zero_class Y] : mul_zero_class (locally_constant X Y) :=
{ zero_mul := by { intros, ext, simp only [mul_apply, zero_apply, zero_mul] },
  mul_zero := by { intros, ext, simp only [mul_apply, zero_apply, mul_zero] },
  .. locally_constant.has_zero,
  .. locally_constant.has_mul }

instance [mul_zero_one_class Y] : mul_zero_one_class (locally_constant X Y) :=
{ .. locally_constant.mul_zero_class, .. locally_constant.mul_one_class }

section char_fn

variables (Y) [mul_zero_one_class Y] {U V : set X}

/-- Characteristic functions are locally constant functions taking `x : X` to `1` if `x ∈ U`,
  where `U` is a clopen set, and `0` otherwise. -/
noncomputable def char_fn (hU : is_clopen U) : locally_constant X Y := indicator 1 hU

lemma coe_char_fn (hU : is_clopen U) : (char_fn Y hU : X → Y) = set.indicator U 1 :=
rfl

lemma char_fn_eq_one [nontrivial Y] (x : X) (hU : is_clopen U) :
  char_fn Y hU x = (1 : Y) ↔ x ∈ U := set.indicator_eq_one_iff_mem _

lemma char_fn_eq_zero [nontrivial Y] (x : X) (hU : is_clopen U) :
  char_fn Y hU x = (0 : Y) ↔ x ∉ U := set.indicator_eq_zero_iff_not_mem _

lemma char_fn_inj [nontrivial Y] (hU : is_clopen U) (hV : is_clopen V)
  (h : char_fn Y hU = char_fn Y hV) : U = V :=
set.indicator_one_inj Y $ coe_inj.mpr h

end char_fn

@[to_additive] instance [has_div Y] : has_div (locally_constant X Y) :=
{ div := λ f g, ⟨f / g, f.is_locally_constant.div g.is_locally_constant⟩ }

@[to_additive] lemma coe_div [has_div Y] (f g : locally_constant X Y) :
  ⇑(f / g) = f / g := rfl

@[to_additive] lemma div_apply [has_div Y] (f g : locally_constant X Y) (x : X) :
  (f / g) x = f x / g x := rfl

@[to_additive] instance [semigroup Y] : semigroup (locally_constant X Y) :=
{ mul_assoc := by { intros, ext, simp only [mul_apply, mul_assoc] },
  .. locally_constant.has_mul }

instance [semigroup_with_zero Y] : semigroup_with_zero (locally_constant X Y) :=
{ .. locally_constant.mul_zero_class,
  .. locally_constant.semigroup }

@[to_additive] instance [comm_semigroup Y] : comm_semigroup (locally_constant X Y) :=
{ mul_comm := by { intros, ext, simp only [mul_apply, mul_comm] },
  .. locally_constant.semigroup }

@[to_additive] instance [monoid Y] : monoid (locally_constant X Y) :=
{ mul := (*),
  .. locally_constant.semigroup, .. locally_constant.mul_one_class }

instance [add_monoid_with_one Y] : add_monoid_with_one (locally_constant X Y) :=
{ nat_cast := λ n, const X n,
  nat_cast_zero := by ext; simp [nat.cast],
  nat_cast_succ := λ _, by ext; simp [nat.cast],
  .. locally_constant.add_monoid, .. locally_constant.has_one }

@[to_additive] instance [comm_monoid Y] : comm_monoid (locally_constant X Y) :=
{ .. locally_constant.comm_semigroup, .. locally_constant.monoid }

@[to_additive] instance [group Y] : group (locally_constant X Y) :=
{ mul_left_inv := by { intros, ext, simp only [mul_apply, inv_apply, one_apply, mul_left_inv] },
  div_eq_mul_inv := by { intros, ext, simp only [mul_apply, inv_apply, div_apply, div_eq_mul_inv] },
  .. locally_constant.monoid, .. locally_constant.has_inv, .. locally_constant.has_div }

@[to_additive] instance [comm_group Y] : comm_group (locally_constant X Y) :=
{ .. locally_constant.comm_monoid, .. locally_constant.group }

instance [distrib Y] : distrib (locally_constant X Y) :=
{ left_distrib := by { intros, ext, simp only [mul_apply, add_apply, mul_add] },
  right_distrib := by { intros, ext, simp only [mul_apply, add_apply, add_mul] },
  .. locally_constant.has_add, .. locally_constant.has_mul }

instance [non_unital_non_assoc_semiring Y] : non_unital_non_assoc_semiring (locally_constant X Y) :=
{ .. locally_constant.add_comm_monoid, .. locally_constant.has_mul,
  .. locally_constant.distrib, .. locally_constant.mul_zero_class }

instance [non_unital_semiring Y] : non_unital_semiring (locally_constant X Y) :=
{ .. locally_constant.semigroup, .. locally_constant.non_unital_non_assoc_semiring }

instance [non_assoc_semiring Y] : non_assoc_semiring (locally_constant X Y) :=
{ .. locally_constant.mul_one_class, .. locally_constant.add_monoid_with_one,
  .. locally_constant.non_unital_non_assoc_semiring }

/-- The constant-function embedding, as a ring hom.  -/
@[simps] def const_ring_hom [non_assoc_semiring Y] : Y →+* locally_constant X Y :=
{ to_fun    := const X,
  .. const_monoid_hom,
  .. const_add_monoid_hom, }

instance [semiring Y] : semiring (locally_constant X Y) :=
{ .. locally_constant.non_assoc_semiring, .. locally_constant.monoid }

instance [non_unital_comm_semiring Y] : non_unital_comm_semiring (locally_constant X Y) :=
{ .. locally_constant.non_unital_semiring, .. locally_constant.comm_semigroup }

instance [comm_semiring Y] : comm_semiring (locally_constant X Y) :=
{ .. locally_constant.semiring, .. locally_constant.comm_monoid }

instance [non_unital_non_assoc_ring Y] : non_unital_non_assoc_ring (locally_constant X Y) :=
{ .. locally_constant.add_comm_group, .. locally_constant.has_mul,
  .. locally_constant.distrib, .. locally_constant.mul_zero_class }

instance [non_unital_ring Y] : non_unital_ring (locally_constant X Y) :=
{ .. locally_constant.semigroup, .. locally_constant.non_unital_non_assoc_ring }

instance [non_assoc_ring Y] : non_assoc_ring (locally_constant X Y) :=
{ .. locally_constant.mul_one_class, .. locally_constant.non_unital_non_assoc_ring }

instance [ring Y] : ring (locally_constant X Y) :=
{ .. locally_constant.semiring, .. locally_constant.add_comm_group }

instance [non_unital_comm_ring Y] : non_unital_comm_ring (locally_constant X Y) :=
{ .. locally_constant.non_unital_comm_semiring, .. locally_constant.non_unital_ring }

instance [comm_ring Y] : comm_ring (locally_constant X Y) :=
{ .. locally_constant.comm_semiring, .. locally_constant.ring }

variables {R : Type*}

instance [has_smul R Y] : has_smul R (locally_constant X Y) :=
{ smul := λ r f,
  { to_fun := r • f,
    is_locally_constant := (f.is_locally_constant.comp ((•) r) : _), } }

@[simp] lemma coe_smul [has_smul R Y] (r : R) (f : locally_constant X Y) : ⇑(r • f) = r • f := rfl

lemma smul_apply [has_smul R Y] (r : R) (f : locally_constant X Y) (x : X) :
  (r • f) x = r • (f x) :=
rfl

instance [monoid R] [mul_action R Y] : mul_action R (locally_constant X Y) :=
function.injective.mul_action _ coe_injective (λ _ _, rfl)

instance [monoid R] [add_monoid Y] [distrib_mul_action R Y] :
  distrib_mul_action R (locally_constant X Y) :=
function.injective.distrib_mul_action coe_fn_add_monoid_hom coe_injective (λ _ _, rfl)

instance [semiring R] [add_comm_monoid Y] [module R Y] : module R (locally_constant X Y) :=
function.injective.module R coe_fn_add_monoid_hom coe_injective (λ _ _, rfl)

section algebra

variables [comm_semiring R] [semiring Y] [algebra R Y]

instance : algebra R (locally_constant X Y) :=
{ to_ring_hom := const_ring_hom.comp $ algebra_map R Y,
  commutes'   := by { intros, ext, exact algebra.commutes' _ _, },
  smul_def'   := by { intros, ext, exact algebra.smul_def' _ _, }, }

@[simp] lemma coe_algebra_map (r : R) :
  ⇑(algebra_map R (locally_constant X Y) r) = algebra_map R (X → Y) r :=
rfl

end algebra

end locally_constant


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

/-!
# Finite intervals in a sigma type

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

This file provides the `locally_finite_order` instance for the disjoint sum of orders `Σ i, α i` and
calculates the cardinality of its finite intervals.

## TODO

Do the same for the lexicographical order
-/

open finset function

namespace sigma
variables {ι : Type*} {α : ι → Type*}

/-! ### Disjoint sum of orders -/

section disjoint
variables [decidable_eq ι] [Π i, preorder (α i)] [Π i, locally_finite_order (α i)]

instance : locally_finite_order (Σ i, α i) :=
{ finset_Icc := sigma_lift (λ _, Icc),
  finset_Ico := sigma_lift (λ _, Ico),
  finset_Ioc := sigma_lift (λ _, Ioc),
  finset_Ioo := sigma_lift (λ _, Ioo),
  finset_mem_Icc := λ ⟨i, a⟩ ⟨j, b⟩ ⟨k, c⟩, begin
    simp_rw [mem_sigma_lift, le_def, mem_Icc, exists_and_distrib_left, ←exists_and_distrib_right,
      ←exists_prop],
    exact bex_congr (λ _ _, by split; rintro ⟨⟨⟩, ht⟩; exact ⟨rfl, ht⟩),
  end,
  finset_mem_Ico := λ ⟨i, a⟩ ⟨j, b⟩ ⟨k, c⟩, begin
    simp_rw [mem_sigma_lift, le_def, lt_def, mem_Ico, exists_and_distrib_left,
      ←exists_and_distrib_right, ←exists_prop],
    exact bex_congr (λ _ _, by split; rintro ⟨⟨⟩, ht⟩; exact ⟨rfl, ht⟩),
  end,
  finset_mem_Ioc := λ ⟨i, a⟩ ⟨j, b⟩ ⟨k, c⟩, begin
    simp_rw [mem_sigma_lift, le_def, lt_def, mem_Ioc, exists_and_distrib_left,
      ←exists_and_distrib_right, ←exists_prop],
    exact bex_congr (λ _ _, by split; rintro ⟨⟨⟩, ht⟩; exact ⟨rfl, ht⟩),
  end,
  finset_mem_Ioo := λ ⟨i, a⟩ ⟨j, b⟩ ⟨k, c⟩, begin
    simp_rw [mem_sigma_lift, lt_def, mem_Ioo, exists_and_distrib_left, ←exists_and_distrib_right,
      ←exists_prop],
    exact bex_congr (λ _ _, by split; rintro ⟨⟨⟩, ht⟩; exact ⟨rfl, ht⟩),
  end }

section
variables (a b : Σ i, α i)

lemma card_Icc : (Icc a b).card = if h : a.1 = b.1 then (Icc (h.rec a.2) b.2).card else 0 :=
card_sigma_lift _ _ _

lemma card_Ioc : (Ioc a b).card = if h : a.1 = b.1 then (Ioc (h.rec a.2) b.2).card else 0 :=
card_sigma_lift _ _ _

lemma card_Ioo : (Ioo a b).card = if h : a.1 = b.1 then (Ioo (h.rec a.2) b.2).card else 0 :=
card_sigma_lift _ _ _

end

variables (i : ι) (a b : α i)

@[simp] lemma Icc_mk_mk : Icc (⟨i, a⟩ : sigma α) ⟨i, b⟩ = (Icc a b).map (embedding.sigma_mk i) :=
dif_pos rfl

@[simp] lemma Ico_mk_mk : Ico (⟨i, a⟩ : sigma α) ⟨i, b⟩ = (Ico a b).map (embedding.sigma_mk i) :=
dif_pos rfl

@[simp] lemma Ioc_mk_mk : Ioc (⟨i, a⟩ : sigma α) ⟨i, b⟩ = (Ioc a b).map (embedding.sigma_mk i) :=
dif_pos rfl

@[simp] lemma Ioo_mk_mk : Ioo (⟨i, a⟩ : sigma α) ⟨i, b⟩ = (Ioo a b).map (embedding.sigma_mk i) :=
dif_pos rfl

end disjoint
end sigma


import inner_product_spaces.real_ip.ip_normed_space

noncomputable theory

section
variables {α : Type*}
variables [decidable_eq α] [add_comm_group α] [vector_space ℝ α] [ℝ_inner_product_space α]

open real

local attribute [instance] classical.prop_decidable

theorem ip_parallelogram_law (x y : α) : ∥x+y∥^2+∥x-y∥^2=2*∥x∥^2+2*∥y∥^2 :=
begin
    repeat {rw [sqr_norm]},
    simp,
    rw [←neg_one_smul ℝ, mul_right],
    ring,
end

class ℝ_parallelopotamus (β : Type*) [normed_space ℝ β] :=
(parallelogram_law : ∀ (x y : β), ∥x+y∥^2+∥x-y∥^2=2*∥x∥^2+2*∥y∥^2)

variables {β : Type*}
variables [decidable_eq β] [normed_space ℝ β] [ℝ_parallelopotamus β]

lemma par_law (x y : β) : ∥x+y∥^2 + ∥x-y∥^2 = 2*∥x∥^2+2*∥y∥^2 :=
by apply ℝ_parallelopotamus.parallelogram_law

lemma par_law' (x y : β) : ∥x+y∥^2 = 2*∥x∥^2 + 2*∥y∥^2 - ∥x-y∥^2 :=
begin
    rw [←add_zero (∥x+y∥^2), ←add_right_neg (∥x-y∥^2), ←add_assoc, sub_eq_add_neg _ (∥x-y∥^2)],
    apply congr_arg (λ r, r + -(∥x-y∥^2)),
    exact par_law x y,
end

instance par_has_inner_product : has_ℝ_inner_product β :=
⟨λ x y, 1/4*(∥x+y∥^2 - ∥x-y∥^2)⟩

lemma nonneg_norm {a : ℝ} {h : a ≥ 0} : ∥a∥ = a :=
by {dsimp [norm], rw [←real.sqrt_sqr_eq_abs, real.sqrt_sqr h]}

lemma neg_norm {a : ℝ} {h : a < 0} : ∥a∥ = -a :=
by {dsimp [norm],
    rw [←abs_neg],
    exact @nonneg_norm _ (le_of_lt (neg_pos_of_neg h))}

set_option class.instance_max_depth 100
lemma norm_sq_eq_norm_sqr (x : β) : ⟪x ∥ x⟫ = ∥x∥^2 :=
begin
    dsimp [inner_product],
    simp,
    have l : (1 : ℝ) + 1 = 2 := rfl,
    have h : x + x = (2 : ℝ) • x := begin
        rw [←one_smul ℝ x, ←add_smul, one_smul],
        have w : (1 : ℝ) + 1 = 2 := rfl,
        rw [w],
    end,
    have w : ((0 : ℝ) ^2) = 0 := by {rw [pow_two, mul_zero]},
    rw [w, neg_zero, zero_add, h, norm_smul, pow_two, @nonneg_norm 2 (by linarith),
    ←pow_two, mul_pow],
    have k : (2 : ℝ)^2 = (4 : ℝ) := begin
        have k₁ : 2^2 = 4 := rfl,
        have k₂ := congr_arg (λ (n : ℕ), (n : ℝ)) k₁,
        simp at k₂,
        exact k₂,
    end,
    rw [k, ←mul_assoc, inv_mul_cancel, one_mul],

    exact four_ne_zero,
end

lemma par_pos_def (x : β) (h : x ≠ (0 : β)) : ⟪x ∥ x⟫ > (0 : ℝ) :=
by {rw [norm_sq_eq_norm_sqr, pow_two],
    exact mul_pos ((norm_pos_iff x).2 h) ((norm_pos_iff x).2 h)}

lemma par_conj_symm (x y : β) : ⟪x ∥ y⟫ = ⟪y ∥ x⟫ :=
begin
    dsimp [inner_product],
    simp,
    have w : x+-y = -(y+-x) := by simp,
    rw [w, ←neg_one_smul ℝ (y+-x), norm_smul],
    have k := @neg_norm (-1) (by linarith),
    rw [neg_neg] at k,
    rw [k, one_mul],
end

-- Scott: so what's the plan here?
-- How many applications of the parallelogram axiom are required?
lemma par_add_law {x y z : β} : ∥x+y+z∥^2 = ∥x+y∥^2 + ∥x+z∥^2 + ∥y+z∥^2 - ∥x∥^2 - ∥y∥^2 - ∥z∥^2 :=
begin
    dsimp [inner_product],
    sorry
end

lemma par_add_in_fst_coord {x y z : β} : ⟪x+y ∥ z⟫ = ⟪x ∥ z⟫ + ⟪y ∥ z⟫ :=
begin
    dsimp [inner_product],
    rw [par_add_law, par_add_law, ←left_distrib],
    apply congr_arg (λ (r : ℝ), 1/4*r),
    simp,
    ring,
end

@[simp] lemma par_right_orthog_to_zero {x : β} : ⟪0 ∥ x⟫ = 0 :=
by {dsimp [inner_product], simp}

@[simp] lemma par_left_orthog_to_zero {x : β} : ⟪x ∥ 0⟫ = 0 :=
by {rw [par_conj_symm], exact par_right_orthog_to_zero}

lemma par_smul_nat (x z : β) (n : ℕ) : ⟪(n : ℝ) • x ∥ z⟫ = (n : ℝ) * ⟪x ∥ z⟫ :=
by {induction n, {simp}, {rw [nat.cast_succ, add_smul, one_smul, par_add_in_fst_coord, n_ih,
    ←one_mul ⟪x ∥ z⟫, ←mul_assoc, ←right_distrib, mul_one, one_mul]}}

lemma par_smul_neg {x z : β} : ⟪-x ∥ z⟫ = -⟪x ∥ z⟫ :=
begin
    dsimp [inner_product],
    simp,
    ring,
    have w₁ : -x-z = -(x+z) := by simp,
    rw [w₁, ←neg_one_smul ℝ (x+z), norm_smul, neg_norm, neg_neg, one_mul],
    have w₂ : ∥x + z∥ ^ 2 - ∥x - z∥ ^ 2 = -(∥z - x∥ ^ 2 - ∥x + z∥ ^ 2) := begin
        simp,
        have w₂ : x+-z = -(z+-x) := by simp,
        rw [w₂, ←neg_one_smul ℝ _, norm_smul, neg_norm, neg_neg, one_mul],
        linarith,
    end,
    rw [w₂],
    ring,
    linarith,
end

lemma par_smul_int {x z : β} (n : ℤ) : ⟪(n : ℝ) • x ∥ z⟫ = (n : ℝ) * ⟪x ∥ z⟫ :=
by {cases n, {rw [int.cast_of_nat], exact par_smul_nat x z n},
    {rw [int.cast_neg_succ_of_nat, neg_add_rev, ←neg_one_mul, ←neg_one_mul ↑n,
    ←left_distrib, ←smul_smul, neg_one_smul, par_smul_neg, ←neg_one_mul, mul_assoc],
    apply congr_arg (λ (r : ℝ), (-1)*r),
    rw [←nat.cast_one, ←nat.cast_add],
    exact par_smul_nat x z (1+n)}}

lemma rat_mul_denom_eq_num (q : ℚ) : q * q.denom = q.num :=
begin
    rw [rat.num_denom q],
    sorry,
end

lemma par_smul_rat {x z : β} (r : ℚ) : ⟪(r : ℝ) • x ∥ z⟫ = (r : ℝ) * ⟪x ∥ z⟫ :=
begin
    let p := r.num,
    have ph : p = r.num := rfl,
    let q := r.denom,
    have qh : q = r.denom := rfl,
    let h := r.pos,

    rw [←qh] at h,
    have w := @par_smul_nat _ _ _ _ ((r : ℝ) • x) z q,
    have w₁ : ↑(r.denom) * ↑(rat.mk (r.num) ↑(r.denom)) = ↑r.num := sorry,
    conv at w {to_lhs, rw [rat.num_denom r, qh, ←mul_smul, w₁]},
    repeat {sorry},
end

lemma par_smul_real {x z : β} (r : ℝ) : ⟪r • x ∥ z⟫ = r * ⟪x ∥ z⟫ :=
begin
    sorry,
end

lemma par_linearity (x y z : β) (a : ℝ) : ⟪a•x+y ∥ z⟫ = a*⟪x ∥ z⟫ + ⟪y ∥ z⟫ :=
by {rw [par_add_in_fst_coord, par_smul_real]}

instance par_is_ip_space : ℝ_inner_product_space β :=
{conj_symm := par_conj_symm, linearity := par_linearity, pos_def := par_pos_def}

end


section Logic
  -- Basics
  -- assumption(s) `|-` goal(s)

  -- `Prop` = a True/False statement
  variable (P Q R : Prop)

  /- Tactics:
    * `intro` = assume, introduce an hypothesis
    * `exact` = use exactly the assumption to solve the proof
    * `apply` = "argues backwards", works with implication (P → Q)
                (and use it to REDUCE the "goal" closer to hypothesis)
            eg.: if `|- Q` doing `apply h` (h : P → Q) reduces the goals to to `|- P`
              like saying "because of `h` it is enough to prove this new simpler thing"
  -/
  /-
    Writing `hp : P` means (one of the following):
    - `hp` is a proof of `P`
    - `hp` is the assumption that `P` is true
    - `P` is true and this fact is called `hp`
    *** `hp : P` and `P : Prop` are different! The latter means `P`is a true/false statement
  -/
  -- Examples from the online workbook
  section examples
    -- `P` `Q` and `R` are all true. Deduce `P` is true
    example (hP: P)(hQ: Q)(hR :R) : P := by
      exact hP -- I use the exact tactic when the assumption cover the goal

    -- Assume `Q` is true. Prove that `P → Q`.
    example (hQ : Q) : P → Q := by
      -- The goal is of the form `X → Y` so we can use `intro`
      intro h -- now `h` is the hypothesis that `P` is true.
      -- Our goal is now the same as a hypothesis so we can use `exact`
      exact hQ

    -- Assume `P → Q` and `P` is true. Deduce `Q`.
    example (h : P → Q) (hP : P) : Q := by
      apply h  -- goal is `⊢ Q` which matches with the conclusion of `h`
      exact hP -- now the goal is changed to `P` that is one of the assumptions

  end examples

  section exercises  -- my turn ...
    -- Every proposition implies itself
    example : P → P := by
      intro p
      apply p

    /-- If we know `P`, and we also know `P → Q`, we can deduce `Q`.
    This is called "Modus Ponens" by logicians. -/
    example : P → (P → Q) → Q := by
      intro hP
      intro hPQ
      apply hPQ
      exact hP

    /-- `→` is transitive. That is, if `P → Q` and `Q → R` are true, then
      so is `P → R`. -/
    example : (P → Q) → (Q → R) → (P → R) := by
      intro hPQ
      intro hQR
      intro hP
      apply hQR
      apply hPQ
      exact hP

    -- If `h : P → Q → R` with goal `⊢ R` and you `apply h`, you'll get
    -- two goals! Note that tactics operate on only the first goal.
    example : (P → Q → R) → (P → Q) → (P → R) := by
      intro hPQR -- P → Q → R
      intro hPQ  -- P → Q
      intro hP   -- P ⊢ R
      apply hPQR -- goal 1: R ⊢ P
      exact hP
      apply hPQ  -- goal 2: Q ⊢ P
      exact hP

  end exercises

  section hardOnes
    variable (S T : Prop)

    example : (P → R) → (S → Q) → (R → T) → (Q → R) → S → T := by
      intro hPR
      intro hSQ
      intro hRT
      intro hQR
      intro hS
      apply hRT
      apply hQR
      apply hSQ
      exact hS

    example : (P → Q) → ((P → Q) → P) → Q := by
      intro hPQ
      intro hPQP
      apply hPQ
      apply hPQP
      exact hPQ

    example : ((P → Q) → R) → ((Q → R) → P) → ((R → P) → Q) → P := by
      intro hPQR
      intro hQRP
      intro hRPQ
      apply hQRP
      intro hQ
      apply hPQR
      intro hP
      apply hRPQ
      intro hR
      apply hP

    example : ((Q → P) → P) → (Q → R) → (R → P) → P := by
      intro hQPP
      intro hQR
      intro hRP
      apply hQPP
      intro hQ
      apply hRP
      apply hQR
      apply hQ

    example : (((P → Q) → Q) → Q) → (P → Q) := by
      intros hPQQQ hP
      apply hPQQQ
      intro hPQ
      apply hPQ
      apply hP

    example :
      (((P → Q → Q) → ((P → Q) → Q)) → R) →
      ((((P → P) → Q) → (P → P → Q)) → R) →
      (((P → P → Q) → ((P → P) → Q)) → R) → R := by
        intros hPQQ_PQQ_R PPQ_PPQ_R PPQ_PPQ_R₂
        apply hPQQ_PQQ_R
        intro hPQQ hPQ
        apply hPQ
        sorry

  end hardOnes
end Logic


import tactic.fin_cases
import logic.function
import data.nat.basic

namespace list
  open well_founded_tactics

  -- sizeof_lt_sizeof_of_mem, map_wf, map_wf_eq_map courtesy of Sebastian Ullrich
  lemma sizeof_lt_sizeof_of_mem {α} [has_sizeof α] {a : α} : ∀ {l : list α}, a ∈ l → sizeof a < sizeof l
  | []      h := absurd h (not_mem_nil _)
  | (b::bs) h :=
  begin
    cases eq_or_mem_of_mem_cons h with h_1 h_2,
    subst h_1,
    { unfold_sizeof, cancel_nat_add_lt, trivial_nat_lt },
    { have aux₁ := sizeof_lt_sizeof_of_mem h_2,
      unfold_sizeof,
      exact nat.lt_add_left _ _ _ (nat.lt_add_left _ _ _ aux₁) }
  end

  def map_wf {α β : Type*} [has_sizeof α] (xs : list α) (f : Π (a : α), (sizeof a < 1 + sizeof xs) → β) : list β :=
  xs.attach.map (λ p, have sizeof p.val < 1 + sizeof xs,
                        from nat.lt_add_left _ _ _ (list.sizeof_lt_sizeof_of_mem p.property),
                      f p.val this)

  lemma map_wf_eq_map {α β : Type*} [has_sizeof α] {xs : list α} {f : α → β} : map_wf xs (λ a _, f a) = map f xs :=
  by simp only [map_wf, attach, map_pmap, pmap_eq_map]

  lemma sizeof_filter_le_sizeof {α : Type*} (p : α → Prop) [decidable_pred p] (xs : list α) : list.sizeof (filter p xs) <= list.sizeof xs :=
  begin
    induction xs,
    { rw list.filter_nil },
    by_cases p xs_hd,
    { rw filter_cons_of_pos xs_tl h,
      unfold_sizeof,
      assumption },
    { rw filter_cons_of_neg xs_tl h,
      unfold_sizeof,
      exact le_add_left xs_ih }
  end

  lemma all_map_bool_iff_all {α : Type*} (p : α → bool) (xs : list α) : list.all (list.map p xs) id ↔ list.all xs p :=
  begin
    simp only [all_iff_forall, and_imp, id.def, mem_map, exists_imp_distrib],
    split;
    intro h,
    { intros a a_in_xs,
      cases h' : p a;
      exact h _ a a_in_xs h' },
    intros b a a_in_xs h',
    exact h'.subst (h a a_in_xs)
  end

  def group {α : Type*} [p : setoid α] [decidable_rel p.r] : list α → list (list α)
  | []        := []
  | (x :: xs) := have list.sizeof (filter (not ∘ (≈ x)) xs) < 1 + list.sizeof xs, from
    begin
      have h : list.sizeof (filter (not ∘ (≈ x)) xs) ≤ list.sizeof xs, from sizeof_filter_le_sizeof _ xs,
      rw nat.add_comm,
      rw ←nat.succ_eq_add_one,
      rwa nat.lt_succ_iff
    end, (x :: filter (≈ x) xs) :: group (filter (not ∘ (≈ x)) xs)

  lemma sizeof_lt_of_length_lt {α : Type*} {xs ys : list α} (h : length xs < length ys) : list.sizeof xs < list.sizeof ys :=
  begin
    induction xs generalizing ys,
    { induction ys;
      unfold_sizeof,
      { exact absurd h (lt_irrefl (length nil)) },
      induction ys_tl;
      unfold_sizeof,
      { exact zero_lt_one },
      exact nat.zero_lt_one_add (list.sizeof ys_tl_tl) },
    induction ys;
    unfold_sizeof,
    { simp only [add_comm, length] at h,
      exact false.elim (nat.not_succ_le_zero (1 + length xs_tl) h) },
    simp only [add_comm, length, add_lt_add_iff_left] at h,
    exact xs_ih h
  end

  @[elab_as_eliminator] def strong_induction_on {α : Type*} {p : list α → Sort*} :
    ∀ xs : list α, (∀ xs, (∀ ys, length ys < length xs → p ys) → p xs) → p xs
  | xs := λ ih, ih xs (λ ys h1,
    have list.sizeof ys < list.sizeof xs, from sizeof_lt_of_length_lt h1,
    strong_induction_on ys ih)

  lemma length_filter_le_length {α : Type*} (p : α → Prop) [decidable_pred p] (xs : list α) :
    length (filter p xs) <= length xs :=
  length_le_of_sublist (filter_sublist xs)

  lemma filter_append_not_filter_perm {α : Type*} (p : α → Prop) [decidable_pred p] (xs : list α) :
    filter p xs ++ filter (not ∘ p) xs ~ xs :=
  begin
    letI := classical.dec_eq α,
    rw perm_iff_count,
    intro a,
    induction xs,
    { simp only [filter_nil, append_nil] },
    by_cases p xs_hd,
    { rw filter_cons_of_pos xs_tl h,
      rw @filter_cons_of_neg _ (not ∘ p) _ _ xs_tl (non_contradictory_intro h),
      simp only [cons_append, count_cons'],
      apply congr_arg (+ ite (a = xs_hd) 1 0),
      assumption },
    { rw @filter_cons_of_pos _ (not ∘ p) _ _ xs_tl h,
      rw filter_cons_of_neg xs_tl h,
      simp only [count_append, count_cons'],
      rw ←add_assoc,
      apply congr_arg (+ ite (a = xs_hd) 1 0),
      rwa ←count_append }
  end

  lemma length_filter_lt_length_cons {α : Type*} (p : α → Prop) [decidable_pred p] (x : α) (xs : list α) :
    length (filter p xs) < length (x :: xs) :=
  calc length (filter p xs)
        ≤ length xs        : length_filter_le_length _ xs
    ... < length (x :: xs) : by simp only [lt_add_iff_pos_left, add_comm, length, nat.zero_lt_one]

  lemma join_group_perm {α : Type*} [p : setoid α] [decidable_rel p.r] (xs : list α) : join (group xs) ~ xs :=
  begin
    letI := classical.dec_eq α,
    induction xs using list.strong_induction_on with xs ih,
    cases xs,
    { simp only [group, join] },
    rw perm_iff_count,
    intro a,
    simp only [group, cons_append, join, count_cons'],
    apply congr_arg (+ ite (a = xs_hd) 1 0),
    simp only [count_append],
    simp only [] at ih,
    replace ih := ih (filter (not ∘ (≈ xs_hd)) xs_tl),
    have h : length (filter (not ∘ (≈ xs_hd)) xs_tl) < length (xs_hd :: xs_tl),
    { exact length_filter_lt_length_cons _ xs_hd xs_tl },
    have perm, from ih h,
    rw perm_iff_count at perm,
    rw perm a,
    rw ←count_append,
    revert a,
    rw ←perm_iff_count,
    exact filter_append_not_filter_perm (≈ xs_hd) xs_tl
  end

  lemma group_equiv {α : Type*} [p : setoid α] [decidable_rel p.r] {xs : list α} :
    ∀ g ∈ group xs, ∀ x y ∈ g, x ≈ y :=
  begin
    intros g g_group x y x_in_g y_in_g,
    induction xs using list.strong_induction_on with xs ih,
    cases xs,
    { simp only [group, not_mem_nil] at g_group,
      contradiction },
    simp only [group, mem_cons_iff] at g_group,
    cases g_group,
    { rw g_group at *,
      simp only [mem_cons_iff, mem_filter] at x_in_g y_in_g,
      cases x_in_g,
      { rw x_in_g,
        cases y_in_g,
        { rw y_in_g },
        { symmetry,
          exact y_in_g.right } },
      { cases y_in_g,
        { rw ←y_in_g at x_in_g,
          exact x_in_g.right },
        { transitivity,
          { exact x_in_g.right },
          { symmetry,
            exact y_in_g.right } } } },
    exact ih _ (length_filter_lt_length_cons _ xs_hd xs_tl) g_group
  end

  lemma nil_not_mem_group {α : Type*} [p : setoid α] [decidable_rel p.r] (xs : list α)
    : [] ∉ group xs :=
  begin
    induction xs using list.strong_induction_on with xs ih,
    cases xs,
    { simp only [group], exact not_mem_nil nil },
    simp only [group, mem_cons_iff],
    rw not_or_distrib,
    simp only [true_and, not_false_iff],
    exact ih (filter (not ∘ λ (_x : α), _x ≈ xs_hd) xs_tl) (length_filter_lt_length_cons _ xs_hd xs_tl)
  end

  lemma group_equiv_disjoint' {α : Type*} [p : setoid α] [decidable_rel p.r] (xs : list α) :
    ∀ g1 g2 ∈ group xs, (∀ x1 ∈ g1, ∀ x2 ∈ g2, x1 ≈ x2) → g1 = g2 :=
  begin
    intros g1 g2 g1_group g2_group h,
    induction xs using list.strong_induction_on with xs ih,
    cases xs,
    { simp only [group, not_mem_nil] at g1_group,
      contradiction },
    simp only [group, mem_cons_iff] at g1_group g2_group,
    cases g1_group,
    { rw g1_group at *,
      cases g2_group,
      { rw g2_group at * },
      { cases g2,
        { exact absurd g2_group (nil_not_mem_group _) },
        have h3 : ∃ l, l ∈ group (filter (not ∘ λ (_x : α), _x ≈ xs_hd) xs_tl) ∧ g2_hd ∈ l,
        from ⟨g2_hd :: g2_tl, ⟨g2_group, mem_cons_self g2_hd g2_tl⟩⟩,
        replace h3 := mem_join.mpr h3,
        rw mem_of_perm (join_group_perm _) at h3,
        replace h3 := of_mem_filter h3,
        simp only [function.comp_app] at h3,
        have h4 : g2_hd ≈ xs_hd,
        { symmetry,
          exact h xs_hd (mem_cons_self xs_hd _) g2_hd (mem_cons_self g2_hd g2_tl) },
        contradiction } },
    cases g2_group,
    rw g2_group at *,
    { cases g1,
      { exact absurd g1_group (nil_not_mem_group _) },
      have h3 : ∃ l, l ∈ group (filter (not ∘ λ (_x : α), _x ≈ xs_hd) xs_tl) ∧ g1_hd ∈ l,
      from ⟨g1_hd :: g1_tl, ⟨g1_group, mem_cons_self g1_hd g1_tl⟩⟩,
      replace h3 := mem_join.mpr h3,
      rw mem_of_perm (join_group_perm _) at h3,
      replace h3 := of_mem_filter h3,
      simp only [function.comp_app] at h3,
      have h4 : g1_hd ≈ xs_hd, from h g1_hd (mem_cons_self g1_hd g1_tl) xs_hd (mem_cons_self xs_hd _),
      contradiction },
    exact ih _ (length_filter_lt_length_cons _ xs_hd xs_tl) g1_group g2_group
  end

  section group_equiv_disjoint
    local attribute [instance] classical.prop_decidable
    lemma group_equiv_disjoint {α : Type*} [p : setoid α] [d : decidable_rel p.r] (xs : list α) :
      ∀ g1 g2 ∈ group xs, g1 ≠ g2 → ∀ x1 ∈ g1, ∀ x2 ∈ g2, ¬(x1 ≈ x2) :=
    begin
      intros g1 g2 g1_group g2_group,
      contrapose,
      simp only [and_imp, not_imp, not_not, exists_imp_distrib, not_forall],
      intros x1 x1_in_g1 x2 x2_in_g2 h,
      suffices g : ∀ x1 ∈ g1, ∀ x2 ∈ g2, x1 ≈ x2,
      { exact group_equiv_disjoint' xs g1 g2 g1_group g2_group g },
      intros y1 y1_in_g1 y2 y2_in_g2,
      calc y1 ≈ x1 : group_equiv g1 g1_group y1 x1 y1_in_g1 x1_in_g1
          ... ≈ x2 : h
          ... ≈ y2 : group_equiv g2 g2_group x2 y2 x2_in_g2 y2_in_g2
    end
  end group_equiv_disjoint

  lemma nodup_perm_group {α : Type*} [decidable_eq α] [p : setoid α] [decidable_rel p.r] (xs : list α) :
    pairwise (λ a b, ¬(a ~ b)) (group xs) :=
  begin
    induction xs using list.strong_induction_on with xs ih,
    cases xs,
    { simp only [group],
      exact pairwise.nil },
    simp only [group, pairwise_cons],
    split,
    { intros a h h',
      have h2 : ∃ l, l ∈ group (filter (not ∘ λ (_x : α), _x ≈ xs_hd) xs_tl) ∧ xs_hd ∈ l,
      { use a,
        split,
        { assumption },
        rw mem_of_perm h'.symm,
        exact mem_cons_self xs_hd _ },
      replace h2 := mem_join.mpr h2,
      rw mem_of_perm (join_group_perm _) at h2,
      replace h2 := of_mem_filter h2,
      simp only [function.comp_app] at h2,
      exact absurd (setoid.refl xs_hd) h2 },
    exact ih _ (length_filter_lt_length_cons _ xs_hd xs_tl)
  end

  lemma nodup_group {α : Type*} [decidable_eq α] [p : setoid α] [decidable_rel p.r] (xs : list α) :
    nodup (group xs) :=
  begin
    have h, from nodup_perm_group xs,
    unfold nodup,
    have h' : ∀ a b, (λ (a b : list α), ¬a ~ b) a b → ne a b,
    { intros a b h' a_eq_b,
      rw a_eq_b at h',
      exact h' (setoid.refl b) },
    exact pairwise.imp h' h
  end

  lemma pairwise_equiv_disjoint_group {α : Type*} [decidable_eq α] [p : setoid α] [decidable_rel p.r] (xs : list α) :
    pairwise (λ g1 g2 : list α, ∀ x1 ∈ g1, ∀ x2 ∈ g2, ¬(x1 ≈ x2)) (group xs) :=
  begin
    have h, from nodup_perm_group xs,
    suffices h' : ∀ g1 g2, g1 ∈ group xs → g2 ∈ group xs → ¬(g1 ~ g2) → ∀ x1 ∈ g1, ∀ x2 ∈ g2, ¬(x1 ≈ x2),
    { exact pairwise.imp_of_mem h' h },
    intros g1 g2 g1_group g2_group g1_not_perm_g2,
    have g1_neq_g2 : g1 ≠ g2,
    { intro h',
      rw h' at g1_not_perm_g2,
      exact absurd (setoid.refl g2) g1_not_perm_g2 },
    exact group_equiv_disjoint xs g1 g2 g1_group g2_group g1_neq_g2
  end

  lemma pairwise_disjoint_group {α : Type*} [decidable_eq α] [p : setoid α] [decidable_rel p.r] (xs : list α) :
    pairwise disjoint (group xs) :=
  begin
    have h, from pairwise_equiv_disjoint_group xs,
    suffices h' : ∀ g1 g2 : list α, (∀ (x1 : α), x1 ∈ g1 → ∀ (x2 : α), x2 ∈ g2 → ¬x1 ≈ x2) → disjoint g1 g2,
    { exact pairwise.imp h' h },
    intros g1 g2 h',
    unfold disjoint,
    intros a a_in_g1 a_in_g2,
    exact absurd (setoid.refl a) (h' a a_in_g1 a a_in_g2)
  end

  lemma group_perm_iff_group_sub {α : Type*} [p : setoid α] [decidable_rel p.r] (xs ys : list α) :
    group xs ~ group ys ↔ group xs ⊆ group ys ∧ group ys ⊆ group xs :=
  begin
    letI := classical.dec_eq α,
    split,
    { intro h,
      exact ⟨perm_subset h, perm_subset h.symm⟩ },
    rintro ⟨xs_sub_ys, ys_sub_xs⟩,
    rw perm_iff_count,
    intro g,
    have h1, from nat.of_le_succ (nodup_iff_count_le_one.mp (nodup_group xs) g),
    have h2, from nat.of_le_succ (nodup_iff_count_le_one.mp (nodup_group ys) g),
    rw le_zero_iff_eq at h1 h2,
    cases h1,
    { cases h2,
      { rw h1, rw h2 },
      { replace h1 := not_mem_of_count_eq_zero h1,
        replace h2 := count_pos.mp (h2.symm.subst nat.zero_lt_one),
        rw subset_def at ys_sub_xs,
        exact absurd (ys_sub_xs h2) h1 } },
    { cases h2,
      { replace h1 := count_pos.mp (h1.symm.subst nat.zero_lt_one),
        replace h2 := not_mem_of_count_eq_zero h2,
        rw subset_def at ys_sub_xs,
        exact absurd (xs_sub_ys h1) h2 },
      { rw h1, rw h2 } }
  end

  lemma filter_equiv_mem_group {α : Type*} [p : setoid α] [decidable_rel p.r] {x : α} {xs : list α} (h : x ∈ xs) :
    filter (≈ x) xs ∈ group xs :=
  begin
    induction xs using list.strong_induction_on with xs ih,
    cases xs,
    { simp only [not_mem_nil] at h, contradiction },
    simp only [group, mem_cons_iff],
    by_cases h_equiv : xs_hd ≈ x,
    { apply or.inl,
      have g : ∀ y ∈ xs_tl, y ≈ xs_hd ↔ y ≈ x,
      { intros y y_in_tl,
        split;
        intro g,
        { transitivity, exact g, exact h_equiv },
        { transitivity, exact g, exact (setoid.symm h_equiv) } },
      rw filter_congr g,
      apply filter_cons_of_pos,
      assumption },
    apply or.inr,
    rw @filter_cons_of_neg _ (λ y, y ≈ x) _ xs_hd xs_tl h_equiv,
    simp only [mem_cons_iff] at h,
    cases h,
    { rw h at h_equiv,
      exact absurd (setoid.refl xs_hd) h_equiv },
    have h' : x ∈ filter (not ∘ λ (_x : α), _x ≈ xs_hd) xs_tl,
    { apply mem_filter_of_mem h,
      simp only [function.comp_app],
      intro h',
      exact absurd (setoid.symm h') h_equiv },
    have g, from ih _ (length_filter_lt_length_cons _ xs_hd xs_tl) h',
    rw filter_filter at g,
    simp only [function.comp_app] at g,
    have g' : ∀ y ∈ xs_tl, (y ≈ x ∧ ¬y ≈ xs_hd) ↔ y ≈ x,
    { intros y y_in_tl,
      split,
      { intro h'',
        exact h''.left },
      intro y_eq_x,
      split,
      { assumption },
      intro h'',
      exact absurd (setoid.trans (setoid.symm h'') y_eq_x) h_equiv },
    rwa filter_congr g' at g
  end

  lemma cons_eq_filter_of_group {α : Type*} [p : setoid α] [decidable_rel p.r] {g_hd : α} {xs g_tl : list α}
    (h : (g_hd :: g_tl : list α) ∈ group xs) :
    (g_hd :: g_tl : list α) = filter (≈ g_hd) xs :=
  begin
    induction xs using list.strong_induction_on with xs ih,
    cases xs,
    { simp only [group, not_mem_nil] at h, contradiction },
    simp only [group, mem_cons_iff] at h,
    rcases h with ⟨hd_eq, h⟩,
    { rw hd_eq at *,
      rw h at *,
      exact (@filter_cons_of_pos _ (≈ xs_hd) _ _ xs_tl (setoid.refl xs_hd)).symm },
    have g : (g_hd :: g_tl : list α) = _, from ih _ (length_filter_lt_length_cons _ xs_hd xs_tl) h,
    rw g,
    simp only [filter_filter, function.comp_app] at *,
    by_cases g' : xs_hd ≈ g_hd,
    { have eqv : ∀ y ∈ xs_tl, (y ≈ g_hd ∧ ¬y ≈ xs_hd) ↔ false,
      { intros y y_in_tl,
        split,
        { rintros ⟨a, b⟩,
          exact absurd (setoid.trans a (setoid.symm g')) b },
        { intro f, contradiction } },
       rw filter_congr eqv at g,
       simp only [filter_false] at g,
       contradiction },
    rw @filter_cons_of_neg _ (λ y, y ≈ g_hd) _ xs_hd xs_tl g',
    have eqv : ∀ y ∈ xs_tl, (y ≈ g_hd ∧ ¬y ≈ xs_hd) ↔ y ≈ g_hd,
    { intros y y_in_tl,
      split,
      { intro x, exact x.left },
      { intro y_eq_g_hd,
        split,
        { assumption },
        { intro y_eq_xs_hd,
          exact absurd (setoid.trans (setoid.symm y_eq_xs_hd) y_eq_g_hd) g' } } },
    rw filter_congr eqv
  end

  lemma group_eq_of_mem_equiv {α : Type*} [p : setoid α] [decidable_rel p.r] {xs g1 g2 : list α}
    (h1 : g1 ∈ group xs) (h2 : g2 ∈ group xs) (h : ∃ x ∈ g1, ∃ y ∈ g2, x ≈ y) :
    g1 = g2 :=
  begin
    cases g1,
    { exact absurd h1 (nil_not_mem_group xs) },
    cases g2,
    { exact absurd h2 (nil_not_mem_group xs) },
    rw cons_eq_filter_of_group h1 at *,
    rw cons_eq_filter_of_group h2 at *,
    rcases h with ⟨x, x_in_g1, y, y_in_g2, h⟩,
    simp only [mem_filter] at *,
    apply filter_congr,
    intros z z_in_xs,
    split;
    intro h_eq,
    { calc z ≈ g1_hd : h_eq
         ... ≈ x : setoid.symm x_in_g1.right
         ... ≈ y : h
         ... ≈ g2_hd : y_in_g2.right },
    { calc z ≈ g2_hd : h_eq
         ... ≈ y : setoid.symm y_in_g2.right
         ... ≈ x : setoid.symm h
         ... ≈ g1_hd : x_in_g1.right }
  end

  lemma group_perm_of_perm {α : Type*} [p : setoid α] [decidable_rel p.r] {xs ys : list α} (h : xs ~ ys) :
    ∀ gx ∈ group xs, ∃ gy ∈ group ys, gx ~ gy :=
  begin
    intros gx gx_group,
    cases gx,
    { exact absurd gx_group (nil_not_mem_group xs) },
    set gy := filter (≈ gx_hd) ys with gy_def,
    use gy,
    have g : gx_hd ∈ ys,
    from (mem_of_perm h).mp
      ((mem_of_perm (join_group_perm xs)).mp
        (mem_join_of_mem gx_group (mem_cons_self gx_hd gx_tl))),
    use filter_equiv_mem_group g,
    rw gy_def,
    rw cons_eq_filter_of_group gx_group,
    apply perm_filter,
    assumption
  end

  section map_on_of_nodup
    local attribute [instance] classical.prop_decidable
    lemma inj_on_of_nodup_map {α β : Type*} {f : α → β} {s : list α} (nd : nodup (map f s))
      {x : α} (x_in_s : x ∈ s) {y : α} (y_in_s : y ∈ s) (f_eq : f x = f y) : x = y :=
    begin
      unfold nodup at nd,
      rw pairwise_map at nd,
      have s : symmetric (λ (a b : α), f a ≠ f b),
      { unfold symmetric,
        intros x y,
        exact ne.symm },
      have h, from forall_of_pairwise s nd x x_in_s y y_in_s,
      by_contradiction,
      exact absurd f_eq (h a)
    end
  end map_on_of_nodup

end list

namespace multiset
  def group' {α : Type*} [p : setoid α] [decidable_rel p.r] (xs : list α) : multiset (multiset α) :=
  ↑(list.map (λ g, (↑g : multiset α)) (list.group xs))

  lemma nodup_map_coe_of_perm_nodup {α : Type*} [p : setoid α] [decidable_rel p.r] (xs : list (list α)) (h : list.pairwise (λ a b, ¬(a ~ b)) xs) :
    list.nodup (list.map coe xs : list (multiset α)) :=
  begin
    letI := classical.dec_eq α,
    rw list.nodup_iff_count_le_one,
    intro s,
    induction xs,
    { simp only [list.not_mem_nil, list.count_eq_zero_of_not_mem, zero_le, not_false_iff, list.map, zero_le_one] },
    simp only [list.map],
    rw list.count_cons,
    split_ifs,
    { apply nat.succ_le_succ,
      simp only [le_zero_iff_eq],
      rw list.count_eq_zero_of_not_mem,
      rw h_1 at *,
      simp only [not_exists, coe_eq_coe, list.mem_map, not_and],
      intros a a_in_tl,
      replace h := list.rel_of_pairwise_cons h a_in_tl,
      intro h',
      exact absurd (h'.symm) h },
    { exact xs_ih (list.pairwise_of_pairwise_cons h) }
  end

  lemma group'_eq_of_perm {α : Type*} [p : setoid α] [decidable_rel p.r] {xs ys : list α} (h : xs ~ ys) : group' xs = group' ys :=
  begin
    letI := classical.dec_eq α,
    unfold group',
    simp only [coe_eq_coe],
    rw list.perm_ext (nodup_map_coe_of_perm_nodup _ (list.nodup_perm_group xs))
      (nodup_map_coe_of_perm_nodup _ (list.nodup_perm_group ys)),
    simp only [list.mem_map],
    intro s,
    split,
    { rintro ⟨ax, ax_group, ax_eq_s⟩,
      rcases list.group_perm_of_perm h ax ax_group with ⟨ay, ⟨ay_group, ax_eq_ay⟩⟩,
      use [ay, ay_group],
      rw ←coe_eq_coe at ax_eq_ay,
      rw ←ax_eq_ay,
      assumption },
    { rintro ⟨ay, ay_group, ay_eq_s⟩,
      rcases list.group_perm_of_perm h.symm ay ay_group with ⟨ax, ⟨ax_group, ay_eq_ax⟩⟩,
      use [ax, ax_group],
      rw ←coe_eq_coe at ay_eq_ax,
      rw ←ay_eq_ax,
      assumption }
  end

  lemma join_group'_eq {α : Type*} [p : setoid α] [decidable_rel p.r] (xs : list α) : join (group' xs) = xs :=
  begin
    simp only [group', coe_join, coe_eq_coe],
    exact list.join_group_perm xs
  end

  lemma nil_not_mem_group' {α : Type*} [p : setoid α] [decidable_rel p.r] (xs : list α)
    : ∅ ∉ group' xs :=
  begin
    simp [group'],
    intros x x_in_group h,
    rw coe_eq_zero at h,
    rw h at x_in_group,
    have g, from list.nil_not_mem_group xs,
    contradiction
  end

  lemma group'_equiv {α : Type*} [p : setoid α] [decidable_rel p.r] {xs : list α} :
    ∀ g ∈ group' xs, ∀ x y ∈ g, x ≈ y :=
  begin
    simp only [group', and_imp, list.mem_map, mem_coe, exists_imp_distrib],
    intros g x h heq,
    rw ←heq,
    simp only [mem_coe],
    exact list.group_equiv x h
  end

  lemma pairwise_equiv_disjoint_group' {α : Type*} [decidable_eq α] [p : setoid α] [decidable_rel p.r] (xs : list α) :
    pairwise (λ g1 g2 : multiset α, ∀ x1 ∈ g1, ∀ x2 ∈ g2, ¬(x1 ≈ x2)) (group' xs) :=
  begin
    simp only [group'],
    rw pairwise_coe_iff_pairwise,
    have h, from list.pairwise_equiv_disjoint_group xs,
    { rw list.pairwise_map,
      simpa only [mem_coe] },
    unfold symmetric,
    intros x y h x1 x1_in_y x2 x2_in_x h',
    exact absurd (setoid.symm h') (h x2 x2_in_x x1 x1_in_y)
  end

  lemma filter_equiv_mem_group' {α : Type*} [p : setoid α] [decidable_rel p.r] {x : α} {xs : list α} (h : x ∈ xs) :
    filter (≈ x) xs ∈ group' xs :=
  begin
    simp only [group', coe_filter, coe_eq_coe, list.mem_map, mem_coe],
    have h, from list.filter_equiv_mem_group h,
    use list.filter (λ (_x : α), _x ≈ x) xs,
    split,
    { assumption },
    refl
  end

  lemma subset_of_eq {α : Type*} {xs ys : multiset α} (h : xs = ys) : xs ⊆ ys ∧ ys ⊆ xs :=
  begin
    rw h,
    exact ⟨subset.refl ys, subset.refl ys⟩
  end

  lemma cons_eq_filter_of_group' {α : Type*} [p : setoid α] [decidable_rel p.r] {g_hd : α} {g_tl : multiset α} {xs : list α}
    (h : g_hd :: g_tl ∈ group' xs) :
    g_hd :: g_tl = filter (≈ g_hd) xs :=
  begin
    letI := classical.dec_eq α,
    simp only [group', list.mem_map, mem_coe, list.map] at h,
    simp only [coe_filter],
    rcases h with ⟨a, a_group, a_eq_g⟩,
    cases a,
    { simp only [coe_nil_eq_zero, zero_ne_cons] at a_eq_g,
      contradiction },
    have g : (a_hd :: a_tl : list α) = list.filter (λ (_x : α), _x ≈ a_hd) xs, from list.cons_eq_filter_of_group a_group,
    rw ←a_eq_g,
    rw g,
    simp only [coe_eq_coe],
    have g_hd_mem_a, from (subset_of_eq a_eq_g).right (mem_cons_self g_hd g_tl),
    simp only [mem_coe] at g_hd_mem_a,
    have g_hd_equiv_a_hd, from list.group_equiv (a_hd :: a_tl) a_group a_hd g_hd (list.mem_cons_self a_hd a_tl) g_hd_mem_a,
    have equiv : (∀ x ∈ xs, x ≈ a_hd ↔ x ≈ g_hd),
    { intros x x_in_xs,
      split;
      intro h_eq,
      { exact setoid.trans h_eq g_hd_equiv_a_hd },
      { exact setoid.trans h_eq (setoid.symm g_hd_equiv_a_hd) } },
    rw list.filter_congr equiv
  end

  lemma group'_eq_of_mem_equiv {α : Type*} [p : setoid α] [decidable_rel p.r] {xs : list α} {g1 g2 : multiset α}
    (h1 : g1 ∈ group' xs) (h2 : g2 ∈ group' xs) (h : ∃ x ∈ g1, ∃ y ∈ g2, x ≈ y) :
    g1 = g2 :=
  begin
    simp only [group', list.mem_map, mem_coe] at h1 h2,
    rcases h1 with ⟨g1a, g1a_group, g1a_def⟩,
    rcases h2 with ⟨g2a, g2a_group, g2a_def⟩,
    rw ←g1a_def at *,
    rw ←g2a_def at *,
    simp only [coe_eq_coe],
    simp only [exists_prop, mem_coe] at h,
    rcases h with ⟨x, x_in_g1a, y, y_in_g2a, h⟩,
    rw list.group_eq_of_mem_equiv g1a_group g2a_group ⟨x, x_in_g1a, y, y_in_g2a, h⟩
  end

  def group {α : Type*} [p : setoid α] [decidable_rel p.r] (s : multiset α) : multiset (multiset α) :=
  quot.lift_on s group' (@group'_eq_of_perm _ _ _)

  lemma join_group_eq {α : Type*} [p : setoid α] [decidable_rel p.r] (xs : multiset α) : join (group xs) = xs :=
  quot.induction_on xs join_group'_eq

  lemma nil_not_mem_group {α : Type*} [p : setoid α] [decidable_rel p.r] (xs : multiset α) : ∅ ∉ group xs :=
  quot.induction_on xs nil_not_mem_group'

  lemma group_equiv {α : Type*} [p : setoid α] [decidable_rel p.r] {xs : multiset α} :
    ∀ g ∈ group xs, ∀ x y ∈ g, x ≈ y :=
  quot.induction_on xs (@group'_equiv _ _ _)

  lemma pairwise_equiv_disjoint_group {α : Type*} [decidable_eq α] [p : setoid α] [decidable_rel p.r] (xs : multiset α) :
    pairwise (λ g1 g2 : multiset α, ∀ x1 ∈ g1, ∀ x2 ∈ g2, ¬(x1 ≈ x2)) (group xs) :=
  quot.induction_on xs pairwise_equiv_disjoint_group'

  lemma filter_equiv_mem_group {α : Type*} [p : setoid α] [decidable_rel p.r] {x : α} {xs : multiset α} :
    x ∈ xs → filter (≈ x) xs ∈ group xs :=
  quot.induction_on xs (λ l, filter_equiv_mem_group')

  lemma cons_eq_filter_of_group {α : Type*} [p : setoid α] [decidable_rel p.r] {g_hd : α} {g_tl : multiset α} {xs : multiset α} :
    g_hd :: g_tl ∈ group xs → g_hd :: g_tl = filter (≈ g_hd) xs :=
  quot.induction_on xs (λ l, cons_eq_filter_of_group')

  lemma group_eq_of_mem_equiv {α : Type*} [p : setoid α] [decidable_rel p.r] {xs g1 g2 : multiset α} :
    g1 ∈ group xs → g2 ∈ group xs → (∃ x ∈ g1, ∃ y ∈ g2, x ≈ y) → g1 = g2 :=
  quot.induction_on xs (λ l, @group'_eq_of_mem_equiv _ _ _ l _ _)

  @[simp] lemma filter_true {α : Type*} {h : decidable_pred (λ a : α, true)} (s : multiset α) :
    @filter α (λ _, true) h s = s :=
  quot.induction_on s (λ l, congr_arg coe (list.filter_true l))

  @[simp] lemma filter_false {α : Type*} {h : decidable_pred (λ a : α, false)} (s : multiset α) :
    @filter α (λ _, false) h s = [] :=
  quot.induction_on s (λ l, congr_arg coe (list.filter_false l))

  lemma disjoint_filter_filter {α : Type*} {p1 p2 : α → Prop} [decidable_pred p1] [decidable_pred p2] {s : multiset α} :
    disjoint (s.filter p1) (s.filter p2) ↔ ∀ x ∈ s, p1 x → ¬p2 x :=
  begin
    simp only [disjoint, and_imp, mem_filter],
    split;
    intro h,
    { intros x x_in_s p1_x,
      exact h x_in_s p1_x x_in_s },
    intros x x_in_s p1_x x_in_s,
    exact h x x_in_s p1_x
  end

  lemma inj_on_of_nodup_map {α β : Type*} {f : α → β} {s : multiset α} :
    nodup (map f s) → ∀ x ∈ s, ∀ y ∈ s, f x = f y → x = y :=
  quot.induction_on s (λ l, @list.inj_on_of_nodup_map α β f l)

  lemma map_add_of_disjoint {α β : Type*} [decidable_eq α] (f1 f2 : α → β) {s1 s2 : multiset α} (h : disjoint s1 s2) :
    map f1 s1 + map f2 s2 = map (λ x, if x ∈ s1 then f1 x else f2 x) (s1 + s2) :=
  begin
    simp only [map_add],
    have h1 : map f1 s1 = map (λ (x : α), ite (x ∈ s1) (f1 x) (f2 x)) s1,
    { have h1' : ∀ x ∈ s1, f1 x = ite (x ∈ s1) (f1 x) (f2 x),
      { intros x x_in_s1,
        rw if_pos x_in_s1 },
      rw map_congr h1' },
    have h2 : map f2 s2 = map (λ (x : α), ite (x ∈ s1) (f1 x) (f2 x)) s2,
    { have h2' : ∀ x ∈ s2, f2 x = ite (x ∈ s1) (f1 x) (f2 x),
      { intros x x_in_s2,
        rw if_neg,
        exact h.symm x_in_s2 },
      rw map_congr h2' },
    rw h1, rw h2
  end
end multiset

namespace finset
  def join {α : Type*} [decidable_eq α] (xs : list (finset α)) : finset α := xs.foldr (∪) ∅

  @[simp] theorem mem_join {α : Type*} [decidable_eq α] {x : α} {xs : list (finset α)} : x ∈ join xs ↔ ∃ S ∈ xs, x ∈ S :=
  begin
    apply iff.intro,
    { intro h,
      induction xs;
      unfold join at *,
      { simp only [list.foldr_nil, not_mem_empty] at h,
        contradiction },
      { simp only [mem_union, list.foldr_cons] at h,
        cases h,
        { exact ⟨xs_hd, ⟨or.inl rfl, h⟩⟩ },
        { rcases xs_ih h with ⟨S, S_in_tl, x_in_S⟩,
          exact ⟨S, ⟨or.inr S_in_tl, x_in_S⟩⟩ } } },
    { intro h,
      induction xs,
      { simp only [list.not_mem_nil, exists_false, not_false_iff, exists_prop_of_false] at h,
        contradiction },
      { unfold join at *,
        rcases h with ⟨S, S_in_hd_or_tl, x_in_S⟩,
        simp only [mem_union, list.foldr_cons, list.mem_cons_iff] at *,
        cases S_in_hd_or_tl,
        { rw S_in_hd_or_tl at x_in_S,
          exact or.inl x_in_S },
        { exact or.inr (xs_ih ⟨S, S_in_hd_or_tl, x_in_S⟩) } } }
    end

  @[simp] lemma erase_insert_eq_erase {α : Type*} [decidable_eq α] (s : finset α) (a : α) :
    erase (insert a s) a = erase s a :=
  begin
    ext,
    simp only [mem_insert, mem_erase, and_or_distrib_left, not_and_self, false_or]
  end

  lemma erase_insert_eq_insert_erase {α : Type*} [decidable_eq α] {a b : α} (s : finset α)
    (h : a ≠ b) :
    erase (insert a s) b = insert a (erase s b) :=
  begin
    ext,
    simp only [mem_insert, mem_erase, and_or_distrib_left],
    apply iff.intro;
    intro h₁;
    cases h₁,
    { exact or.inl h₁.right },
    { exact or.inr h₁ },
    { rw h₁, exact or.inl ⟨h, rfl⟩ },
    { exact or.inr h₁ }
  end

  lemma sort_empty {α : Type*} (r : α → α → Prop) [decidable_rel r]
    [is_trans α r] [is_antisymm α r] [is_total α r] :
    sort r ∅ = [] :=
  begin
    apply (multiset.coe_eq_zero (sort r ∅)).mp,
    simp only [sort_eq, empty_val]
  end

  lemma sort_split {α : Type*} [decidable_eq α] (p : α → α → Prop) [decidable_rel p]
    [is_trans α p] [is_antisymm α p] [is_total α p]
    (a : α) (s : finset α) :
    ∃ l r : list α, sort p (insert a s) = l ++ a :: r :=
  list.mem_split ((mem_sort p).mpr (mem_insert_self a s))

  lemma map_congr {α β : Type*} (f g : α ↪ β) {s : finset α} : (∀ x ∈ s, f.1 x = g.1 x) → map f s = map g s :=
  λ h, eq_of_veq (multiset.map_congr h)
end finset

namespace function
  notation f `[` a `↦` b `]` := function.update f a b
end function


import data.real.basic
import data.set.lattice

open set

--begin hide
namespace xena
-- This will eventually be the first level, containing basic definitions
-- Work in progress
-- First I used ⊂ in the definition, then changed to ⊆
-- in order to be able to use subset.trans -- DS
-- end hide

def is_open (X : set ℝ) := ∀ x ∈ X, ∃ δ > 0, { y : ℝ  | x - δ < y ∧ y < x + δ } ⊆ X
variable β : Type

-- begin hide
-- Checking definitions
--def countable_union (X : nat → set ℝ) := {t : ℝ | exists i, t ∈ X i}
-- end hide

/- Lemma
Arbitrary union of open sets is open -- WIP, to do.
-/
lemma is_open_union_of_open (X : β → set ℝ ) ( hj : ∀ j, is_open (X j) )
    : is_open (Union X) :=
begin
    intros x hx,
    simp at hx,
    cases hx with i hi,
    have H := hj i,
    have G := H x hi,
    cases G with d hd, use d,
    cases hd with hd1 hd2,
    split, exact hd1,
    have hd3 : X i ⊆ Union X,
        intros t ht, simp,
        use i, exact ht,
    exact subset.trans hd2 hd3, done
end

end xena -- hide


import prelim.induction prelim.collections prelim.presetoid
import matroid.rankfun matroid.indep
import .uniform .direct_sum

open matroid set
open_locale classical big_operators

noncomputable theory

namespace partition

variables {α ι : Type*} [fintype α] (f : α → ι){b : ι → ℤ}

/-- the partition matroid - given a partition of α encoded by a function f : α → ι, the independent
sets are those whose intersection with each cell i has size at most b i -/
def M (f : α → ι) (b : ι → ℤ) : matroid α := idsum.M f (λ i, unif.uniform_matroid_on _ (b i))

lemma indep_iff (hb : ∀ i, 0 ≤ b i) (X : set α) :
  (M f b).is_indep X ↔ ∀ i, size {x ∈ X | f x = i} ≤ b i :=
begin
  simp_rw [M, idsum.indep_iff, ← idsum.size_coe_eq],
  refine ⟨λ h, λ i, _, λ h, λ i, _⟩,
  {exact (unif.uniform_matroid_indep_iff (hb i)).mp (h i), },
  exact (unif.uniform_matroid_indep_iff (hb i)).mpr (h i),
end

lemma r_eq (hb : ∀ i, 0 ≤ b i) (X : set α) :
  (M f b).r X = ∑ᶠ (i : ι), (min (b i) (size {x ∈ X | f x = i})) :=
begin
  simp_rw [M, idsum.r_eq, ← idsum.size_coe_eq],
  convert rfl, ext i, rw unif.uniform_matroid_rank (hb i),
end

end partition

section presetoid_class

open presetoid

variables {α : Type*} [fintype α] (S : presetoid α)

namespace presetoid_matroid

/- Given a presetoid S on α, we construct a matroid on α whose independent sets are those containing
no elements of the kernel of α, and at most one element of each class of α -/

def partition_fn : set α → ℤ :=
  λ X, ite (X = ∅) 0 1

lemma partition_fn_nonneg:
  ∀ (X : set α), 0 ≤ partition_fn X :=
λ X, by {unfold partition_fn, split_ifs; norm_num,}

def M : matroid α := partition.M S.cl partition_fn

lemma M_def :
  M S = partition.M S.cl partition_fn :=
rfl

lemma r_eq (X : set α) :
  (M S).r X = size {P ∈ S.classes | (X ∩ P).nonempty} :=
begin
  rw [M_def, partition.r_eq, ← sum_size_fiber_eq_size _ id],
  rotate, apply_instance, apply partition_fn_nonneg,
  convert rfl, funext,
  rw partition_fn, dsimp only [id.def], split_ifs,
  { subst h,
    rw min_eq_left (size_nonneg {x ∈ X | S.cl x = ∅}),
    simp only [and_imp, mem_sep_eq, size_zero_iff_empty, presetoid.mem_classes_iff,
    id.def, sep_in_eq_empty_iff, exists_imp_distrib],
    rintros P x hx rfl - hx',
    exact cl_eq_empty_iff.mp hx' hx, },
  by_cases hi : ∃ x ∈ X, S.cl x = i, swap,
  { convert (min_eq_right (zero_le_one : (0 :ℤ) ≤ 1 )).symm,
    { simp only [and_imp, mem_sep_eq, size_zero_iff_empty, presetoid.mem_classes_iff,
        sep_in_eq_empty_iff, exists_imp_distrib],
      rintros s x hx rfl hxX rfl,
      obtain ⟨x',hx'⟩ := hxX,
      rw mem_inter_iff at hx',
      exact hi ⟨x', hx'.1, cl_eq_cl_of_rel (mem_cl_iff.mp hx'.2)⟩ },
    simp only [size_zero_iff_empty, sep_in_eq_empty_iff],
    exact λ x hx hS, hi ⟨x,hx,hS⟩},
  obtain ⟨x,hx,rfl⟩ := hi,
  rw [presetoid.cl_eq_empty_iff, not_not] at h,
  convert (λ m hm, by {rw min_eq_left hm} : (∀ m : ℤ, 1 ≤ m → 1 = min 1 m)) _ _,
  { rw size_one_iff_eq_singleton,
    refine ⟨S.cl x, ext_iff.mpr (λ f, _)⟩,
    simp only [mem_sep_eq, presetoid.mem_classes_iff, mem_singleton_iff,
    and_iff_right_iff_imp],
    rintros rfl,
    exact ⟨⟨x, h, rfl⟩,⟨x,mem_inter hx (mem_cl_iff.mpr h)⟩⟩},
  exact one_le_size_iff_has_mem.mpr ⟨x, by {simpa using hx}⟩,
end

lemma indep_iff (I : set α) :
  (M S).is_indep I ↔ disjoint I S.kernel ∧ ∀ P ∈ S.classes, size (I ∩ P) ≤ 1 :=
begin
  rw [M_def, partition.indep_iff, partition_fn, disjoint_right],
  swap, apply partition_fn_nonneg,
  simp only [and_imp, presetoid.mem_classes_iff, exists_imp_distrib, mem_kernel_iff, not_imp_not],
  refine ⟨λ h, ⟨by {simpa using h ∅}, _⟩, λ h P, _⟩,
  { rintros P x hx rfl,
    convert h (S.cl x),
    { ext, rw [eq_comm, cl_eq_cl_iff hx, rel_comm, ← mem_cl_iff], refl},
    suffices : (S.cl x) ≠ ∅, split_ifs; tauto,
    simp_rw [ne_empty_iff_has_mem, mem_cl_iff],
    exact ⟨x,hx⟩ },
  by_cases hP : ∃ x, P = S.cl x,
  { obtain ⟨x,rfl⟩ := hP,
    by_cases hx : S.rel x x,
    { convert h.2 (S.cl x) _ hx rfl,
      {ext y, rw [eq_comm, cl_eq_cl_iff hx, rel_comm, mem_cl_iff]},
      simpa using hx},
    rw [cl_eq_empty_iff.mpr hx],
    simpa using h.1},
  convert (λ Q, by {split_ifs; norm_num} : ∀ Q: Prop, (0 : ℤ) ≤ ite Q (0 : ℤ) 1) _ ,
  rw [size_zero_iff_empty, sep_in_eq_empty_iff],
  exact λ x hx hxP, hP ⟨x, hxP.symm⟩,
end

end presetoid_matroid

end presetoid_class