/-
The Sinz at-most-one encoding.

Authors: Cayden Codel, Jeremy Avigad, Marijn Heule
Carnegie Mellon University
-/

import data.list.basic
import cnf.cnf
import cnf.gensym
import cnf.encoding
import cardinality.distinct
import cardinality.amk
import cardinality.alk

variables {V : Type*} [inhabited V] [decidable_eq V]

namespace sinz_amk

open list nat prod
open literal clause cnf assignment distinct gensym encoding amk alk

variables (k : nat) {l : list (literal V)} {g : gensym V}
          {τ : assignment V} (hdis : disj l g)

def sig_var_matrix (V : Type*) := nat → nat → V

def matrix (g : gensym V) (n : nat) : sig_var_matrix V :=
  λ row col, g.nth ((row * n) + col)

-- i runs from 0 to (length l - 1)
@[inline] def xi_to_si (S : sig_var_matrix V) (i : nat) (lit : literal V) : clause V :=
  [lit.flip, Pos (S 0 i)]

-- row runs from 0 to k, col runs from 0 to (length l - 2), with n = |l|
@[inline] def si_to_next_si (S : sig_var_matrix V) (n row col : nat) : cnf V :=
  if (col < n - 1) then [[Neg (S row col), Pos (S row (col + 1))]] else []

-- row runs from 0 to k - 1, col runs from 0 to (length l - 1), with n = |l|
@[inline] def ternary (S : sig_var_matrix V) (n row col : nat) (lit : literal V) : cnf V :=
  if (0 < col) then [[lit.flip, Neg (S row (col - 1)), Pos (S (row + 1) col)]] else []

def sinz_amk (k : nat) : enc_fn V
| []       g := ⟨[], g⟩
| l        g :=
  let n := length l in
  let S := matrix g n in
  ⟨(map_with_index (λ (idx : nat) (lit : literal V), xi_to_si S idx lit)) l ++

   join ((range (k + 1)).map (λ row,
     join ((range (n - 1)).map (λ col, si_to_next_si S n row col)))) ++

   join ((range k).map (λ row,
     join (map_with_index (λ (col : nat) (lit : literal V), ternary S n row col lit) l))) ++

   [[Neg (S k (n - 1))]],
   (g.nfresh ((k + 1) * length l)).2⟩

theorem sinz_amk_mem_vars :
  ∀ ⦃v⦄, v ∈ (sinz_amk k l g).1.vars → v ∈ (clause.vars l) ∨ (v ∈ (g.nfresh ((k + 1) * length l)).1) :=
begin
  cases l with lit₁ ls,
  { simp [sinz_amk] },
  { intros v hv,
    simp [sinz_amk, -length, -map_with_index_cons] at hv,
    rcases hv with (hmem | ⟨row, hrow, col, hcol, hmem⟩ | ⟨row, hrow, _, ⟨_, col, ⟨hcol, rfl⟩, rfl⟩, h⟩ | rfl),
    { rcases mem_vars_iff_exists_mem_clause_and_mem.mp hmem with ⟨c, hc, hv⟩,
      simp [-length, -map_with_index_cons] at hc,
      rcases hc with ⟨lit, i, ⟨hi, rfl⟩, rfl⟩,
      simp [xi_to_si, flip_var_eq, var] at hv,
      rcases hv with (rfl | rfl),
      { exact or.inl (mem_vars_of_mem (nth_le_mem _ _ hi)) },
      { right,
        unfold matrix,
        apply nth_mem_nfresh_of_lt,
        rw [zero_mul, zero_add, add_mul, one_mul, add_comm],
        exact lt_add_right _ _ _ hi } },
    { rcases mem_vars_iff_exists_mem_clause_and_mem.mp hmem with ⟨c, hc, hv⟩,
      simp at hcol,
      simp [si_to_next_si, hcol] at hc, subst hc,
      simp [flip_var_eq, var] at hv,
      right,
      rcases hv with (rfl | rfl);
      unfold matrix; apply nth_mem_nfresh_of_lt,
      { have h₁ : row * (ls.length + 1) + col < (row + 1) * (ls.length + 1),
        { rw [add_mul, one_mul], exact (add_lt_add_iff_left _).mpr (lt_succ_of_lt hcol) },
        exact lt_of_lt_of_le h₁ (nat.mul_le_mul_right _ (succ_le_of_lt hrow)) },
      { have h₁ : row * (ls.length + 1) + (col + 1) < (row + 1) * (ls.length + 1),
        { rw [add_mul, one_mul], exact (add_lt_add_iff_left _).mpr (succ_lt_succ hcol) },
        exact lt_of_lt_of_le h₁ (nat.mul_le_mul_right _ (succ_le_of_lt hrow)) } },
    { cases col,
      { simp [ternary] at h, contradiction },
      { simp [ternary, var, flip_var_eq, -length, -nth_le] at h,
        rcases h with (rfl | rfl | rfl),
        { exact or.inl (mem_vars_of_mem (nth_le_mem _ _ hcol)) },
        { right,
          rw length at hcol,
          unfold matrix,
          apply nth_mem_nfresh_of_lt,
          have h₁ : row * (ls.length + 1) + col < (row + 1) * (ls.length + 1),
          { rw [add_mul, one_mul], exact (add_lt_add_iff_left _).mpr (lt_of_succ_lt hcol) },
          exact lt_of_lt_of_le h₁ (nat.mul_le_mul_right _ (succ_le_of_lt (lt_succ_of_lt hrow))) },
        { right,
          simp [length, succ_eq_add_one] at hcol |-,
          unfold matrix,
          apply nth_mem_nfresh_of_lt,
          apply lt_of_lt_of_le (add_lt_add_left (succ_lt_succ hcol) _),
          have : (row + 1) * (ls.length + 1) + (ls.length + 1) = (row + 2) * (ls.length + 1),
          { simp [add_mul, two_mul, add_assoc] },
          rw this,
          exact nat.mul_le_mul_right _ (succ_le_succ (succ_le_of_lt hrow)) } } },
    { simp [var, matrix], right,
      apply nth_mem_nfresh_of_lt,
      simp [add_mul] } }
end

theorem matrix_not_mem_vars {g : gensym V} {l : list (literal V)} :
  disj l g → ∀ (r c : nat), (matrix g (length l) r c) ∉ clause.vars l :=
begin
  intros hdis r c,
  rw matrix,
  exact disj_right.mp hdis (nth_mem_stock _ _)
end

theorem xi_to_si_mem_sinz_amk (g : gensym V) {i : nat} (Hi : i < length l) :
  [(l.nth_le i Hi).flip, Pos (matrix g (length l) 0 i)] ∈ (sinz_amk k l g).1 :=
begin
  cases l with lit₁ ls, { simp at Hi, contradiction },
  rw sinz_amk,
  simp [xi_to_si, -map_with_index_cons],
  left,
  use [(lit₁ :: ls).nth_le i Hi, i, Hi],
  exact ⟨rfl, rfl⟩
end

theorem si_to_next_si_mem_sinz_amk (g : gensym V) {row col : nat} :
  row < (k + 1) → col < (length l) - 1 →
  [Neg (matrix g (length l) row col), Pos (matrix g (length l) row (col + 1))] ∈ (sinz_amk k l g).1 :=
begin
  intros hrow hcol,
  cases l with lit₁ ls, { simp at hcol, contradiction },
  rw sinz_amk,
  simp [si_to_next_si, -map_with_index_cons],
  right, left,
  use [row, hrow, col, hcol],
  simp at hcol, simp [hcol]
end

theorem ternary_mem_sinz_amk (g : gensym V) {row col : nat} (hcol : col < length l) :
  row < k → 0 < col →
  [(l.nth_le col hcol).flip, Neg (matrix g (length l) row (col - 1)),
    Pos (matrix g (length l) (row + 1) col)] ∈ (sinz_amk k l g).1 :=
begin
  intros hr hc,
  cases l with lit₁ ls, { simp at hcol, contradiction },
  rw sinz_amk,
  simp [ternary, -map_with_index_cons],
  right, right,
  use [row, hr, [[((lit₁ :: ls).nth_le col hcol).flip, Neg (matrix g (ls.length + 1) row (col - 1)),
      Pos (matrix g (ls.length + 1) (row + 1) col )]]],
  split,
  { use [(lit₁ :: ls).nth_le col hcol, col, hcol], simp [hc] },
  { exact mem_singleton_self _ }
end

theorem neg_final_mem_sinz_amk (g : gensym V) (l : list (literal V)) :
  l ≠ [] → [Neg (matrix g (length l) k ((length l) - 1))] ∈ (sinz_amk k l g).1 :=
begin
  cases l with lit₁ ls,
  { intro hcon, contradiction },
  { intro hnil,
    rw sinz_amk,
    simp only [mem_append, mem_singleton, eq_self_iff_true, and_self, or_true] }
end

def row_and_col_from_var (S : sig_var_matrix V) (n : nat) (v : V) : nat → nat → (nat × nat)
| 0       0       := ⟨0, 0⟩
| 0       (c + 1) := if v = S 0 (c + 1) then ⟨0, c + 1⟩ else row_and_col_from_var 0 c
| (r + 1) 0       := if v = S (r + 1) 0 then ⟨r + 1, 0⟩ else row_and_col_from_var r (n - 1)
| (r + 1) (c + 1) := if v = S (r + 1) (c + 1) then ⟨r + 1, c + 1⟩ else row_and_col_from_var (r + 1) c

def sinz_amk_tau (l : list (literal V)) (g : gensym V) (τ : assignment V) : assignment V :=
  aite (clause.vars l) τ
    (λ v, let ⟨r, c⟩ := row_and_col_from_var (matrix g (length l)) (length l) v (k + 1) ((length l) - 1) in
       (alk (r + 1)).eval τ (l.take (c + 1)))

theorem hleper {a b c : nat} : a ≠ b → c + a ≠ c + b  :=
begin
  exact (add_ne_add_right c).mpr
end

theorem matrix_ne_of_ne_or_ne {g : gensym V} {n r₁ r₂ c₁ c₂ : nat} :
  c₁ < n → c₂ < n → r₁ ≠ r₂ ∨ c₁ ≠ c₂ → (matrix g n r₁ c₁) ≠ (matrix g n r₂ c₂) :=
begin
  rintros hc₁ hc₂ (h | h);
  unfold matrix; apply nth_ne_of_ne,
  { induction r₁ with r₁ ih generalizing r₂,
    { cases r₂,
      { exact absurd (eq.refl 0) h },
      { rw [zero_mul, zero_add],
        apply ne_of_lt,
        rw [succ_eq_add_one, add_mul, one_mul, add_comm (r₂ * n) n, add_assoc],
        exact lt_add_right _ _ _ hc₁ } },
    { cases r₂,
      { rw [zero_mul, zero_add],
        apply ne_of_gt,
        rw [succ_eq_add_one, add_mul, one_mul, add_comm (r₁ * n) n, add_assoc],
        exact lt_add_right _ _ _ hc₂ },
      { repeat { rw [succ_eq_add_one, add_mul, one_mul, add_comm _ n, add_assoc] },
        apply (add_ne_add_right n).mpr,
        exact ih ((add_ne_add_left 1).mp h) } } },
  { induction r₁ with r₁ ih generalizing r₂,
    { rw [zero_mul, zero_add],
      cases r₂,
      { rw [zero_mul, zero_add], exact h },
      { apply ne_of_lt,
        rw [succ_eq_add_one, add_mul, one_mul, add_comm (r₂ * n) n, add_assoc],
        exact lt_add_right _ _ _ hc₁ } },
    { cases r₂,
      { rw [zero_mul, zero_add],
        apply ne_of_gt,
        rw [succ_eq_add_one, add_mul, one_mul, add_comm (r₁ * n) n, add_assoc],
        exact lt_add_right _ _ _ hc₂ },
      { repeat { rw [succ_eq_add_one, add_mul, one_mul, add_comm _ n, add_assoc] },
        apply (add_ne_add_right n).mpr,
        exact ih } } }
end

theorem row_and_col_from_var_eq_row_and_col_of_lt (g : gensym V) {n row col r c : nat} :
  row ≤ r → col < n → c < n → (row = r → col ≤ c) →
  row_and_col_from_var (matrix g n) n (matrix g n row col) r c = ⟨row, col⟩ :=
