-- https://github.com/kckennylau/Lean/blob/master/Sym.lean

import data.fintype data.equiv.basic group_theory.subgroup

namespace list

@[simp] lemma length_attach {α} (L : list α) :
  L.attach.length = L.length :=
length_pmap

@[simp] lemma nth_le_attach {α} (L : list α) (i) (H : i < L.attach.length) :
  (L.attach.nth_le i H).1 = L.nth_le i (length_attach L ▸ H) :=
calc  (L.attach.nth_le i H).1
    = (L.attach.map subtype.val).nth_le i (by simpa using H) : by rw nth_le_map'
... = L.nth_le i _ : by congr; apply attach_map_val

@[simp] lemma nth_le_range {n} (i) (H : i < (range n).length) :
  nth_le (range n) i H = i :=
option.some.inj $ by rw [← nth_le_nth _, nth_range (by simpa using H)]

attribute [simp] length_of_fn
attribute [simp] nth_le_of_fn

-- Congratulations, I proved that two things which have
-- equally few lemmas are equal.
theorem of_fn_eq_pmap {α n} {f : fin n → α} :
  of_fn f = pmap (λ i hi, f ⟨i, hi⟩) (range n) (λ _, mem_range.1) :=
by rw [pmap_eq_map_attach]; from ext_le (by simp)
  (λ i hi1 hi2, by simp at hi1; simp [nth_le_of_fn f ⟨i, hi1⟩])

theorem nodup_of_fn {α n} {f : fin n → α} (hf : function.injective f) :
  nodup (of_fn f) :=
by rw of_fn_eq_pmap; from nodup_pmap
  (λ _ _ _ _ H, fin.veq_of_eq $ hf H) (nodup_range n)

end list

section fin

variables {m n : ℕ}

def fin_zero_elim {C : Sort*} : fin 0 → C :=
λ x, false.elim $ nat.not_lt_zero x.1 x.2

def fin_sum : (fin m ⊕ fin n) ≃ fin (m + n) :=
{ to_fun := λ x, sum.rec_on x
    (λ y, ⟨y.1, nat.lt_of_lt_of_le y.2 $ nat.le_add_right m n⟩)
    (λ y, ⟨m + y.1, nat.add_lt_add_left y.2 m⟩),
  inv_fun := λ x, if H : x.1 < m
    then sum.inl ⟨x.1, H⟩
    else sum.inr ⟨x.1 - m, nat.lt_of_add_lt_add_left $
      show m + (x.1 - m) < m + n,
      from (nat.add_sub_of_le $ le_of_not_gt H).symm ▸ x.2⟩,
  left_inv := λ x, sum.cases_on x
    (λ y, by simp [y.2]; from fin.eq_of_veq rfl)
    (λ y, have H : ¬m + y.val < m, by simp [nat.zero_le],
       by simp [H, nat.add_sub_cancel_left];
       from fin.eq_of_veq rfl),
  right_inv := λ x, begin
    by_cases H : x.1 < m,
    { dsimp; rw [dif_pos H]; simp },
    { dsimp; rw [dif_neg H]; simp,
      apply fin.eq_of_veq; simp,
      rw [nat.add_sub_of_le (le_of_not_gt H)] }
  end }

def fin_prod : (fin m × fin n) ≃ fin (m * n) :=
{ to_fun := λ x, ⟨x.2.1 + n * x.1.1, calc
          x.2.1 + n * x.1.1 + 1
        = x.1.1 * n + x.2.1 + 1 : by ac_refl
    ... ≤ x.1.1 * n + n : nat.add_le_add_left x.2.2 _
    ... = (x.1.1 + 1) * n : eq.symm $ nat.succ_mul _ _
    ... ≤ m * n : nat.mul_le_mul_right _ x.1.2⟩,
  inv_fun := λ x, have H : n > 0,
      from nat.pos_of_ne_zero $ λ H,
        nat.not_lt_zero x.1 $ by subst H; from x.2,
    (⟨x.1 / n, (nat.div_lt_iff_lt_mul _ _ H).2 x.2⟩,
     ⟨x.1 % n, nat.mod_lt _ H⟩),
  left_inv := λ ⟨x, y⟩, have H : n > 0,
      from nat.pos_of_ne_zero $ λ H,
        nat.not_lt_zero y.1 $ H ▸ y.2,
    prod.ext
    (fin.eq_of_veq $ calc
            (y.1 + n * x.1) / n
          = y.1 / n + x.1 : nat.add_mul_div_left _ _ H
      ... = 0 + x.1 : by rw nat.div_eq_of_lt y.2
      ... = x.1 : nat.zero_add x.1)
    (fin.eq_of_veq $ calc
            (y.1 + n * x.1) % n
          = y.1 % n : nat.add_mul_mod_self_left _ _ _
      ... = y.1 : nat.mod_eq_of_lt y.2),
    right_inv := λ x, fin.eq_of_veq $ nat.mod_add_div _ _ }

@[simp] lemma fin.raise_val (k : fin n) :
  k.raise.val = k.val :=
rfl

def fin.fall : Π i : fin (n+1), i.1 < n → fin n :=
λ i h, ⟨i.1, h⟩

@[simp] lemma fin.fall_val (k : fin (n+1)) (H : k.1 < n) :
  (k.fall H).val = k.val :=
rfl

def fin.descend (pivot : fin (n+1)) : Π i : fin (n+1), i ≠ pivot → fin n :=
λ i H, if h : i.1 < pivot.1
  then i.fall (lt_of_lt_of_le h $ nat.le_of_lt_succ pivot.2)
  else i.pred (λ H1, H $ by subst H1;
    replace h := nat.eq_zero_of_le_zero (le_of_not_gt h);
    from fin.eq_of_veq h.symm)

def fin.ascend (pivot : fin (n+1)) : Π i : fin n, fin (n+1) :=
λ i, if i.1 < pivot.1 then i.raise else i.succ

theorem fin.ascend_ne (pivot : fin (n+1)) (i : fin n) :
  pivot.ascend i ≠ pivot :=
λ H, begin
  unfold fin.ascend at H,
  split_ifs at H;
  rw ← H at h;
  simp [lt_irrefl, nat.lt_succ_self] at h;
  cc
end

@[simp] lemma fin.ascend_descend (pivot i : fin (n+1))
  (H : i ≠ pivot) : pivot.ascend (pivot.descend i H) = i :=
begin
  unfold fin.descend fin.ascend,
  split_ifs with H1 H2 H3; apply fin.eq_of_veq; simp at *,
  { cases pivot with p hp,
    cases i with i hi,
    cases i with i, { simp at * },
    exfalso, apply H, apply fin.eq_of_veq,
    apply le_antisymm, { apply nat.succ_le_of_lt H2 },
    simpa using H1 },
  { cases pivot with p hp,
    cases i with i hi,
    cases i with i,
    { exfalso, apply H, apply fin.eq_of_veq, symmetry,
      apply nat.eq_zero_of_le_zero H2 },
    refl }
end

@[simp] lemma fin.descend_ascend (pivot : fin (n+1))
  (i : fin n) (H : pivot.ascend i ≠ pivot) :
  pivot.descend (pivot.ascend i) H = i :=
begin
  unfold fin.descend fin.ascend,
  apply fin.eq_of_veq,
  by_cases h : i.val < pivot.val,
  { simp [h] },
  { unfold ite dite,
    cases nat.decidable_lt ((ite (i.val < pivot.val) (fin.raise i) (fin.succ i)).val) (pivot.val) with h1 h1,
    { simp,
      cases nat.decidable_lt (i.val) (pivot.val),
      { simp },
      { cc } },
    { simp,
      cases nat.decidable_lt (i.val) (pivot.val) with h2 h2,
      { simp [h2] at h1,
        simp at *,
        exfalso, apply lt_asymm (nat.lt_succ_self i.1),
        apply lt_of_lt_of_le h1 h },
      { simp } } }
end

@[simp] lemma fin.succ_pred (i : fin (n+1)) (H : i ≠ 0) :
  (i.pred H).succ = i :=
begin
  apply fin.eq_of_veq,
  cases i with i hi,
  cases i,
  { exfalso, apply H, apply fin.eq_of_veq, refl },
  refl
end

@[simp] lemma fin.pred_succ (i : fin n) (H : i.succ ≠ 0) :
  i.succ.pred H = i :=
by cases i; refl

instance : preorder (fin n) :=
by apply_instance

end fin

section miscellaneous

theorem nat.pred_eq_of_eq_succ {m n : ℕ}
  (H : m = n.succ) : m.pred = n :=
by simp [H]

@[simp] lemma equiv.symm_apply_eq {α β} {e : α ≃ β} {x y} :
  e.symm x = y ↔ x = e y :=
⟨λ H, by simp [H.symm], λ H, by simp [H]⟩

theorem finset.lt_wf {α} [decidable_eq α] :
  well_founded (@has_lt.lt (finset α) _) :=
have H : subrelation (@has_lt.lt (finset α) _)
    (inv_image (<) finset.card),
  from λ x y hxy, finset.card_lt_card hxy,
subrelation.wf H $ inv_image.wf _ $ nat.lt_wf

def finset.min' {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅) : α :=
@option.get _ S.min $
  let ⟨k, hk⟩ := finset.exists_mem_of_ne_empty H in
  let ⟨b, hb⟩ := finset.min_of_mem hk in by simp at hb; simp [hb]

