sorting.v 9.72 KB
 Robbert Krebbers committed Jan 29, 2019 1 ``````(* Copyright (c) 2012-2019, Coq-std++ developers. *) `````` Robbert Krebbers committed Jul 23, 2016 2 3 4 5 6 ``````(* This file is distributed under the terms of the BSD license. *) (** Merge sort. Adapted from the implementation of Hugo Herbelin in the Coq standard library, but without using the module system. *) From Coq Require Export Sorted. From stdpp Require Export orders list. `````` Ralf Jung committed Jan 31, 2017 7 ``````Set Default Proof Using "Type". `````` Robbert Krebbers committed Jul 23, 2016 8 9 10 11 12 13 14 15 16 17 `````` Section merge_sort. Context {A} (R : relation A) `{∀ x y, Decision (R x y)}. Fixpoint list_merge (l1 : list A) : list A → list A := fix list_merge_aux l2 := match l1, l2 with | [], _ => l2 | _, [] => l1 | x1 :: l1, x2 :: l2 => `````` 18 `````` if decide (R x1 x2) then x1 :: list_merge l1 (x2 :: l2) `````` Robbert Krebbers committed Jul 23, 2016 19 20 `````` else x2 :: list_merge_aux l2 end. `````` Robbert Krebbers committed Sep 08, 2017 21 `````` Global Arguments list_merge !_ !_ / : assert. `````` Robbert Krebbers committed Jul 23, 2016 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 `````` Local Notation stack := (list (option (list A))). Fixpoint merge_list_to_stack (st : stack) (l : list A) : stack := match st with | [] => [Some l] | None :: st => Some l :: st | Some l' :: st => None :: merge_list_to_stack st (list_merge l' l) end. Fixpoint merge_stack (st : stack) : list A := match st with | [] => [] | None :: st => merge_stack st | Some l :: st => list_merge l (merge_stack st) end. Fixpoint merge_sort_aux (st : stack) (l : list A) : list A := match l with | [] => merge_stack st | x :: l => merge_sort_aux (merge_list_to_stack st [x]) l end. Definition merge_sort : list A → list A := merge_sort_aux []. End merge_sort. `````` Robbert Krebbers committed Jun 27, 2019 44 45 46 47 48 ``````(** Helper definition for [Sorted_reverse] below *) Inductive TlRel {A} (R : relation A) (a : A) : list A → Prop := | TlRel_nil : TlRel R a [] | TlRel_cons b l : R b a → TlRel R a (l ++ [b]). `````` Robbert Krebbers committed Jul 23, 2016 49 50 51 52 ``````(** ** Properties of the [Sorted] and [StronglySorted] predicate *) Section sorted. Context {A} (R : relation A). `````` Robbert Krebbers committed Jul 05, 2019 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 `````` Lemma elem_of_StronglySorted_app l1 l2 x1 x2 : StronglySorted R (l1 ++ l2) → x1 ∈ l1 → x2 ∈ l2 → R x1 x2. Proof. induction l1 as [|x1' l1 IH]; simpl; [by rewrite elem_of_nil|]. intros [? Hall]%StronglySorted_inv [->|?]%elem_of_cons ?; [|by auto]. rewrite Forall_app, !Forall_forall in Hall. naive_solver. Qed. Lemma StronglySorted_app_inv_l l1 l2 : StronglySorted R (l1 ++ l2) → StronglySorted R l1. Proof. induction l1 as [|x1' l1 IH]; simpl; [|inversion_clear 1]; decompose_Forall; constructor; auto. Qed. Lemma StronglySorted_app_inv_r l1 l2 : StronglySorted R (l1 ++ l2) → StronglySorted R l2. Proof. induction l1 as [|x1' l1 IH]; simpl; [|inversion_clear 1]; decompose_Forall; auto. Qed. `````` Robbert Krebbers committed Jul 23, 2016 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 `````` Lemma Sorted_StronglySorted `{!Transitive R} l : Sorted R l → StronglySorted R l. Proof. by apply Sorted.Sorted_StronglySorted. Qed. Lemma StronglySorted_unique `{!AntiSymm (=) R} l1 l2 : StronglySorted R l1 → StronglySorted R l2 → l1 ≡ₚ l2 → l1 = l2. Proof. intros Hl1; revert l2. induction Hl1 as [|x1 l1 ? IH Hx1]; intros l2 Hl2 E. { symmetry. by apply Permutation_nil. } destruct Hl2 as [|x2 l2 ? Hx2]. { by apply Permutation_nil in E. } assert (x1 = x2); subst. { rewrite Forall_forall in Hx1, Hx2. assert (x2 ∈ x1 :: l1) as Hx2' by (by rewrite E; left). assert (x1 ∈ x2 :: l2) as Hx1' by (by rewrite <-E; left). inversion Hx1'; inversion Hx2'; simplify_eq; auto. } f_equal. by apply IH, (inj (x2 ::)). Qed. Lemma Sorted_unique `{!Transitive R, !AntiSymm (=) R} l1 l2 : Sorted R l1 → Sorted R l2 → l1 ≡ₚ l2 → l1 = l2. Proof. auto using StronglySorted_unique, Sorted_StronglySorted. Qed. Global Instance HdRel_dec x `{∀ y, Decision (R x y)} l : Decision (HdRel R x l). Proof. refine match l with | [] => left _ | y :: l => cast_if (decide (R x y)) end; abstract first [by constructor | by inversion 1]. Defined. Global Instance Sorted_dec `{∀ x y, Decision (R x y)} : ∀ l, Decision (Sorted R l). Proof. refine (fix go l := match l return Decision (Sorted R l) with | [] => left _ | x :: l => cast_if_and (decide (HdRel R x l)) (go l) end); clear go; abstract first [by constructor | by inversion 1]. Defined. Global Instance StronglySorted_dec `{∀ x y, Decision (R x y)} : ∀ l, Decision (StronglySorted R l). Proof. refine (fix go l := match l return Decision (StronglySorted R l) with | [] => left _ | x :: l => cast_if_and (decide (Forall (R x) l)) (go l) end); clear go; abstract first [by constructor | by inversion 1]. Defined. `````` Robbert Krebbers committed Jun 27, 2019 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 `````` Section fmap. Context {B} (f : A → B). Lemma HdRel_fmap (R1 : relation A) (R2 : relation B) x l : (∀ y, R1 x y → R2 (f x) (f y)) → HdRel R1 x l → HdRel R2 (f x) (f <\$> l). Proof. destruct 2; constructor; auto. Qed. Lemma Sorted_fmap (R1 : relation A) (R2 : relation B) l : (∀ x y, R1 x y → R2 (f x) (f y)) → Sorted R1 l → Sorted R2 (f <\$> l). Proof. induction 2; simpl; constructor; eauto using HdRel_fmap. Qed. Lemma StronglySorted_fmap (R1 : relation A) (R2 : relation B) l : (∀ x y, R1 x y → R2 (f x) (f y)) → StronglySorted R1 l → StronglySorted R2 (f <\$> l). Proof. induction 2; csimpl; constructor; rewrite ?Forall_fmap; eauto using Forall_impl. Qed. End fmap. `````` Robbert Krebbers committed Jun 27, 2019 140 141 142 143 144 145 146 147 148 149 150 151 152 `````` Lemma HdRel_reverse l x : HdRel R x l → TlRel (flip R) x (reverse l). Proof. destruct 1; rewrite ?reverse_cons; by constructor. Qed. Lemma Sorted_snoc l x : Sorted R l → TlRel R x l → Sorted R (l ++ [x]). Proof. induction 1 as [|y l Hsort IH Hhd]; intros Htl; simpl. { repeat constructor. } constructor. apply IH. - inversion Htl as [|? [|??]]; simplify_list_eq; by constructor. - destruct Hhd; constructor; [|done]. inversion Htl as [|? [|??]]; by try discriminate_list. Qed. `````` Robbert Krebbers committed Jul 23, 2016 153 154 ``````End sorted. `````` Robbert Krebbers committed Jun 27, 2019 155 156 157 158 159 160 161 ``````Lemma Sorted_reverse {A} (R : relation A) l : Sorted R l → Sorted (flip R) (reverse l). Proof. induction 1; rewrite ?reverse_nil, ?reverse_cons; auto using Sorted_snoc, HdRel_reverse. Qed. `````` Robbert Krebbers committed Jul 23, 2016 162 163 ``````(** ** Correctness of merge sort *) Section merge_sort_correct. `````` Robbert Krebbers committed Jan 31, 2017 164 `````` Context {A} (R : relation A) `{∀ x y, Decision (R x y)}. `````` Robbert Krebbers committed Jul 23, 2016 165 `````` `````` Robbert Krebbers committed Jun 21, 2019 166 167 168 169 `````` Lemma list_merge_nil_l l2 : list_merge R [] l2 = l2. Proof. by destruct l2. Qed. Lemma list_merge_nil_r l1 : list_merge R l1 [] = l1. Proof. by destruct l1. Qed. `````` Robbert Krebbers committed Jul 23, 2016 170 171 172 173 174 175 176 177 178 179 180 `````` Lemma list_merge_cons x1 x2 l1 l2 : list_merge R (x1 :: l1) (x2 :: l2) = if decide (R x1 x2) then x1 :: list_merge R l1 (x2 :: l2) else x2 :: list_merge R (x1 :: l1) l2. Proof. done. Qed. Lemma HdRel_list_merge x l1 l2 : HdRel R x l1 → HdRel R x l2 → HdRel R x (list_merge R l1 l2). Proof. destruct 1 as [|x1 l1 IH1], 1 as [|x2 l2 IH2]; rewrite ?list_merge_cons; simpl; repeat case_decide; auto. Qed. `````` Robbert Krebbers committed Jan 31, 2017 181 `````` Lemma Sorted_list_merge `{!Total R} l1 l2 : `````` Robbert Krebbers committed Jul 23, 2016 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 `````` Sorted R l1 → Sorted R l2 → Sorted R (list_merge R l1 l2). Proof. intros Hl1. revert l2. induction Hl1 as [|x1 l1 IH1]; induction 1 as [|x2 l2 IH2]; rewrite ?list_merge_cons; simpl; repeat case_decide; constructor; eauto using HdRel_list_merge, HdRel_cons, total_not. Qed. Lemma merge_Permutation l1 l2 : list_merge R l1 l2 ≡ₚ l1 ++ l2. Proof. revert l2. induction l1 as [|x1 l1 IH1]; intros l2; induction l2 as [|x2 l2 IH2]; rewrite ?list_merge_cons; simpl; repeat case_decide; auto. - by rewrite (right_id_L [] (++)). - by rewrite IH2, Permutation_middle. Qed. Local Notation stack := (list (option (list A))). Inductive merge_stack_Sorted : stack → Prop := | merge_stack_Sorted_nil : merge_stack_Sorted [] | merge_stack_Sorted_cons_None st : merge_stack_Sorted st → merge_stack_Sorted (None :: st) | merge_stack_Sorted_cons_Some l st : Sorted R l → merge_stack_Sorted st → merge_stack_Sorted (Some l :: st). Fixpoint merge_stack_flatten (st : stack) : list A := match st with | [] => [] | None :: st => merge_stack_flatten st | Some l :: st => l ++ merge_stack_flatten st end. `````` Robbert Krebbers committed Jan 31, 2017 212 `````` Lemma Sorted_merge_list_to_stack `{!Total R} st l : `````` Robbert Krebbers committed Jul 23, 2016 213 214 215 216 217 218 219 220 221 222 223 224 225 `````` merge_stack_Sorted st → Sorted R l → merge_stack_Sorted (merge_list_to_stack R st l). Proof. intros Hst. revert l. induction Hst; repeat constructor; naive_solver auto using Sorted_list_merge. Qed. Lemma merge_list_to_stack_Permutation st l : merge_stack_flatten (merge_list_to_stack R st l) ≡ₚ l ++ merge_stack_flatten st. Proof. revert l. induction st as [|[l'|] st IH]; intros l; simpl; auto. by rewrite IH, merge_Permutation, (assoc_L _), (comm (++) l). Qed. `````` Robbert Krebbers committed Jan 31, 2017 226 `````` Lemma Sorted_merge_stack `{!Total R} st : `````` Robbert Krebbers committed Jul 23, 2016 227 228 229 230 231 232 233 `````` merge_stack_Sorted st → Sorted R (merge_stack R st). Proof. induction 1; simpl; auto using Sorted_list_merge. Qed. Lemma merge_stack_Permutation st : merge_stack R st ≡ₚ merge_stack_flatten st. Proof. induction st as [|[] ? IH]; intros; simpl; auto. by rewrite merge_Permutation, IH. Qed. `````` Robbert Krebbers committed Jan 31, 2017 234 `````` Lemma Sorted_merge_sort_aux `{!Total R} st l : `````` Robbert Krebbers committed Jul 23, 2016 235 236 237 238 239 240 241 242 243 244 245 246 247 `````` merge_stack_Sorted st → Sorted R (merge_sort_aux R st l). Proof. revert st. induction l; simpl; auto using Sorted_merge_stack, Sorted_merge_list_to_stack. Qed. Lemma merge_sort_aux_Permutation st l : merge_sort_aux R st l ≡ₚ merge_stack_flatten st ++ l. Proof. revert st. induction l as [|?? IH]; simpl; intros. - by rewrite (right_id_L [] (++)), merge_stack_Permutation. - rewrite IH, merge_list_to_stack_Permutation; simpl. by rewrite Permutation_middle. Qed. `````` Robbert Krebbers committed Jan 31, 2017 248 `````` Lemma Sorted_merge_sort `{!Total R} l : Sorted R (merge_sort R l). `````` Robbert Krebbers committed Jul 23, 2016 249 250 251 `````` Proof. apply Sorted_merge_sort_aux. by constructor. Qed. Lemma merge_sort_Permutation l : merge_sort R l ≡ₚ l. Proof. unfold merge_sort. by rewrite merge_sort_aux_Permutation. Qed. `````` Robbert Krebbers committed Jan 31, 2017 252 `````` Lemma StronglySorted_merge_sort `{!Transitive R, !Total R} l : `````` Robbert Krebbers committed Jul 23, 2016 253 254 255 `````` StronglySorted R (merge_sort R l). Proof. auto using Sorted_StronglySorted, Sorted_merge_sort. Qed. End merge_sort_correct.``````