begin
  intros hrow hcol hc hcle,
  induction r with r ihr generalizing c,
  { simp at hrow, subst hrow, simp only [eq_self_iff_true, forall_true_left] at hcle,
    induction c with c ihc,
    { simp at hcle, subst hcle, rw row_and_col_from_var },
    { rcases eq_or_lt_of_le hcle with (rfl | h),
      { simp only [row_and_col_from_var, eq_self_iff_true, if_true] },
      { rw row_and_col_from_var,
        simp [matrix_ne_of_ne_or_ne (lt_trans h hc) hc (or.inr (ne_of_lt h))],
        exact ihc (lt_of_succ_lt hc) (le_of_lt_succ h) } } },
  { rcases eq_or_lt_of_le hrow with (rfl | hrow'),
    { induction c with c ihc,
      { simp at hcle, subst hcle,
        simp only [row_and_col_from_var, eq_self_iff_true, if_true] },
      { simp at hcle,
        rcases eq_or_lt_of_le hcle with (rfl | hclt),
        { simp only [row_and_col_from_var, eq_self_iff_true, if_true] },
        { rw row_and_col_from_var,
          simp [matrix_ne_of_ne_or_ne hcol hc (or.inr (ne_of_lt hclt))],
          exact ihc (lt_of_succ_lt hc) (λ _, le_of_lt_succ hclt) } } },
    { induction c with c ihc,
      { rw row_and_col_from_var,
        simp [matrix_ne_of_ne_or_ne hcol hc (or.inl (ne_of_lt hrow'))],
        apply ihr (le_of_lt_succ hrow'),
        { cases n,
          { exact absurd hc (nat.not_lt_zero 0) },
          { simp only [succ_sub_succ_eq_sub, tsub_zero], exact lt_succ_self n } },
        { cases n,
          { exact absurd hc (nat.not_lt_zero 0) },
          { intro _, simp only [succ_sub_succ_eq_sub, tsub_zero], exact le_of_lt_succ hcol } } },
      { rw row_and_col_from_var,
        simp [matrix_ne_of_ne_or_ne hcol hc (or.inl (ne_of_lt hrow'))],
        apply ihc (lt_of_succ_lt hc),
        intro hcon,
        exact absurd hcon (ne_of_lt hrow') } } }
end

theorem sinz_amk_eval_tt_under_sinz_amk_tau {k : nat} (hdis : disj l g) : ∀ (τ : assignment V),
  (amk k).eval τ l = tt → (sinz_amk k l g).1.eval (sinz_amk_tau k l g τ) = tt :=
begin
  intros τ heval,
  cases l with lit₁ ls,
  { simp [sinz_amk] },
  { rw sinz_amk,
    simp [-map_with_index_cons],
    split,
    { rw eval_tt_iff_forall_clause_eval_tt,
      intros c hc,
      simp [xi_to_si, -map_with_index_cons] at hc,
      rcases hc with ⟨_, i, ⟨hi, rfl⟩, rfl⟩,
      rw eval_tt_iff_exists_literal_eval_tt,
      cases hlit : ((lit₁ :: ls).nth_le i hi).eval τ,
      { use [((lit₁ :: ls).nth_le i hi).flip],
        split, { exact mem_cons_self _ _ },
        { simp only [eval_flip, bnot_eq_true_eq_eq_ff, sinz_amk_tau],
          rw aite_pos_lit (mem_vars_of_mem (nth_le_mem (lit₁ :: ls) i hi)),
          exact hlit } },
      { use [Pos (matrix g (ls.length + 1) 0 i)],
        simp [literal.eval],
        rw sinz_amk_tau,
        have := (matrix_not_mem_vars hdis 0 i),
        rw length at this |-,
        rw [aite_neg this, succ_sub_one],
        rw row_and_col_from_var_eq_row_and_col_of_lt g (zero_le (_ + 1)) hi (lt_succ_self _),
        { rw sinz_amk_tau._match_1,
          rw alo_eval_tt_iff_exists_eval_tt,
          use [((lit₁ :: ls).nth_le _ hi), nth_le_mem_take_of_lt hi (lt_succ_self _), hlit] },
        { exact (λ hcon, absurd hcon.symm (succ_ne_zero k)) } } },
    split,
    { rw eval_tt_iff_forall_clause_eval_tt,
      intros c hc,
      simp at hc,
      rcases hc with ⟨row, hrow, col, hcol, hc⟩,
      simp [si_to_next_si, hcol] at hc, subst hc,
      rw eval_tt_iff_exists_literal_eval_tt,
      cases halk : (alk (row + 1)).eval τ ((lit₁ :: ls).take (col + 1)),
      { use [Neg (matrix g (ls.length + 1) row col), mem_cons_self _ _],
        simp [literal.eval],
        rw sinz_amk_tau,
        have := (matrix_not_mem_vars hdis row col),
        rw length at this,
        rw aite_neg this, simp,
        rw row_and_col_from_var_eq_row_and_col_of_lt g (le_of_lt hrow) (lt_succ_of_lt hcol) (lt_succ_self _),
        { rw sinz_amk_tau._match_1, exact halk },
        { exact (λ hcon, absurd hcon (ne_of_lt hrow)) } },
      { use Pos (matrix g (ls.length + 1) row (col + 1)),
        simp [literal.eval],
        rw sinz_amk_tau,
        have := (matrix_not_mem_vars hdis row (col + 1)),
        rw length at this,
        rw aite_neg this, simp,
        rw row_and_col_from_var_eq_row_and_col_of_lt g (le_of_lt hrow) (succ_lt_succ hcol) (lt_succ_self _),
        { rw sinz_amk_tau._match_1,
          exact eval_take_succ_tt_of_eval_take_tt halk },
        { exact (λ _, succ_le_of_lt hcol) } } },
    split,
    { rw eval_tt_iff_forall_clause_eval_tt,
      intros c hc,
      simp [-map_with_index_cons] at hc,
      rcases hc with ⟨row, hrow, _, ⟨_, col, ⟨hcol, rfl⟩, rfl⟩, hc⟩,
      rw ternary at hc,
      cases col,
      { simp at hc, contradiction },
      { simp at hc, subst hc,
        rw eval_tt_iff_exists_literal_eval_tt,
        cases hlit : ((lit₁ :: ls).nth_le _ hcol).eval τ,
        { use [((lit₁ :: ls).nth_le _ hcol).flip, mem_cons_self _ _],
          simp [eval_flip, -nth_le],
          rw sinz_amk_tau,
          rw aite_pos_lit (mem_vars_of_mem (nth_le_mem (lit₁ :: ls) _ hcol)),
          exact hlit },
        { cases halk : (alk (row + 1)).eval τ ((lit₁ :: ls).take (col + 1)),
          { use [Neg (matrix g (ls.length + 1) row col)],
            simp [literal.eval],
            rw sinz_amk_tau,
            have := (matrix_not_mem_vars hdis row col),
            rw length at this,
            rw aite_neg this, simp,
            rw row_and_col_from_var_eq_row_and_col_of_lt g (le_of_lt (lt_succ_of_lt hrow)) (lt_of_succ_lt hcol) (lt_succ_self _),
            { rw sinz_amk_tau._match_1, exact halk },
            { rintro rfl, exact absurd (lt_of_succ_lt hrow) (not_lt.mpr (le_refl _)) } },
          { use [Pos (matrix g (ls.length + 1) (row + 1) (col + 1))],
            simp [literal.eval],
            rw sinz_amk_tau,
            have := (matrix_not_mem_vars hdis (row + 1) (col + 1)),
            rw length at this,
            rw aite_neg this, simp,
            rw row_and_col_from_var_eq_row_and_col_of_lt g
              (succ_le_of_lt (lt_succ_of_lt hrow)) hcol (lt_succ_self _),
            { rw sinz_amk_tau._match_1, rw alk.eval_take_tail_pos hlit, exact halk },
            { exact (λ hcon, absurd hcon (ne_of_lt (succ_lt_succ hrow))) } } } } },
    { simp [literal.eval],
      rw sinz_amk_tau,
      have := (matrix_not_mem_vars hdis k ls.length),
      rw length at this,
      rw aite_neg this, simp,
      rw row_and_col_from_var_eq_row_and_col_of_lt g (le_succ k) (lt_succ_self _) (lt_succ_self _),
      { rw sinz_amk_tau._match_1,
        simp,
        rw [amk_eval_eq_alk_succ_eval, bnot_eq_true_eq_eq_ff] at heval, exact heval },
      { exact (λ _, le_refl _) } } }
end

-- TODO: verify if need hdis later...
theorem signal_semantics {k : nat} :
  (sinz_amk k l g).1.eval τ = tt → ∀ ⦃row col : nat⦄, row < k + 1 → col < length l →
  τ (matrix g (length l) row col) = ff → (amk row).eval τ (l.take (col + 1)) = tt :=
begin
  intros heval row col hrow hcol htau,
  rw eval_tt_iff_forall_clause_eval_tt at heval,
  induction row with row ihr generalizing col,
  { induction col with col ihc,
    { have := heval _ (xi_to_si_mem_sinz_amk k g hcol),
      simp [eval_flip, literal.eval, htau] at this,
      cases l with lit₁ ls,
      { simp at hcol, contradiction },
      { rw nth_le at this,
        rw [take, take, amk.eval_cons_neg this, amk.eval_nil] } },
    { cases hlit : (l.nth_le _ hcol).eval τ,
      { cases htau' : τ (matrix g l.length 0 col),
        { rw amk.eval_take_tail_neg hlit,
          exact ihc (lt_of_succ_lt hcol) htau' },
        { cases l with lit₁ ls,
          { simp at hcol, contradiction },
          { simp at hcol,
            have : col < (lit₁ :: ls).length - 1,
            { simp only [length, add_succ_sub_one, add_zero], exact succ_lt_succ_iff.mp hcol },
            have := heval _ (si_to_next_si_mem_sinz_amk k g hrow this),
            rw length at htau htau',
            simp [literal.eval, htau', htau] at this, contradiction } } },
      { have := heval _ (xi_to_si_mem_sinz_amk k g hcol),
        simp [literal.eval, eval_flip, hlit, htau] at this, contradiction } } },
  { induction col with col ihc,
    { cases l with lit₁ ls; simp },
    { cases htau' : τ (matrix g l.length row col),
      { have := ihr (lt_of_succ_lt hrow) (lt_of_succ_lt hcol) htau',
        cases hlit : (l.nth_le _ hcol).eval τ,
        { rw amk.eval_take_tail_neg hlit,
          exact eval_tt_of_le_of_eval_tt (le_succ row) this },
        { rw amk.eval_take_tail_pos hlit,
          exact this } },
      { cases hlit : (l.nth_le _ hcol).eval τ,
        { cases htau'' : τ (matrix g l.length (row + 1) col),
          { rw amk.eval_take_tail_neg hlit,
            exact ihc (lt_of_succ_lt hcol) htau'' },
          { cases l with lit₁ ls,
            { simp at hcol, contradiction },
            { have : col < (lit₁ :: ls).length - 1,
              { simp only [length, add_succ_sub_one, add_zero], exact succ_lt_succ_iff.mp hcol },
              have := heval _ (si_to_next_si_mem_sinz_amk k g hrow this),
              rw length at htau htau'',
              simp [literal.eval, htau, htau''] at this, contradiction } } },
        { have := heval _ (ternary_mem_sinz_amk k g hcol (succ_lt_succ_iff.mp hrow) (ne_zero.pos (succ col))),
          simp [literal.eval, eval_flip, hlit, htau', htau] at this,
          contradiction } } } }
end

theorem sinz_amk_formula_encodes_amk : is_correct (amk k) (sinz_amk k : enc_fn V) :=
begin
  intros l g hdis τ,
  split,
  { intro hamk,
    use [sinz_amk_tau k l g τ, sinz_amk_eval_tt_under_sinz_amk_tau hdis τ hamk],
    intros v hv,
    rw [sinz_amk_tau, aite_pos hv] },
  { rintros ⟨σ, hs, hagree_on⟩,
    have hs_copy := hs,
    rw eval_tt_iff_forall_clause_eval_tt at hs,
    cases l with lit₁ ls,
    { simp },
    { have hfinal := hs _ (neg_final_mem_sinz_amk k g (lit₁ :: ls) (ne_nil_of_mem (mem_cons_self _ _))),
      simp [literal.eval] at hfinal,
      have : ls.length < (lit₁ :: ls).length,
      { rw length, exact lt_succ_self _ },
      have := signal_semantics hs_copy (lt_succ_self k) this hfinal,
      simp only [take, take_length] at this,
      rw amk.eval_eq_of_agree_on k hagree_on,
      exact this } }
end

theorem helper {a b : nat} : a * b + b = (a + 1) * b :=
begin
  exact (add_one_mul a b).symm,
end

theorem sinz_amk_is_wb : is_wb (sinz_amk k : enc_fn V) :=
begin
  intros l g hdis,
  cases l with lit₁ ls,
  { simp [sinz_amk] },
  { split,
    { simp [sinz_amk],
      exact nfresh_stock_subset g ((k + 1) * (length ls + 1)) },
    { intros v hv,
      rcases sinz_amk_mem_vars k hv with (h | h),
      { exact set.mem_union_left _ h },
      { apply set.mem_union_right,
        split,
        { exact nfresh_mem_stock h },
        { rw sinz_amk,
          unfold prod.snd,
          exact nth_not_mem_nfresh_stock h } } } }
end

theorem sinz_amk_encodes_amk : encodes (amk k) (sinz_amk k : enc_fn V) :=
⟨sinz_amk_formula_encodes_amk k, sinz_amk_is_wb k⟩

end sinz_amk


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura

Definitions and properties of div and mod. Much of the development follows Isabelle's library.
-/
import .sub
open eq.ops well_founded decidable prod

namespace nat

/- div -/

-- auxiliary lemma used to justify div
private definition div_rec_lemma {x y : nat} : 0 < y ∧ y ≤ x → x - y < x :=
and.rec (λ ypos ylex, sub_lt (lt_of_lt_of_le ypos ylex) ypos)

private definition div.F (x : nat) (f : Π x₁, x₁ < x → nat → nat) (y : nat) : nat :=
if H : 0 < y ∧ y ≤ x then f (x - y) (div_rec_lemma H) y + 1 else zero

protected definition div := fix div.F

definition nat_has_divide [instance] [priority nat.prio] : has_div nat :=
has_div.mk nat.div

theorem div_def (x y : nat) : div x y = if 0 < y ∧ y ≤ x then div (x - y) y + 1 else 0 :=
congr_fun (fix_eq div.F x) y

protected theorem div_zero [simp] (a : ℕ) : a / 0 = 0 :=
div_def a 0 ⬝ if_neg (!not_and_of_not_left (lt.irrefl 0))

theorem div_eq_zero_of_lt {a b : ℕ} (h : a < b) : a / b = 0 :=
div_def a b ⬝ if_neg (!not_and_of_not_right (not_le_of_gt h))

protected theorem zero_div [simp] (b : ℕ) : 0 / b = 0 :=
div_def 0 b ⬝ if_neg (and.rec not_le_of_gt)

theorem div_eq_succ_sub_div {a b : ℕ} (h₁ : b > 0) (h₂ : a ≥ b) : a / b = succ ((a - b) / b) :=
div_def a b ⬝ if_pos (and.intro h₁ h₂)

theorem add_div_self (x : ℕ) {z : ℕ} (H : z > 0) : (x + z) / z = succ (x / z) :=
calc
  (x + z) / z = if 0 < z ∧ z ≤ x + z then (x + z - z) / z + 1 else 0 : !div_def
            ... = (x + z - z) / z + 1 : if_pos (and.intro H (le_add_left z x))
            ... = succ (x / z)        : {!nat.add_sub_cancel}

theorem add_div_self_left {x : ℕ} (z : ℕ) (H : x > 0) : (x + z) / x = succ (z / x) :=
!add.comm ▸ !add_div_self H

local attribute succ_mul [simp]

theorem add_mul_div_self {x y z : ℕ} (H : z > 0) : (x + y * z) / z = x / z + y :=
nat.induction_on y
  (by simp)
  (take y,
    assume IH : (x + y * z) / z = x / z + y, calc
      (x + succ y * z) / z = (x + y * z + z) / z    : by inst_simp
                       ... = succ ((x + y * z) / z) : !add_div_self H
                       ... = succ (x / z + y)       : IH)

theorem add_mul_div_self_left (x z : ℕ) {y : ℕ} (H : y > 0) : (x + y * z) / y = x / y + z :=
!mul.comm ▸ add_mul_div_self H

protected theorem mul_div_cancel (m : ℕ) {n : ℕ} (H : n > 0) : m * n / n = m :=
calc
  m * n / n = (0 + m * n) / n : by simp
          ... = 0 / n + m     : add_mul_div_self H
          ... = m             : by simp

protected theorem mul_div_cancel_left {m : ℕ} (n : ℕ) (H : m > 0) : m * n / m = n :=
!mul.comm ▸ !nat.mul_div_cancel H

/- mod -/

private definition mod.F (x : nat) (f : Π x₁, x₁ < x → nat → nat) (y : nat) : nat :=
if H : 0 < y ∧ y ≤ x then f (x - y) (div_rec_lemma H) y else x

protected definition mod := fix mod.F

definition nat_has_mod [instance] [priority nat.prio] : has_mod nat :=
has_mod.mk nat.mod

notation [priority nat.prio] a ≡ b `[mod `:0 c:0 `]` := a % c = b % c

theorem mod_def (x y : nat) : mod x y = if 0 < y ∧ y ≤ x then mod (x - y) y else x :=
congr_fun (fix_eq mod.F x) y

theorem mod_zero [simp] (a : ℕ) : a % 0 = a :=
mod_def a 0 ⬝ if_neg (!not_and_of_not_left (lt.irrefl 0))

theorem mod_eq_of_lt {a b : ℕ} (h : a < b) : a % b = a :=
mod_def a b ⬝ if_neg (!not_and_of_not_right (not_le_of_gt h))

theorem zero_mod [simp] (b : ℕ) : 0 % b = 0 :=
mod_def 0 b ⬝ if_neg (λ h, and.rec_on h (λ l r, absurd (lt_of_lt_of_le l r) (lt.irrefl 0)))

theorem mod_eq_sub_mod {a b : ℕ} (h₁ : b > 0) (h₂ : a ≥ b) : a % b = (a - b) % b :=
mod_def a b ⬝ if_pos (and.intro h₁ h₂)

theorem add_mod_self [simp] (x z : ℕ) : (x + z) % z = x % z :=
by_cases_zero_pos z
  (by rewrite add_zero)
  (take z, assume H : z > 0,
    calc
      (x + z) % z = if 0 < z ∧ z ≤ x + z then (x + z - z) % z else _ : mod_def
                ... = (x + z - z) % z   : if_pos (and.intro H (le_add_left z x))
                ... = x % z             : nat.add_sub_cancel)

theorem add_mod_self_left [simp] (x z : ℕ) : (x + z) % x = z % x :=
!add.comm ▸ !add_mod_self

local attribute succ_mul [simp]

theorem add_mul_mod_self [simp] (x y z : ℕ) : (x + y * z) % z = x % z :=
nat.induction_on y (by simp) (by inst_simp)

theorem add_mul_mod_self_left [simp] (x y z : ℕ) : (x + y * z) % y = x % y :=
by inst_simp

theorem mul_mod_left [simp] (m n : ℕ) : (m * n) % n = 0 :=
calc (m * n) % n = (0 + m * n) % n : by simp
            ...  = 0               : by inst_simp

theorem mul_mod_right [simp] (m n : ℕ) : (m * n) % m = 0 :=
by inst_simp

theorem mod_lt (x : ℕ) {y : ℕ} (H : y > 0) : x % y < y :=
nat.case_strong_induction_on x
  (show 0 % y < y, from !zero_mod⁻¹ ▸ H)
  (take x,
    assume IH : ∀x', x' ≤ x → x' % y < y,
    show succ x % y < y, from
      by_cases -- (succ x < y)
        (assume H1 : succ x < y,
          have succ x % y = succ x, from mod_eq_of_lt H1,
          show succ x % y < y, from this⁻¹ ▸ H1)
        (assume H1 : ¬ succ x < y,
          have y ≤ succ x, from le_of_not_gt H1,
          have h : succ x % y = (succ x - y) % y, from mod_eq_sub_mod H this,
          have succ x - y < succ x, from sub_lt !succ_pos H,
          have succ x - y ≤ x, from le_of_lt_succ this,
          show succ x % y < y, from h⁻¹ ▸ IH _ this))

theorem mod_one (n : ℕ) : n % 1 = 0 :=
have H1 : n % 1 < 1, from !mod_lt !succ_pos,
eq_zero_of_le_zero (le_of_lt_succ H1)

/- properties of div and mod -/

-- the quotient - remainder theorem
theorem eq_div_mul_add_mod (x y : ℕ) : x = x / y * y + x % y :=
begin
  eapply by_cases_zero_pos y,
  show x = x / 0 * 0 + x % 0, from
    (calc
      x / 0 * 0 + x % 0 = 0 + x % 0 : mul_zero
        ... = x % 0                 : zero_add
        ... = x                     : mod_zero)⁻¹,
  intro y H,
  show x = x / y * y + x % y,
  begin
    eapply nat.case_strong_induction_on x,
    show 0 = (0 / y) * y + 0 % y, by rewrite [zero_mod, add_zero, nat.zero_div, zero_mul],
    intro x IH,
    show succ x = succ x / y * y + succ x % y, from
      if H1 : succ x < y then
         have H2 : succ x / y = 0, from div_eq_zero_of_lt H1,
         have H3 : succ x % y = succ x, from mod_eq_of_lt H1,
         begin rewrite [H2, H3, zero_mul, zero_add] end
      else
         have H2 : y ≤ succ x, from le_of_not_gt H1,
         have H3 : succ x / y = succ ((succ x - y) / y), from div_eq_succ_sub_div H H2,
         have H4 : succ x % y = (succ x - y) % y, from mod_eq_sub_mod H H2,
         have H5 : succ x - y < succ x, from sub_lt !succ_pos H,
         have H6 : succ x - y ≤ x, from le_of_lt_succ H5,
         (calc
             succ x / y * y + succ x % y =
                  succ ((succ x - y) / y) * y + succ x % y      : by rewrite H3
            ... = ((succ x - y) / y) * y + y + succ x % y       : by rewrite succ_mul
            ... = ((succ x - y) / y) * y + y + (succ x - y) % y : by rewrite H4
            ... = ((succ x - y) / y) * y + (succ x - y) % y + y : add.right_comm
            ... = succ x - y + y                                : by rewrite -(IH _ H6)
            ... = succ x                                        : nat.sub_add_cancel H2)⁻¹
  end
end

theorem mod_eq_sub_div_mul (x y : ℕ) : x % y = x - x / y * y :=
nat.eq_sub_of_add_eq (!add.comm ▸ !eq_div_mul_add_mod)⁻¹

theorem mod_add_mod (m n k : ℕ) : (m % n + k) % n = (m + k) % n :=
by rewrite [eq_div_mul_add_mod m n at {2}, add.assoc, add.comm (m / n * n), add_mul_mod_self]

theorem add_mod_mod (m n k : ℕ) : (m + n % k) % k = (m + n) % k :=
by rewrite [add.comm, mod_add_mod, add.comm]

theorem add_mod_eq_add_mod_right {m n k : ℕ} (i : ℕ) (H : m % n = k % n) :
  (m + i) % n = (k + i) % n :=
by rewrite [-mod_add_mod, -mod_add_mod k, H]

theorem add_mod_eq_add_mod_left {m n k : ℕ} (i : ℕ) (H : m % n = k % n) :
  (i + m) % n = (i + k) % n :=
by rewrite [add.comm, add_mod_eq_add_mod_right _ H, add.comm]

theorem mod_eq_mod_of_add_mod_eq_add_mod_right {m n k i : ℕ} :
  (m + i) % n = (k + i) % n → m % n = k % n :=
by_cases_zero_pos n
  (by rewrite [*mod_zero]; apply eq_of_add_eq_add_right)
  (take n,
    assume npos : n > 0,
    assume H1 : (m + i) % n = (k + i) % n,
    have H2 : (m + i % n) % n = (k + i % n) % n, by rewrite [*add_mod_mod, H1],
    have H3 : (m + i % n + (n - i % n)) % n = (k + i % n + (n - i % n)) % n,
      from add_mod_eq_add_mod_right _ H2,
    begin
      revert H3,
      rewrite [*add.assoc, add_sub_of_le (le_of_lt (!mod_lt npos)), *add_mod_self],
      intros, assumption
    end)

theorem mod_eq_mod_of_add_mod_eq_add_mod_left {m n k i : ℕ} :
  (i + m) % n = (i + k) % n → m % n = k % n :=
by rewrite [add.comm i m, add.comm i k]; apply mod_eq_mod_of_add_mod_eq_add_mod_right

theorem mod_le {x y : ℕ} : x % y ≤ x :=
!eq_div_mul_add_mod⁻¹ ▸ !le_add_left

theorem eq_remainder {q1 r1 q2 r2 y : ℕ} (H1 : r1 < y) (H2 : r2 < y)
  (H3 : q1 * y + r1 = q2 * y + r2) : r1 = r2 :=
calc
  r1 = r1 % y               : mod_eq_of_lt H1
    ... = (r1 + q1 * y) % y : !add_mul_mod_self⁻¹
    ... = (q1 * y + r1) % y : add.comm
    ... = (r2 + q2 * y) % y : by rewrite [H3, add.comm]
    ... = r2 % y            : !add_mul_mod_self
    ... = r2                : mod_eq_of_lt H2

theorem eq_quotient {q1 r1 q2 r2 y : ℕ} (H1 : r1 < y) (H2 : r2 < y)
  (H3 : q1 * y + r1 = q2 * y + r2) : q1 = q2 :=
have H4 : q1 * y + r2 = q2 * y + r2, from (eq_remainder H1 H2 H3) ▸ H3,
have H5 : q1 * y = q2 * y, from add.right_cancel H4,
have H6 : y > 0, from lt_of_le_of_lt !zero_le H1,
show q1 = q2, from eq_of_mul_eq_mul_right H6 H5

protected theorem mul_div_mul_left {z : ℕ} (x y : ℕ) (zpos : z > 0) :
  (z * x) / (z * y) = x / y :=
if H : y = 0 then
  by rewrite [H, mul_zero, *nat.div_zero]
else
  have ypos : y > 0, from pos_of_ne_zero H,
  have zypos : z * y > 0, from mul_pos zpos ypos,
  have H1 : (z * x) % (z * y) < z * y, from !mod_lt zypos,
  have H2 : z * (x % y) < z * y, from mul_lt_mul_of_pos_left (!mod_lt ypos) zpos,
  eq_quotient H1 H2
    (calc
      ((z * x) / (z * y)) * (z * y) + (z * x) % (z * y) = z * x : eq_div_mul_add_mod
        ... = z * (x / y * y + x % y)                           : eq_div_mul_add_mod
        ... = z * (x / y * y) + z * (x % y)                     : left_distrib
        ... = (x / y) * (z * y) + z * (x % y)                   : mul.left_comm)

protected theorem mul_div_mul_right {x z y : ℕ} (zpos : z > 0) : (x * z) / (y * z) = x / y :=
!mul.comm ▸ !mul.comm ▸ !nat.mul_div_mul_left zpos

theorem mul_mod_mul_left (z x y : ℕ) : (z * x) % (z * y) = z * (x % y) :=
or.elim (eq_zero_or_pos z)
  (assume H : z = 0, H⁻¹ ▸ calc
      (0 * x) % (z * y) = 0 % (z * y)   : zero_mul
                      ... = 0           : zero_mod
                      ... = 0 * (x % y) : zero_mul)
  (assume zpos : z > 0,
    or.elim (eq_zero_or_pos y)
      (assume H : y = 0, by rewrite [H, mul_zero, *mod_zero])
      (assume ypos : y > 0,
        have zypos : z * y > 0, from mul_pos zpos ypos,
        have H1 : (z * x) % (z * y) < z * y, from !mod_lt zypos,
        have H2 : z * (x % y) < z * y, from mul_lt_mul_of_pos_left (!mod_lt ypos) zpos,
        eq_remainder H1 H2
          (calc
            ((z * x) / (z * y)) * (z * y) + (z * x) % (z * y) = z * x : eq_div_mul_add_mod
              ... = z * (x / y * y + x % y)                           : eq_div_mul_add_mod
              ... = z * (x / y * y) + z * (x % y)                     : left_distrib
              ... = (x / y) * (z * y) + z * (x % y)                   : mul.left_comm)))

theorem mul_mod_mul_right (x z y : ℕ) : (x * z) % (y * z) = (x % y) * z :=
mul.comm z x ▸ mul.comm z y ▸ !mul.comm ▸ !mul_mod_mul_left

theorem mod_self (n : ℕ) : n % n = 0 :=
nat.cases_on n (by rewrite zero_mod)
  (take n, by rewrite [-zero_add (succ n) at {1}, add_mod_self])

theorem mul_mod_eq_mod_mul_mod (m n k : nat) : (m * n) % k = ((m % k) * n) % k :=
calc
  (m * n) % k = (((m / k) * k + m % k) * n) % k : eq_div_mul_add_mod
            ... = ((m % k) * n) % k             :
                    by rewrite [right_distrib, mul.right_comm, add.comm, add_mul_mod_self]

theorem mul_mod_eq_mul_mod_mod (m n k : nat) : (m * n) % k = (m * (n % k)) % k :=
!mul.comm ▸ !mul.comm ▸ !mul_mod_eq_mod_mul_mod

protected theorem div_one (n : ℕ) : n / 1 = n :=
have n / 1 * 1 + n % 1 = n, from !eq_div_mul_add_mod⁻¹,
begin rewrite [-this at {2}, mul_one, mod_one] end

protected theorem div_self {n : ℕ} (H : n > 0) : n / n = 1 :=
have (n * 1) / (n * 1) = 1 / 1, from !nat.mul_div_mul_left H,
by rewrite [nat.div_one at this, -this, *mul_one]

theorem div_mul_cancel_of_mod_eq_zero {m n : ℕ} (H : m % n = 0) : m / n * n = m :=
by rewrite [eq_div_mul_add_mod m n at {2}, H, add_zero]

theorem mul_div_cancel_of_mod_eq_zero {m n : ℕ} (H : m % n = 0) : n * (m / n) = m :=
!mul.comm ▸ div_mul_cancel_of_mod_eq_zero H

/- dvd -/

theorem dvd_of_mod_eq_zero {m n : ℕ} (H : n % m = 0) : m ∣ n :=
dvd.intro (!mul.comm ▸ div_mul_cancel_of_mod_eq_zero H)

theorem mod_eq_zero_of_dvd {m n : ℕ} (H : m ∣ n) : n % m = 0 :=
dvd.elim H (take z, assume H1 : n = m * z, H1⁻¹ ▸ !mul_mod_right)

theorem dvd_iff_mod_eq_zero (m n : ℕ) : m ∣ n ↔ n % m = 0 :=
iff.intro mod_eq_zero_of_dvd dvd_of_mod_eq_zero

definition dvd.decidable_rel [instance] : decidable_rel dvd :=
take m n, decidable_of_decidable_of_iff _ (iff.symm !dvd_iff_mod_eq_zero)

protected theorem div_mul_cancel {m n : ℕ} (H : n ∣ m) : m / n * n = m :=
div_mul_cancel_of_mod_eq_zero (mod_eq_zero_of_dvd H)

protected theorem mul_div_cancel' {m n : ℕ} (H : n ∣ m) : n * (m / n) = m :=
!mul.comm ▸ nat.div_mul_cancel H

theorem dvd_of_dvd_add_left {m n₁ n₂ : ℕ} (H₁ : m ∣ n₁ + n₂) (H₂ : m ∣ n₁) : m ∣ n₂ :=
obtain (c₁ : nat) (Hc₁ : n₁ + n₂ = m * c₁), from H₁,
obtain (c₂ : nat) (Hc₂ : n₁ = m * c₂), from H₂,
have   aux : m * (c₁ - c₂) = n₂, from calc
  m * (c₁ - c₂) = m * c₁  - m * c₂ : nat.mul_sub_left_distrib
           ...  = n₁ + n₂ - m * c₂ : Hc₁
           ...  = n₁ + n₂ - n₁     : Hc₂
           ...  = n₂               : nat.add_sub_cancel_left,
dvd.intro aux

theorem dvd_of_dvd_add_right {m n₁ n₂ : ℕ} (H : m ∣ n₁ + n₂) : m ∣ n₂ → m ∣ n₁ :=
nat.dvd_of_dvd_add_left (!add.comm ▸ H)

theorem dvd_sub {m n₁ n₂ : ℕ} (H1 : m ∣ n₁) (H2 : m ∣ n₂) : m ∣ n₁ - n₂ :=
by_cases
  (assume H3 : n₁ ≥ n₂,
    have H4 : n₁ = n₁ - n₂ + n₂, from (nat.sub_add_cancel H3)⁻¹,
    show m ∣ n₁ - n₂, from nat.dvd_of_dvd_add_right (H4 ▸ H1) H2)
  (assume H3 : ¬ (n₁ ≥ n₂),
    have H4 : n₁ - n₂ = 0, from sub_eq_zero_of_le (le_of_lt (lt_of_not_ge H3)),
    show m ∣ n₁ - n₂, from H4⁻¹ ▸ dvd_zero _)

theorem dvd.antisymm {m n : ℕ} : m ∣ n → n ∣ m → m = n :=
by_cases_zero_pos n
  (assume H1, assume H2 : 0 ∣ m, eq_zero_of_zero_dvd H2)
  (take n,
    assume Hpos : n > 0,
    assume H1 : m ∣ n,
    assume H2 : n ∣ m,
    obtain k (Hk : n = m * k), from exists_eq_mul_right_of_dvd H1,
    obtain l (Hl : m = n * l), from exists_eq_mul_right_of_dvd H2,
    have n * (l * k) = n, from !mul.assoc ▸ Hl ▸ Hk⁻¹,
    have l * k = 1,       from eq_one_of_mul_eq_self_right Hpos this,
    have k = 1,           from eq_one_of_mul_eq_one_left this,
    show m = n,           from (mul_one m)⁻¹ ⬝ (this ▸ Hk⁻¹))

protected theorem mul_div_assoc (m : ℕ) {n k : ℕ} (H : k ∣ n) : m * n / k = m * (n / k) :=
or.elim (eq_zero_or_pos k)
  (assume H1 : k = 0,
    calc
      m * n / k = m * n / 0     : H1
              ... = 0           : nat.div_zero
              ... = m * 0       : mul_zero m
              ... = m * (n / 0) : nat.div_zero
              ... = m * (n / k) : H1)
  (assume H1 : k > 0,
    have H2 : n = n / k * k, from (nat.div_mul_cancel H)⁻¹,
      calc
        m * n / k = m * (n / k * k) / k   : H2
                ... = m * (n / k) * k / k : mul.assoc
                ... = m * (n / k)         : nat.mul_div_cancel _ H1)

theorem dvd_of_mul_dvd_mul_left {m n k : ℕ} (kpos : k > 0) (H : k * m ∣ k * n) : m ∣ n :=
dvd.elim H
  (take l,
    assume H1 : k * n = k * m * l,
    have H2 : n = m * l, from eq_of_mul_eq_mul_left kpos (H1 ⬝ !mul.assoc),
    dvd.intro H2⁻¹)

theorem dvd_of_mul_dvd_mul_right {m n k : ℕ} (kpos : k > 0) (H : m * k ∣ n * k) : m ∣ n :=
nat.dvd_of_mul_dvd_mul_left kpos (!mul.comm ▸ !mul.comm ▸ H)

lemma dvd_of_eq_mul (i j n : nat) : n = j*i → j ∣ n :=
begin intros, subst n, apply dvd_mul_right end

theorem div_dvd_div {k m n : ℕ} (H1 : k ∣ m) (H2 : m ∣ n) : m / k ∣ n / k :=
have H3 : m = m / k * k, from (nat.div_mul_cancel H1)⁻¹,
have H4 : n = n / k * k, from (nat.div_mul_cancel (dvd.trans H1 H2))⁻¹,
or.elim (eq_zero_or_pos k)
  (assume H5 : k = 0,
    have H6: n / k = 0, from (congr_arg _ H5 ⬝ !nat.div_zero),
      H6⁻¹ ▸ !dvd_zero)
  (assume H5 : k > 0,
    nat.dvd_of_mul_dvd_mul_right H5 (H3 ▸ H4 ▸ H2))

protected theorem div_eq_iff_eq_mul_right {m n : ℕ} (k : ℕ) (H : n > 0) (H' : n ∣ m) :
  m / n = k ↔ m = n * k :=
iff.intro
  (assume H1, by rewrite [-H1, nat.mul_div_cancel' H'])
  (assume H1, by rewrite [H1, !nat.mul_div_cancel_left H])

protected theorem div_eq_iff_eq_mul_left {m n : ℕ} (k : ℕ) (H : n > 0) (H' : n ∣ m) :
  m / n = k ↔ m = k * n :=
!mul.comm ▸ !nat.div_eq_iff_eq_mul_right H H'

protected theorem eq_mul_of_div_eq_right {m n k : ℕ} (H1 : n ∣ m) (H2 : m / n = k) :
  m = n * k :=
calc
  m     = n * (m / n) : nat.mul_div_cancel' H1
    ... = n * k       : H2

protected theorem div_eq_of_eq_mul_right {m n k : ℕ} (H1 : n > 0) (H2 : m = n * k) :
  m / n = k :=
calc
  m / n = n * k / n : H2
      ... = k       : !nat.mul_div_cancel_left H1

protected theorem eq_mul_of_div_eq_left {m n k : ℕ} (H1 : n ∣ m) (H2 : m / n = k) :
  m = k * n :=
!mul.comm ▸ !nat.eq_mul_of_div_eq_right H1 H2

protected theorem div_eq_of_eq_mul_left {m n k : ℕ} (H1 : n > 0) (H2 : m = k * n) :
  m / n = k :=
!nat.div_eq_of_eq_mul_right H1 (!mul.comm ▸ H2)

lemma add_mod_eq_of_dvd (i j n : nat) : n ∣ j → (i + j) % n = i % n :=
assume h,
obtain k (hk : j = n * k), from exists_eq_mul_right_of_dvd h,
begin
  subst j, rewrite mul.comm,
  apply add_mul_mod_self
end

/- / and ordering -/

lemma le_of_dvd {m n : nat} : n > 0 → m ∣ n → m ≤ n :=
assume (h₁ : n > 0) (h₂ : m ∣ n),
have h₃ : n % m = 0, from mod_eq_zero_of_dvd h₂,
by_contradiction
 (λ nle : ¬ m ≤ n,
   have   h₄ : m > n, from lt_of_not_ge nle,
   have h₅ : n % m = n, from mod_eq_of_lt h₄,
   begin
     rewrite h₃ at h₅, subst n,
     exact absurd h₁ (lt.irrefl 0)
   end)

theorem div_mul_le (m n : ℕ) : m / n * n ≤ m :=
calc
  m = m / n * n + m % n : eq_div_mul_add_mod
    ... ≥ m / n * n       : le_add_right

protected theorem div_le_of_le_mul {m n k : ℕ} (H : m ≤ n * k) : m / k ≤ n :=
or.elim (eq_zero_or_pos k)
  (assume H1 : k = 0,
    calc
      m / k = m / 0 : H1
          ... = 0       : nat.div_zero
          ... ≤ n       : zero_le)
  (assume H1 : k > 0,
    le_of_mul_le_mul_right (calc
      m / k * k ≤ m / k * k + m % k : le_add_right
        ... = m                     : eq_div_mul_add_mod
        ... ≤ n * k                 : H) H1)

protected theorem div_le_self (m n : ℕ) : m / n ≤ m :=
nat.cases_on n (!nat.div_zero⁻¹ ▸ !zero_le)
  take n,
  have H : m ≤ m * succ n, from calc
        m = m * 1      : mul_one
      ... ≤ m * succ n : !mul_le_mul_left (succ_le_succ !zero_le),
  nat.div_le_of_le_mul H

protected theorem mul_le_of_le_div {m n k : ℕ} (H : m ≤ n / k) : m * k ≤ n :=
calc
  m * k ≤ n / k * k : !mul_le_mul_right H
    ... ≤ n           : div_mul_le

protected theorem le_div_of_mul_le {m n k : ℕ} (H1 : k > 0) (H2 : m * k ≤ n) : m ≤ n / k :=
have H3 : m * k < (succ (n / k)) * k, from
  calc
    m * k ≤ n                  : H2
      ... = n / k * k + n % k  : eq_div_mul_add_mod
      ... < n / k * k + k      : add_lt_add_left (!mod_lt H1)
      ... = (succ (n / k)) * k : succ_mul,
le_of_lt_succ (lt_of_mul_lt_mul_right H3)

protected theorem le_div_iff_mul_le {m n k : ℕ} (H : k > 0) : m ≤ n / k ↔ m * k ≤ n :=
iff.intro !nat.mul_le_of_le_div (!nat.le_div_of_mul_le H)

protected theorem div_le_div {m n : ℕ} (k : ℕ) (H : m ≤ n) : m / k ≤ n / k :=
by_cases_zero_pos k
  (by rewrite [*nat.div_zero])
  (take k, assume H1 : k > 0, nat.le_div_of_mul_le H1 (le.trans !div_mul_le H))

protected theorem div_lt_of_lt_mul {m n k : ℕ} (H : m < n * k) : m / k < n :=
lt_of_mul_lt_mul_right (calc
  m / k * k ≤ m / k * k + m % k : le_add_right
    ... = m                     : eq_div_mul_add_mod
    ... < n * k                 : H)

protected theorem lt_mul_of_div_lt {m n k : ℕ} (H1 : k > 0) (H2 : m / k < n) : m < n * k :=
have H3 : succ (m / k) * k ≤ n * k, from !mul_le_mul_right (succ_le_of_lt H2),
have H4 : m / k * k + k ≤ n * k, by rewrite [succ_mul at H3]; apply H3,
calc
  m     = m / k * k + m % k : eq_div_mul_add_mod
    ... < m / k * k + k     : add_lt_add_left (!mod_lt H1)
    ... ≤ n * k             : H4

protected theorem div_lt_iff_lt_mul {m n k : ℕ} (H : k > 0) : m / k < n ↔ m < n * k :=
iff.intro (!nat.lt_mul_of_div_lt H) !nat.div_lt_of_lt_mul

protected theorem div_le_iff_le_mul_of_div {m n : ℕ} (k : ℕ) (H : n > 0) (H' : n ∣ m) :
  m / n ≤ k ↔ m ≤ k * n :=
by refine iff.trans (!le_iff_mul_le_mul_right H) _; rewrite [!nat.div_mul_cancel H']

protected theorem le_mul_of_div_le_of_div {m n k : ℕ} (H1 : n > 0) (H2 : n ∣ m) (H3 : m / n ≤ k) :
  m ≤ k * n :=
iff.mp (!nat.div_le_iff_le_mul_of_div H1 H2) H3

-- needed for integer division
theorem mul_sub_div_of_lt {m n k : ℕ} (H : k < m * n) :
  (m * n - (k + 1)) / m = n - k / m - 1 :=
begin
  have H1 : k / m < n, from nat.div_lt_of_lt_mul (!mul.comm ▸ H),
  have H2 : n - k / m ≥ 1, from
    nat.le_sub_of_add_le (calc
       1 + k / m = succ (k / m) : add.comm
               ... ≤ n          : succ_le_of_lt H1),
  have H3 : n - k / m = n - k / m - 1 + 1, from (nat.sub_add_cancel H2)⁻¹,
  have H4 : m > 0, from pos_of_ne_zero (assume H': m = 0, not_lt_zero k (begin rewrite [H' at H, zero_mul at H], exact H end)),
  have H5   : k % m + 1 ≤ m, from succ_le_of_lt (!mod_lt H4),
  have H6 : m - (k % m + 1) < m, from nat.sub_lt_self H4 !succ_pos,
calc
  (m * n - (k + 1)) / m = (m * n - (k / m * m + k % m + 1)) / m : eq_div_mul_add_mod
     ... = (m * n - k / m * m - (k % m + 1)) / m                  : by rewrite [*nat.sub_sub]
     ... = ((n - k / m) * m - (k % m + 1)) / m                    :
               by rewrite [mul.comm m, nat.mul_sub_right_distrib]
     ... = ((n - k / m - 1) * m + m - (k % m + 1)) / m            :
               by rewrite [H3 at {1}, right_distrib, nat.one_mul]
     ... = ((n - k / m - 1) * m + (m - (k % m + 1))) / m          : {nat.add_sub_assoc H5 _}
     ... = (m - (k % m + 1)) / m + (n - k / m - 1)                :
               by rewrite [add.comm, (add_mul_div_self H4)]
     ... = n - k / m - 1                                          :
               by rewrite [div_eq_zero_of_lt H6, zero_add]
end

private lemma div_div_aux (a b c : nat) : b > 0 → c > 0 → (a / b) / c = a / (b * c) :=
suppose b > 0, suppose c > 0,
nat.strong_induction_on a
(λ a ih,
  let k₁ := a / (b*c) in
  let k₂ := a %(b*c) in
  have bc_pos : b*c > 0, from mul_pos `b > 0` `c > 0`,
  have k₂ < b * c,       from mod_lt _ bc_pos,
  have k₂ ≤ a,           from !mod_le,
  or.elim (eq_or_lt_of_le this)
    (suppose k₂ = a,
     have i₁ : a < b * c,   by rewrite -this; assumption,
     have k₁ = 0,           from div_eq_zero_of_lt i₁,
     have a / b < c,      by rewrite [mul.comm at i₁]; exact nat.div_lt_of_lt_mul i₁,
     begin
       rewrite [`k₁ = 0`],
       show (a / b) / c = 0, from div_eq_zero_of_lt `a / b < c`
     end)
    (suppose k₂ < a,
     have a = k₁*(b*c) + k₂,         from eq_div_mul_add_mod a (b*c),
     have a / b = k₁*c + k₂ / b, by
       rewrite [this at {1}, mul.comm b c at {2}, -mul.assoc,
                add.comm, add_mul_div_self `b > 0`, add.comm],
     have e₁ : (a / b) / c = k₁ + (k₂ / b) / c, by
       rewrite [this, add.comm, add_mul_div_self `c > 0`, add.comm],
     have e₂ : (k₂ / b) / c = k₂ / (b * c), from ih k₂ `k₂ < a`,
     have e₃ : k₂ / (b * c)   = 0,          from div_eq_zero_of_lt `k₂ < b * c`,
     have (k₂ / b) / c      = 0,            by rewrite [e₂, e₃],
     show (a / b) / c = k₁,                 by rewrite [e₁, this]))

protected lemma div_div_eq_div_mul (a b c : nat) : (a / b) / c = a / (b * c) :=
begin
 cases b with b,
   rewrite [zero_mul, *nat.div_zero, nat.zero_div],
   cases c with c,
     rewrite [mul_zero, *nat.div_zero],
     apply div_div_aux a (succ b) (succ c) dec_trivial dec_trivial
end

lemma div_lt_of_ne_zero : ∀ {n : nat}, n ≠ 0 → n / 2 < n
| 0        h := absurd rfl h
| (succ n) h :=
  begin
    apply nat.div_lt_of_lt_mul,
    rewrite [-add_one, right_distrib],
    change n + 1 < (n * 1 + n) + (1 + 1),
    rewrite [mul_one, -add.assoc],
    apply add_lt_add_right,
    show n < n + n + 1,
    begin
      rewrite [add.assoc, -add_zero n at {1}],
      apply add_lt_add_left,
      apply zero_lt_succ
    end
  end
end nat


import analysis.complex.basic
import analysis.normed_space.operator_norm

open complex

variables {F : Type*} [normed_group F] [normed_space ℂ F]

-- Extend `fr : F →ₗ[ℝ] ℝ` to `F →ₗ[ℂ] ℂ` in a way that will also be continuous and have its norm
-- bounded by `∥fr∥` if `fr` is continuous.
noncomputable def linear_map.extend_to_C (fr : F →ₗ[ℝ] ℝ) : F →ₗ[ℂ] ℂ :=
begin
  let fc := λ z, (fr.to_fun z : ℂ) - I * fr.to_fun (I • z),
  have add : ∀ x y : F, fc (x + y) = fc x + fc y,
  {
    intros,
    calc
      (fr.to_fun (x + y) : ℂ) - I * fr.to_fun (I • (x + y))
        = (fr.to_fun (x + y) : ℂ) - I * fr.to_fun (I • x + I • y) : by rw smul_add
    ... = ((fr.to_fun x + fr.to_fun y) : ℂ) - I * fr.to_fun (I • x + I • y) :
      by rw [←complex.of_real_add, fr.add]
    ... = ((fr.to_fun x + fr.to_fun y) : ℂ) - I * (fr.to_fun (I • x) + fr.to_fun (I • y)) :
      by rw [←complex.of_real_add (fr.to_fun (I • x)), fr.add]
    ... = fr.to_fun x - I * fr.to_fun (I • x) + (fr.to_fun y - I * fr.to_fun (I • y)) : by ring,
  },

  have smul_ℝ : ∀ (c : ℝ) (x : F), fc (c • x) = c * fc x,
  {
    intros,
    have h1 : (fr.to_fun (c • x) : ℂ) = (c * fr.to_fun x : ℂ),
    { rw [←complex.of_real_mul, fr.smul, smul_eq_mul] },

    have h2 : I * fr.to_fun (I • c • x) = c * (I * fr.to_fun (I • x)),
    calc
      I * fr.to_fun (I • c • x)
        = I * fr.to_fun (I • (c : ℂ) • x) : rfl
    ... = I * fr.to_fun ((c : ℂ) • I • x) : by rw smul_comm
    ... = I * fr.to_fun (c • I • x) : rfl
    ... = I * (c * fr.to_fun (I • x)) : by rw [←complex.of_real_mul, fr.smul, smul_eq_mul]
    ... = c * (I * fr.to_fun (I • x)) : by ring,

    calc
      (fr.to_fun (c • x) : ℂ) - I * fr.to_fun (I • c • x)
        = (c * fr.to_fun x : ℂ) - c * (I * fr.to_fun (I • x)) : by rw [h1, h2]
    ... = c * (fr.to_fun x - I * fr.to_fun (I • x)) : by ring,
  },

  have smul_I : ∀ x : F, fc (I • x) = I * fc x,
  {
    intros,
    have h1 : I * fr.to_fun (I • I • x) = - (I * fr.to_fun x),
    {
      calc I * fr.to_fun (I • I • x)
          = I * fr.to_fun (((-1 : ℝ) : ℂ) • x) : by rw [←mul_smul, I_mul_I, of_real_neg, of_real_one]
      ... = I * fr.to_fun ((-1 : ℝ) • x) : rfl
      ... = I * ((-1 : ℝ) * fr.to_fun x : ℝ) : by rw [fr.smul, smul_eq_mul]
      ... = I * -1 * fr.to_fun x : by rw [of_real_mul, mul_assoc, of_real_neg, of_real_one]
      ... = - (I * fr.to_fun x) : by ring
    },

    calc fc (I • x)
        = (fr.to_fun (I • x) : ℂ) - I * fr.to_fun (I • I • x) : rfl
    ... = (fr.to_fun (I • x) : ℂ) - - (I * fr.to_fun x) : by rw h1
    ... = (fr.to_fun (I • x) : ℂ) + I * fr.to_fun x : by rw sub_neg_eq_add
    ... = I * fr.to_fun x + fr.to_fun (I • x) : by rw add_comm
    ... = I * fr.to_fun x - I * I * fr.to_fun (I • x) : by rw [I_mul_I, neg_one_mul, sub_neg_eq_add]
    ... = I * fr.to_fun x - I * (I * fr.to_fun (I • x)) : by rw mul_assoc
    ... = I * fc x : by rw mul_sub,
  },

  have smul_ℂ : ∀ (c : ℂ) (x : F), fc (c • x) = c • fc x,
  {
    intros,
    let a : ℂ := c.re,
    let b : ℂ := c.im,
    calc
      fc (c • x)
        = fc ((a + b * I) • x) : by rw re_add_im
    ... = fc (a • x + (b * I) • x) : by rw add_smul
    ... = fc (a • x) + fc ((b * I) • x) : by rw add
    ... = fc (c.re • x) + fc ((b * I) • x) : rfl
    ... = a * fc x + fc ((b * I) • x) : by rw smul_ℝ
    ... = a * fc x + fc (b • I • x) : by rw mul_smul
    ... = a * fc x + fc (c.im • I • x) : rfl
    ... = a * fc x + b * fc (I • x) : by rw smul_ℝ
    ... = a * fc x + b * (I * fc x) : by rw smul_I
    ... = a * fc x + b * I * fc x : by rw mul_assoc
    ... = (a + b * I) * fc x : by rw add_mul
    ... = c * fc x : by rw re_add_im c,
  },

  exact { to_fun := fc, add := add, smul := smul_ℂ }
end

-- The norm of the extension is bounded by ∥fr∥.
lemma norm_bound (fr : F →L[ℝ] ℝ) :
  ∀ x : F, ∥fr.to_linear_map.extend_to_C x∥ ≤ ∥fr∥ * ∥x∥ :=
begin
  intros,
  let lm := fr.to_linear_map.extend_to_C,

  -- We aim to find a `t : ℂ` such that
  -- * `lm (t • x) = fr (t • x)` (so `lm (t • x) = t * lm x ∈ ℝ`)
  -- * `∥lm x∥ = ∥lm (t • x)∥` (so `t.abs` must be 1)
  -- If `lm x ≠ 0`, `(lm x)⁻¹` satisfies the first requirement, and after normalizing, it
  -- satisfies the second.
  -- (If `lm x = 0`, the goal is trivial.)
  classical,
  by_cases lm x = 0,
  {
    rw [h, norm_zero],
    apply mul_nonneg'; exact norm_nonneg _,
  },

  let fx := (lm x)⁻¹,
  let t := fx / fx.abs,
  have ht : t.abs = 1,
  {
    rw [complex.abs_div, abs_of_real, complex.abs_abs],
    apply div_self,
    dsimp only [fx],
    rw [complex.abs_inv],
    apply inv_ne_zero,
    dsimp only [(≠)],
    rw complex.abs_eq_zero,
    exact h,
  },
  have : lm (t • x) = fr (t • x),
  {
    ext,
    {
      unfold_coes,
      calc (lm.to_fun (t • x)).re
          = ((fr.to_linear_map.to_fun (t • x) : ℂ)
            - I * fr.to_linear_map.to_fun (I • t • x)).re : rfl
      ... = (fr.to_linear_map.to_fun (t • x) : ℂ).re
             - (I * fr.to_linear_map.to_fun (I • t • x)).re : by rw sub_re
      ... = (fr.to_linear_map.to_fun (t • x) : ℂ).re
             - ((fr.to_linear_map.to_fun (I • t • x) : ℂ) * I).re : by rw mul_comm
      ... = (fr.to_linear_map.to_fun (t • x) : ℂ).re : by rw [smul_re, I_re, mul_zero, sub_zero],
    },

    rw of_real_im,
    calc (lm (t • x)).im
        = (t * lm x).im : by { unfold_coes, rw [lm.smul, smul_eq_mul], }
    ... = ((lm x)⁻¹ / (lm x)⁻¹.abs * lm x).im : rfl
    ... = (1 / (lm x)⁻¹.abs : ℂ).im : by rw [div_mul_eq_mul_div, inv_mul_cancel h]
    ... = 0 : by rw [←complex.of_real_one, ←of_real_div, of_real_im],
  },

  calc ∥lm x∥
      = t.abs * ∥lm x∥ : by rw [ht, one_mul]
  ... = ∥t * lm x∥ : by rw [normed_field.norm_mul, t.norm_eq_abs]
  ... = ∥lm (t • x)∥ : by { unfold_coes, rw [←smul_eq_mul, lm.smul] }
  ... = ∥(fr (t • x) : ℂ)∥ : by rw this
  ... = ∥fr (t • x)∥ : by rw norm_real
  ... ≤ ∥fr∥ * ∥t • x∥ : continuous_linear_map.le_op_norm _ _
  ... = ∥fr∥ * (∥t∥ * ∥x∥) : by rw norm_smul
  ... = ∥fr∥ * ∥x∥ : by rw [norm_eq_abs, ht, one_mul],
end

-- Extend `fr : F →L[ℝ] ℝ` to `F →L[ℂ] ℂ`.
noncomputable def continuous_linear_map.extend_to_C (fr : F →L[ℝ] ℝ) : F →L[ℂ] ℂ :=
  fr.to_linear_map.extend_to_C.mk_continuous ∥fr∥ (norm_bound _)


import .love03_forward_proofs_demo

/-! # LoVe Exercise 4: Functional Programming -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1: Reverse of a List

We define a new accumulator-based version of `reverse`. The first argument,
`as`, serves as the accumulator. This definition is __tail-recursive__, meaning
that compilers and interpreters can easily optimize the recursion away,
resulting in more efficient code. -/

def accurev {α : Type} : list α → list α → list α
| as []        := as
| as (x :: xs) := accurev (x :: as) xs

/-! 1.1. Our intention is that `accurev [] xs` should be equal to `reverse xs`.
But if we start an induction, we quickly see that the induction hypothesis is
not strong enough. Start by proving the following generalization (using the
`induction'` tactic or pattern matching): -/

lemma accurev_eq_reverse_append {α : Type} :
  ∀as xs : list α, accurev as xs = reverse xs ++ as :=
sorry

/-! 1.2. Derive the desired equation. -/

lemma accurev_eq_reverse {α : Type} (xs : list α) :
  accurev [] xs = reverse xs :=
sorry

/-! 1.3. Prove the following property.

Hint: A one-line inductionless proof is possible. -/

lemma accurev_accurev {α : Type} (xs : list α) :
  accurev [] (accurev [] xs) = xs :=
sorry

/-! 1.4. Prove the following lemma by structural induction, as a "paper" proof.
This is a good exercise to develop a deeper understanding of how structural
induction works (and is good practice for the final exam).

    lemma accurev_eq_reverse_append {α : Type} :
      ∀as xs : list α, accurev as xs = reverse xs ++ as

Guidelines for paper proofs:

We expect detailed, rigorous, mathematical proofs. You are welcome to use
standard mathematical notation or Lean structured commands (e.g., `assume`,
`have`, `show`, `calc`). You can also use tactical proofs (e.g., `intro`,
`apply`), but then please indicate some of the intermediate goals, so that we
can follow the chain of reasoning.

Major proof steps, including applications of induction and invocation of the
induction hypothesis, must be stated explicitly. For each case of a proof by
induction, you must list the inductive hypotheses assumed (if any) and the goal
to be proved. Minor proof steps corresponding to `refl`, `simp`, or `cc` need
not be justified if you think they are obvious (to humans), but you should say
which key lemmas they depend on. You should be explicit whenever you use a
function definition or an introduction rule for an inductive predicate. -/

-- enter your paper proof here

/-! ## Question 2: Drop and Take

The `drop` function removes the first `n` elements from the front of a list. -/

def drop {α : Type} : ℕ → list α → list α
| 0       xs        := xs
| (_ + 1) []        := []
| (m + 1) (x :: xs) := drop m xs

/-! 2.1. Define the `take` function, which returns a list consisting of the the
first `n` elements at the front of a list.

To avoid unpleasant surprises in the proofs, we recommend that you follow the
same recursion pattern as for `drop` above. -/

def take {α : Type} : ℕ → list α → list α :=
sorry

#eval take 0 [3, 7, 11]   -- expected: []
#eval take 1 [3, 7, 11]   -- expected: [3]
#eval take 2 [3, 7, 11]   -- expected: [3, 7]
#eval take 3 [3, 7, 11]   -- expected: [3, 7, 11]
#eval take 4 [3, 7, 11]   -- expected: [3, 7, 11]

#eval take 2 ["a", "b", "c"]   -- expected: ["a", "b"]

/-! 2.2. Prove the following lemmas, using `induction'` or pattern matching.
Notice that they are registered as simplification rules thanks to the `@[simp]`
attribute. -/

@[simp] lemma drop_nil {α : Type} :
  ∀n : ℕ, drop n ([] : list α) = [] :=
sorry

@[simp] lemma take_nil {α : Type} :
  ∀n : ℕ, take n ([] : list α) = [] :=
sorry

/-! 2.3. Follow the recursion pattern of `drop` and `take` to prove the
following lemmas. In other words, for each lemma, there should be three cases,
and the third case will need to invoke the induction hypothesis.

Hint: Note that there are three variables in the `drop_drop` lemma (but only two
arguments to `drop`). For the third case, `←add_assoc` might be useful. -/

lemma drop_drop {α : Type} :
  ∀(m n : ℕ) (xs : list α), drop n (drop m xs) = drop (n + m) xs
| 0       n xs        := by refl
-- supply the two missing cases here

lemma take_take {α : Type} :
  ∀(m : ℕ) (xs : list α), take m (take m xs) = take m xs :=
sorry

lemma take_drop {α : Type} :
  ∀(n : ℕ) (xs : list α), take n xs ++ drop n xs = xs :=
sorry

/-! ## Question 3: A Type of λ-Terms

3.1. Define an inductive type corresponding to the untyped λ-terms, as given
by the following context-free grammar:

    term ::= 'var' string        -- variable (e.g., `x`)
           | 'lam' string term   -- λ-expression (e.g., `λx, t`)
           | 'app' term term     -- application (e.g., `t u`) -/

-- enter your definition here

/-! 3.2. Register a textual representation of the type `term` as an instance of
the `has_repr` type class. Make sure to supply enough parentheses to guarantee
that the output is unambiguous. -/

def term.repr : term → string
-- enter your answer here

@[instance] def term.has_repr : has_repr term :=
{ repr := term.repr }

/-! 3.3. Test your textual representation. The following command should print
something like `(λx, ((y x) x))`. -/

#eval (term.lam "x" (term.app (term.app (term.var "y") (term.var "x"))
    (term.var "x")))

end LoVe


/-
Copyright (c) 2021 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import order.lattice
import data.fin
import data.set_like.basic
import data.list.sort
import data.equiv.fin
import data.equiv.functor
/-!
# Jordan Hölder Theorem

This file proves the Jordan Hölder theorem for a `jordan_hoelder_lattice`, a class also defined in this
file. Examples of `jordan_hoelder_lattice` include `subgroup G` if `G` is a group, and
`submodule R M` if `M` is an `R`-module. Using this approach the theorem need not be proved seperately
for both groups and modules, the proof in this file can be applied to both.

## Main definitions
The main definitions in this file are `jordan_hoelder_lattice` and `composition_series`,
and the relation `equivalent` on `composition_series`

A `jordan_hoelder_lattice` is the class for which the Jordan Hölder theorem is proved. A Jordan Hölder
class is a lattice equipped with a notion of maximality, `is_maximal`, and a notion of isoorphism of
pairs `iso`. In the example of subgroups of a group, `is_maximal H K` means that `H` is a maximal normal
subgroup of `K`, and `iso (H₁, K₁) (H₂, K₂)` means that the quotient `H₁ / K₁` is isomorphic to the
quotient `H₂ / K₂`. `iso` be symmetric and transitive and must satisfy the second isomorphism theorem
`iso (H, H ⊔ K) (H ⊓ K, K)`.

A `composition_series X` is a finite nonempty series of elements of the lattice `X` such that
each element is maximal inside the next. The length of a `composition_series X` is
one less than the number of elements in the series. Note that there is no stipulation
that a series start from the bottom of the lattice and finish at the top.
For a composition series `s`, `s.top` is the largest element of the series,
and `s.bot` is the least element.

Two `composition_series X`, `s₁` and `s₂` are equivalent if there is a bijection
`e : fin s₁.length ≃ fin s₂.length` such that for any `i`,
`iso (s₁ i) (s₁ i.succ) (s₂ (e i), s₂ (e i.succ))`

## Main theorems

The main theorem is `jordan_hoelder`, which says that if two composition
series have the same least element and the same largest element,
then they are `equivalent`.
-/

universe u

open set

/--
A `jordan_hoelder_lattice` is the class for which the Jordan Hölder theorem is proved. A Jordan Hölder
class is a lattice equipped with a notion of maximality, `is_maximal`, and a notion of isoorphism of
pairs `iso`. In the example of subgroups of a group, `is_maximal H K` means that `H` is a maximal normal
subgroup of `K`, and `iso (H₁, K₁) (H₂, K₂)` means that the quotient `H₁ / K₁` is isomorphic to the
quotient `H₂ / K₂`. `iso` be symmetric and transitive and must satisfy the second isomorphism theorem
`iso (H, H ⊔ K) (H ⊓ K, K)`. Examples include `subgroup G` if `G` is a group, and
`submodule R M` if `M` is an `R`-module
-/
class jordan_hoelder_lattice (X : Type u) [lattice X] :=
(is_maximal : X → X → Prop)
(lt_of_is_maximal : ∀ {x y}, is_maximal x y → x < y)
(sup_eq_of_is_maximal : ∀ {x y z}, is_maximal x z → is_maximal y z →
  x ≠ y → x ⊔ y = z)
(is_maximal_inf_left_of_is_maximal_sup : ∀ {x y}, is_maximal x (x ⊔ y) → is_maximal y (x ⊔ y) →
  is_maximal (x ⊓ y) x)
(iso : (X × X) → (X × X) → Prop)
(iso_symm : ∀ {x y}, iso x y → iso y x)
(iso_trans : ∀ {x y z}, iso x y → iso y z → iso x z)
(second_iso : ∀ {x y}, is_maximal x (x ⊔ y) → iso (x, x ⊔ y) (x ⊓ y, y))

namespace jordan_hoelder_lattice

variables {X : Type u} [lattice X] [jordan_hoelder_lattice X]

lemma is_maximal_inf_right_of_is_maximal_sup {x y : X}
  (hxz : is_maximal x (x ⊔ y)) (hyz : is_maximal y (x ⊔ y)) :
   is_maximal (x ⊓ y) y :=
begin
  rw [inf_comm],
  rw [sup_comm] at hxz hyz,
  exact is_maximal_inf_left_of_is_maximal_sup hyz hxz
end

lemma is_maximal_of_eq_inf (x b : X) {a y : X}
  (ha : x ⊓ y = a) (hxy : x ≠ y)
  (hxb : is_maximal x b) (hyb : is_maximal y b) :
  is_maximal a y :=
begin
  have hb : x ⊔ y = b,
    from sup_eq_of_is_maximal hxb hyb hxy,
  substs a b,
  exact is_maximal_inf_right_of_is_maximal_sup hxb hyb
end

lemma second_iso_of_eq {x y a b: X} (hm : is_maximal x a) (ha : x ⊔ y = a) (hb : x ⊓ y = b) :
  iso (x, a) (b, y) :=
by substs a b; exact second_iso hm

lemma iso_refl_of_is_maximal {x y : X} (h : is_maximal x y) : iso (x, y) (x, y) :=
second_iso_of_eq h
  (sup_eq_right.2 (le_of_lt (lt_of_is_maximal h)))
  (inf_eq_left.2 (le_of_lt (lt_of_is_maximal h)))

end jordan_hoelder_lattice

open jordan_hoelder_lattice

attribute [symm] iso_symm
attribute [trans] iso_trans

/--
A `composition_series X` is a finite nonempty series of elements of a `jordan_hoelder_lattice` such that
each element is maximal inside the next. The length of a `composition_series X` is
one less than the number of elements in the series. Note that there is no stipulation
that a series start from the bottom of the lattice and finish at the top.
For a composition series `s`, `s.top` is the largest element of the series,
and `s.bot` is the least element.
-/
structure composition_series (X : Type u) [lattice X] [jordan_hoelder_lattice X] : Type u :=
(length : ℕ)
(series : fin (length + 1) → X)
(step' : ∀ i : fin length, is_maximal (series i.cast_succ) (series i.succ))

namespace composition_series

variables {X : Type u} [lattice X] [jordan_hoelder_lattice X]

instance : has_coe_to_fun (composition_series X) :=
{ F := _, coe := composition_series.series }

variables {X}

lemma step (s : composition_series X) : ∀ i : fin s.length,
  is_maximal (s i.cast_succ) (s i.succ) := s.step'

@[simp] lemma coe_fn_mk (length : ℕ) (series step) :
  (@composition_series.mk X _ _ length series step : fin length.succ → X) = series := rfl

theorem lt_succ (s : composition_series X) (i : fin s.length) :
  s i.cast_succ < s i.succ :=
lt_of_is_maximal (s.step _)

protected theorem strict_mono (s : composition_series X) : strict_mono s :=
fin.strict_mono_iff_lt_succ.2 (λ i h, s.lt_succ ⟨i, nat.lt_of_succ_lt_succ h⟩)

protected theorem injective (s : composition_series X) : function.injective s :=
s.strict_mono.injective

@[simp] protected theorem inj (s : composition_series X) {i j : fin s.length.succ} :
  s i = s j ↔ i = j :=
s.injective.eq_iff

instance : has_mem X (composition_series X) :=
⟨λ x s, x ∈ set.range s⟩

lemma mem_def {x : X} {s : composition_series X} : x ∈ s ↔ x ∈ set.range s := iff.rfl

lemma total {s : composition_series X} {x y : X} (hx : x ∈ s) (hy : y ∈ s) : x ≤ y ∨ y ≤ x :=
begin
  rcases set.mem_range.1 hx with ⟨i, rfl⟩,
  rcases set.mem_range.1 hy with ⟨j, rfl⟩,
  rw [s.strict_mono.le_iff_le, s.strict_mono.le_iff_le],
  exact le_total i j
end

/-- The ordered `list X` of elements of a `composition_series X`. -/
def to_list (s : composition_series X) : list X := list.of_fn s

/-- Two `composition_series` are equal if they are the same length and
have the same `i`th element for every `i` -/
lemma ext_fun {s₁ s₂ : composition_series X}
  (hl : s₁.length = s₂.length)
  (h : ∀ i, s₁ i = s₂ (fin.cast (congr_arg nat.succ hl) i)) :
  s₁ = s₂ :=
begin
  cases s₁, cases s₂,
  dsimp at *,
  subst hl,
  simpa [function.funext_iff] using h
end

@[simp] lemma length_to_list (s : composition_series X) : s.to_list.length = s.length + 1 :=
by rw [to_list, list.length_of_fn]

lemma to_list_ne_nil (s : composition_series X) : s.to_list ≠ [] :=
by rw [← list.length_pos_iff_ne_nil, length_to_list]; exact nat.succ_pos _

lemma to_list_injective : function.injective (@composition_series.to_list X _ _) :=
λ s₁ s₂ (h : list.of_fn s₁ = list.of_fn s₂),
have h₁ : s₁.length = s₂.length,
  from nat.succ_injective
    ((list.length_of_fn s₁).symm.trans $
      (congr_arg list.length h).trans $
      list.length_of_fn s₂),
have h₂ : ∀ i : fin s₁.length.succ, (s₁ i) = s₂ (fin.cast (congr_arg nat.succ h₁) i),
  begin
    assume i,
    rw [← list.nth_le_of_fn s₁ i, ← list.nth_le_of_fn s₂],
    simp [h]
  end,
begin
  cases s₁, cases s₂,
  dsimp at *,
  subst h₁,
  simp only [heq_iff_eq, eq_self_iff_true, true_and],
  simp only [fin.cast_refl] at h₂,
  exact funext h₂
end

lemma chain'_to_list (s : composition_series X) :
  list.chain' is_maximal s.to_list :=
list.chain'_iff_nth_le.2
  begin
    assume i hi,
    simp only [to_list, list.nth_le_of_fn'],
    rw [length_to_list] at hi,
    exact s.step ⟨i, hi⟩
  end

lemma to_list_sorted (s : composition_series X) : s.to_list.sorted (<) :=
list.pairwise_iff_nth_le.2 (λ i j hi hij,
  begin
    dsimp [to_list],
    rw [list.nth_le_of_fn', list.nth_le_of_fn'],
    exact s.strict_mono hij
  end)

lemma to_list_nodup (s : composition_series X) : s.to_list.nodup :=
list.nodup_iff_nth_le_inj.2
  (λ i j hi hj,
    begin
      delta to_list,
      rw [list.nth_le_of_fn', list.nth_le_of_fn', s.injective.eq_iff, fin.ext_iff, fin.coe_mk, fin.coe_mk],
      exact id
    end)

@[simp] lemma mem_to_list {s : composition_series X} {x : X} : x ∈ s.to_list ↔ x ∈ s :=
by rw [to_list, list.mem_of_fn, mem_def]

/-- Make a `composition_series X` from the ordered list of its elements. -/
def of_list (l : list X) (hl : l ≠ []) (hc : list.chain' is_maximal l) :
  composition_series X :=
{ length := l.length - 1,
  series := λ i, l.nth_le i begin
      conv_rhs { rw ← nat.sub_add_cancel (list.length_pos_of_ne_nil hl) },
      exact i.2
    end,
  step' := λ ⟨i, hi⟩, list.chain'_iff_nth_le.1 hc i hi }

lemma length_of_list (l : list X) (hl : l ≠ []) (hc : list.chain' is_maximal l) :
  (of_list l hl hc).length = l.length - 1 := rfl

lemma of_list_to_list (s : composition_series X) :
  of_list s.to_list s.to_list_ne_nil s.chain'_to_list = s :=
begin
  refine ext_fun _ _,
  { rw [length_of_list, length_to_list, nat.succ_sub_one] },
  { rintros ⟨i, hi⟩,
    dsimp [of_list, to_list],
    rw [list.nth_le_of_fn'] }
end

@[simp] lemma of_list_to_list' (s : composition_series X) (hs : s.to_list ≠ [])
  (hc : list.chain' is_maximal s.to_list) :
  of_list s.to_list s.to_list_ne_nil s.chain'_to_list = s :=
of_list_to_list s

@[simp] lemma to_list_of_list (l : list X) (hl : l ≠ []) (hc : list.chain' is_maximal l)  :
  to_list (of_list l hl hc) = l :=
begin
  refine list.ext_le _ _,
  { rw [length_to_list, length_of_list, nat.sub_add_cancel
      (list.length_pos_of_ne_nil hl)] },
  { assume i hi hi',
    dsimp [of_list, to_list],
    rw [list.nth_le_of_fn'],
    refl }
end

/-- Two `composition_series` are equal if they have the same elements. See also `ext_fun`. -/
@[ext] lemma ext {s₁ s₂ : composition_series X} (h : ∀ x, x ∈ s₁ ↔ x ∈ s₂) : s₁ = s₂ :=
to_list_injective $ list.eq_of_perm_of_sorted
  (by classical; exact list.perm_of_nodup_nodup_to_finset_eq
    s₁.to_list_nodup
    s₂.to_list_nodup
    (finset.ext $ by simp *))
  s₁.to_list_sorted s₂.to_list_sorted

/-- The largest element of a `composition_series` -/
def top (s : composition_series X) : X := s (fin.last _)

lemma top_mem (s : composition_series X) : s.top ∈ s :=
mem_def.2 (set.mem_range.2 ⟨fin.last _, rfl⟩)

@[simp] lemma le_top {s : composition_series X} (i : fin (s.length + 1)) : s i ≤ s.top :=
s.strict_mono.monotone (fin.le_last _)

lemma le_top_of_mem {s : composition_series X} {x : X} (hx : x ∈ s) : x ≤ s.top :=
let ⟨i, hi⟩ := set.mem_range.2 hx in hi ▸ le_top _

/-- The smallest element of a `composition_series` -/
def bot (s : composition_series X) : X := s 0

lemma bot_mem (s : composition_series X) : s.bot ∈ s :=
mem_def.2 (set.mem_range.2 ⟨0, rfl⟩)

@[simp] lemma bot_le {s : composition_series X} (i : fin (s.length + 1)) : s.bot ≤ s i :=
s.strict_mono.monotone (fin.zero_le _)

lemma bot_le_of_mem {s : composition_series X} {x : X} (hx : x ∈ s) : s.bot ≤ x :=
let ⟨i, hi⟩ := set.mem_range.2 hx in hi ▸ bot_le _

instance : set_like (composition_series X) X :=
{ coe := λ s, set.range s,
  coe_injective' := λ s₁ s₂ h, ext $ λ x, begin
    dsimp at h,
    rw [mem_def, mem_def, h]
  end }

lemma length_pos_of_mem_ne {s : composition_series X}
  {x y : X} (hx : x ∈ s) (hy : y ∈ s) (hxy : x ≠ y) :
  0 < s.length :=
let ⟨i, hi⟩ := hx, ⟨j, hj⟩ := hy in
have hij : i ≠ j, from mt s.inj.2 $ λ h, hxy (hi ▸ hj ▸ h),
hij.lt_or_lt.elim
  (λ hij, (lt_of_le_of_lt (zero_le i)
    (lt_of_lt_of_le hij (nat.le_of_lt_succ j.2))))
  (λ hji, (lt_of_le_of_lt (zero_le j)
    (lt_of_lt_of_le hji (nat.le_of_lt_succ i.2))))

lemma forall_mem_eq_of_length_eq_zero {s : composition_series X}
  (hs : s.length = 0) {x y} (hx : x ∈ s) (hy : y ∈ s) : x = y :=
by_contradiction (λ hxy, pos_iff_ne_zero.1 (length_pos_of_mem_ne hx hy hxy) hs)

/-- `s.take i` returns the inital segment of `s` up to and including
the `i`th term.  -/
@[simps] def take (s : composition_series X) (i : fin (s.length + 1)) :
  composition_series X :=
{ length := i,
  series := λ j, s (fin.cast_le (nat.succ_le_of_lt i.2) j),
  step' := λ j,
    by simpa using s.step (fin.cast_le (nat.le_of_lt_succ i.2) j) }

@[simp] lemma top_take  (s : composition_series X) (i : fin (s.length + 1)) :
  (s.take i).top = s i :=
begin
  cases i,
  simp [top, fin.ext_iff],
end

@[simp] lemma bot_take  (s : composition_series X) (i : fin (s.length + 1)) :
  (s.take i).bot = s.bot := rfl

/-- `s.drop i` returns the final segment of `s` starting at and including
the `i`th term.  -/
@[simps] def drop (s : composition_series X) (i : fin (s.length + 1)) :
  composition_series X :=
{ length := s.length - i,
  series :=
    have (i : ℕ) + (s.length - i + 1) = s.length + 1,
      by rw [← add_assoc, nat.add_sub_cancel' (nat.le_of_lt_succ i.is_lt)],
    λ j, s (fin.cast this (fin.cast_add_right i j)),
  step' := λ j, begin
    have := s.step (fin.cast (nat.add_sub_cancel' (nat.le_of_lt_succ i.is_lt)) (fin.cast_add_right i j)),
    cases j,
    simpa
  end }

@[simp] lemma top_drop  (s : composition_series X) (i : fin (s.length + 1)) :
  (s.drop i).top = s.top :=
begin
  cases i with _ hi,
  simp [top, fin.ext_iff, nat.add_sub_cancel' (nat.le_of_lt_succ hi)],
end

@[simp] lemma bot_drop  (s : composition_series X) (i : fin (s.length + 1)) :
  (s.drop i).bot = s i :=
begin
  cases i,
  simp [bot, fin.ext_iff],
end

/-- Remove the largest element from a `composition_series`. If the series `s`
has length zero, then `s.erase_top = s` -/
@[simps] def erase_top (s : composition_series X) : composition_series X :=
{ length := s.length - 1,
  series := λ i, s ⟨i, lt_of_lt_of_le i.2 (nat.succ_le_succ (nat.sub_le_self _ _))⟩,
  step' := λ i, begin
    have := s.step ⟨i, lt_of_lt_of_le i.2 (nat.sub_le_self _ _)⟩,
    cases i,
    exact this
  end }

lemma top_erase_top (s : composition_series X) :
  s.erase_top.top = s ⟨s.length - 1, lt_of_le_of_lt (nat.sub_le_self _ _) (nat.lt_succ_self _)⟩ :=
show s _ = s _, from congr_arg s
begin
  ext,
  simp only [erase_top_length, fin.coe_last, fin.coe_cast_succ, fin.coe_of_nat_eq_mod,
    fin.coe_mk, coe_coe]
end

lemma erase_top_top_le (s : composition_series X) : s.erase_top.top ≤ s.top :=
by simp [erase_top, top, s.strict_mono.le_iff_le, fin.le_iff_coe_le_coe, nat.sub_le_self]

@[simp] lemma bot_erase_top (s : composition_series X) : s.erase_top.bot = s.bot := rfl

lemma mem_erase_top_of_ne_of_mem {s : composition_series X} {x : X}
  (hx : x ≠ s.top) (hxs : x ∈ s) : x ∈ s.erase_top :=
begin
  { rcases hxs with ⟨i, rfl⟩,
    have hi : (i : ℕ) < (s.length - 1).succ,
    { conv_rhs { rw [← nat.succ_sub (length_pos_of_mem_ne ⟨i, rfl⟩ s.top_mem hx),
        nat.succ_sub_one] },
      exact lt_of_le_of_ne
        (nat.le_of_lt_succ i.2)
        (by simpa [top, s.inj, fin.ext_iff] using hx) },
    refine ⟨i.cast_succ, _⟩,
    simp [fin.ext_iff, nat.mod_eq_of_lt hi] }
end

lemma erase_top_le (s : composition_series X) : s.erase_top ≤ s :=
begin
  rintros x ⟨i, rfl⟩,
  simp [mem_def, erase_top],
end

lemma mem_erase_top {s : composition_series X} {x : X}
  (h : 0 < s.length) : x ∈ s.erase_top ↔ x ≠ s.top ∧ x ∈ s :=
begin
  simp only [mem_def],
  dsimp only [erase_top, coe_fn_mk],
  split,
  { rintros ⟨i, rfl⟩,
    have hi : (i : ℕ) < s.length,
    { conv_rhs { rw [← nat.succ_sub_one s.length, nat.succ_sub h] },
      exact i.2 },
    simp [top, fin.ext_iff, (ne_of_lt hi)] },
  { intro h,
    exact mem_erase_top_of_ne_of_mem h.1 h.2 }
end

lemma lt_top_of_mem_erase_top
  {s : composition_series X} {x : X}
  (h : 0 < s.length)
  (hx : x ∈ s.erase_top) :
  x < s.top :=
lt_of_le_of_ne
  (le_top_of_mem ((mem_erase_top h).1 hx).2)
  ((mem_erase_top h).1 hx).1

lemma is_maximal_erase_top_top {s : composition_series X} (h : 0 < s.length) :
  is_maximal s.erase_top.top s.top :=
have s.length - 1 + 1 = s.length,
  by conv_rhs { rw [← nat.succ_sub_one s.length] }; rw nat.succ_sub h,
begin
  rw [top_erase_top, top],
  convert s.step ⟨s.length - 1, nat.sub_lt h zero_lt_one⟩;
  ext; simp [this]
end

/-- Remove the smallest element from a `composition_series`. If the series `s`
has length zero, then `s.erase_bot = s` -/
@[simps] def erase_bot (s : composition_series X) : composition_series X :=
{ length := s.length - 1,
  series := λ i, if h0s : 0 < s.length then s (fin.succ ⟨i,
    (by conv_rhs {rw [← nat.sub_add_cancel h0s]}; exact i.is_lt)⟩)
    else s.top,
  step' := λ i, begin
    have := s.step (⟨i + 1, nat.add_lt_of_lt_sub_right i.2⟩),
    have h0s : 0 < s.length,
      from lt_of_lt_of_le (fin.pos_iff_nonempty.2 ⟨i⟩) (nat.sub_le_self _ _),
    cases i,
    simpa [h0s]
  end }

lemma bot_erase_bot (s : composition_series X) (h0s : 0 < s.length):
  s.erase_bot.bot = s ⟨1, nat.succ_lt_succ h0s⟩ :=
by simp [erase_bot, bot, h0s]

lemma le_erase_bot_bot (s : composition_series X) : s.bot ≤ s.erase_bot.bot :=
by simp [erase_bot, bot, fin.le_iff_coe_le_coe, nat.sub_le_self];
  split_ifs; simp [s.strict_mono.le_iff_le, fin.le_iff_coe_le_coe]

@[simp] lemma top_erase_bot (s : composition_series X) : s.erase_bot.top = s.top :=
begin
  simp [erase_bot, top],
  split_ifs,
  { simp [fin.ext_iff, nat.sub_add_cancel h] },
  { refl }
end

lemma mem_erase_bot_of_ne_of_mem {s : composition_series X} {x : X}
  (hx : x ≠ s.bot) (hxs : x ∈ s) : x ∈ s.erase_bot :=
begin
  rcases hxs with ⟨i, rfl⟩,
  have hi0 : (0 : ℕ) < i, from nat.pos_of_ne_zero (by simpa [bot, fin.ext_iff] using hx),
  have hi : (i - 1 : ℕ) < (s.length - 1).succ,
  { conv_rhs { rw [← nat.succ_sub (length_pos_of_mem_ne ⟨i, rfl⟩ s.bot_mem hx),
      nat.succ_sub_one] },
    exact (nat.sub_lt_right_iff_lt_add hi0).2 i.2 },
  refine ⟨⟨i - 1, hi⟩, _⟩,
  dsimp [erase_bot],
  split_ifs,
  { simp [fin.ext_iff, nat.sub_add_cancel hi0] },
  { cases i,
    simp [*, bot, top, fin.ext_iff] at *,
    simp * at *}
end

lemma erase_bot_le (s : composition_series X) : s.erase_top ≤ s :=
begin
  rintros x ⟨i, rfl⟩,
  simp [mem_def],
end

lemma mem_erase_bot {s : composition_series X} {x : X}
  (h0s : 0 < s.length) : x ∈ s.erase_bot ↔ x ≠ s.bot ∧ x ∈ s :=
begin
  simp only [mem_def],
  dsimp only [erase_bot, coe_fn_mk],
  split,
  { rintros ⟨i, rfl⟩,
    have hi : (i : ℕ) < s.length,
    { conv_rhs { rw [← nat.succ_sub_one s.length, nat.succ_sub h0s] },
      exact i.2 },
    simp [bot, fin.ext_iff, (ne_of_lt hi), h0s] },
  { intro h,
    exact mem_erase_bot_of_ne_of_mem h.1 h.2 }
end

lemma bot_lt_of_mem_erase_bot
  {s : composition_series X} {x : X}
  (h : 0 < s.length)
  (hx : x ∈ s.erase_bot) :
  s.bot < x :=
lt_of_le_of_ne
  (bot_le_of_mem ((mem_erase_bot h).1 hx).2)
  ((mem_erase_bot h).1 hx).1.symm

lemma is_maximal_bot_erase_bot {s : composition_series X} (h : 0 < s.length) :
  is_maximal s.bot s.erase_bot.bot :=
have s.length - 1 + 1 = s.length,
  by conv_rhs { rw [← nat.succ_sub_one s.length] }; rw nat.succ_sub h,
begin
  rw [bot_erase_bot s h, bot],
  convert s.step ⟨0, h⟩,
end

/-- If `s.top` and `x` are both maximal inside `y`, and `¬ s i ≤ x`, then
`x ⊓ s i` is maximal inside `s i` -/
lemma is_maximal_inf_series'
  {s : composition_series X} {x y : X}
  {i : fin (s.length + 1)}
  (hy : is_maximal x y)
  (ht : is_maximal s.top y):
  ¬ s i ≤ x →
  is_maximal (x ⊓ s i) (s i) :=
begin
  refine fin.reverse_induction _ _ i,
  { intro hb,
    refine is_maximal_of_eq_inf _ _ rfl _ hy ht,
    { rintro rfl,
      exact hb (le_refl _) } },
  { intros i ih hb,
    refine is_maximal_of_eq_inf (x ⊓ s i.succ) _ _ _ (ih _) (s.step i),
    { rw [inf_assoc, inf_eq_right.2 (le_of_lt (lt_of_is_maximal (s.step _))), inf_comm] },
    { assume h,
      exact hb (h ▸ inf_le_left) },
    { assume h,
      exact hb (le_trans (s.strict_mono.monotone (le_of_lt i.cast_succ_lt_succ)) h) } }
end

/-- If `x` is maximal inside `s j`, and `¬ s i ≤ x` and `i ≤ j`, then
`x ⊓ s i` is maximal inside `s i` -/
lemma is_maximal_inf_series
  {s : composition_series X} {x : X}
  {i j : fin (s.length + 1)}
  (hij : i ≤ j)
  (hm : is_maximal x (s j))
  (hb : ¬ s i ≤ x) : is_maximal (x ⊓ s i) (s i) :=
begin
  have : ∀ (t : composition_series X) (i : fin (t.length + 1)),
    is_maximal x t.top → ¬ t i ≤ x → is_maximal (x ⊓ t i) (t i),
  { intros t i hm,
    refine fin.last_cases _ _ i,
    { assume h,
      erw [inf_eq_left.2 (le_of_lt (lt_of_is_maximal hm))],
      exact hm },
    { intros i hb,
      have h0t : 0 < t.length,
        from fin.pos_iff_nonempty.2 ⟨i⟩,
      have := @is_maximal_inf_series' _ _ _ _ _ _
        ⟨i, by rw [erase_top_length, nat.sub_add_cancel h0t]; exact i.2⟩
        hm (is_maximal_erase_top_top h0t) hb,
      exact this } },
  let i' : fin ((s.take j).length + 1) := ⟨i, nat.lt_succ_of_le hij⟩,
  simpa using this (s.take j) i' (by simpa using hm) (by simpa using hb)
end

lemma append_cast_add_aux
  {s₁ s₂ : composition_series X}
  (h : s₁ (fin.last _) = s₂ 0)
  (i : fin s₁.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.cast_add s₂.length i).cast_succ = s₁ i.cast_succ :=
by { cases i, simp [fin.append, *] }

lemma append_succ_cast_add_aux
  {s₁ s₂ : composition_series X}
  (h : s₁ (fin.last _) = s₂ 0)
  (i : fin s₁.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.cast_add s₂.length i).succ = s₁ i.succ :=
begin
  cases i with i hi,
  simp only [fin.append, hi, fin.succ_mk, function.comp_app, fin.cast_succ_mk,
    fin.coe_mk, fin.cast_add_mk],
  split_ifs,
  { refl },
  { have : i + 1 = s₁.length, from le_antisymm hi (le_of_not_gt h_1),
    calc s₂ ⟨i + 1 - s₁.length, by simp [this]⟩
        = s₂ 0 : congr_arg s₂ (by simp [fin.ext_iff, this])
    ... = s₁ (fin.last _) : h.symm
    ... = _ : congr_arg s₁ (by simp [fin.ext_iff, this]) }
end

lemma append_cast_add_right_aux
  {s₁ s₂ : composition_series X}
  (h : s₁ (fin.last _) = s₂ 0)
  (i : fin s₂.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.cast_add_right s₁.length i).cast_succ = s₂ i.cast_succ :=
by { cases i, simp [fin.append, *] }

lemma append_succ_cast_add_right_aux
  {s₁ s₂ : composition_series X}
  (h : s₁ (fin.last _) = s₂ 0)
  (i : fin s₂.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.cast_add_right s₁.length i).succ = s₂ i.succ :=
begin
  cases i with i hi,
  simp [fin.append, add_assoc]
end

/-- Append two composition series `s₁` and `s₂` such that
the least element of `s₁` is the maximum element of `s₂`. -/
@[simps length] def append (s₁ s₂ : composition_series X)
  (h : s₁.top = s₂.bot) :
  composition_series X :=
{ length := s₁.length + s₂.length,
  series := fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂,
  step' := λ i, begin
    refine fin.add_cases  _ _ i,
    { intro i,
      rw [append_succ_cast_add_aux h, append_cast_add_aux h],
      exact s₁.step i },
    { intro i,
      rw [append_cast_add_right_aux h, append_succ_cast_add_right_aux h],
      exact s₂.step i }
  end }

@[simp] lemma append_cast_add
  {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot)
  (i : fin s₁.length) :
  append s₁ s₂ h (fin.cast_add s₂.length i).cast_succ = s₁ i.cast_succ :=
append_cast_add_aux h i

@[simp] lemma append_succ_cast_add
  {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot)
  (i : fin s₁.length) :
  append s₁ s₂ h (fin.cast_add s₂.length i).succ = s₁ i.succ :=
append_succ_cast_add_aux h i

@[simp] lemma append_cast_add_right
  {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot)
  (i : fin s₂.length) :
  append s₁ s₂ h (fin.cast_add_right s₁.length i).cast_succ = s₂ i.cast_succ :=
append_cast_add_right_aux h i

@[simp] lemma append_succ_cast_add_right
  {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot)
  (i : fin s₂.length) :
  append s₁ s₂ h (fin.cast_add_right s₁.length i).succ = s₂ i.succ :=
append_succ_cast_add_right_aux h i

@[simp] lemma top_append
  {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) :
  (append s₁ s₂ h).top = s₂.top :=
by simp [top, append, fin.append, fin.ext_iff]

@[simp] lemma bot_append
  {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) :
  (append s₁ s₂ h).bot = s₁.bot :=
have s₁.length = 0 → s₁ 0 = s₁.top :=
  λ h, forall_mem_eq_of_length_eq_zero h s₁.bot_mem s₁.top_mem,
by revert this; simp [bot, append, fin.append, fin.ext_iff, h] { contextual := tt }

lemma take_append_drop
  (s : composition_series X) (i : fin (s.length + 1)) :
  (s.take i).append (s.drop i) (by simp) = s :=
begin
  refine ext_fun _ _,
  { simp [nat.add_sub_cancel' (nat.le_of_lt_succ i.is_lt)] },
  { intro j,
    refine fin.last_cases _ _ j,
    { rw [← top, top_append],
      simp [top, fin.ext_iff] },
    { assume j,
      refine fin.add_cases _ _ j,
      { intro j,
        simp [fin.ext_iff] },
      { intro j,
        simp [fin.ext_iff] } } }
end

/-- Add an element to the top of a `composition_series` -/
@[simps length] def snoc
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal s.top x) :
  composition_series X :=
{ length := s.length + 1,
  series := fin.snoc s x,
  step' := λ i, begin
    refine fin.last_cases _ _ i,
    { rwa [fin.snoc_cast_succ, fin.succ_last, fin.snoc_last, ← top] },
    { intro i,
      rw [fin.snoc_cast_succ, ← fin.cast_succ_fin_succ, fin.snoc_cast_succ],
      exact s.step _ }
  end }

@[simp] lemma top_snoc
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal s.top x) :
  (snoc s x hsat).top = x :=
fin.snoc_last _ _

@[simp] lemma snoc_last
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal s.top x) :
  snoc s x hsat (fin.last (s.length + 1)) = x :=
fin.snoc_last _ _

@[simp] lemma snoc_cast_succ
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal s.top x) (i : fin (s.length + 1)) :
  snoc s x hsat (i.cast_succ) = s i :=
fin.snoc_cast_succ _ _ _

@[simp] lemma bot_snoc
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal s.top x) :
  (snoc s x hsat).bot = s.bot :=
by rw [bot, bot, ← fin.cast_succ_zero, snoc_cast_succ]

lemma mem_snoc
  {s : composition_series X}
  {x y: X}
  {hsat : is_maximal s.top x} :
  y ∈ snoc s x hsat ↔ y ∈ s ∨ y = x :=
begin
  simp only [snoc, mem_def],
  split,
  { rintros ⟨i, rfl⟩,
    refine fin.last_cases _ (λ i, _) i,
    { right, simp },
    { left, simp } },
  { intro h,
    rcases h with ⟨i, rfl⟩ | rfl,
    { use i.cast_succ, simp },
    { use (fin.last _), simp } }
end

lemma eq_snoc_erase_top
  {s : composition_series X}
  (h : 0 < s.length) :
  s = snoc (erase_top s) s.top
    (is_maximal_erase_top_top h) :=
begin
  ext x,
  simp [mem_snoc, mem_erase_top h],
  by_cases h : x = s.top; simp [*, s.top_mem]
end

@[simp] lemma snoc_erase_top_top {s : composition_series X}
  (h : is_maximal s.erase_top.top s.top) :
  s.erase_top.snoc s.top h = s :=
have h : 0 < s.length,
  from nat.pos_of_ne_zero begin
    assume hs,
    refine ne_of_gt (lt_of_is_maximal h) _,
    simp [top, fin.ext_iff, hs]
  end,
(eq_snoc_erase_top h).symm

/-- Add an element to the bottom of a `composition_series` -/
@[simps length] def cons
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal x s.bot) :
  composition_series X :=
{ length := s.length + 1,
  series := fin.cons x s,
  step' := λ i, begin
    refine fin.cases _ _ i,
    { rwa [fin.cons_succ, fin.cast_succ_zero, fin.cons_zero, ← bot] },
    { intro i,
      rw [fin.cons_succ, fin.cast_succ_fin_succ, fin.cons_succ],
      exact s.step _ }
  end }

@[simp] lemma bot_cons
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal x s.bot) :
  (cons s x hsat).bot = x :=
by simp [bot, cons]

@[simp] lemma cons_zero
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal x s.bot) :
  cons s x hsat 0 = x :=
bot_cons _ _ _

@[simp] lemma cons_succ
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal x s.bot) (i : fin (s.length + 1)) :
  cons s x hsat (i.succ) = s i :=
fin.cons_succ _ _ _

@[simp] lemma top_cons
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal x s.bot) :
  (cons s x hsat).top = s.top :=
begin
  rw [top],
  dsimp only [cons_length],
  rw [← fin.succ_last, cons_succ, top]
end

lemma mem_cons
  {s : composition_series X}
  {x y: X}
  {hsat : is_maximal x s.bot} :
  y ∈ cons s x hsat ↔ y ∈ s ∨ y = x :=
begin
  simp only [snoc, mem_def],
  split,
  { rintros ⟨i, rfl⟩,
    refine fin.cases _ (λ i, _) i,
    { right, simp },
    { left, simp } },
  { intro h,
    rcases h with ⟨i, rfl⟩ | rfl,
    { use i.succ, simp },
    { use 0, simp } }
end

lemma eq_cons_erase_bot
  {s : composition_series X}
  (h : 0 < s.length) :
  s = cons (erase_bot s) s.bot
    (is_maximal_bot_erase_bot h) :=
begin
  ext x,
  simp [mem_cons, mem_erase_bot h],
  by_cases h : x = s.bot; simp [*, s.bot_mem]
end

@[simp] lemma cons_erase_bot_bot {s : composition_series X}
  (h : is_maximal s.bot s.erase_bot.bot) :
  s.erase_bot.cons s.bot h = s :=
have h : 0 < s.length,
  from nat.pos_of_ne_zero begin
    assume hs,
    refine ne_of_gt (lt_of_is_maximal h) _,
    simp [bot, fin.ext_iff, hs, erase_bot, top]
  end,
(eq_cons_erase_bot h).symm

/-- For a composition series `s` and an element `x`, return the series
whose `i`th term is `x ⊓ s i` -/
@[simps] def infinum (s : composition_series X) (x : X)
  (hm : is_maximal x s.top) (hb : ¬ s.bot ≤ x) :
  composition_series X :=
{ length := s.length,
  series := λ i, x ⊓ s i,
  step' := λ i, begin
    generalize hj : i.succ = j,
    revert i,
    refine fin.last_cases _ _ j,
    { intros i hj,
      rw [top] at hm,
      rw [inf_eq_left.2 (le_of_lt (lt_of_is_maximal hm))],
      refine is_maximal_of_eq_inf _ _ inf_comm _ (s.step i) (hj.symm ▸ hm),
      rintro rfl,
      exact hb (bot_le _) },
    { intros j i hj, rw [← hj],
      exact is_maximal_of_eq_inf
        (s i.cast_succ)
        (s i.succ)
        (by rw [inf_comm, inf_assoc, inf_eq_right.2 (le_of_lt (s.strict_mono (i.cast_succ_lt_succ)))])
        (λ h, hb (le_trans (bot_le i.cast_succ) (h.symm ▸ inf_le_left)))
        (s.step i)
        (is_maximal_inf_series (fin.le_last _) hm
          (λ h, hb (le_trans (s.strict_mono.monotone (fin.zero_le _)) h)))  }
  end }

@[simp] lemma infinum_top
  (s : composition_series X) (x : X)
  (hm : is_maximal x s.top) (hb : ¬ s.bot ≤ x) :
  (s.infinum x hm hb).top = x :=
begin
  dsimp [top],
  simpa [top] using le_of_lt (lt_of_is_maximal hm)
end

lemma iso_inf_mem_top
  {s : composition_series X}
  {x : X} {i : fin (s.length + 1)}
  (hm : is_maximal x s.top) :
  ∀ (hb : ¬s i ≤ x),
  iso (x ⊓ s i, s i) (x, s.top) :=
begin
  refine fin.reverse_induction _ _ i,
  { intro hb,
    rw [← top, inf_eq_left.2],
    { exact iso_refl_of_is_maximal hm },
    { exact le_of_lt (lt_of_is_maximal hm) } },
  { intros i ih hb,
    have : ¬ s i.succ ≤ x,
      from λ h, hb $ le_trans
        (le_of_lt (s.strict_mono i.cast_succ_lt_succ)) h,
    refine iso_trans _ (ih this),
    exact iso_symm (second_iso_of_eq
      (is_maximal_inf_series (fin.le_last _) hm this)
      (sup_eq_of_is_maximal (is_maximal_inf_series (fin.le_last _) hm this)
        (s.step i)
        (λ h, hb (h ▸ inf_le_left)))
      (by rw [inf_assoc, inf_eq_right.2
        (le_of_lt (s.strict_mono i.cast_succ_lt_succ))])) }
end

/-- Two `composition_series X`, `s₁` and `s₂` are equivalent if there is a bijection
`e : fin s₁.length ≃ fin s₂.length` such that for any `i`,
`iso (s₁ i) (s₁ i.succ) (s₂ (e i), s₂ (e i.succ))` -/
def equivalent (s₁ s₂ : composition_series X) : Prop :=
∃ f : fin s₁.length ≃ fin s₂.length,
  ∀ i : fin s₁.length,
    iso (s₁ i.cast_succ, s₁ i.succ)
    (s₂ (f i).cast_succ, s₂ (f i).succ)

namespace equivalent

@[refl] lemma refl (s : composition_series X) : equivalent s s :=
⟨equiv.refl _, λ _, iso_refl_of_is_maximal (s.step _)⟩

@[symm] lemma symm {s₁ s₂ : composition_series X} (h : equivalent s₁ s₂) :
  equivalent s₂ s₁ :=
⟨h.some.symm, λ i, iso_symm (by simpa using h.some_spec (h.some.symm i))⟩

@[trans] lemma trans {s₁ s₂ s₃ : composition_series X}
  (h₁ : equivalent s₁ s₂)
  (h₂ : equivalent s₂ s₃) :
  equivalent s₁ s₃ :=
⟨h₁.some.trans h₂.some, λ i, iso_trans (h₁.some_spec i) (h₂.some_spec (h₁.some i))⟩

lemma append
  {s₁ s₂ t₁ t₂ : composition_series X}
  (hs : s₁.top = s₂.bot)
  (ht : t₁.top = t₂.bot)
  (h₁ : equivalent s₁ t₁)
  (h₂ : equivalent s₂ t₂) :
  equivalent (append s₁ s₂ hs) (append t₁ t₂ ht) :=
let e : fin (s₁.length + s₂.length) ≃ fin (t₁.length + t₂.length) :=
  calc fin (s₁.length + s₂.length) ≃ fin s₁.length ⊕ fin s₂.length : fin_sum_fin_equiv.symm
  ... ≃ fin t₁.length ⊕ fin t₂.length : equiv.sum_congr h₁.some h₂.some
  ... ≃ fin (t₁.length + t₂.length) : fin_sum_fin_equiv in
⟨e, begin
  assume i,
  refine fin.add_cases _ _ i,
  { assume i,
    simpa [top, bot] using h₁.some_spec i },
  { assume i,
    simpa [top, bot] using h₂.some_spec i }
end⟩

protected lemma snoc
  {s₁ s₂ : composition_series X}
  {x₁ x₂ : X}
  {hsat₁ : is_maximal s₁.top x₁}
  {hsat₂ : is_maximal s₂.top x₂}
  (hequiv : equivalent s₁ s₂)
  (htop : iso (s₁.top, x₁) (s₂.top, x₂)) :
  equivalent (s₁.snoc x₁ hsat₁) (s₂.snoc x₂ hsat₂) :=
let e : fin s₁.length.succ ≃ fin s₂.length.succ :=
  calc fin (s₁.length + 1) ≃ option (fin s₁.length) : fin_succ_equiv_last
  ... ≃ option (fin s₂.length) : functor.map_equiv option hequiv.some
  ... ≃ fin (s₂.length + 1) : fin_succ_equiv_last.symm in
⟨e,  λ i, begin
  refine fin.last_cases _ _ i,
  { simpa [top] using htop },
  { assume i,
    simpa [fin.succ_cast_succ] using hequiv.some_spec i }
end⟩

protected lemma cons
  {s₁ s₂ : composition_series X}
  {x₁ x₂ : X}
  {hsat₁ : is_maximal x₁ s₁.bot}
  {hsat₂ : is_maximal x₂ s₂.bot}
  (hequiv : equivalent s₁ s₂)
  (hbot : iso (x₁, s₁.bot) (x₂, s₂.bot)) :
  equivalent (s₁.cons x₁ hsat₁) (s₂.cons x₂ hsat₂) :=
let e : fin s₁.length.succ ≃ fin s₂.length.succ :=
  calc fin (s₁.length + 1) ≃ option (fin s₁.length) : fin_succ_equiv _
  ... ≃ option (fin s₂.length) : functor.map_equiv option hequiv.some
  ... ≃ fin (s₂.length + 1) : (fin_succ_equiv _).symm in
⟨e,  λ i, begin
  refine fin.cases _ _ i,
  { simpa [bot] using hbot },
  { assume i,
    simpa [← fin.succ_cast_succ] using hequiv.some_spec i }
end⟩

lemma cons_snoc
  {s₁ s₂ : composition_series X}
  {x₁ x₂ : X}
  {hsat₁ : is_maximal x₁ s₁.bot}
  {hsat₂ : is_maximal s₂.top x₂}
  (hequiv : equivalent s₁ s₂)
  (hbottop : iso (x₁, s₁.bot) (s₂.top, x₂)) :
  equivalent (s₁.cons x₁ hsat₁) (s₂.snoc x₂ hsat₂) :=
let e : fin s₁.length.succ ≃ fin s₂.length.succ :=
  calc fin (s₁.length + 1) ≃ option (fin s₁.length) : fin_succ_equiv _
  ... ≃ option (fin s₂.length) : functor.map_equiv option hequiv.some
  ... ≃ fin (s₂.length + 1) : fin_succ_equiv_last.symm in
⟨e,  λ i, begin
  refine fin.cases _ _ i,
  { simpa [bot] using hbottop },
  { assume i,
    simp [← fin.succ_cast_succ],
    simpa [fin.succ_cast_succ] using hequiv.some_spec i }
end⟩

lemma infinum (s : composition_series X) (x : X)
  (hm : is_maximal x s.top) (hb : ¬ s.bot ≤ x) :
  equivalent (s.infinum x hm hb) s :=
⟨equiv.refl _, λ i, begin simp,
  refine iso_symm (second_iso_of_eq _ _ _),
  { simpa using s.step i },
  { refine sup_eq_of_is_maximal _ _ _,
    { simpa using s.step i },
    { exact is_maximal_inf_series (fin.le_last _) (by simpa)
        (λ h, hb (le_trans (bot_le _) h)) },
    { intro h,
      refine hb (le_trans (bot_le i.cast_succ) _),
      simp * at * } },
  { simp [inf_left_comm, inf_eq_left.2 (le_of_lt (s.strict_mono (fin.cast_succ_lt_succ i)))] }
end⟩

lemma snoc_infinum_cons
  (s : composition_series X) (x : X)
  (hm : is_maximal x s.top) (hb : ¬ s.bot ≤ x) :
  ((s.infinum x hm hb).snoc s.top (by simpa)).equivalent
  (s.cons (x ⊓ s.bot) (is_maximal_inf_series (fin.zero_le _) hm hb)) :=
equivalent.symm $ equivalent.cons_snoc
  (equivalent.infinum _ _ _ _).symm
  (by simpa [bot] using iso_inf_mem_top hm hb)

lemma length_eq {s₁ s₂ : composition_series X} (h : equivalent s₁ s₂) : s₁.length = s₂.length :=
by simpa using fintype.card_congr h.some

lemma snoc_snoc_swap
  {s : composition_series X}
  {x₁ x₂ y₁ y₂ : X}
  {hsat₁ : is_maximal s.top x₁}
  {hsat₂ : is_maximal s.top x₂}
  {hsaty₁ : is_maximal (snoc s x₁ hsat₁).top y₁}
  {hsaty₂ : is_maximal (snoc s x₂ hsat₂).top y₂}
  (hr₁ : iso (s.top, x₁) (x₂, y₂))
  (hr₂ : iso (x₁, y₁) (s.top, x₂)) :
  equivalent
    (snoc (snoc s x₁ hsat₁) y₁ hsaty₁)
    (snoc (snoc s x₂ hsat₂) y₂ hsaty₂) :=
let e : fin (s.length + 1 + 1) ≃ fin (s.length + 1 + 1) :=
equiv.swap (fin.last _) (fin.cast_succ (fin.last _)) in
have h1 : ∀ {i : fin s.length},
  i.cast_succ.cast_succ ≠ (fin.last _).cast_succ,
  from λ _, ne_of_lt (by simp [fin.cast_succ_lt_last]),
have h2 : ∀ {i : fin s.length},
  i.cast_succ.cast_succ ≠ (fin.last _),
  from λ _, ne_of_lt (by simp [fin.cast_succ_lt_last]),
⟨e, begin
  intro i,
  dsimp only [e],
  refine fin.last_cases _ (λ i, _) i,
  { erw [equiv.swap_apply_left, snoc_cast_succ, snoc_last, fin.succ_last, snoc_last,
      snoc_cast_succ, snoc_cast_succ, fin.succ_cast_succ, snoc_cast_succ,
      fin.succ_last, snoc_last],
    exact hr₂ },
  { refine fin.last_cases _ (λ i, _) i,
    { erw [equiv.swap_apply_right, snoc_cast_succ, snoc_cast_succ,
        snoc_cast_succ, fin.succ_cast_succ, snoc_cast_succ,
        fin.succ_last, snoc_last, snoc_last, fin.succ_last, snoc_last],
      exact hr₁ },
    { erw [equiv.swap_apply_of_ne_of_ne h2 h1, snoc_cast_succ, snoc_cast_succ,
        snoc_cast_succ, snoc_cast_succ, fin.succ_cast_succ, snoc_cast_succ,
        fin.succ_cast_succ, snoc_cast_succ, snoc_cast_succ, snoc_cast_succ],
      exact iso_refl_of_is_maximal (s.step i) } }
end⟩

end equivalent

lemma length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top)
  (hs₁ : s₁.length = 0) : s₂.length = 0 :=
begin
  have : s₁.bot = s₁.top,
    from congr_arg s₁ (fin.ext (by simp [hs₁])),
  have : (fin.last s₂.length) = (0 : fin s₂.length.succ),
    from s₂.injective (hb.symm.trans (this.trans ht)).symm,
  simpa [fin.ext_iff]
end

lemma length_pos_of_bot_eq_bot_of_top_eq_top_of_length_pos
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top) :
  0 < s₁.length → 0 < s₂.length :=
not_imp_not.1 begin
  simp only [pos_iff_ne_zero, ne.def, not_iff_not, not_not],
  exact length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb.symm ht.symm
end

lemma eq_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top)
  (hs₁0 : s₁.length = 0) :
  s₁ = s₂ :=
have ∀ x, x ∈ s₁ ↔ x = s₁.top,
  from λ x, ⟨λ hx, forall_mem_eq_of_length_eq_zero hs₁0 hx s₁.top_mem, λ hx, hx.symm ▸ s₁.top_mem⟩,
have ∀ x, x ∈ s₂ ↔ x = s₂.top,
  from λ x, ⟨λ hx, forall_mem_eq_of_length_eq_zero
      (length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb ht hs₁0)
    hx s₂.top_mem, λ hx, hx.symm ▸ s₂.top_mem⟩,
by { ext, simp * }

/-- Given a `composition_series`, `s`, and an element `x`
such that `x` is maximal inside `s.top` there is a series, `t`,
such that `t.top = x`, `t.bot = s.bot`
and `snoc t s.top _` is equivalent to `s`. -/
lemma exists_top_eq_snoc_equivalant (s : composition_series X) (x : X)
  (hm : is_maximal x s.top) (hb : s.bot ≤ x) :
  ∃ t : composition_series X, t.bot = s.bot ∧ t.length + 1 = s.length ∧
    ∃ htx : t.top = x, equivalent s (snoc t s.top (htx.symm ▸ hm)) :=
begin
  induction hn : s.length with n ih generalizing s x,
  { exact (ne_of_gt (lt_of_le_of_lt hb (lt_of_is_maximal hm))
      (forall_mem_eq_of_length_eq_zero hn s.top_mem s.bot_mem)).elim },
  { have h0s : 0 < s.length, from hn.symm ▸ nat.succ_pos _,
    by_cases hetx : s.erase_top.top = x,
    { use s.erase_top,
      simp [← hetx, hn] },
    { have imxs : is_maximal (x ⊓ s.erase_top.top) s.erase_top.top,
        from is_maximal_of_eq_inf x s.top rfl (ne.symm hetx) hm
          (is_maximal_erase_top_top h0s),
      have := ih _ _ imxs (le_inf (by simpa) (le_top_of_mem s.erase_top.bot_mem)) (by simp [hn]),
      rcases this with ⟨t, htb, htl, htt, hteqv⟩,
      have hmtx : is_maximal t.top x,
        from is_maximal_of_eq_inf s.erase_top.top s.top
          (by rw [inf_comm, htt]) hetx
          (is_maximal_erase_top_top h0s) hm,
      use snoc t x hmtx,
      refine ⟨by simp [htb], by simp [htl], by simp, _⟩,
      have : s.equivalent ((snoc t s.erase_top.top (htt.symm ▸ imxs)).snoc s.top
        (by simpa using is_maximal_erase_top_top h0s)),
      { conv_lhs { rw eq_snoc_erase_top h0s },
        exact equivalent.snoc hteqv
          (by simpa using iso_refl_of_is_maximal
            (is_maximal_erase_top_top h0s)) },
      refine this.trans _,
      refine equivalent.snoc_snoc_swap _ _,
      { exact iso_symm (second_iso_of_eq hm
          (sup_eq_of_is_maximal hm
            (is_maximal_erase_top_top h0s)
            (ne.symm hetx))
          htt.symm) },
      { exact second_iso_of_eq (is_maximal_erase_top_top h0s)
          (sup_eq_of_is_maximal
            (is_maximal_erase_top_top h0s)
            hm hetx)
          (by rw [inf_comm, htt]) } } }
end

/-- The **Jordan-Hölder** theorem, stated for any `jordan_hoelder_lattice`.
If two composition series start and finish at the same place, they are equivalent. -/
theorem jordan_hoelder (s₁ s₂ : composition_series X)
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top) :
  equivalent s₁ s₂ :=
begin
  induction hle : s₁.length with n ih generalizing s₁ s₂,
  { rw [eq_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb ht hle] },
  { have h0s₂ : 0 < s₂.length,
      from length_pos_of_bot_eq_bot_of_top_eq_top_of_length_pos hb ht (hle.symm ▸ nat.succ_pos _),
    rcases exists_top_eq_snoc_equivalant s₁ s₂.erase_top.top
      (ht.symm ▸ is_maximal_erase_top_top h0s₂)
      (hb.symm ▸ s₂.bot_erase_top ▸ bot_le_of_mem (top_mem _)) with ⟨t, htb, htl, htt, hteq⟩,
    have := ih t s₂.erase_top (by simp [htb, ← hb]) htt (nat.succ_inj'.1 (htl.trans hle)),
    refine hteq.trans _,
    conv_rhs { rw [eq_snoc_erase_top h0s₂] },
    simp only [ht],
    exact equivalent.snoc this
      (by simp [htt, iso_refl_of_is_maximal (is_maximal_erase_top_top h0s₂)]) }
end

end composition_series