theorem finset.min'_mem {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅) : S.min' H ∈ S :=
finset.mem_of_min $ by simp [finset.min']

theorem finset.min'_le {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅)
  (x) (H2 : x ∈ S) : S.min' H ≤ x :=
finset.le_min_of_mem H2 $ option.get_mem _

theorem finset.le_min' {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅)
  (x) (H2 : ∀ y ∈ S, x ≤ y) : x ≤ S.min' H :=
H2 _ $ finset.min'_mem _ _

def finset.max' {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅) : α :=
@option.get _ S.max $
  let ⟨k, hk⟩ := finset.exists_mem_of_ne_empty H in
  let ⟨b, hb⟩ := finset.max_of_mem hk in by simp at hb; simp [hb]

theorem finset.max'_mem {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅) : S.max' H ∈ S :=
finset.mem_of_max $ by simp [finset.max']

theorem finset.le_max' {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅)
  (x) (H2 : x ∈ S) : x ≤ S.max' H :=
finset.le_max_of_mem H2 $ option.get_mem _

theorem finset.max'_le {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅)
  (x) (H2 : ∀ y ∈ S, y ≤ x) : S.max' H ≤ x :=
H2 _ $ finset.max'_mem _ _

theorem finset.min'_lt_max' {α} [decidable_linear_order α]
  (S : finset α) (H : S ≠ ∅) {i j}
  (H1 : i ∈ S) (H2 : j ∈ S) (H3 : i ≠ j) :
  S.min' H < S.max' H :=
begin
  rcases lt_trichotomy i j with H4 | H4 | H4,
  { have H5 := finset.min'_le S H i H1,
    have H6 := finset.le_max' S H j H2,
    apply lt_of_le_of_lt H5,
    apply lt_of_lt_of_le H4 H6 },
  { cc },
  { have H5 := finset.min'_le S H j H2,
    have H6 := finset.le_max' S H i H1,
    apply lt_of_le_of_lt H5,
    apply lt_of_lt_of_le H4 H6 }
end

end miscellaneous

variable (n : ℕ)

def Sym : Type :=
equiv.perm (fin n)

instance : has_coe_to_fun (Sym n) :=
equiv.has_coe_to_fun

@[extensionality] theorem Sym.ext (σ τ : Sym n)
  (H : ∀ i, σ i = τ i) : σ = τ :=
equiv.ext _ _ H

theorem Sym.ext_iff (σ τ : Sym n) :
  σ = τ ↔ ∀ i, σ i = τ i :=
⟨λ H i, H ▸ rfl, Sym.ext _ _ _⟩

instance : decidable_eq (Sym n) :=
λ σ τ, decidable_of_iff' _ (Sym.ext_iff _ _ _)

instance : group (Sym n) :=
equiv.perm.perm_group

variable {n}

section perm

def Sym.to_list (σ : Sym n) : list (fin n) :=
list.of_fn σ

theorem Sym.to_list_perm (σ : Sym n) :
  σ.to_list ~ list.of_fn (1 : Sym n) :=
(list.perm_ext
  (list.nodup_of_fn $ σ.bijective.1)
  (list.nodup_of_fn $ (1 : Sym n).bijective.1)).2 $ λ f,
by rw [list.of_fn_eq_pmap, list.of_fn_eq_pmap, list.mem_pmap, list.mem_pmap]; from
⟨λ _, ⟨f.1, by simp [f.2], fin.eq_of_veq rfl⟩,
λ _, ⟨(σ⁻¹ f).1, by simp [(σ⁻¹ f).2], by convert equiv.apply_inverse_apply σ f;
  from congr_arg _ (fin.eq_of_veq rfl)⟩⟩

def list.to_sym (L : list (fin n))
  (HL : L ~ list.of_fn (1 : Sym n)) : Sym n :=
{ to_fun := λ f, list.nth_le L f.1 $
    by rw [list.perm_length HL, list.length_of_fn]; from f.2,
  inv_fun := λ f, ⟨list.index_of f L,
    begin
      convert list.index_of_lt_length.2 _,
      { rw [list.perm_length HL, list.length_of_fn] },
      { rw [list.mem_of_perm HL, list.mem_iff_nth_le],
        refine ⟨f.1, _, _⟩,
        { rw list.length_of_fn,
          exact f.2 },
        { apply list.nth_le_of_fn } }
    end⟩,
  left_inv := λ f, fin.eq_of_veq $ list.nth_le_index_of
    ((list.perm_nodup HL).2 $ list.nodup_of_fn $ λ _ _, id) _ _,
  right_inv := λ f, list.index_of_nth_le $ list.index_of_lt_length.2 $
    (list.mem_of_perm HL).2 $ list.mem_iff_nth_le.2 $
    ⟨f.1, by rw list.length_of_fn; from f.2,
      list.nth_le_of_fn _ _⟩ }

@[simp] lemma list.to_sym_apply (L : list (fin n))
  (HL : L ~ list.of_fn (1 : Sym n)) (i) :
  (L.to_sym HL) i = L.nth_le i.1 (by simp [list.perm_length HL, i.2]) :=
rfl

@[simp] lemma Sym.to_list_to_sym (σ : Sym n) :
  σ.to_list.to_sym σ.to_list_perm = σ :=
Sym.ext _ _ _ $ λ i, fin.eq_of_veq $ by simp [Sym.to_list]

end perm

namespace Sym

def equiv_0 : Sym 0 ≃ fin (0:ℕ).fact :=
{ to_fun    := λ _, ⟨0, dec_trivial⟩,
  inv_fun   := λ _, 1,
  left_inv  := λ _, ext _ _ _ $ λ ⟨n, H⟩, by cases H,
  right_inv := λ ⟨n, H⟩, fin.eq_of_veq $
    by cases H with H1 H1; [refl, cases H1] }

def descend (σ : Sym (n+1)) : Sym n :=
{ to_fun    := λ i, (σ 0).descend (σ i.succ)
    (λ H, by cases i; from nat.no_confusion
      (fin.veq_of_eq (σ.bijective.1 H))),
  inv_fun   := λ i, (σ.symm ((σ 0).ascend i)).pred $ λ H,
    fin.ascend_ne (σ 0) i $ by simpa using H,
  left_inv  := λ i, fin.eq_of_veq $ by dsimp; rw [fin.pred_val];
    apply nat.pred_eq_of_eq_succ; rw [← fin.succ_val];
    apply fin.veq_of_eq; simp,
  right_inv := λ i, fin.eq_of_veq $ by simp }

def ascend (σ : Sym n) (k : fin (n+1)) : Sym (n+1) :=
{ to_fun    := λ i, if H : i = 0 then k
    else k.ascend $ σ $ i.pred H,
  inv_fun   := λ i, if H : i = k then 0
    else (σ.symm $ k.descend i H).succ,
  left_inv  := λ i, fin.eq_of_veq $ begin
      dsimp,
      by_cases h1 : i = 0,
      { simp [h1] },
      { rw [dif_neg h1],
        rw [dif_neg (fin.ascend_ne k (σ (i.pred h1)))],
        simp }
    end,
  right_inv := λ i, fin.eq_of_veq $ begin
      dsimp,
      by_cases h1 : i = k,
      { simp [h1] },
      { rw [dif_neg h1, dif_neg], { simp },
        intro H,
        replace H := fin.veq_of_eq H,
        simp at H,
        exact nat.no_confusion H }
    end }

@[simp] lemma descend_ascend (σ : Sym n) (k : fin (n+1)) :
  descend (ascend σ k) = σ :=
begin
  ext i,
  dsimp [ascend, descend],
  have H : i.succ ≠ 0,
  { intro H,
    replace H := fin.veq_of_eq H,
    simp at H, injections },
  simp [H]
end

def equiv_succ (ih : Sym n ≃ fin n.fact) :
  Sym (n+1) ≃ (fin (n+1) × fin n.fact) :=
{ to_fun    := λ σ, (σ 0, ih $ descend σ),
  inv_fun   := λ F, ascend (ih.symm F.2) F.1,
  left_inv  := λ σ, ext _ _ _ $ λ i, begin
    dsimp, rw [equiv.inverse_apply_apply ih],
    dsimp [descend, ascend],
    split_ifs, {subst h},
    simp
  end,
  right_inv := λ F, prod.ext
      (fin.eq_of_veq $ by dsimp [ascend]; simp) $
    fin.eq_of_veq $ by simp }

protected def equiv : Sym n ≃ fin n.fact :=
nat.rec_on n equiv_0 $ λ n ih,
calc  Sym (n+1)
    ≃ (fin (n+1) × fin n.fact) : equiv_succ ih
... ≃ fin (n+1).fact : fin_prod

instance : fintype (Sym n) :=
fintype.of_equiv _ Sym.equiv.symm

theorem card : fintype.card (Sym n) = nat.fact n :=
(fintype.of_equiv_card Sym.equiv.symm).trans $
fintype.card_fin _

theorem Cayley (α : Type*) [group α] [fintype α] :
  ∃ f : α → Sym (fintype.card α), function.injective f ∧ is_group_hom f :=
nonempty.rec_on (fintype.card_eq.1 $ fintype.card_fin $ fintype.card α) $ λ φ,
⟨λ x, ⟨λ i, φ.symm (x * φ i), λ i, φ.symm (x⁻¹ * φ i),
  λ i, by simp, λ i, by simp⟩,
λ x y H, have H1 : _ := congr_fun (equiv.mk.inj H).1 (φ.symm 1), by simpa using H1,
⟨λ x y, ext _ _ _ $ λ i, by simp [mul_assoc]⟩⟩

@[simp] lemma mul_apply (σ τ : Sym n) (i : fin n) :
  (σ * τ) i = σ (τ i) :=
rfl

@[simp] lemma one_apply (i : fin n) :
  (1 : Sym n) i = i :=
rfl

@[simp] lemma inv_apply (σ : Sym n) (i : fin n) :
  σ⁻¹ i = σ.symm i :=
rfl

def swap (i j : fin n) : Sym n :=
{ to_fun    := λ k, if k = i then j
    else if k = j then i else k,
  inv_fun   := λ k, if k = i then j
    else if k = j then i else k,
  left_inv  := λ k, by dsimp; split_ifs; cc,
  right_inv := λ k, by dsimp; split_ifs; cc }

@[simp] lemma swap_left (i j : fin n) :
  swap i j i = j :=
by dsimp [swap]; cc

@[simp] lemma swap_right (i j : fin n) :
  swap i j j = i :=
by dsimp [swap]; split_ifs; cc

@[simp] lemma swap_mul_self (i j : fin n) :
  swap i j * swap i j = 1 :=
ext _ _ _ $ λ k, by dsimp [swap]; split_ifs; cc

theorem swap_comm (i j : fin n) :
  swap i j = swap j i :=
ext _ _ _ $ λ k, by dsimp [swap]; split_ifs; cc

theorem swap_canonical (i j : fin n)
  (H1 H2 : ({i, j} : finset (fin n)) ≠ ∅) :
  swap (finset.min' _ H1) (finset.max' _ H2) = swap i j :=
begin
  have H3 := finset.min'_mem _ H1,
  have H4 : finset.min' _ H1 = j ∨ finset.min' _ H1 = i,
  { simpa using H3 },
  have H5 := finset.max'_mem _ H2,
  have H6 : finset.max' _ H2 = j ∨ finset.max' _ H2 = i,
  { simpa using H5 },
  cases H4; cases H6,
  { rw [H4, H6],
    have H7 := finset.min'_le _ H1 i (by simp),
    have H8 := finset.le_max' _ H2 i (by simp),
    rw H4 at H7, rw H6 at H8,
    have H9 := le_antisymm H7 H8,
    subst H9 },
  { rw [H4, H6, swap_comm] },
  { rw [H4, H6] },
  { rw [H4, H6],
    have H7 := finset.min'_le _ H1 j (by simp),
    have H8 := finset.le_max' _ H2 j (by simp),
    rw H4 at H7, rw H6 at H8,
    have H9 := le_antisymm H7 H8,
    subst H9 }
end

@[simp] theorem swap_self (i : fin n) :
  swap i i = 1 :=
ext _ _ _ $ λ k, by dsimp [swap]; split_ifs; cc

def support (σ : Sym n) : finset (fin n) :=
finset.filter (λ i, σ i ≠ i) finset.univ

theorem support_def {σ : Sym n} {i : fin n} :
  i ∈ σ.support ↔ σ i ≠ i :=
⟨λ H, (finset.mem_filter.1 H).2, λ H, finset.mem_filter.2 ⟨finset.mem_univ _, H⟩⟩

def support_choice (σ : Sym n) (H : σ.support ≠ ∅) :
  { i // i ∈ σ.support } :=
⟨σ.support.min' H, finset.min'_mem _ _⟩

theorem support_swap {i j : fin n} (H : i ≠ j) :
  (swap i j).support = {i, j} :=
begin
  ext k, split,
  { intro H1,
    simp [support_def, swap] at H1,
    split_ifs at H1 with h1 h2 h3 h4,
    { subst h1, simp },
    { subst h2, simp },
    cc },
  { intro H1,
    simp at H1,
    cases H1 with H1 H1;
    subst H1;
    simp [support_def, swap, H.symm, H] }
end

theorem support_swap_mul {σ : Sym n} {i : fin n}
  (H : i ∈ σ.support) : (swap (σ i) i * σ).support < σ.support :=
begin
  split,
  { intros j h1,
    simp [support_def, swap] at *,
    split_ifs at h1,
    { intro h2, rw ← h2 at h, subst h, cc },
    { cc },
    { cc } },
  intro H1,
  specialize H1 H,
  simp [support_def, swap] at H1,
  apply H1
end

@[simp] lemma support_one : support (1 : Sym n) = ∅ :=
finset.eq_empty_of_forall_not_mem $ λ i H,
support_def.1 H rfl

variable (n)
@[derive decidable_eq]
structure step : Type :=
(fst : fin n)
(snd : fin n)
(lt  : fst < snd)
variable {n}

instance step.fintype : fintype (step n) :=
@fintype.of_surjective { i : fin n × fin n // i.1 < i.2 } _ _ _
  (λ i, (⟨i.1.1, i.1.2, i.2⟩ : step n)) $ λ s,
⟨⟨(s.1, s.2), s.3⟩, by cases s; refl⟩

instance : has_mem (fin n) (step n) :=
⟨λ i s, i = s.1 ∨ i = s.2⟩

@[extensionality] theorem step.ext (s t : step n)
  (H1 : s.1 = t.1) (H2 : s.2 = t.2) : s = t :=
by cases s; cases t; congr; assumption

def step.mk' (i j : fin n) (H : i ≠ j) : step n :=
if h : i < j then ⟨i, j, h⟩ else
⟨j, i, (eq_or_lt_of_not_lt h).resolve_left H⟩

def step.eval (s : step n) : Sym n :=
swap s.1 s.2

@[simp] lemma step.eval_mul_self (s : step n) :
  s.eval * s.eval = 1 :=
by simp [step.eval]

@[simp] lemma step.eval_mk' (i j : fin n) (H : i ≠ j) :
  (step.mk' i j H).eval = swap i j :=
by unfold step.mk'; split_ifs; simp [step.eval, swap_comm]

theorem choice.aux (σ : Sym n)
  (H : ∃ i j, i ≠ j ∧ σ = swap i j) :
  σ.support ≠ ∅ :=
let ⟨i, j, h1, h2⟩ := H in by
  refine finset.ne_empty_of_mem (_ : j ∈ σ.support);
  rw [h2, support_swap h1];
  apply finset.mem_insert_self

def choice (σ : Sym n)
  (H : ∃ i j, i ≠ j ∧ σ = swap i j) : step n :=
{ fst := σ.support.min' $ choice.aux _ H,
  snd := σ.support.max' $ choice.aux _ H,
  lt  := by rcases H with ⟨i, j, h1, h2⟩; subst h2; dsimp;
    refine finset.min'_lt_max' _ _ _ _ h1;
    simp [support_swap h1] }

theorem eval_choice (σ : Sym n)
  (H : ∃ i j, i ≠ j ∧ σ = swap i j) :
  (σ.choice H).eval = σ :=
begin
  rcases H with ⟨i, j, h1, h2⟩,
  subst h2, unfold step.eval choice, dsimp,
  convert swap_canonical i j _ _;
  simp [support_swap h1]
end

theorem choice_eval (s : step n)
  (H : ∃ i j, i ≠ j ∧ s.eval = swap i j) :
  s.eval.choice H = s :=
begin
  ext; dsimp [step.eval, choice],
  { apply le_antisymm,
    { apply finset.min'_le,
      simp [support_swap (ne_of_lt s.3)] },
    { apply finset.le_min',
      intros y h1,
      simp [support_swap (ne_of_lt s.3)] at h1,
      cases h1; subst h1,
      apply le_of_lt s.3 } },
  { apply le_antisymm,
    { apply finset.max'_le,
      intros y h1,
      simp [support_swap (ne_of_lt s.3)] at h1,
      cases h1; subst h1,
      apply le_of_lt s.3 },
    { apply finset.le_max',
      simp [support_swap (ne_of_lt s.3)] } }
end

def list_step.aux : has_well_founded (Sym n) :=
{ r := inv_image (<) support,
  wf := inv_image.wf _ finset.lt_wf }

local attribute [instance] list_step.aux
attribute [elab_as_eliminator] well_founded.fix
attribute [elab_as_eliminator] well_founded.induction

def list_step (σ : Sym n) : list (step n) :=
by refine well_founded.fix list_step.aux.wf _ σ; from
λ σ ih, if H : σ.support = ∅ then []
  else let ⟨i, hi⟩ := σ.support_choice H in
    step.mk' (σ i) i (support_def.1 hi)
    :: ih (swap (σ i) i * σ) (support_swap_mul hi)

@[simp] lemma list_step_prod (σ : Sym n) :
  (σ.list_step.map step.eval).prod = σ :=
well_founded.induction list_step.aux.wf σ $ λ σ ih,
begin
  dsimp [list_step],
  rw [well_founded.fix_eq],
  split_ifs,
  { ext, by_contra H,
    suffices : i ∈ (∅ : finset (fin n)),
    { simp at this, cc },
    rw [← h, support_def],
    exact mt eq.symm H },
  cases support_choice σ h with i hi,
  unfold list_step._match_1,
  specialize ih _ (support_swap_mul hi),
  dsimp [list_step] at ih,
  rw [list.map_cons, list.prod_cons, ih, ← mul_assoc],
  rw [step.eval_mk', swap_mul_self, one_mul]
end

theorem mem_step_iff_mem_support (s : step n) (i : fin n) :
  i ∈ s ↔ i ∈ s.eval.support :=
begin
  unfold step.eval,
  simp [support_swap (ne_of_lt s.3)],
  rw [or_comm], refl
end

theorem support_eq_of_mul_eq_one {σ τ : Sym n} (H : σ * τ = 1) :
  σ.support = τ.support :=
begin
  ext i, simp [support_def, not_iff_not],
  rw [eq_comm, iff.comm],
  convert equiv.symm_apply_eq,
  symmetry,
  rw [equiv.symm_apply_eq, ← mul_apply, H, one_apply],
end

theorem of_mem_mul_support {σ τ : Sym n} {i}
  (H : i ∈ (σ * τ).support) :
  i ∈ σ.support ∨ i ∈ τ.support :=
by_contradiction $ λ H2,
by simp [support_def, not_or_distrib] at H H2;
simp [H2] at H; cc

theorem of_not_mem_mul_support {σ τ : Sym n} {i}
  (H : i ∉ (σ * τ).support) :
  i ∈ σ.support ↔ i ∈ τ.support :=
begin
  simp [support_def] at H ⊢,
  split,
  { intros H2 H3, rw H3 at H, cc },
  { intros H2 H3, rw ← H3 at H,
    replace H := σ.bijective.1 H,
    rw H3 at H, cc }
end

theorem not_mem_mul_support {σ τ : Sym n} {i}
  (H1 : i ∉ σ.support) (H2 : i ∉ τ.support) :
  i ∉ (σ * τ).support :=
begin
  simp [support_def] at H1 H2 ⊢,
  rw [H2, H1]
end

@[simp] lemma mem_mk' {i j k : fin n} (H : i ≠ j) :
  k ∈ step.mk' i j H ↔ k = i ∨ k = j :=
begin
  unfold step.mk',
  split_ifs,
  { refl },
  { apply or_comm }
end

-- (ab)(cd) = (cd)(ab)
theorem sgn_aux5 (s t : step n)
  (H1 : s.1 ≠ t.1) (H2 : s.1 ≠ t.2)
  (H3 : s.2 ≠ t.1) (H4 : s.2 ≠ t.2) :
  s.eval * t.eval = t.eval * s.eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  dsimp [step.eval, swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(ac) = (bc)(ab)
theorem sgn_aux4a (s t : step n)
  (H1 : s.1 = t.1) (H4 : s.2 ≠ t.2) :
  s.eval * t.eval = (step.mk' s.2 t.2 H4).eval * s.eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  unfold step.eval step.mk',
  simp [swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(ca) = (cb)(ab)
theorem sgn_aux4b (s t : step n) (H1 : s.1 = t.2)
  (H2 : t.1 < s.2) :
  s.eval * t.eval = (⟨t.1, s.2, H2⟩ : step n).eval * s.eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  have := ne_of_lt H2,
  dsimp [step.eval, swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(ac) = (ac)(bc)
theorem sgn_aux4c (s t : step n)
  (H1 : s.1 = t.1) (H4 : s.2 ≠ t.2) :
  s.eval * t.eval = t.eval * (step.mk' s.2 t.2 H4).eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  unfold step.eval step.mk',
  simp [swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(ca) = (ca)(cb)
theorem sgn_aux4d (s t : step n)
  (H1 : s.1 = t.2) (H4 : t.1 < s.2) :
  s.eval * t.eval = t.eval * (⟨t.1, s.2, H4⟩ : step n).eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  have := ne_of_lt H4,
  simp [step.eval, swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(bc) = (bc)(ac)
theorem sgn_aux3a (s t : step n) (H1 : s.2 = t.1)
  (H2 : s.1 < t.2) :
  s.eval * t.eval = t.eval * (⟨s.1, t.2, H2⟩ : step n).eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  have := ne_of_lt H2,
  dsimp [step.eval, swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(cb) = (cb)(ac)
theorem sgn_aux3b (s t : step n) (H1 : s.2 = t.2)
  (H2 : s.1 ≠ t.1) :
  s.eval * t.eval = t.eval * (step.mk' s.1 t.1 H2).eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  unfold step.eval step.mk',
  simp [swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(bc) = (ac)(ab)
theorem sgn_aux3c (s t : step n) (H1 : s.2 = t.1)
  (H2 : s.1 < t.2) :
  s.eval * t.eval = (⟨s.1, t.2, H2⟩ : step n).eval * s.eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  have := ne_of_lt H2,
  dsimp [step.eval, swap], ext k,
  dsimp at *,
  split_ifs; cc
end

-- (ab)(cb) = (ac)(ab)
theorem sgn_aux3d (s t : step n) (H1 : s.2 = t.2)
  (H2 : s.1 ≠ t.1) :
  s.eval * t.eval = (step.mk' s.1 t.1 H2).eval * s.eval :=
begin
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  unfold step.eval step.mk',
  simp [swap], ext k,
  dsimp at *,
  split_ifs; cc
end

theorem sgn_aux2 (s t : step n) (i) (H : i ∈ s) :
  s = t ∨ ∃ s' t' : step n, s.eval * t.eval = s'.eval * t'.eval
    ∧ i ∉ s' ∧ i ∈ t' :=
begin
  cases H with H H; subst H,
  { by_cases H2 : s.1 = t.1,
    { by_cases H3 : s.2 = t.2,
      { left, ext; assumption },
      right, -- (ab)(ac) = (bc)(ab)
      refine ⟨step.mk' s.2 t.2 H3, s, _, _⟩,
      { exact sgn_aux4a _ _ H2 _ },
      rw [mem_mk'],
      exact ⟨λ H, or.cases_on H
        (ne_of_lt s.3) (H2.symm ▸ (ne_of_lt t.3)),
      or.inl rfl⟩ },
    right,
    by_cases H3 : s.1 = t.2,
    { -- (ab)(ca) = (cb)(ab)
      have H4 : t.1 < s.2 := lt_trans t.3 (H3 ▸ s.3),
      refine ⟨⟨t.1, s.2, H4⟩, s, _, _⟩,
      { exact sgn_aux4b _ _ H3 _ },
      exact ⟨λ H, or.cases_on H
        H2 (ne_of_lt s.3),
      or.inl rfl⟩ },
    by_cases H4 : s.2 = t.1,
    { -- (ab)(bc) = (bc)(ac)
      have H5 : s.1 < t.2 := lt_trans s.3 (H4.symm ▸ t.3),
      refine ⟨t, ⟨s.1, t.2, H5⟩, _, _⟩,
      { exact sgn_aux3a _ _ H4 _ },
      exact ⟨λ H, or.cases_on H
        H2 (ne_of_lt H5),
      or.inl rfl⟩ },
    by_cases H5 : s.2 = t.2,
    { -- (ab)(cb) = (cb)(ac)
      refine ⟨t, step.mk' s.1 t.1 H2, _, _⟩,
      { exact sgn_aux3b _ _ H5 _ },
      exact ⟨λ H, or.cases_on H
        H2 H3,
      by simp⟩ },
    -- (ab)(cd) = (cd)(ab)
    refine ⟨t, s, _, _⟩,
    { exact sgn_aux5 _ _ H2 H3 H4 H5 },
    exact ⟨λ H, or.cases_on H
      H2 H3,
    or.inl rfl⟩ },
  by_cases H2 : s.1 = t.1,
  { by_cases H3 : s.2 = t.2,
    { left, ext; assumption },
    right, -- (ab)(ac) = (ac)(bc)
    refine ⟨t, step.mk' s.2 t.2 H3, _, _⟩,
    { exact sgn_aux4c _ _ H2 _ },
    rw [mem_mk'],
    exact ⟨λ H, or.cases_on H
      (H2 ▸ ne_of_gt s.3) H3,
    or.inl rfl⟩ },
  right,
  by_cases H3 : s.1 = t.2,
  { -- (ab)(ca) = (ca)(cb)
    have H4 : t.1 < s.2 := lt_trans t.3 (H3 ▸ s.3),
    refine ⟨t, ⟨t.1, s.2, H4⟩, _, _⟩,
    { exact sgn_aux4d _ _ H3 _ },
    exact ⟨λ H, or.cases_on H
      (ne_of_gt H4) (H3 ▸ ne_of_gt s.3),
    or.inr rfl⟩ },
  by_cases H4 : s.2 = t.1,
  { -- (ab)(bc) = (ac)(ab)
    have H5 : s.1 < t.2 := lt_trans s.3 (H4.symm ▸ t.3),
    refine ⟨⟨s.1, t.2, H5⟩, s, _, _⟩,
    { exact sgn_aux3c _ _ H4 _ },
    exact ⟨λ H, or.cases_on H
      (ne_of_gt s.3) (H4.symm ▸ ne_of_lt t.3),
    or.inr rfl⟩ },
  by_cases H5 : s.2 = t.2,
  { -- (ab)(cb) = (ac)(ab)
    refine ⟨step.mk' s.1 t.1 H2, s, _, _⟩,
    { exact sgn_aux3d _ _ H5 _ },
    rw [mem_mk'],
    exact ⟨λ H, or.cases_on H
      (ne_of_gt s.3) (H5.symm ▸ ne_of_gt t.3),
    or.inr rfl⟩ },
  refine ⟨t, s, _, _⟩,
  { exact sgn_aux5 _ _ H2 H3 H4 H5 },
  exact ⟨λ H, or.cases_on H
    H4 H5,
  or.inr rfl⟩
end

theorem sgn_aux (L1 : list (step n)) (s : step n) (L2 : list (step n)) (i : fin n)
  (H1 : (L1.map step.eval).prod * s.eval * (L2.map step.eval).prod = 1)
  (H2 : i ∈ s) (H3 : i ∉ (L1.map step.eval).prod.support) :
  ∃ (L : list (step n)),
    (L.map step.eval).prod = 1
    ∧ L.length + 2 = L1.length + 1 + L2.length :=
begin
  induction L2 with hd tl ih generalizing L1 s,
  { simp at H1,
    simp [mem_step_iff_mem_support] at H2,
    rw support_eq_of_mul_eq_one H1 at H3,
    cc },
  simp [mul_assoc] at H1,
  simp [mem_step_iff_mem_support] at H2,
  have H4 := H3,
  rw [support_eq_of_mul_eq_one H1] at H4,
  replace H4 := of_not_mem_mul_support H4,
  replace H4 := H4.1 H2,
  rw [← mem_step_iff_mem_support] at H2,
  rcases sgn_aux2 s hd i H2 with H5 | ⟨s', t', H5, H6, H7⟩,
  { subst H5,
    rw [← mul_assoc s.eval, step.eval_mul_self, one_mul] at H1,
    rw [← list.prod_append, ← list.map_append] at H1,
    refine ⟨_, H1, _⟩,
    simp, unfold bit0, ac_refl },
  specialize ih (L1 ++ [s']) t' _ H7 _,
  rcases ih with ⟨L, H8, H9⟩,
  refine ⟨L, H8, _⟩,
  { simp [H9] },
  { simp at H5 ⊢,
    rw [mul_assoc (L1.map step.eval).prod, ← H5],
    simpa [mul_assoc] using H1 },
  simpa using not_mem_mul_support H3 _,
  simpa [mem_step_iff_mem_support] using H6
end

theorem length_even_of_prod_one (L : list (step n))
  (H : (L.map step.eval).prod = 1) :
  L.length % 2 = 0 :=
begin
  generalize H1 : L.length = k,
  revert L,
  apply nat.strong_induction_on k,
  intros k ih L H H1,
  cases k with k, { refl },
  cases k with k,
  { exfalso,
    rw list.length_eq_one at H1,
    cases H1 with s H2,
    subst H2,
    replace H := congr_arg support H,
    simp [step.eval, support_swap (ne_of_lt s.3)] at H,
    exact H },
  cases L with hd tl, { simp at H1, injections },
  rcases sgn_aux [] hd tl hd.1 _ (or.inl rfl) _ with ⟨L, H2, H3⟩,
  specialize ih k _ L H2 _,
  change (k + 2) % 2 = 0,
  { rw [nat.add_mod_right, ih] },
  { constructor, constructor },
  { simp at H1 H3,
    rw ← H3 at H1,
    exact nat.succ_inj (nat.succ_inj H1) },
  { simpa using H },
  simp
end

theorem length_mod_two_eq (L1 L2 : list (step n))
  (H : (L1.map step.eval).prod = (L2.map step.eval).prod) :
  L1.length % 2 = L2.length % 2 :=
have H1 : (L2.map step.eval).reverse.prod = (L2.map step.eval).prod⁻¹,
  from list.rec_on L2 (by simp) $ λ hd tl ih,
    by simp [ih, eq_inv_iff_mul_eq_one],
have H2 : _,
  from length_even_of_prod_one (L1 ++ L2.reverse) $
    by simp [H1, H],
have H3 : 2 ∣ L1.length + L2.length,
  by simpa [nat.dvd_iff_mod_eq_zero] using H2,
calc  L1.length % 2
    = (L1.length + L2.length + L2.length) % 2 :
  by rw [add_assoc, ← mul_two, nat.add_mul_mod_self_right]
... = L2.length % 2 :
  by cases H3 with k H4; rw [H4, add_comm, nat.add_mul_mod_self_left]

end Sym

@[derive decidable_eq]
inductive mu2 : Type
| plus_one : mu2
| minus_one : mu2

namespace mu2

definition neg : mu2 → mu2
| plus_one := minus_one
| minus_one := plus_one

instance : has_one mu2 := ⟨plus_one⟩
instance : has_neg mu2 := ⟨neg⟩

instance : comm_group mu2 :=
{ mul := λ x y, mu2.rec_on x (mu2.rec_on y 1 (-1)) (mu2.rec_on y (-1) 1),
  mul_assoc := λ x y z, by cases x; cases y; cases z; refl,
  mul_one := λ x, by cases x; refl,
  one_mul := λ x, by cases x; refl,
  inv := id,
  mul_left_inv := λ x, by cases x; refl,
  mul_comm := λ x y, by cases x; cases y; refl,
  .. mu2.has_one }

instance : fintype mu2 :=
{ elems := {1, -1},
  complete := λ x, mu2.cases_on x (or.inr $ or.inl rfl) (or.inl rfl) }

theorem card : fintype.card mu2 = 2 :=
rfl

theorem neg_one_pow {n} : (-1 : mu2) ^ n = (-1 : mu2) ^ (n%2) :=
have H : (-1 : mu2) ^ 2 = 1, from rfl,
by rw [← nat.mod_add_div n 2, pow_add, pow_mul, H, one_pow, mul_one, nat.mod_add_div n 2]

@[simp] lemma mul_self_eq_one (x : mu2) : x * x = 1 :=
by cases x; refl

@[simp] lemma inv_eq_self (x : mu2) : x⁻¹ = x :=
rfl

@[simp] protected lemma mul_neg_one (x : mu2) : x * -1 = -x :=
by cases x; refl

@[simp] protected lemma neg_one_mul (x : mu2) : -1 * x = -x :=
by cases x; refl

@[simp] lemma neg_mul_self (x : mu2) : -x * x = -1 :=
by cases x; refl

@[simp] lemma mul_neg (x y : mu2) : x * -y = -x * y :=
by cases x; cases y; refl

end mu2

namespace Sym

def sgn (σ : Sym n) : mu2 :=
(-1) ^ σ.list_step.length

instance sgn.is_group_hom : is_group_hom (@sgn n) :=
begin
  constructor,
  intros σ τ,
  unfold sgn,
  rw [← pow_add, ← list.length_append],
  rw [mu2.neg_one_pow, eq_comm, mu2.neg_one_pow],
  refine congr_arg _ _,
  apply length_mod_two_eq,
  simp
end

@[simp] lemma sgn_step (s : step n) :
  sgn s.eval = -1 :=
suffices s.eval.list_step.length % 2 = [s].length % 2,
  by unfold sgn; rw [mu2.neg_one_pow, this]; refl,
length_mod_two_eq _ _ $ by simp

@[simp] lemma sgn_mul (σ τ : Sym n) :
  sgn (σ * τ) = sgn σ * sgn τ :=
is_group_hom.mul sgn _ _

@[simp] lemma sgn_one :
  sgn (1 : Sym n) = 1 :=
is_group_hom.one sgn

@[simp] lemma sgn_inv (σ : Sym n) :
  sgn σ⁻¹ = sgn σ :=
is_group_hom.inv sgn _

def eq_sgn_aux4 (s t : step n) : Sym n :=
swap (swap s.1 t.1 s.2) t.2 * swap s.1 t.1

theorem eq_sgn_aux3 (s t : step n) :
  eq_sgn_aux4 s t s.1 = t.1 :=
begin
  dsimp [eq_sgn_aux4, swap],
  have := ne_of_lt s.3,
  have := ne_of_lt t.3,
  simp, split_ifs; cc
end

theorem eq_sgn_aux2 (s t : step n) :
  eq_sgn_aux4 s t s.2 = t.2 :=
begin
  dsimp [eq_sgn_aux4, swap],
  simp
end

theorem eq_sgn_aux (s t : step n) :
  eq_sgn_aux4 s t * s.eval * (eq_sgn_aux4 s t)⁻¹ = t.eval :=
begin
  ext k,
  by_cases H1 : k = t.1,
  { subst H1,
    dsimp [step.eval],
    simp [equiv.symm_apply_eq.2 (eq_sgn_aux3 s t).symm, eq_sgn_aux2] },
  by_cases H2 : k = t.2,
  { subst H2,
    dsimp [step.eval],
    simp [equiv.symm_apply_eq.2 (eq_sgn_aux2 s t).symm, eq_sgn_aux3] },
  dsimp [step.eval, swap],
  simp [H1, H2, eq_sgn_aux2, eq_sgn_aux3]
end

theorem eq_sgn (f : Sym n → mu2) [is_group_hom f]
  (s : step n) (H1 : f s.eval = -1) (σ : Sym n) :
  f σ = sgn σ :=
begin
  have H2 : ∀ t : step n, f t.eval = -1,
  { intro t,
    rw [← eq_sgn_aux s t],
    simp [is_group_hom.mul f, is_group_hom.inv f, H1] },
  have H3 := list_step_prod σ,
  revert H3, generalize : list_step σ = L, intro H3, subst H3,
  induction L with hd tl ih, { simp [is_group_hom.one f] },
  simp [is_group_hom.mul f, ih, H2]
end

section inversions

def step.map (s : step n) (σ : Sym n) : step n :=
step.mk' (σ s.1) (σ s.2) $ λ H, ne_of_lt s.3 $
σ.bijective.1 H

@[simp] lemma step.map_map_inv (s : step n) (σ : Sym n) :
  (s.map σ).map σ⁻¹ = s :=
begin
  unfold step.map step.mk',
  by_cases H1 : σ s.1 < σ s.2,
  { rw [dif_pos H1], dsimp,
    rw dif_pos, ext; simp,
    simp [s.3] },
  rw [dif_neg H1], dsimp,
  rw dif_neg, ext; simp,
  simp [le_of_lt s.3]
end

@[simp] lemma step.map_inv_map (s : step n) (σ : Sym n) :
  (s.map σ⁻¹).map σ = s :=
by simpa using step.map_map_inv s σ⁻¹

def inversion (σ : Sym n) (s : step n) : mu2 :=
if σ s.1 > σ s.2 then -1 else 1

def inversions (σ : Sym n) : mu2 :=
finset.prod finset.univ $ inversion σ

theorem inversion_mul (σ τ : Sym n) (s : step n) :
  inversion (σ * τ) s = inversion σ (s.map τ) * inversion τ s :=
begin
  unfold inversion step.map step.mk',
  split_ifs with h1 h2 h3 h3 h4 h4 h2 h3 h3 h4 h4; try { refl },
  { exfalso, apply lt_asymm h2 h3 },
  { exfalso, apply lt_asymm h1 h3 },
  { simp at *, exfalso,
    exact ne_of_lt s.3 (τ.bijective.1 $ le_antisymm h4 h2) },
  { exfalso, apply lt_asymm h2 h3 },
  { simp at *, exfalso,
    exact ne_of_lt s.3 (τ.bijective.1 $ le_antisymm h4 h2) },
  { simp at *, exfalso,
    exact ne_of_lt s.3 (τ.bijective.1 $ σ.bijective.1 $ le_antisymm h1 h3) }
end

instance : is_group_hom (@inversions n) :=
⟨λ σ τ, calc
      inversions (σ * τ)
    = finset.prod finset.univ (inversion (σ * τ)) : rfl
... = finset.prod finset.univ (λ s : step n,
        inversion σ (s.map τ) * inversion τ s) :
  congr_arg _ $ funext $ inversion_mul σ τ
... = finset.prod finset.univ (λ s : step n,
        inversion σ (s.map τ)) * inversions τ :
  finset.prod_mul_distrib
... = finset.prod finset.univ (inversion σ) * inversions τ :
  congr_arg (λ z, z * inversions τ) $ finset.prod_bij
    (λ s _, step.map s τ) (λ _ _, finset.mem_univ _) (λ _ _, rfl)
    (λ s t _ _ H, by simpa using congr_arg (λ z, step.map z τ⁻¹) H)
    (λ s _, ⟨s.map τ⁻¹, finset.mem_univ _, by simp⟩)⟩

variable (n)
def step01 : step (n+2) :=
⟨⟨0, nat.zero_lt_succ _⟩, ⟨1, nat.succ_lt_succ $ nat.zero_lt_succ _⟩, dec_trivial⟩
variable {n}

theorem inversions_step01 : inversions (step01 n).eval = -1 :=
show _ = finset.prod {step01 n} (inversion (step01 n).eval), from
eq.symm $ finset.prod_subset (finset.subset_univ _) $ λ s _ H1, begin
  unfold inversion step.eval swap step01; dsimp at *, rw if_neg,
  by_cases H2 : s.1.1 = 0,
  { rw [if_pos, if_neg, if_neg],
    { intro H3,
      replace H3 := nat.le_of_lt_succ H3,
      replace H3 := nat.eq_zero_of_le_zero H3,
      exact ne_of_lt s.3 (fin.eq_of_veq $ H2.trans H3.symm) },
    { intro H3, apply H1, simp, ext, exact fin.eq_of_veq H2, exact H3 },
    { exact ne_of_gt (H2 ▸ s.3 : s.2.1 > 0), },
    { exact fin.eq_of_veq H2 } },
  by_cases H3 : s.1.1 = 1,
  { rw [if_neg, if_pos], exact nat.not_lt_zero _,
    exact fin.eq_of_veq H3, exact mt fin.veq_of_eq H2 },
  rw [if_neg, if_neg, if_neg, if_neg],
  { exact lt_asymm s.3 },
  { intro H4, have H5 := s.3, rw H4 at H5,
    replace H5 := nat.le_of_lt_succ H5,
    replace H5 := nat.eq_zero_of_le_zero H5,
    cc },
  { intro H4, have H5 := s.3, rw H4 at H5,
    cases H5 },
  { exact mt fin.veq_of_eq H3 },
  { exact mt fin.veq_of_eq H2 }
end

theorem inversions_eq_sgn : ∀ σ : Sym n, inversions σ = sgn σ :=
nat.cases_on n dec_trivial $ λ n,
nat.cases_on n dec_trivial $ λ n σ,
eq_sgn inversions (step01 n) inversions_step01 σ

end inversions

end Sym

variable (n)
def Alt : Type :=
is_group_hom.ker (@Sym.sgn n)

instance : group (Alt n) :=
by unfold Alt; apply_instance


example (P Q : Type) : (P → Q) → ((Q → empty) → (P → empty)) :=
begin
    intro pq,
    intro qf,
    intro p,
    apply qf,
    apply pq,
    exact p,
end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

! This file was ported from Lean 3 source module order.chain
! leanprover-community/mathlib commit c227d107bbada5d0d9d20287e3282c0a7f1651a0
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Set.Pairwise.Basic
import Mathbin.Data.Set.Lattice
import Mathbin.Data.SetLike.Basic

/-!
# Chains and flags

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

This file defines chains for an arbitrary relation and flags for an order and proves Hausdorff's
Maximality Principle.

## Main declarations

* `is_chain s`: A chain `s` is a set of comparable elements.
* `max_chain_spec`: Hausdorff's Maximality Principle.
* `flag`: The type of flags, aka maximal chains, of an order.

## Notes

Originally ported from Isabelle/HOL. The
[original file](https://isabelle.in.tum.de/dist/library/HOL/HOL/Zorn.html) was written by Jacques D.
Fleuriot, Tobias Nipkow, Christian Sternagel.
-/

open Classical Set

variable {α β : Type _}

/-! ### Chains -/

section Chain

variable (r : α → α → Prop)

-- mathport name: «expr ≺ »
local infixl:50 " ≺ " => r

#print IsChain /-
/-- A chain is a set `s` satisfying `x ≺ y ∨ x = y ∨ y ≺ x` for all `x y ∈ s`. -/
def IsChain (s : Set α) : Prop :=
  s.Pairwise fun x y => x ≺ y ∨ y ≺ x
#align is_chain IsChain
-/

#print SuperChain /-
/-- `super_chain s t` means that `t` is a chain that strictly includes `s`. -/
def SuperChain (s t : Set α) : Prop :=
  IsChain r t ∧ s ⊂ t
#align super_chain SuperChain
-/

#print IsMaxChain /-
/-- A chain `s` is a maximal chain if there does not exists a chain strictly including `s`. -/
def IsMaxChain (s : Set α) : Prop :=
  IsChain r s ∧ ∀ ⦃t⦄, IsChain r t → s ⊆ t → s = t
#align is_max_chain IsMaxChain
-/

variable {r} {c c₁ c₂ c₃ s t : Set α} {a b x y : α}

#print isChain_empty /-
theorem isChain_empty : IsChain r ∅ :=
  Set.pairwise_empty _
#align is_chain_empty isChain_empty
-/

#print Set.Subsingleton.isChain /-
theorem Set.Subsingleton.isChain (hs : s.Subsingleton) : IsChain r s :=
  hs.Pairwise _
#align set.subsingleton.is_chain Set.Subsingleton.isChain
-/

#print IsChain.mono /-
theorem IsChain.mono : s ⊆ t → IsChain r t → IsChain r s :=
  Set.Pairwise.mono
#align is_chain.mono IsChain.mono
-/

#print IsChain.mono_rel /-
theorem IsChain.mono_rel {r' : α → α → Prop} (h : IsChain r s) (h_imp : ∀ x y, r x y → r' x y) :
    IsChain r' s :=
  h.mono' fun x y => Or.imp (h_imp x y) (h_imp y x)
#align is_chain.mono_rel IsChain.mono_rel
-/

#print IsChain.symm /-
/-- This can be used to turn `is_chain (≥)` into `is_chain (≤)` and vice-versa. -/
theorem IsChain.symm (h : IsChain r s) : IsChain (flip r) s :=
  h.mono' fun _ _ => Or.symm
#align is_chain.symm IsChain.symm
-/

#print isChain_of_trichotomous /-
theorem isChain_of_trichotomous [IsTrichotomous α r] (s : Set α) : IsChain r s := fun a _ b _ hab =>
  (trichotomous_of r a b).imp_right fun h => h.resolve_left hab
#align is_chain_of_trichotomous isChain_of_trichotomous
-/

#print IsChain.insert /-
theorem IsChain.insert (hs : IsChain r s) (ha : ∀ b ∈ s, a ≠ b → a ≺ b ∨ b ≺ a) :
    IsChain r (insert a s) :=
  hs.insert_of_symmetric (fun _ _ => Or.symm) ha
#align is_chain.insert IsChain.insert
-/

#print isChain_univ_iff /-
theorem isChain_univ_iff : IsChain r (univ : Set α) ↔ IsTrichotomous α r :=
  by
  refine' ⟨fun h => ⟨fun a b => _⟩, fun h => @isChain_of_trichotomous _ _ h univ⟩
  rw [or_left_comm, or_iff_not_imp_left]
  exact h trivial trivial
#align is_chain_univ_iff isChain_univ_iff
-/

/- warning: is_chain.image -> IsChain.image is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (r : α -> α -> Prop) (s : β -> β -> Prop) (f : α -> β), (forall (x : α) (y : α), (r x y) -> (s (f x) (f y))) -> (forall {c : Set.{u1} α}, (IsChain.{u1} α r c) -> (IsChain.{u2} β s (Set.image.{u1, u2} α β f c)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (r : α -> α -> Prop) (s : β -> β -> Prop) (f : α -> β), (forall (x : α) (y : α), (r x y) -> (s (f x) (f y))) -> (forall {c : Set.{u2} α}, (IsChain.{u2} α r c) -> (IsChain.{u1} β s (Set.image.{u2, u1} α β f c)))
Case conversion may be inaccurate. Consider using '#align is_chain.image IsChain.imageₓ'. -/
theorem IsChain.image (r : α → α → Prop) (s : β → β → Prop) (f : α → β)
    (h : ∀ x y, r x y → s (f x) (f y)) {c : Set α} (hrc : IsChain r c) : IsChain s (f '' c) :=
  fun x ⟨a, ha₁, ha₂⟩ y ⟨b, hb₁, hb₂⟩ =>
  ha₂ ▸ hb₂ ▸ fun hxy => (hrc ha₁ hb₁ <| ne_of_apply_ne f hxy).imp (h _ _) (h _ _)
#align is_chain.image IsChain.image

section Total

variable [IsRefl α r]

#print IsChain.total /-
theorem IsChain.total (h : IsChain r s) (hx : x ∈ s) (hy : y ∈ s) : x ≺ y ∨ y ≺ x :=
  (eq_or_ne x y).elim (fun e => Or.inl <| e ▸ refl _) (h hx hy)
#align is_chain.total IsChain.total
-/

#print IsChain.directedOn /-
theorem IsChain.directedOn (H : IsChain r s) : DirectedOn r s := fun x hx y hy =>
  (H.Total hx hy).elim (fun h => ⟨y, hy, h, refl _⟩) fun h => ⟨x, hx, refl _, h⟩
#align is_chain.directed_on IsChain.directedOn
-/

#print IsChain.directed /-
protected theorem IsChain.directed {f : β → α} {c : Set β} (h : IsChain (f ⁻¹'o r) c) :
    Directed r fun x : { a : β // a ∈ c } => f x := fun ⟨a, ha⟩ ⟨b, hb⟩ =>
  by_cases
    (fun hab : a = b => by
      simp only [hab, exists_prop, and_self_iff, Subtype.exists] <;> exact ⟨b, hb, refl _⟩)
    fun hab => (h ha hb hab).elim (fun h => ⟨⟨b, hb⟩, h, refl _⟩) fun h => ⟨⟨a, ha⟩, refl _, h⟩
#align is_chain.directed IsChain.directed
-/

#print IsChain.exists3 /-
theorem IsChain.exists3 (hchain : IsChain r s) [IsTrans α r] {a b c} (mem1 : a ∈ s) (mem2 : b ∈ s)
    (mem3 : c ∈ s) : ∃ (z : _)(mem4 : z ∈ s), r a z ∧ r b z ∧ r c z :=
  by
  rcases directed_on_iff_directed.mpr (IsChain.directed hchain) a mem1 b mem2 with ⟨z, mem4, H1, H2⟩
  rcases directed_on_iff_directed.mpr (IsChain.directed hchain) z mem4 c mem3 with
    ⟨z', mem5, H3, H4⟩
  exact ⟨z', mem5, trans H1 H3, trans H2 H3, H4⟩
#align is_chain.exists3 IsChain.exists3
-/

end Total

#print IsMaxChain.isChain /-
theorem IsMaxChain.isChain (h : IsMaxChain r s) : IsChain r s :=
  h.1
#align is_max_chain.is_chain IsMaxChain.isChain
-/

#print IsMaxChain.not_superChain /-
theorem IsMaxChain.not_superChain (h : IsMaxChain r s) : ¬SuperChain r s t := fun ht =>
  ht.2.Ne <| h.2 ht.1 ht.2.1
#align is_max_chain.not_super_chain IsMaxChain.not_superChain
-/

/- warning: is_max_chain.bot_mem -> IsMaxChain.bot_mem is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {s : Set.{u1} α} [_inst_1 : LE.{u1} α] [_inst_2 : OrderBot.{u1} α _inst_1], (IsMaxChain.{u1} α (LE.le.{u1} α _inst_1) s) -> (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) (Bot.bot.{u1} α (OrderBot.toHasBot.{u1} α _inst_1 _inst_2)) s)
but is expected to have type
  forall {α : Type.{u1}} {s : Set.{u1} α} [_inst_1 : LE.{u1} α] [_inst_2 : OrderBot.{u1} α _inst_1], (IsMaxChain.{u1} α (fun (x._@.Mathlib.Order.Chain._hyg.1657 : α) (x._@.Mathlib.Order.Chain._hyg.1659 : α) => LE.le.{u1} α _inst_1 x._@.Mathlib.Order.Chain._hyg.1657 x._@.Mathlib.Order.Chain._hyg.1659) s) -> (Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) (Bot.bot.{u1} α (OrderBot.toBot.{u1} α _inst_1 _inst_2)) s)
Case conversion may be inaccurate. Consider using '#align is_max_chain.bot_mem IsMaxChain.bot_memₓ'. -/
theorem IsMaxChain.bot_mem [LE α] [OrderBot α] (h : IsMaxChain (· ≤ ·) s) : ⊥ ∈ s :=
  (h.2 (h.1.insert fun a _ _ => Or.inl bot_le) <| subset_insert _ _).symm ▸ mem_insert _ _
#align is_max_chain.bot_mem IsMaxChain.bot_mem

/- warning: is_max_chain.top_mem -> IsMaxChain.top_mem is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {s : Set.{u1} α} [_inst_1 : LE.{u1} α] [_inst_2 : OrderTop.{u1} α _inst_1], (IsMaxChain.{u1} α (LE.le.{u1} α _inst_1) s) -> (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) (Top.top.{u1} α (OrderTop.toHasTop.{u1} α _inst_1 _inst_2)) s)
but is expected to have type
  forall {α : Type.{u1}} {s : Set.{u1} α} [_inst_1 : LE.{u1} α] [_inst_2 : OrderTop.{u1} α _inst_1], (IsMaxChain.{u1} α (fun (x._@.Mathlib.Order.Chain._hyg.1744 : α) (x._@.Mathlib.Order.Chain._hyg.1746 : α) => LE.le.{u1} α _inst_1 x._@.Mathlib.Order.Chain._hyg.1744 x._@.Mathlib.Order.Chain._hyg.1746) s) -> (Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) (Top.top.{u1} α (OrderTop.toTop.{u1} α _inst_1 _inst_2)) s)
Case conversion may be inaccurate. Consider using '#align is_max_chain.top_mem IsMaxChain.top_memₓ'. -/
theorem IsMaxChain.top_mem [LE α] [OrderTop α] (h : IsMaxChain (· ≤ ·) s) : ⊤ ∈ s :=
  (h.2 (h.1.insert fun a _ _ => Or.inr le_top) <| subset_insert _ _).symm ▸ mem_insert _ _
#align is_max_chain.top_mem IsMaxChain.top_mem

open Classical

#print SuccChain /-
/-- Given a set `s`, if there exists a chain `t` strictly including `s`, then `succ_chain s`
is one of these chains. Otherwise it is `s`. -/
def SuccChain (r : α → α → Prop) (s : Set α) : Set α :=
  if h : ∃ t, IsChain r s ∧ SuperChain r s t then choose h else s
#align succ_chain SuccChain
-/

#print succChain_spec /-
theorem succChain_spec (h : ∃ t, IsChain r s ∧ SuperChain r s t) : SuperChain r s (SuccChain r s) :=
  by
  let ⟨t, hc'⟩ := h
  have : IsChain r s ∧ SuperChain r s (choose h) :=
    @choose_spec _ (fun t => IsChain r s ∧ SuperChain r s t) _
  simp [SuccChain, dif_pos, h, this.right]
#align succ_chain_spec succChain_spec
-/

#print IsChain.succ /-
theorem IsChain.succ (hs : IsChain r s) : IsChain r (SuccChain r s) :=
  if h : ∃ t, IsChain r s ∧ SuperChain r s t then (succChain_spec h).1
  else by
    simp [SuccChain, dif_neg, h]
    exact hs
#align is_chain.succ IsChain.succ
-/

#print IsChain.superChain_succChain /-
theorem IsChain.superChain_succChain (hs₁ : IsChain r s) (hs₂ : ¬IsMaxChain r s) :
    SuperChain r s (SuccChain r s) :=
  by
  simp [IsMaxChain, not_and_or, not_forall_not] at hs₂
  obtain ⟨t, ht, hst⟩ := hs₂.neg_resolve_left hs₁
  exact succChain_spec ⟨t, hs₁, ht, ssubset_iff_subset_ne.2 hst⟩
#align is_chain.super_chain_succ_chain IsChain.superChain_succChain
-/

#print subset_succChain /-
theorem subset_succChain : s ⊆ SuccChain r s :=
  if h : ∃ t, IsChain r s ∧ SuperChain r s t then (succChain_spec h).2.1
  else by simp [SuccChain, dif_neg, h, subset.rfl]
#align subset_succ_chain subset_succChain
-/

#print ChainClosure /-
/-- Predicate for whether a set is reachable from `∅` using `succ_chain` and `⋃₀`. -/
inductive ChainClosure (r : α → α → Prop) : Set α → Prop
  | succ : ∀ {s}, ChainClosure s → ChainClosure (SuccChain r s)
  | union : ∀ {s}, (∀ a ∈ s, ChainClosure a) → ChainClosure (⋃₀ s)
#align chain_closure ChainClosure
-/

#print maxChain /-
/-- An explicit maximal chain. `max_chain` is taken to be the union of all sets in `chain_closure`.
-/
def maxChain (r : α → α → Prop) :=
  ⋃₀ setOf (ChainClosure r)
#align max_chain maxChain
-/

#print chainClosure_empty /-
theorem chainClosure_empty : ChainClosure r ∅ :=
  by
  have : ChainClosure r (⋃₀ ∅) := ChainClosure.union fun a h => h.rec _
  simpa using this
#align chain_closure_empty chainClosure_empty
-/

#print chainClosure_maxChain /-
theorem chainClosure_maxChain : ChainClosure r (maxChain r) :=
  ChainClosure.union fun s => id
#align chain_closure_max_chain chainClosure_maxChain
-/

private theorem chain_closure_succ_total_aux (hc₁ : ChainClosure r c₁) (hc₂ : ChainClosure r c₂)
    (h : ∀ ⦃c₃⦄, ChainClosure r c₃ → c₃ ⊆ c₂ → c₂ = c₃ ∨ SuccChain r c₃ ⊆ c₂) :
    SuccChain r c₂ ⊆ c₁ ∨ c₁ ⊆ c₂ := by
  induction hc₁
  case succ c₃ hc₃ ih =>
    cases' ih with ih ih
    · exact Or.inl (ih.trans subset_succChain)
    · exact (h hc₃ ih).imp_left fun h => h ▸ subset.rfl
  case
    union s hs ih =>
    refine' or_iff_not_imp_left.2 fun hn => sUnion_subset fun a ha => _
    exact (ih a ha).resolve_left fun h => hn <| h.trans <| subset_sUnion_of_mem ha
#align chain_closure_succ_total_aux chain_closure_succ_total_aux

private theorem chain_closure_succ_total (hc₁ : ChainClosure r c₁) (hc₂ : ChainClosure r c₂)
    (h : c₁ ⊆ c₂) : c₂ = c₁ ∨ SuccChain r c₁ ⊆ c₂ :=
  by
  induction hc₂ generalizing c₁ hc₁ h
  case
    succ c₂ hc₂ ih =>
    refine' (chain_closure_succ_total_aux hc₁ hc₂ fun c₁ => ih).imp h.antisymm' fun h₁ => _
    obtain rfl | h₂ := ih hc₁ h₁
    · exact subset.rfl
    · exact h₂.trans subset_succChain
  case union s hs ih =>
    apply Or.imp_left h.antisymm'
    apply by_contradiction
    simp [not_or, sUnion_subset_iff, not_forall]
    intro c₃ hc₃ h₁ h₂
    obtain h | h := chain_closure_succ_total_aux hc₁ (hs c₃ hc₃) fun c₄ => ih _ hc₃
    · exact h₁ (subset_succ_chain.trans h)
    obtain h' | h' := ih c₃ hc₃ hc₁ h
    · exact h₁ h'.subset
    · exact h₂ (h'.trans <| subset_sUnion_of_mem hc₃)
#align chain_closure_succ_total chain_closure_succ_total

#print ChainClosure.total /-
theorem ChainClosure.total (hc₁ : ChainClosure r c₁) (hc₂ : ChainClosure r c₂) :
    c₁ ⊆ c₂ ∨ c₂ ⊆ c₁ :=
  (chainClosure_succ_total_aux hc₂ hc₁ fun c₃ hc₃ => chainClosure_succ_total hc₃ hc₁).imp_left
    subset_succChain.trans
#align chain_closure.total ChainClosure.total
-/

#print ChainClosure.succ_fixpoint /-
theorem ChainClosure.succ_fixpoint (hc₁ : ChainClosure r c₁) (hc₂ : ChainClosure r c₂)
    (hc : SuccChain r c₂ = c₂) : c₁ ⊆ c₂ :=
  by
  induction hc₁
  case succ s₁ hc₁ h => exact (chain_closure_succ_total hc₁ hc₂ h).elim (fun h => h ▸ hc.subset) id
  case union s hs ih => exact sUnion_subset ih
#align chain_closure.succ_fixpoint ChainClosure.succ_fixpoint
-/

#print ChainClosure.succ_fixpoint_iff /-
theorem ChainClosure.succ_fixpoint_iff (hc : ChainClosure r c) :
    SuccChain r c = c ↔ c = maxChain r :=
  ⟨fun h => (subset_unionₛ_of_mem hc).antisymm <| chainClosure_maxChain.succ_fixpoint hc h, fun h =>
    subset_succChain.antisymm' <| (subset_unionₛ_of_mem hc.succ).trans h.symm.Subset⟩
#align chain_closure.succ_fixpoint_iff ChainClosure.succ_fixpoint_iff
-/

#print ChainClosure.isChain /-
theorem ChainClosure.isChain (hc : ChainClosure r c) : IsChain r c :=
  by
  induction hc
  case succ c hc h => exact h.succ
  case union s hs h =>
    change ∀ c ∈ s, IsChain r c at h
    exact fun c₁ ⟨t₁, ht₁, (hc₁ : c₁ ∈ t₁)⟩ c₂ ⟨t₂, ht₂, (hc₂ : c₂ ∈ t₂)⟩ hneq =>
      ((hs _ ht₁).Total <| hs _ ht₂).elim (fun ht => h t₂ ht₂ (ht hc₁) hc₂ hneq) fun ht =>
        h t₁ ht₁ hc₁ (ht hc₂) hneq
#align chain_closure.is_chain ChainClosure.isChain
-/

#print maxChain_spec /-
/-- **Hausdorff's maximality principle**

There exists a maximal totally ordered set of `α`.
Note that we do not require `α` to be partially ordered by `r`. -/
theorem maxChain_spec : IsMaxChain r (maxChain r) :=
  by_contradiction fun h =>
    let ⟨h₁, H⟩ := chainClosure_maxChain.IsChain.superChain_succChain h
    H.Ne (chainClosure_maxChain.succ_fixpoint_iff.mpr rfl).symm
#align max_chain_spec maxChain_spec
-/

end Chain

/-! ### Flags -/

#print Flag /-
/-- The type of flags, aka maximal chains, of an order. -/
structure Flag (α : Type _) [LE α] where
  carrier : Set α
  Chain' : IsChain (· ≤ ·) carrier
  max_chain' : ∀ ⦃s⦄, IsChain (· ≤ ·) s → carrier ⊆ s → carrier = s
#align flag Flag
-/

namespace Flag

section LE

variable [LE α] {s t : Flag α} {a : α}

instance : SetLike (Flag α) α where
  coe := carrier
  coe_injective' s t h := by
    cases s
    cases t
    congr

#print Flag.ext /-
@[ext]
theorem ext : (s : Set α) = t → s = t :=
  SetLike.ext'
#align flag.ext Flag.ext
-/

#print Flag.mem_coe_iff /-
@[simp]
theorem mem_coe_iff : a ∈ (s : Set α) ↔ a ∈ s :=
  Iff.rfl
#align flag.mem_coe_iff Flag.mem_coe_iff
-/

#print Flag.coe_mk /-
@[simp]
theorem coe_mk (s : Set α) (h₁ h₂) : (mk s h₁ h₂ : Set α) = s :=
  rfl
#align flag.coe_mk Flag.coe_mk
-/

#print Flag.mk_coe /-
@[simp]
theorem mk_coe (s : Flag α) : mk (s : Set α) s.Chain' s.max_chain' = s :=
  ext rfl
#align flag.mk_coe Flag.mk_coe
-/

#print Flag.chain_le /-
theorem chain_le (s : Flag α) : IsChain (· ≤ ·) (s : Set α) :=
  s.Chain'
#align flag.chain_le Flag.chain_le
-/

#print Flag.maxChain /-
protected theorem maxChain (s : Flag α) : IsMaxChain (· ≤ ·) (s : Set α) :=
  ⟨s.chain_le, s.max_chain'⟩
#align flag.max_chain Flag.maxChain
-/

/- warning: flag.top_mem -> Flag.top_mem is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : LE.{u1} α] [_inst_2 : OrderTop.{u1} α _inst_1] (s : Flag.{u1} α _inst_1), Membership.Mem.{u1, u1} α (Flag.{u1} α _inst_1) (SetLike.hasMem.{u1, u1} (Flag.{u1} α _inst_1) α (Flag.setLike.{u1} α _inst_1)) (Top.top.{u1} α (OrderTop.toHasTop.{u1} α _inst_1 _inst_2)) s
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : LE.{u1} α] [_inst_2 : OrderTop.{u1} α _inst_1] (s : Flag.{u1} α _inst_1), Membership.mem.{u1, u1} α (Flag.{u1} α _inst_1) (SetLike.instMembership.{u1, u1} (Flag.{u1} α _inst_1) α (Flag.instSetLikeFlag.{u1} α _inst_1)) (Top.top.{u1} α (OrderTop.toTop.{u1} α _inst_1 _inst_2)) s
Case conversion may be inaccurate. Consider using '#align flag.top_mem Flag.top_memₓ'. -/
theorem top_mem [OrderTop α] (s : Flag α) : (⊤ : α) ∈ s :=
  s.maxChain.top_mem
#align flag.top_mem Flag.top_mem

/- warning: flag.bot_mem -> Flag.bot_mem is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : LE.{u1} α] [_inst_2 : OrderBot.{u1} α _inst_1] (s : Flag.{u1} α _inst_1), Membership.Mem.{u1, u1} α (Flag.{u1} α _inst_1) (SetLike.hasMem.{u1, u1} (Flag.{u1} α _inst_1) α (Flag.setLike.{u1} α _inst_1)) (Bot.bot.{u1} α (OrderBot.toHasBot.{u1} α _inst_1 _inst_2)) s
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : LE.{u1} α] [_inst_2 : OrderBot.{u1} α _inst_1] (s : Flag.{u1} α _inst_1), Membership.mem.{u1, u1} α (Flag.{u1} α _inst_1) (SetLike.instMembership.{u1, u1} (Flag.{u1} α _inst_1) α (Flag.instSetLikeFlag.{u1} α _inst_1)) (Bot.bot.{u1} α (OrderBot.toBot.{u1} α _inst_1 _inst_2)) s
Case conversion may be inaccurate. Consider using '#align flag.bot_mem Flag.bot_memₓ'. -/
theorem bot_mem [OrderBot α] (s : Flag α) : (⊥ : α) ∈ s :=
  s.maxChain.bot_mem
#align flag.bot_mem Flag.bot_mem

end LE

section Preorder

variable [Preorder α] {a b : α}

#print Flag.le_or_le /-
protected theorem le_or_le (s : Flag α) (ha : a ∈ s) (hb : b ∈ s) : a ≤ b ∨ b ≤ a :=
  s.chain_le.Total ha hb
#align flag.le_or_le Flag.le_or_le
-/

instance [OrderTop α] (s : Flag α) : OrderTop s :=
  Subtype.orderTop s.top_mem

instance [OrderBot α] (s : Flag α) : OrderBot s :=
  Subtype.orderBot s.bot_mem

instance [BoundedOrder α] (s : Flag α) : BoundedOrder s :=
  Subtype.boundedOrder s.bot_mem s.top_mem

end Preorder

section PartialOrder

variable [PartialOrder α]

#print Flag.chain_lt /-
theorem chain_lt (s : Flag α) : IsChain (· < ·) (s : Set α) := fun a ha b hb h =>
  (s.le_or_le ha hb).imp h.lt_of_le h.lt_of_le'
#align flag.chain_lt Flag.chain_lt
-/

instance [DecidableEq α] [@DecidableRel α (· ≤ ·)] [@DecidableRel α (· < ·)] (s : Flag α) :
    LinearOrder s :=
  { Subtype.partialOrder _ with
    le_total := fun a b => s.le_or_le a.2 b.2
    DecidableEq := Subtype.decidableEq
    decidableLe := Subtype.decidableLE
    decidableLt := Subtype.decidableLT }

end PartialOrder

instance [LinearOrder α] : Unique (Flag α)
    where
  default := ⟨univ, isChain_of_trichotomous _, fun s _ => s.subset_univ.antisymm'⟩
  uniq s := SetLike.coe_injective <| s.3 (isChain_of_trichotomous _) <| subset_univ _

end Flag


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Kevin Buzzard, Yury Kudryashov, Eric Wieser
-/
import linear_algebra.span
import order.partial_sups

/-! ### Products of modules

This file defines constructors for linear maps whose domains or codomains are products.

It contains theorems relating these to each other, as well as to `submodule.prod`, `submodule.map`,
`submodule.comap`, `linear_map.range`, and `linear_map.ker`.

## Main definitions

- products in the domain:
  - `linear_map.fst`
  - `linear_map.snd`
  - `linear_map.coprod`
  - `linear_map.prod_ext`
- products in the codomain:
  - `linear_map.inl`
  - `linear_map.inr`
  - `linear_map.prod`
- products in both domain and codomain:
  - `linear_map.prod_map`
  - `linear_equiv.prod_map`
  - `linear_equiv.skew_prod`
-/

universes u v w x y z u' v' w' y'
variables {R : Type u} {K : Type u'} {M : Type v} {V : Type v'} {M₂ : Type w} {V₂ : Type w'}
variables {M₃ : Type y} {V₃ : Type y'} {M₄ : Type z} {ι : Type x}

section prod

namespace linear_map

variables (S : Type*) [semiring R] [semiring S]
variables [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃] [add_comm_monoid M₄]
variables [module R M] [module R M₂] [module R M₃] [module R M₄]
variables (f : M →ₗ[R] M₂)

section
variables (R M M₂)

/-- The first projection of a product is a linear map. -/
def fst : M × M₂ →ₗ[R] M := { to_fun := prod.fst, map_add' := λ x y, rfl, map_smul' := λ x y, rfl }

/-- The second projection of a product is a linear map. -/
def snd : M × M₂ →ₗ[R] M₂ := { to_fun := prod.snd, map_add' := λ x y, rfl, map_smul' := λ x y, rfl }
end

@[simp] theorem fst_apply (x : M × M₂) : fst R M M₂ x = x.1 := rfl
@[simp] theorem snd_apply (x : M × M₂) : snd R M M₂ x = x.2 := rfl

theorem fst_surjective : function.surjective (fst R M M₂) := λ x, ⟨(x, 0), rfl⟩
theorem snd_surjective : function.surjective (snd R M M₂) := λ x, ⟨(0, x), rfl⟩

/-- The prod of two linear maps is a linear map. -/
@[simps] def prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) : (M →ₗ[R] M₂ × M₃) :=
{ to_fun    := pi.prod f g,
  map_add'  := λ x y, by simp only [pi.prod, prod.mk_add_mk, map_add],
  map_smul' := λ c x, by simp only [pi.prod, prod.smul_mk, map_smul, ring_hom.id_apply] }

lemma coe_prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) : ⇑(f.prod g) = pi.prod f g := rfl

@[simp] theorem fst_prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) :
  (fst R M₂ M₃).comp (prod f g) = f := by ext; refl

@[simp] theorem snd_prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) :
  (snd R M₂ M₃).comp (prod f g) = g := by ext; refl

@[simp] theorem pair_fst_snd : prod (fst R M M₂) (snd R M M₂) = linear_map.id :=
fun_like.coe_injective pi.prod_fst_snd

/-- Taking the product of two maps with the same domain is equivalent to taking the product of
their codomains.

See note [bundled maps over different rings] for why separate `R` and `S` semirings are used. -/
@[simps] def prod_equiv
  [module S M₂] [module S M₃] [smul_comm_class R S M₂] [smul_comm_class R S M₃] :
  ((M →ₗ[R] M₂) × (M →ₗ[R] M₃)) ≃ₗ[S] (M →ₗ[R] M₂ × M₃) :=
{ to_fun := λ f, f.1.prod f.2,
  inv_fun := λ f, ((fst _ _ _).comp f, (snd _ _ _).comp f),
  left_inv := λ f, by ext; refl,
  right_inv := λ f, by ext; refl,
  map_add' := λ a b, rfl,
  map_smul' := λ r a, rfl }

section
variables (R M M₂)

/-- The left injection into a product is a linear map. -/
def inl : M →ₗ[R] M × M₂ := prod linear_map.id 0

/-- The right injection into a product is a linear map. -/
def inr : M₂ →ₗ[R] M × M₂ := prod 0 linear_map.id

theorem range_inl : range (inl R M M₂) = ker (snd R M M₂) :=
begin
  ext x,
  simp only [mem_ker, mem_range],
  split,
  { rintros ⟨y, rfl⟩, refl },
  { intro h, exact ⟨x.fst, prod.ext rfl h.symm⟩ }
end

theorem ker_snd : ker (snd R M M₂) = range (inl R M M₂) :=
eq.symm $ range_inl R M M₂

theorem range_inr : range (inr R M M₂) = ker (fst R M M₂) :=
begin
  ext x,
  simp only [mem_ker, mem_range],
  split,
  { rintros ⟨y, rfl⟩, refl },
  { intro h, exact ⟨x.snd, prod.ext h.symm rfl⟩ }
end

theorem ker_fst : ker (fst R M M₂) = range (inr R M M₂) :=
eq.symm $ range_inr R M M₂

end

@[simp] theorem coe_inl : (inl R M M₂ : M → M × M₂) = λ x, (x, 0) := rfl
theorem inl_apply (x : M) : inl R M M₂ x = (x, 0) := rfl

@[simp] theorem coe_inr : (inr R M M₂ : M₂ → M × M₂) = prod.mk 0 := rfl
theorem inr_apply (x : M₂) : inr R M M₂ x = (0, x) := rfl

theorem inl_eq_prod : inl R M M₂ = prod linear_map.id 0 := rfl

theorem inr_eq_prod : inr R M M₂ = prod 0 linear_map.id := rfl

theorem inl_injective : function.injective (inl R M M₂) :=
λ _, by simp

/-- The coprod function `λ x : M × M₂, f x.1 + g x.2` is a linear map. -/
def coprod (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) : M × M₂ →ₗ[R] M₃ :=
f.comp (fst _ _ _) + g.comp (snd _ _ _)

@[simp] theorem coprod_apply (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) (x : M × M₂) :
  coprod f g x = f x.1 + g x.2 := rfl

@[simp] theorem coprod_inl (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) :
  (coprod f g).comp (inl R M M₂) = f :=
by ext; simp only [map_zero, add_zero, coprod_apply, inl_apply, comp_apply]

@[simp] theorem coprod_inr (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) :
  (coprod f g).comp (inr R M M₂) = g :=
by ext; simp only [map_zero, coprod_apply, inr_apply, zero_add, comp_apply]

@[simp] theorem coprod_inl_inr : coprod (inl R M M₂) (inr R M M₂) = linear_map.id :=
by ext; simp only [prod.mk_add_mk, add_zero, id_apply, coprod_apply,
  inl_apply, inr_apply, zero_add]

theorem comp_coprod (f : M₃ →ₗ[R] M₄) (g₁ : M →ₗ[R] M₃) (g₂ : M₂ →ₗ[R] M₃) :
  f.comp (g₁.coprod g₂) = (f.comp g₁).coprod (f.comp g₂) :=
ext $ λ x, f.map_add (g₁ x.1) (g₂ x.2)

theorem fst_eq_coprod : fst R M M₂ = coprod linear_map.id 0 := by ext; simp

theorem snd_eq_coprod : snd R M M₂ = coprod 0 linear_map.id := by ext; simp

@[simp] theorem coprod_comp_prod (f : M₂ →ₗ[R] M₄) (g : M₃ →ₗ[R] M₄)
  (f' : M →ₗ[R] M₂) (g' : M →ₗ[R] M₃) :
  (f.coprod g).comp (f'.prod g') = f.comp f' + g.comp g' :=
rfl

@[simp]
lemma coprod_map_prod (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) (S : submodule R M)
  (S' : submodule R M₂) :
  (submodule.prod S S').map (linear_map.coprod f g) = S.map f ⊔ S'.map g :=
set_like.coe_injective $ begin
  simp only [linear_map.coprod_apply, submodule.coe_sup, submodule.map_coe],
  rw [←set.image2_add, set.image2_image_left, set.image2_image_right],
  exact set.image_prod (λ m m₂, f m + g m₂),
end

/-- Taking the product of two maps with the same codomain is equivalent to taking the product of
their domains.

See note [bundled maps over different rings] for why separate `R` and `S` semirings are used. -/
@[simps] def coprod_equiv [module S M₃] [smul_comm_class R S M₃] :
  ((M →ₗ[R] M₃) × (M₂ →ₗ[R] M₃)) ≃ₗ[S] (M × M₂ →ₗ[R] M₃) :=
{ to_fun := λ f, f.1.coprod f.2,
  inv_fun := λ f, (f.comp (inl _ _ _), f.comp (inr _ _ _)),
  left_inv := λ f, by simp only [prod.mk.eta, coprod_inl, coprod_inr],
  right_inv := λ f, by simp only [←comp_coprod, comp_id, coprod_inl_inr],
  map_add' := λ a b,
    by { ext, simp only [prod.snd_add, add_apply, coprod_apply, prod.fst_add, add_add_add_comm] },
  map_smul' := λ r a,
    by { dsimp, ext, simp only [smul_add, smul_apply, prod.smul_snd, prod.smul_fst,
                                coprod_apply] } }

theorem prod_ext_iff {f g : M × M₂ →ₗ[R] M₃} :
  f = g ↔ f.comp (inl _ _ _) = g.comp (inl _ _ _) ∧ f.comp (inr _ _ _) = g.comp (inr _ _ _) :=
(coprod_equiv ℕ).symm.injective.eq_iff.symm.trans prod.ext_iff

/--
Split equality of linear maps from a product into linear maps over each component, to allow `ext`
to apply lemmas specific to `M →ₗ M₃` and `M₂ →ₗ M₃`.

See note [partially-applied ext lemmas]. -/
@[ext] theorem prod_ext {f g : M × M₂ →ₗ[R] M₃}
  (hl : f.comp (inl _ _ _) = g.comp (inl _ _ _))
  (hr : f.comp (inr _ _ _) = g.comp (inr _ _ _)) :
  f = g :=
prod_ext_iff.2 ⟨hl, hr⟩

/-- `prod.map` of two linear maps. -/
def prod_map (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₄) : (M × M₂) →ₗ[R] (M₃ × M₄) :=
(f.comp (fst R M M₂)).prod (g.comp (snd R M M₂))

@[simp] theorem prod_map_apply (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₄) (x) :
  f.prod_map g x = (f x.1, g x.2) := rfl

lemma prod_map_comap_prod (f : M →ₗ[R] M₂) (g : M₃ →ₗ[R] M₄) (S : submodule R M₂)
  (S' : submodule R M₄) :
  (submodule.prod S S').comap (linear_map.prod_map f g) = (S.comap f).prod (S'.comap g) :=
set_like.coe_injective $ set.preimage_prod_map_prod f g _ _

lemma ker_prod_map (f : M →ₗ[R] M₂) (g : M₃ →ₗ[R] M₄) :
  (linear_map.prod_map f g).ker = submodule.prod f.ker g.ker :=
begin
  dsimp only [ker],
  rw [←prod_map_comap_prod, submodule.prod_bot],
end

section map_mul

variables {A : Type*} [non_unital_non_assoc_semiring A] [module R A]
variables {B : Type*} [non_unital_non_assoc_semiring B] [module R B]

lemma inl_map_mul (a₁ a₂ : A) : linear_map.inl R A B (a₁ * a₂) =
  linear_map.inl R A B a₁ * linear_map.inl R A B a₂ :=
prod.ext rfl (by simp)

lemma inr_map_mul (b₁ b₂ : B) : linear_map.inr R A B (b₁ * b₂) =
  linear_map.inr R A B b₁ * linear_map.inr R A B b₂ :=
prod.ext (by simp) rfl

end map_mul

end linear_map

end prod

namespace linear_map
open submodule

variables [semiring R]
  [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃] [add_comm_monoid M₄]
  [module R M] [module R M₂] [module R M₃] [module R M₄]

lemma range_coprod (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) :
  (f.coprod g).range = f.range ⊔ g.range :=
submodule.ext $ λ x, by simp [mem_sup]

lemma is_compl_range_inl_inr : is_compl (inl R M M₂).range (inr R M M₂).range :=
begin
  split,
  { rintros ⟨_, _⟩ ⟨⟨x, hx⟩, ⟨y, hy⟩⟩,
    simp only [prod.ext_iff, inl_apply, inr_apply, mem_bot] at hx hy ⊢,
    exact ⟨hy.1.symm, hx.2.symm⟩ },
  { rintros ⟨x, y⟩ -,
    simp only [mem_sup, mem_range, exists_prop],
    refine ⟨(x, 0), ⟨x, rfl⟩, (0, y), ⟨y, rfl⟩, _⟩,
    simp }
end

lemma sup_range_inl_inr : (inl R M M₂).range ⊔ (inr R M M₂).range = ⊤ :=
is_compl_range_inl_inr.sup_eq_top

lemma disjoint_inl_inr : disjoint (inl R M M₂).range (inr R M M₂).range :=
by simp [disjoint_def, @eq_comm M 0, @eq_comm M₂ 0] {contextual := tt}; intros; refl
theorem map_coprod_prod (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃)
  (p : submodule R M) (q : submodule R M₂) :
  map (coprod f g) (p.prod q) = map f p ⊔ map g q :=
begin
  refine le_antisymm _ (sup_le (map_le_iff_le_comap.2 _) (map_le_iff_le_comap.2 _)),
  { rw set_like.le_def, rintro _ ⟨x, ⟨h₁, h₂⟩, rfl⟩,
    exact mem_sup.2 ⟨_, ⟨_, h₁, rfl⟩, _, ⟨_, h₂, rfl⟩, rfl⟩ },
  { exact λ x hx, ⟨(x, 0), by simp [hx]⟩ },
  { exact λ x hx, ⟨(0, x), by simp [hx]⟩ }
end

theorem comap_prod_prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃)
  (p : submodule R M₂) (q : submodule R M₃) :
  comap (prod f g) (p.prod q) = comap f p ⊓ comap g q :=
submodule.ext $ λ x, iff.rfl

theorem prod_eq_inf_comap (p : submodule R M) (q : submodule R M₂) :
  p.prod q = p.comap (linear_map.fst R M M₂) ⊓ q.comap (linear_map.snd R M M₂) :=
submodule.ext $ λ x, iff.rfl

theorem prod_eq_sup_map (p : submodule R M) (q : submodule R M₂) :
  p.prod q = p.map (linear_map.inl R M M₂) ⊔ q.map (linear_map.inr R M M₂) :=
by rw [← map_coprod_prod, coprod_inl_inr, map_id]

lemma span_inl_union_inr {s : set M} {t : set M₂} :
  span R (inl R M  M₂ '' s ∪ inr R M M₂ '' t) = (span R s).prod (span R t) :=
by rw [span_union, prod_eq_sup_map, ← span_image, ← span_image]

@[simp] lemma ker_prod (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) :
  ker (prod f g) = ker f ⊓ ker g :=
by rw [ker, ← prod_bot, comap_prod_prod]; refl

lemma range_prod_le (f : M →ₗ[R] M₂) (g : M →ₗ[R] M₃) :
  range (prod f g) ≤ (range f).prod (range g) :=
begin
  simp only [set_like.le_def, prod_apply, mem_range, set_like.mem_coe, mem_prod,
    exists_imp_distrib],
  rintro _ x rfl,
  exact ⟨⟨x, rfl⟩, ⟨x, rfl⟩⟩
end

lemma ker_prod_ker_le_ker_coprod {M₂ : Type*} [add_comm_group M₂] [module R M₂]
  {M₃ : Type*} [add_comm_group M₃] [module R M₃]
  (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) :
  (ker f).prod (ker g) ≤ ker (f.coprod g) :=
by { rintros ⟨y, z⟩, simp {contextual := tt} }

lemma ker_coprod_of_disjoint_range {M₂ : Type*} [add_comm_group M₂] [module R M₂]
  {M₃ : Type*} [add_comm_group M₃] [module R M₃]
  (f : M →ₗ[R] M₃) (g : M₂ →ₗ[R] M₃) (hd : disjoint f.range g.range) :
  ker (f.coprod g) = (ker f).prod (ker g) :=
begin
  apply le_antisymm _ (ker_prod_ker_le_ker_coprod f g),
  rintros ⟨y, z⟩ h,
  simp only [mem_ker, mem_prod, coprod_apply] at h ⊢,
  have : f y ∈ f.range ⊓ g.range,
  { simp only [true_and, mem_range, mem_inf, exists_apply_eq_apply],
    use -z,
    rwa [eq_comm, map_neg, ← sub_eq_zero, sub_neg_eq_add] },
  rw [hd.eq_bot, mem_bot] at this,
  rw [this] at h,
  simpa [this] using h,
end

end linear_map

namespace submodule
open linear_map

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

lemma sup_eq_range (p q : submodule R M) : p ⊔ q = (p.subtype.coprod q.subtype).range :=
submodule.ext $ λ x, by simp [submodule.mem_sup, set_like.exists]

variables (p : submodule R M) (q : submodule R M₂)

@[simp] theorem map_inl : p.map (inl R M M₂) = prod p ⊥ :=
by { ext ⟨x, y⟩, simp only [and.left_comm, eq_comm, mem_map, prod.mk.inj_iff, inl_apply, mem_bot,
  exists_eq_left', mem_prod] }

@[simp] theorem map_inr : q.map (inr R M M₂) = prod ⊥ q :=
by ext ⟨x, y⟩; simp [and.left_comm, eq_comm]

@[simp] theorem comap_fst : p.comap (fst R M M₂) = prod p ⊤ :=
by ext ⟨x, y⟩; simp

@[simp] theorem comap_snd : q.comap (snd R M M₂) = prod ⊤ q :=
by ext ⟨x, y⟩; simp

@[simp] theorem prod_comap_inl : (prod p q).comap (inl R M M₂) = p := by ext; simp

@[simp] theorem prod_comap_inr : (prod p q).comap (inr R M M₂) = q := by ext; simp

@[simp] theorem prod_map_fst : (prod p q).map (fst R M M₂) = p :=
by ext x; simp [(⟨0, zero_mem _⟩ : ∃ x, x ∈ q)]

@[simp] theorem prod_map_snd : (prod p q).map (snd R M M₂) = q :=
by ext x; simp [(⟨0, zero_mem _⟩ : ∃ x, x ∈ p)]

@[simp] theorem ker_inl : (inl R M M₂).ker = ⊥ :=
by rw [ker, ← prod_bot, prod_comap_inl]

@[simp] theorem ker_inr : (inr R M M₂).ker = ⊥ :=
by rw [ker, ← prod_bot, prod_comap_inr]

@[simp] theorem range_fst : (fst R M M₂).range = ⊤ :=
by rw [range_eq_map, ← prod_top, prod_map_fst]

@[simp] theorem range_snd : (snd R M M₂).range = ⊤ :=
by rw [range_eq_map, ← prod_top, prod_map_snd]

variables (R M M₂)

/-- `M` as a submodule of `M × N`. -/
def fst : submodule R (M × M₂) := (⊥ : submodule R M₂).comap (linear_map.snd R M M₂)

/-- `M` as a submodule of `M × N` is isomorphic to `M`. -/
@[simps] def fst_equiv : submodule.fst R M M₂ ≃ₗ[R] M :=
{ to_fun := λ x, x.1.1,
  inv_fun := λ m, ⟨⟨m, 0⟩, by tidy⟩,
  map_add' := by simp,
  map_smul' := by simp,
  left_inv := by tidy,
  right_inv := by tidy, }

lemma fst_map_fst : (submodule.fst R M M₂).map (linear_map.fst R M M₂) = ⊤ :=
by tidy
lemma fst_map_snd : (submodule.fst R M M₂).map (linear_map.snd R M M₂) = ⊥ :=
by { tidy, exact 0, }

/-- `N` as a submodule of `M × N`. -/
def snd : submodule R (M × M₂) := (⊥ : submodule R M).comap (linear_map.fst R M M₂)

/-- `N` as a submodule of `M × N` is isomorphic to `N`. -/
@[simps] def snd_equiv : submodule.snd R M M₂ ≃ₗ[R] M₂ :=
{ to_fun := λ x, x.1.2,
  inv_fun := λ n, ⟨⟨0, n⟩, by tidy⟩,
  map_add' := by simp,
  map_smul' := by simp,
  left_inv := by tidy,
  right_inv := by tidy, }

lemma snd_map_fst : (submodule.snd R M M₂).map (linear_map.fst R M M₂) = ⊥ :=
by { tidy, exact 0, }
lemma snd_map_snd : (submodule.snd R M M₂).map (linear_map.snd R M M₂) = ⊤ :=
by tidy

lemma fst_sup_snd : submodule.fst R M M₂ ⊔ submodule.snd R M M₂ = ⊤ :=
begin
  rw eq_top_iff,
  rintro ⟨m, n⟩ -,
  rw [show (m, n) = (m, 0) + (0, n), by simp],
  apply submodule.add_mem (submodule.fst R M M₂ ⊔ submodule.snd R M M₂),
  { exact submodule.mem_sup_left (submodule.mem_comap.mpr (by simp)), },
  { exact submodule.mem_sup_right (submodule.mem_comap.mpr (by simp)), },
end

lemma fst_inf_snd : submodule.fst R M M₂ ⊓ submodule.snd R M M₂ = ⊥ := by tidy

lemma le_prod_iff {p₁ : submodule R M} {p₂ : submodule R M₂} {q : submodule R (M × M₂)} :
  q ≤ p₁.prod p₂ ↔ map (linear_map.fst R M M₂) q ≤ p₁ ∧ map (linear_map.snd R M M₂) q ≤ p₂ :=
begin
  split,
  { intros h,
    split,
    { rintros x ⟨⟨y1,y2⟩, ⟨hy1,rfl⟩⟩, exact (h hy1).1 },
    { rintros x ⟨⟨y1,y2⟩, ⟨hy1,rfl⟩⟩, exact (h hy1).2 }, },
  { rintros ⟨hH, hK⟩ ⟨x1, x2⟩ h, exact ⟨hH ⟨_ , h, rfl⟩, hK ⟨ _, h, rfl⟩⟩, }
end

lemma prod_le_iff {p₁ : submodule R M} {p₂ : submodule R M₂} {q : submodule R (M × M₂)} :
  p₁.prod p₂ ≤ q ↔ map (linear_map.inl R M M₂) p₁ ≤ q ∧ map (linear_map.inr R M M₂) p₂ ≤ q :=
begin
  split,
  { intros h,
    split,
    { rintros _ ⟨x, hx, rfl⟩, apply h, exact ⟨hx, (zero_mem _)⟩, },
    { rintros _ ⟨x, hx, rfl⟩, apply h, exact ⟨zero_mem _, hx⟩, }, },
  { rintros ⟨hH, hK⟩ ⟨x1, x2⟩ ⟨h1, h2⟩,
    have h1' : (linear_map.inl R _ _) x1 ∈ q, { apply hH, simpa using h1, },
    have h2' : (linear_map.inr R _ _) x2 ∈ q, { apply hK, simpa using h2, },
    simpa using add_mem _ h1' h2', }
end

lemma prod_eq_bot_iff {p₁ : submodule R M} {p₂ : submodule R M₂} :
  p₁.prod p₂ = ⊥ ↔ p₁ = ⊥ ∧ p₂ = ⊥ :=
by simp only [eq_bot_iff, prod_le_iff, (gc_map_comap _).le_iff_le, comap_bot, ker_inl, ker_inr]

lemma prod_eq_top_iff {p₁ : submodule R M} {p₂ : submodule R M₂} :
  p₁.prod p₂ = ⊤ ↔ p₁ = ⊤ ∧ p₂ = ⊤ :=
by simp only [eq_top_iff, le_prod_iff, ← (gc_map_comap _).le_iff_le, map_top, range_fst, range_snd]

end submodule

namespace linear_equiv

/-- Product of modules is commutative up to linear isomorphism. -/
@[simps apply]
def prod_comm (R M N : Type*) [semiring R] [add_comm_monoid M] [add_comm_monoid N]
  [module R M] [module R N] : (M × N) ≃ₗ[R] (N × M) :=
{ to_fun := prod.swap,
  map_smul' := λ r ⟨m, n⟩, rfl,
  ..add_equiv.prod_comm }

section

variables [semiring R]
variables [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃] [add_comm_monoid M₄]
variables {module_M : module R M} {module_M₂ : module R M₂}
variables {module_M₃ : module R M₃} {module_M₄ : module R M₄}
variables (e₁ : M ≃ₗ[R] M₂) (e₂ : M₃ ≃ₗ[R] M₄)

/-- Product of linear equivalences; the maps come from `equiv.prod_congr`. -/
protected def prod :
  (M × M₃) ≃ₗ[R] (M₂ × M₄) :=
{ map_add'  := λ x y, prod.ext (e₁.map_add _ _) (e₂.map_add _ _),
  map_smul' := λ c x, prod.ext (e₁.map_smulₛₗ c _) (e₂.map_smulₛₗ c _),
  .. equiv.prod_congr e₁.to_equiv e₂.to_equiv }

lemma prod_symm : (e₁.prod e₂).symm = e₁.symm.prod e₂.symm := rfl

@[simp] lemma prod_apply (p) :
  e₁.prod e₂ p = (e₁ p.1, e₂ p.2) := rfl

@[simp, norm_cast] lemma coe_prod :
  (e₁.prod e₂ : (M × M₃) →ₗ[R] (M₂ × M₄)) = (e₁ : M →ₗ[R] M₂).prod_map (e₂ : M₃ →ₗ[R] M₄) := rfl

end

section
variables [semiring R]
variables [add_comm_monoid M] [add_comm_monoid M₂] [add_comm_monoid M₃] [add_comm_group M₄]
variables {module_M : module R M} {module_M₂ : module R M₂}
variables {module_M₃ : module R M₃} {module_M₄ : module R M₄}
variables (e₁ : M ≃ₗ[R] M₂) (e₂ : M₃ ≃ₗ[R] M₄)

/-- Equivalence given by a block lower diagonal matrix. `e₁` and `e₂` are diagonal square blocks,
  and `f` is a rectangular block below the diagonal. -/
protected def skew_prod (f : M →ₗ[R] M₄) :
  (M × M₃) ≃ₗ[R] M₂ × M₄ :=
{ inv_fun := λ p : M₂ × M₄, (e₁.symm p.1, e₂.symm (p.2 - f (e₁.symm p.1))),
  left_inv := λ p, by simp,
  right_inv := λ p, by simp,
  .. ((e₁ : M →ₗ[R] M₂).comp (linear_map.fst R M M₃)).prod
    ((e₂ : M₃ →ₗ[R] M₄).comp (linear_map.snd R M M₃) +
      f.comp (linear_map.fst R M M₃)) }

@[simp] lemma skew_prod_apply (f : M →ₗ[R] M₄) (x) :
  e₁.skew_prod e₂ f x = (e₁ x.1, e₂ x.2 + f x.1) := rfl

@[simp] lemma skew_prod_symm_apply (f : M →ₗ[R] M₄) (x) :
  (e₁.skew_prod e₂ f).symm x = (e₁.symm x.1, e₂.symm (x.2 - f (e₁.symm x.1))) := rfl

end
end linear_equiv

namespace linear_map
open submodule

variables [ring R]
variables [add_comm_group M] [add_comm_group M₂] [add_comm_group M₃]
variables [module R M] [module R M₂] [module R M₃]

/-- If the union of the kernels `ker f` and `ker g` spans the domain, then the range of
`prod f g` is equal to the product of `range f` and `range g`. -/
lemma range_prod_eq {f : M →ₗ[R] M₂} {g : M →ₗ[R] M₃} (h : ker f ⊔ ker g = ⊤) :
  range (prod f g) = (range f).prod (range g) :=
begin
  refine le_antisymm (f.range_prod_le g) _,
  simp only [set_like.le_def, prod_apply, mem_range, set_like.mem_coe, mem_prod, exists_imp_distrib,
    and_imp, prod.forall, pi.prod],
  rintros _ _ x rfl y rfl,
  simp only [prod.mk.inj_iff, ← sub_mem_ker_iff],
  have : y - x ∈ ker f ⊔ ker g, { simp only [h, mem_top] },
  rcases mem_sup.1 this with ⟨x', hx', y', hy', H⟩,
  refine ⟨x' + x, _, _⟩,
  { rwa add_sub_cancel },
  { rwa [← eq_sub_iff_add_eq.1 H, add_sub_add_right_eq_sub, ← neg_mem_iff, neg_sub,
      add_sub_cancel'] }
end

end linear_map

namespace linear_map
/-!
## Tunnels and tailings

Some preliminary work for establishing the strong rank condition for noetherian rings.

Given a morphism `f : M × N →ₗ[R] M` which is `i : injective f`,
we can find an infinite decreasing `tunnel f i n` of copies of `M` inside `M`,
and sitting beside these, an infinite sequence of copies of `N`.

We picturesquely name these as `tailing f i n` for each individual copy of `N`,
and `tailings f i n` for the supremum of the first `n+1` copies:
they are the pieces left behind, sitting inside the tunnel.

By construction, each `tailing f i (n+1)` is disjoint from `tailings f i n`;
later, when we assume `M` is noetherian, this implies that `N` must be trivial,
and establishes the strong rank condition for any left-noetherian ring.
-/
section tunnel

-- (This doesn't work over a semiring: we need to use that `submodule R M` is a modular lattice,
-- which requires cancellation.)
variables [ring R]
variables {N : Type*} [add_comm_group M] [module R M] [add_comm_group N] [module R N]

open function

/-- An auxiliary construction for `tunnel`.
The composition of `f`, followed by the isomorphism back to `K`,
followed by the inclusion of this submodule back into `M`. -/
def tunnel_aux (f : M × N →ₗ[R] M) (Kφ : Σ K : submodule R M, K ≃ₗ[R] M) :
  M × N →ₗ[R] M :=
(Kφ.1.subtype.comp Kφ.2.symm.to_linear_map).comp f

lemma tunnel_aux_injective
  (f : M × N →ₗ[R] M) (i : injective f) (Kφ : Σ K : submodule R M, K ≃ₗ[R] M) :
  injective (tunnel_aux f Kφ) :=
(subtype.val_injective.comp Kφ.2.symm.injective).comp i

noncomputable theory

/-- Auxiliary definition for `tunnel`. -/
-- Even though we have `noncomputable theory`,
-- we get an error without another `noncomputable` here.
noncomputable def tunnel' (f : M × N →ₗ[R] M) (i : injective f) :
  ℕ → Σ (K : submodule R M), K ≃ₗ[R] M
| 0 := ⟨⊤, linear_equiv.of_top ⊤ rfl⟩
| (n+1) :=
⟨(submodule.fst R M N).map (tunnel_aux f (tunnel' n)),
  ((submodule.fst R M N).equiv_map_of_injective _ (tunnel_aux_injective f i (tunnel' n))).symm.trans
    (submodule.fst_equiv R M N)⟩

/--
Give an injective map `f : M × N →ₗ[R] M` we can find a nested sequence of submodules
all isomorphic to `M`.
-/
def tunnel (f : M × N →ₗ[R] M) (i : injective f) : ℕ →o order_dual (submodule R M) :=
⟨λ n, (tunnel' f i n).1, monotone_nat_of_le_succ (λ n, begin
    dsimp [tunnel', tunnel_aux],
    rw [submodule.map_comp, submodule.map_comp],
    apply submodule.map_subtype_le,
  end)⟩

/--
Give an injective map `f : M × N →ₗ[R] M` we can find a sequence of submodules
all isomorphic to `N`.
-/
def tailing (f : M × N →ₗ[R] M) (i : injective f) (n : ℕ) : submodule R M :=
(submodule.snd R M N).map (tunnel_aux f (tunnel' f i n))

/-- Each `tailing f i n` is a copy of `N`. -/
def tailing_linear_equiv (f : M × N →ₗ[R] M) (i : injective f) (n : ℕ) : tailing f i n ≃ₗ[R] N :=
((submodule.snd R M N).equiv_map_of_injective _
  (tunnel_aux_injective f i (tunnel' f i n))).symm.trans (submodule.snd_equiv R M N)

lemma tailing_le_tunnel (f : M × N →ₗ[R] M) (i : injective f) (n : ℕ) :
  tailing f i n ≤ tunnel f i n :=
begin
  dsimp [tailing, tunnel_aux],
  rw [submodule.map_comp, submodule.map_comp],
  apply submodule.map_subtype_le,
end

lemma tailing_disjoint_tunnel_succ (f : M × N →ₗ[R] M) (i : injective f) (n : ℕ) :
  disjoint (tailing f i n) (tunnel f i (n+1)) :=
begin
  rw disjoint_iff,
  dsimp [tailing, tunnel, tunnel'],
  rw [submodule.map_inf_eq_map_inf_comap,
    submodule.comap_map_eq_of_injective (tunnel_aux_injective _ i _), inf_comm,
    submodule.fst_inf_snd, submodule.map_bot],
end

lemma tailing_sup_tunnel_succ_le_tunnel (f : M × N →ₗ[R] M) (i : injective f) (n : ℕ) :
  tailing f i n ⊔ tunnel f i (n+1) ≤ tunnel f i n :=
begin
  dsimp [tailing, tunnel, tunnel', tunnel_aux],
  rw [←submodule.map_sup, sup_comm, submodule.fst_sup_snd, submodule.map_comp, submodule.map_comp],
  apply submodule.map_subtype_le,
end

/-- The supremum of all the copies of `N` found inside the tunnel. -/
def tailings (f : M × N →ₗ[R] M) (i : injective f) : ℕ → submodule R M :=
partial_sups (tailing f i)

@[simp] lemma tailings_zero (f : M × N →ₗ[R] M) (i : injective f) :
  tailings f i 0 = tailing f i 0 :=
by simp [tailings]

@[simp] lemma tailings_succ (f : M × N →ₗ[R] M) (i : injective f) (n : ℕ) :
  tailings f i (n+1) = tailings f i n ⊔ tailing f i (n+1) :=
by simp [tailings]

lemma tailings_disjoint_tunnel (f : M × N →ₗ[R] M) (i : injective f) (n : ℕ) :
  disjoint (tailings f i n) (tunnel f i (n+1)) :=
begin
  induction n with n ih,
  { simp only [tailings_zero],
    apply tailing_disjoint_tunnel_succ, },
  { simp only [tailings_succ],
    refine disjoint.disjoint_sup_left_of_disjoint_sup_right _ _,
    apply tailing_disjoint_tunnel_succ,
    apply disjoint.mono_right _ ih,
    apply tailing_sup_tunnel_succ_le_tunnel, },
end

lemma tailings_disjoint_tailing (f : M × N →ₗ[R] M) (i : injective f) (n : ℕ) :
  disjoint (tailings f i n) (tailing f i (n+1)) :=
disjoint.mono_right (tailing_le_tunnel f i _) (tailings_disjoint_tunnel f i _)

end tunnel

end linear_map


variable (p q r : Prop)

example (h : p ∧ q) : p := And.left h
example (h : p ∧ q) : q := And.right h

example : p /\ q <-> q /\ p := sorry