Section splits_and_perms.
Context {T: Type}.
Fixpoint splits (l: list T): list (T * list T) :=
match l with
| nil => nil
| h :: t => (h, t) :: map (fun xy => (fst xy, h :: snd xy)) (splits t)
end.
Proof with auto.
induction l...
simpl.
rewrite map_length.
intuition.
Qed.
Proof with auto.
induction l in p |- *...
simpl.
intuition.
simpl.
intros.
destruct H.
subst...
destruct (fst (conj_prod (in_map_iff _ _ _)) H).
destruct H0.
apply IHl in H1.
subst.
simpl...
apply perm_trans with (a :: fst x :: snd x).
apply perm_swap.
apply perm_skip...
Qed.
Fixpoint insert_everywhere (x: T) (l: list T): list (list T) :=
match l with
| nil => (x :: nil) :: nil
| h :: t => (x :: h :: t) :: map (cons h) (insert_everywhere x t)
end.
Proof with auto.
induction l...
intros.
simpl in H.
intuition.
subst...
intros.
simpl in H.
destruct H.
subst...
apply in_map_iff in H. destruct H as [x0 [A B]].
subst.
apply IHl in B.
eauto.
Qed.
Proof with auto.
induction l...
simpl.
rewrite map_length.
congruence.
Qed.
Definition perms: list T -> list (list T)
:= fold_right (fun h => concat ∘ map (insert_everywhere h)) (nil :: nil).
Proof with auto.
induction l in a |- *.
simpl.
intuition.
subst...
intros.
simpl in H.
unfold Basics.compose in H.
apply In_concat_inv in H. destruct H. destruct H.
apply in_map_iff in H0. destruct H0 as [x0 [A B]].
subst.
eauto using insert_everywhere_are_perms.
Qed.
Proof with auto.
induction l...
simpl.
unfold Basics.compose.
rewrite length_concat.
rewrite map_map.
rewrite (@add_same (S (length l)) (map (fun x => length (insert_everywhere a x)) (perms l))).
rewrite map_length.
rewrite IHl.
rewrite Mult.mult_comm...
intros.
destruct (in_map_iff (fun x => length (insert_everywhere a x)) (perms l) x).
clear H1.
apply H0 in H. clear H0.
destruct H. destruct H.
subst.
rewrite length_insert_everywhere.
f_equal.
apply Permutation_length.
apply perms_are_perms...
Qed.
Definition alt_perms l: list (list T) :=
match l with
| nil => nil :: nil
| _ => concat (map (fun p => (map (cons (fst p)) (perms (snd p)))) (splits l))
end.
Proof with auto.
intro.
set (fun x y: T * list T => fst x = fst y /\ Permutation (snd x) (snd y)).
intros.
induction H.
simpl...
simpl.
apply permuted_skip...
split...
apply Permuted_map.
unfold on.
subst P.
simpl.
apply (Permuted_sub IHPermutation).
intuition.
simpl.
subst P.
apply alt_permuted_swap...
repeat rewrite map_map.
simpl.
apply elemsR_map_map.
simpl...
eauto.
Qed.
Inductive merges_spec: list T -> list T -> list (list T) -> Prop :=
| merges_left_nil x: merges_spec nil x (x :: nil)
| merges_right_nil x: merges_spec x nil (x :: nil)
| merges_cons x y h t r r':
merges_spec y (h :: t) r ->
merges_spec (x :: y) t r' ->
merges_spec (x :: y) (h :: t) (map (cons x) r ++ map (cons h) r').
Hint Constructors merges_spec.
Proof with auto.
intros H.
induction H; intros.
inversion_clear H...
inversion_clear H...
inversion_clear H1.
apply IHmerges_spec1 in H2.
apply IHmerges_spec2 in H3.
congruence.
Qed.
Proof with auto.
intros.
induction H2.
simpl...
simpl...
rewrite app_length.
repeat rewrite map_length.
rewrite IHmerges_spec1. clear IHmerges_spec1.
rewrite IHmerges_spec2. clear IHmerges_spec2.
simpl @length...
Qed.
Definition me (ab: list T * list T): nat := length (fst ab) + length (snd ab).
Program Fixpoint merges_ex (ab: list T * list T) {measure (me ab)}: sig (merges_spec (fst ab) (snd ab)) :=
match ab with
| (nil, x) => x :: nil
| (x, nil) => x :: nil
| (x :: y, h :: t) => map (cons x) (merges_ex (y, h :: t)) ++ map (cons h) (merges_ex (x :: y, t))
end.
Next Obligation. unfold me. simpl. omega. Qed.
Next Obligation. repeat destruct_call merges_ex; auto. Qed.
Definition merges (a b: list T): list (list T) := proj1_sig (merges_ex (a, b)).
Proof with auto.
intros.
apply (@merges_uniq a b).
unfold merges. destruct_call merges_ex...
destruct a... destruct b...
unfold merges. repeat destruct_call merges_ex...
Qed.
Proof with auto.
intros.
rewrite merges_real_eq.
destruct a...
Qed.
Hint Resolve Permutation_concat.
Proof with auto.
intros.
unfold product.
rewrite map_app.
rewrite concat_app...
Qed.
Proof with auto.
induction a...
simpl.
unfold flip at 1.
intros.
rewrite <- IHa.
apply product_app.
Qed. (* todo: this shouldn't need induction anymore *)
Proof with auto.
induction l...
simpl...
simpl.
rewrite perm_swap.
apply perm_skip.
apply perm_skip.
rewrite (map_map (cons a) (insert_everywhere x)).
rewrite (map_map (cons a) (insert_everywhere y)).
simpl.
rewrite (Permutation_concat_map_app (fun x0 => (x :: a :: x0) :: nil) (fun x0 => map (cons a) (insert_everywhere x x0)) (insert_everywhere y l)).
apply Permutation_sym.
rewrite (Permutation_concat_map_app (fun x0 => (y :: a :: x0) :: nil) (fun x => map (cons a) (insert_everywhere y x)) (insert_everywhere x l)).
repeat rewrite concat_app.
repeat rewrite concat_map_singleton_f.
rewrite <- (map_map (insert_everywhere x) (map (cons a))).
rewrite <- (map_map (insert_everywhere y) (map (cons a))).
repeat rewrite <- map_concat.
repeat rewrite map_map.
repeat rewrite <- app_ass.
symmetry in IHl...
apply Permutation_app...
apply Permutation_app_swap.
Qed.
Instance Permutation_perms: Proper (Permutation ==> Permutation) perms.
Proof with eauto 2.
intros l l' P.
induction P...
simpl.
apply Permutation_concat...
simpl.
unfold Basics.compose.
set (perms l). clearbody l0. clear l. rename l0 into l.
repeat rewrite concatMap_concatMap'.
apply Permutation_concatMap.
intros.
unfold Basics.compose.
apply concatMap_insert_everywhere_comm.
Qed.
Proof with auto.
induction l...
simpl.
rewrite IHl.
rewrite (merges_real_eq [a] (a0::l)).
rewrite (merges_real_eq [] (a0::l)).
simpl...
Qed.
Proof with auto.
induction l...
simpl.
transitivity ((a :: a0 :: l) :: map (cons a0) (merges l [a]))...
rewrite (merges_real_eq (a0::l) [a]).
rewrite (merges_real_eq (a0::l) []).
simpl.
transitivity ([a :: a0 :: l] ++ map (cons a0) (merges l [a]))...
apply Permutation_app_swap.
Qed.
(* written with list monad notation, this would be: Permutation (insert_everywhere a >>= merges y x) (merges y >>= insert_everywhere a x). *)
Proof with auto.
revert x y.
apply two_lists_rect; intros.
simpl.
rewrite merges_nil_r.
simpl.
repeat rewrite app_nil_r.
apply merges_insert_everywhere'.
simpl.
rewrite app_nil_r.
rewrite (map_ext (merges []) (fun x0 => [x0])).
rewrite concat_map_singleton...
intros.
apply merges_real_eq.
rewrite (merges_real_eq (y :: y') (x :: x')).
rewrite map_app.
rewrite concat_app.
repeat rewrite map_map.
simpl insert_everywhere.
rewrite (Permutation_concat_map_app (fun x0 => [a :: y :: x0]) (fun x0 => map (cons y) (insert_everywhere a x0))).
rewrite (Permutation_concat_map_app (fun x0 => [a :: x :: x0]) (fun x0 => map (cons x) (insert_everywhere a x0))).
repeat rewrite concat_app.
repeat rewrite concat_map_singleton_f.
rewrite app_ass.
rewrite <- (map_map (insert_everywhere a) (map (cons x))).
rewrite <- (map_map (insert_everywhere a) (map (cons y))).
rewrite <- map_concat.
rewrite <- map_concat.
rewrite H. rewrite H0.
clear H H0.
simpl @map at 7.
simpl @concat at 3.
rewrite map_map.
rewrite (merges_real_eq (y :: y') (a :: x :: x')).
rewrite (merges_real_eq (y :: y') (x :: x')).
rewrite map_app.
repeat rewrite map_map.
rewrite app_ass.
apply Permutation_sym.
rewrite (Permutation_app_swap (map (cons y) (merges y' (a :: x :: x')))).
repeat rewrite app_ass.
apply Permutation_app...
apply Permutation_sym.
rewrite (Permutation_app_swap (map (cons y) (concat (map (merges y') (insert_everywhere a (x :: x')))))).
repeat rewrite app_ass.
apply Permutation_app...
simpl.
rewrite map_map.
rewrite map_app.
rewrite (map_ext (fun x0 : list T => merges (y :: y') (x :: x0)) (fun x0 : list T => map (cons y) (merges y' (x :: x0)) ++ map (cons x) (merges (y :: y') x0))).
all: swap 1 2.
intros.
rewrite merges_real_eq...
apply Permutation_sym.
rewrite Permutation_concat_map_app.
rewrite concat_app.
rewrite app_ass.
rewrite <- (map_map (fun x0 => merges y' (x :: x0)) (map (cons y))).
rewrite <- map_concat.
rewrite Permutation_app_swap.
rewrite <- app_ass.
apply Permutation_app...
rewrite <- (map_map (fun x0 => merges (y :: y') x0) (map (cons x))).
rewrite <- map_concat.
apply Permutation_app...
Qed. (* wow, can hardly believe it's true after this ordeal *)
Proof with auto.
intros.
unfold merges at 1.
destruct_call merges_ex.
simpl in *.
induction m...
rewrite merges_nil_r...
rewrite IHm1.
rewrite IHm2.
rewrite (merges_real_eq (h :: t) (x :: y)).
apply Permutation_app_swap.
Qed.
Hint Immediate merges_sym.
Proof with auto.
unfold product.
intros.
rewrite map_concat.
rewrite map_map.
induction a.
simpl.
rewrite app_nil_r.
rewrite map_map.
unfold uncurry.
simpl.
rewrite (map_ext (fun x => merges [] x) (fun x => x :: nil))...
rewrite concat_map_singleton...
simpl.
unfold Basics.compose.
rewrite IHa. clear IHa.
rewrite (map_ext (fun x : list T => map (uncurry merges) (map (pair x) (perms b)))
(fun x : list T => map (merges x) (perms b))).
rewrite (map_ext (fun x : list T => map (uncurry merges) (map (pair x) (perms b)))
(fun x : list T => map (merges x) (perms b))).
rewrite concat_concat.
rewrite concat_concat.
rewrite map_map.
rewrite map_map.
rewrite map_concat_map.
rewrite concat_concat.
rewrite map_map.
rewrite map_concat_map.
rewrite concat_concat.
rewrite map_map.
apply Permutation_concatMap.
intros.
unfold Basics.compose.
rewrite map_concat_map.
rewrite concat_concat.
rewrite map_map.
rewrite (map_ext (fun x0 => concat ((map (insert_everywhere a) ∘ merges x) x0))
(concat ∘ (map (insert_everywhere a) ∘ merges x)))...
transitivity (concat (map (concat ∘ map (merges x) ∘ insert_everywhere a) (perms b))).
apply Permutation_concatMap.
intros.
unfold Basics.compose.
apply insert_everywhere_merges_commute.
apply Permutation_sym.
rewrite <- (concat_product merges (perms b) (insert_everywhere a x)).
apply Permutation_concatMap.
intros.
unfold Basics.compose.
apply Permutation_sym.
rewrite <- insert_everywhere_merges_commute.
transitivity (concat (map (merges x0) (insert_everywhere a x))).
apply Permutation_sym.
rewrite <- insert_everywhere_merges_commute...
rewrite merges_sym...
apply Permutation_concatMap.
intros...
intros.
rewrite map_map...
intros.
rewrite map_map...
Qed.
Proof with auto.
pattern x, y.
apply two_lists_rect.
intros.
rewrite merges_real_eq in H1.
simpl in H1.
intuition.
subst.
apply (filter_none p x0)...
intros.
rewrite merges_nil_r in H1.
simpl in H1.
intuition.
subst.
apply filter_all...
intros.
rewrite merges_real_eq in H3.
rewrite map_app in H3.
repeat rewrite map_map in H3.
apply in_app_or in H3.
simpl in H3.
destruct H3.
rewrite H1 in H3.
all:swap 1 2. left...
rewrite <- (map_map (filter p) (cons x0)) in H3.
apply in_map_iff in H3.
destruct H3.
destruct H3.
subst.
f_equal.
apply H...
intuition.
rewrite H2 in H3.
all:swap 1 2. left...
apply H0...
intuition.
Qed.
(* While a closed formula for merges length is tricky, we can easily prove that the length depends only on the length of the arguments. *)
Instance length_merges_mor: Proper (on length eq ==> on length eq ==> on length eq) merges.
Proof with auto.
unfold on.
do 4 intro.
generalize y H. clear y H.
unfold merges at 1.
destruct merges_ex.
simpl in *.
induction m; intros.
destruct y...
discriminate.
destruct y0.
rewrite merges_nil_r...
discriminate.
destruct y0. discriminate.
destruct y1. discriminate.
inversion H.
inversion H0.
rewrite merges_real_eq.
repeat rewrite app_length.
repeat rewrite map_length...
Qed.
Proof with try discriminate; auto.
intros.
unfold merges.
destruct merges_ex.
simpl in *.
induction m...
destruct r...
Qed.
End splits_and_perms.
Existing Instance Permutation_perms.
Proof with auto.
induction l...
simpl.
intros.
rewrite IHl...
rewrite H...
Qed.

Lemma filter_perms T p (l: list T):
Permutation
(map (filter p) (perms l))
(concat (map (repeat (fact (length (filter (negb ∘ p) l)) * length (merges (filter p l) (filter (negb ∘ p) l)))) (perms (filter p l)))).