feat(library/data/list): perm is decidable

library/data/list/basic.lean

@@ -66,6 +66,10 @@ theorem length_append : ∀ (s t : list T), length (s ++ t) = length s + length
                     ...  = (length s + 1) + length t  : add.succ_left
                     ...  = length (a :: s) + length t : rfl
 
+theorem eq_nil_of_length_eq_zero : ∀ {l : list T}, length l = 0 → l = []
+| []     H := rfl
+| (a::s) H := nat.no_confusion H
+
 -- add_rewrite length_nil length_cons
 
 /- concat -/

library/data/list/perm.lean

@@ -155,6 +155,35 @@ assume p, calc
    ... = l₁++(l₂++[a]) : append.assoc
    ... ~ l₁++(a::l₂)   : perm_app_right l₁ (symm (perm_cons_app a l₂))
 
+theorem perm_erase [H : decidable_eq A] {a : A} : ∀ {l : list A}, a ∈ l → l ~ a::(erase a l)
+| []     h := absurd h !not_mem_nil
+| (x::t) h :=
+  if Heq : a = x then
+    by rewrite [Heq, erase_cons_head]; exact !perm.refl
+  else
+    have aint : a ∈ t,             from mem_of_ne_of_mem Heq h,
+    have aux : t ~ a :: erase a t, from perm_erase aint,
+    calc x::t ~ x::a::(erase a t)   : skip x aux
+          ... ~ a::x::(erase a t)   : swap
+          ... = a::(erase a (x::t)) : by rewrite [!erase_cons_tail Heq]
+
+theorem erase_perm_erase_of_perm [H : decidable_eq A] (a : A) {l₁ l₂ : list A} : l₁ ~ l₂ → erase a l₁ ~ erase a l₂ :=
+assume p, perm.induction_on p
+  nil
+  (λ x t₁ t₂ p r,
+    if Hax : a = x
+    then by rewrite [Hax, *erase_cons_head]; exact p
+    else by rewrite [*erase_cons_tail _ Hax]; exact (skip x r))
+  (λ x y l,
+    if Hax : a = x
+    then (if Hay : a = y
+          then by rewrite [-Hax, -Hay]; exact !perm.refl
+          else by rewrite [-Hax, erase_cons_tail _ Hay, *erase_cons_head]; exact !perm.refl)
+    else (if Hay : a = y
+          then by rewrite [-Hay, erase_cons_tail _ Hax, *erase_cons_head]; exact !perm.refl
+          else by rewrite[erase_cons_tail _ Hax, *erase_cons_tail _ Hay, erase_cons_tail _ Hax]; exact !swap))
+  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂)
+
 theorem perm_induction_on {P : list A → list A → Prop} {l₁ l₂ : list A} (p : l₁ ~ l₂)
    (h₁ : P [] [])
    (h₂ : ∀ x l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (x::l₁) (x::l₂))
@@ -184,4 +213,42 @@ assume q, qeq.induction_on q
   (λ b t₁ t₂ q₁ r₁, calc
      b::t₂ ~ b::a::t₁ : skip b r₁
        ... ~ a::b::t₁ : swap)
+
+/- permutation is decidable if A has decidable equality -/
+section dec
+open decidable
+variable [Ha : decidable_eq A]
+include Ha
+
+definition decidable_perm_aux : ∀ (n : nat) (l₁ l₂ : list A), length l₁ = n → length l₂ = n → decidable (l₁ ~ l₂)
+| 0     l₁      l₂ H₁ H₂ :=
+  assert l₁n : l₁ = [], from eq_nil_of_length_eq_zero H₁,
+  assert l₂n : l₂ = [], from eq_nil_of_length_eq_zero H₂,
+  by rewrite [l₁n, l₂n]; exact (inl perm.nil)
+| (n+1) (x::t₁) l₂ H₁ H₂ :=
+  if xinl₂ : x ∈ l₂ then
+    let t₂ : list A := erase x l₂ in
+    have len_t₁       : length t₁ = n,                from nat.no_confusion H₁ (λ e, e),
+    assert len_t₂_aux : length t₂ = pred (length l₂), from length_erase_of_mem x l₂ xinl₂,
+    assert len_t₂     : length t₂ = n,                by rewrite [len_t₂_aux, H₂],
+    match decidable_perm_aux n t₁ t₂ len_t₁ len_t₂ with
+    | inl p  := inl (calc
+       x::t₁ ~ x::(erase x l₂) : skip x p
+        ...  ~ l₂              : perm_erase xinl₂)
+    | inr np := inr (λ p : x::t₁ ~ l₂,
+      assert p₁ : erase x (x::t₁) ~ erase x l₂, from erase_perm_erase_of_perm x p,
+      have p₂ : t₁ ~ erase x l₂, by rewrite [erase_cons_head at p₁]; exact p₁,
+      absurd p₂ np)
+    end
+  else
+    inr (λ p : x::t₁ ~ l₂, absurd (mem_perm x (x::t₁) l₂ p !mem_cons) xinl₂)
+
+definition decidable_perm [instance] : ∀ (l₁ l₂ : list A), decidable (l₁ ~ l₂) :=
+λ l₁ l₂,
+if Hl : length l₁ = length l₂ then
+  decidable_perm_aux (length l₂) l₁ l₂ Hl rfl
+else
+  inr (λ p : l₁ ~ l₂, absurd (length_eq_length_of_perm p) Hl)
+end dec
+
 end perm