Changeset 13870 for trunk/abcl/src/org/armedbear/lisp/sort.lisp
 Timestamp:
 02/11/12 15:53:33 (10 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/abcl/src/org/armedbear/lisp/sort.lisp
r13852 r13870 34 34 (require "EXTENSIBLESEQUENCESBASE") 35 35 36 (defun sort (sequence predicate &rest args &key key) 37 (sequence::seqdispatch sequence 38 (sortlist sequence predicate key) 39 (quicksort sequence 0 (1 (length sequence)) predicate (or key #'identity)) 40 (apply #'sequence:sort sequence predicate args))) 41 42 (defun stablesort (sequence predicate &rest args &key key) 43 (sequence::seqdispatch sequence 44 (sortlist sequence predicate key) 45 ;;; Jorge Tavares: 46 ;;; As a quick fix, I send in attach a patch that uses in stablesort merge 47 ;;; sort for all sequences. This is done by coercing the sequence to list, 48 ;;; calling merge sort and coercing it back to the original sequence type. 49 ;;; However, as a long term improvement, the best solution would be to 50 ;;; implement a merge sort for nonlist sequences. 51 (coerce (sortlist (coerce sequence 'list) 52 predicate 53 key) 54 (typeof sequence)) 55 (apply #'sequence:stablesort sequence predicate args))) 36 ;;; 37 ;;; STABLE SORT 38 ;;; 39 40 ;;; 41 ;;; MERGE SORT for vectors (and sequences in general) 42 ;;; 43 ;;;  topdown stable merge sort 44 ;;;  it is defined with 2 macros to allow a single algorithm 45 ;;; and multiple sequence types: mergevectorsbody and mergesortbody 46 ;;;  mergevectorsbody merges two given sequences 47 ;;;  mergesortbody contains the topdown algorithm 48 ;;;  the body macro is called by the mergesortvectors functions, 49 ;;; which typecases the type of sequence and expands the apropriate body 50 ;;;  more types of sequences/vectors can be added 51 ;;;  the macros generate the merge sort body with or without funcall to key 52 ;;;  the mergevectors algorithm is inspired from the CCL base code 53 ;;; 54 55 (defmacro mergevectorsbody (type ref a starta enda b startb endb aux startaux predicate &optional key) 56 (let ((ia (gensym)) 57 (ib (gensym)) 58 (iaux (gensym)) 59 (va (gensym)) 60 (vb (gensym)) 61 (ka (gensym)) 62 (kb (gensym)) 63 (mergeblock (gensym))) 64 `(locally 65 (declare (type fixnum ,starta ,enda ,startb ,endb ,startaux) 66 (type ,type ,a ,b) 67 (type simplevector ,aux) 68 (type function ,predicate ,@(if key `(,key))) 69 (optimize (speed 3) (safety 0))) 70 (block ,mergeblock 71 (let ((,ia ,starta) 72 (,ib ,startb) 73 (,iaux ,startaux) 74 ,va ,vb ,ka ,kb) 75 (declare (type fixnum ,ia ,ib ,iaux)) 76 (cond ((= ,starta ,enda) 77 (when (= ,startb ,endb) 78 (returnfrom ,mergeblock)) 79 (setf ,ia ,startb 80 ,enda ,endb 81 ,a ,b 82 ,va (,ref ,a ,ia))) 83 ((= ,startb ,endb) 84 (setf ,ia ,starta 85 ,va (,ref ,a ,ia))) 86 (t 87 (setf ,va (,ref ,a ,ia) 88 ,vb (,ref ,b ,ib) 89 ,@(if key 90 `(,ka (funcall ,key ,va)) 91 `(,ka ,va)) 92 ,@(if key 93 `(,kb (funcall ,key ,vb)) 94 `(,kb ,vb))) 95 (loop 96 (if (funcall ,predicate ,kb ,ka) 97 (progn 98 (setf (svref ,aux ,iaux) ,vb 99 ,iaux (+ ,iaux 1) 100 ,ib (+ ,ib 1)) 101 (when (= ,ib ,endb) (return)) 102 (setf ,vb (,ref ,b ,ib) 103 ,@(if key 104 `(,kb (funcall ,key ,vb)) 105 `(,kb ,vb)))) 106 (progn 107 (setf (svref ,aux ,iaux) ,va 108 ,iaux (+ ,iaux 1) 109 ,ia (+ ,ia 1)) 110 (when (= ,ia ,enda) 111 (setf ,a ,b 112 ,ia ,ib 113 ,enda ,endb 114 ,va ,vb) 115 (return)) 116 (setf ,va (,ref ,a ,ia) 117 ,@(if key 118 `(,ka (funcall ,key ,va)) 119 `(,ka ,va)))))))) 120 (loop 121 (setf (svref ,aux ,iaux) ,va 122 ,ia (+ ,ia 1)) 123 (when (= ,ia ,enda) (return)) 124 (setf ,va (,ref ,a ,ia) 125 ,iaux (+ ,iaux 1)))))))) 126 127 (defmacro mergesortbody (type ref mpredicate mkey msequence mstart mend) 128 (let ((mergesortcall (gensym)) 129 (maux (gensym)) 130 (aux (gensym)) 131 (sequence (gensym)) 132 (start (gensym)) 133 (end (gensym)) 134 (predicate (gensym)) 135 (key (gensym)) 136 (mid (gensym)) 137 (direction (gensym))) 138 `(locally 139 (declare (optimize (speed 3) (safety 0))) 140 (labels ((,mergesortcall (,sequence ,start ,end ,predicate ,key ,aux ,direction) 141 (declare (type function ,predicate ,@(if mkey `(,key))) 142 (type fixnum ,start ,end) 143 (type ,type ,sequence)) 144 (let ((,mid (+ ,start (ash ( ,end ,start) 1)))) 145 (declare (type fixnum ,mid)) 146 (if (<= ( ,mid 1) ,start) 147 (unless ,direction (setf (,ref ,aux ,start) (,ref ,sequence ,start))) 148 (,mergesortcall ,sequence ,start ,mid ,predicate ,key ,aux (not ,direction))) 149 (if (>= (+ ,mid 1) ,end) 150 (unless ,direction (setf (,ref ,aux ,mid) (,ref ,sequence ,mid))) 151 (,mergesortcall ,sequence ,mid ,end ,predicate ,key ,aux (not ,direction))) 152 (unless ,direction (psetq ,sequence ,aux ,aux ,sequence)) 153 ,(if mkey 154 `(mergevectorsbody ,type ,ref ,sequence ,start ,mid ,sequence 155 ,mid ,end ,aux ,start ,predicate ,key) 156 `(mergevectorsbody ,type ,ref ,sequence ,start ,mid ,sequence 157 ,mid ,end ,aux ,start ,predicate))))) 158 (let ((,maux (makearray ,mend))) 159 (declare (type simplevector ,maux)) 160 (,mergesortcall ,msequence ,mstart ,mend ,mpredicate ,mkey ,maux nil)))))) 161 162 (defun mergesortvectors (sequence predicate key) 163 (let ((end (length sequence))) 164 (typecase sequence 165 (simplevector 166 (if key 167 (mergesortbody simplevector svref predicate key sequence 0 end) 168 (mergesortbody simplevector svref predicate nil sequence 0 end))) 169 (vector 170 (if key 171 (mergesortbody vector aref predicate key sequence 0 end) 172 (mergesortbody vector aref predicate nil sequence 0 end)))) 173 sequence)) 174 175 176 ;;; 177 ;;; MERGE SORT for lists 178 ;;; 56 179 57 180 ;; Adapted from SBCL. … … 183 306 (return list1)))))) 184 307 185 # 186 <> dc:author "Jorge Tavares" ; 187 dc:description 188 """ 189 The quicksort function picks the pivot by selecting a midpoint and 190 also sorts the smaller partition first. These are enough to avoid the 191 stack overflow problem as reported. I've performed some tests and it 192 looks it is correct 193 """" . 194 # 308 309 ;;; 310 ;;; SORT 311 ;;; 312 195 313 ;;; 196 314 ;;; QUICKSORT 197 ;;;  the pivot is a middle point 315 ;;; 316 ;;;  algorithm is in the quicksortbody macro, so that it allows 317 ;;; the use of different types (e.g., simplevector, vector) 318 ;;;  the pivot is picked by selecting middle point 198 319 ;;;  sorts the smaller partition first 199 ;;; 200 (defun quicksort (vector start end predicate key) 201 (declare (type fixnum start end) 202 (type function predicate key))203 ( if (< start end)204 (let* ((i start)205 (j (1+ end))206 (p (+ start (ash ( end start) 1)))207 (d (aref vector p))208 (kd (funcall key d)))209 ( rotatef (aref vector p) (aref vector start))210 ( block outerloop211 (loop212 (loop213 (unless (> (decf j) i) (returnfrom outerloop))214 (when (funcall predicate215 (funcall key (aref vector j)) kd)216 (return)))217 (loop218 (unless (< (incf i) j) (returnfrom outerloop))219 (unless (funcall predicate220 (funcall key (aref vector i)) kd)221 (return)))222 (rotatef (aref vector i) (aref vector j))))223 (setf (aref vector start) (aref vector j)224 (aref vector j) d)225 (if (< ( j start) ( end j))226 (progn227 (quicksort vector start (1 j) predicate key)228 (quicksort vector (1+ j) end predicate key))229 (progn230 (quicksort vector (1+ j) end predicate key)231 (quicksort vector start (1 j) predicate key))))232 vector))233 234 ;;; DEPRECATED  to be removed in abcl1.4 235 ;;; From ECL. 236 (defun quicksort (seq start end pred key)237 (unless key (setq key #'identity))238 (if (<= end (1+ start)) 239 seq 240 (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d))) 241 (block outerloop 242 (loop (loop (decf k)243 (unless (< j k) (returnfrom outerloop))244 (when (funcall pred (funcall key (elt seq k)) kd)245 (return)))246 (loop (incfj)247 (unless (< j k) (returnfrom outerloop))248 (unless (funcall pred (funcall key (elt seq j)) kd)249 (return))) 250 (let ((temp (elt seq j)))251 (setf (elt seq j) (elt seq k)252 (elt seq k) temp)))) 253 (setf (elt seq start) (elt seq j)254 (elt seq j) d)255 (quicksort seq start j pred key)256 (quicksort seq (1+ j) end pred key)))) 257 258 ;;; From ECL. Should already be userextensible as it does no type dispatch 259 ;;; and uses only userextensible functions. 260 (defun merge (resulttype sequence1 sequence2 predicate 261 &keykey262 &aux (l1 (length sequence1)) (l2 (length sequence2)))263 (unless key (setq key #'identity))264 (do ((newseq (makesequence resulttype (+ l1 l2)))265 ( j 0 (1+ j))266 (i1 0)267 (i2 0))268 ((and (= i1 l1) (= i2 l2)) newseq)269 (cond ((and (< i1 l1) (< i2 l2)) 270 (cond ((funcall predicate 271 (funcall key (elt sequence1 i1)) 272 (funcall key (elt sequence2 i2))) 273 (setf (elt newseq j) (elt sequence1 i1)) 274 (incf i1))275 ((funcall predicate 276 (funcall key (elt sequence2 i2)) 277 (funcall key (elt sequence1 i1))) 278 (setf (elt newseq j) (elt sequence2 i2))279 (incf i2))280 (t281 (setf (elt newseq j) (elt sequence1 i1))282 (incf i1))))283 ((< i1 l1) 284 (setf (elt newseq j) (elt sequence1 i1))285 (incf i1))286 (t287 (setf (elt newseq j) (elt sequence2 i2))288 (incf i2)))))320 ;;;  the macro generates the quicksort body with or without funcall to key 321 ;;; 322 323 (defmacro quicksortbody (type ref mpredicate mkey sequence mstart mend) 324 (let ((quicksortcall (gensym)) 325 (predicate (gensym)) 326 (key (gensym)) 327 (vector (gensym)) 328 (start (gensym)) 329 (end (gensym)) 330 (i (gensym)) 331 (j (gensym)) 332 (p (gensym)) 333 (d (gensym)) 334 (kd (gensym))) 335 `(locally 336 (declare (speed 3) (safety 0)) 337 (labels ((,quicksortcall (,vector ,start ,end ,predicate ,key) 338 (declare (type function ,predicate ,@(if mkey `(,key))) 339 (type fixnum ,start ,end) 340 (type ,type ,sequence)) 341 (if (< ,start ,end) 342 (let* ((,i ,start) 343 (,j (1+ ,end)) 344 (,p (the fixnum (+ ,start (ash ( ,end ,start) 1)))) 345 (,d (,ref ,vector ,p)) 346 ,@(if mkey 347 `((,kd (funcall ,key ,d))) 348 `((,kd ,d)))) 349 (rotatef (,ref ,vector ,p) (,ref ,vector ,start)) 350 (block outerloop 351 (loop 352 (loop 353 (unless (> (decf ,j) ,i) (returnfrom outerloop)) 354 (when (funcall ,predicate 355 ,@(if mkey 356 `((funcall ,key (,ref ,vector ,j))) 357 `((,ref ,vector ,j))) 358 ,kd) (return))) 359 (loop 360 (unless (< (incf ,i) ,j) (returnfrom outerloop)) 361 (unless (funcall ,predicate 362 ,@(if mkey 363 `((funcall ,key (,ref ,vector ,i))) 364 `((,ref ,vector ,i))) 365 ,kd) (return))) 366 (rotatef (,ref ,vector ,i) (,ref ,vector ,j)))) 367 (setf (,ref ,vector ,start) (,ref ,vector ,j) 368 (,ref ,vector ,j) ,d) 369 (if (< ( ,j ,start) ( ,end ,j)) 370 (progn 371 (,quicksortcall ,vector ,start (1 ,j) ,predicate ,key) 372 (,quicksortcall ,vector (1+ ,j) ,end ,predicate ,key)) 373 (progn 374 (,quicksortcall ,vector (1+ ,j) ,end ,predicate ,key) 375 (,quicksortcall ,vector ,start (1 ,j) ,predicate ,key))))))) 376 (,quicksortcall ,sequence ,mstart ,mend ,mpredicate ,mkey))))) 377 378 (defun quicksort (sequence predicate key) 379 (let ((end (1 (length sequence)))) 380 (typecase sequence 381 (simplevector 382 (if key 383 (quicksortbody simplevector svref predicate key sequence 0 end) 384 (quicksortbody simplevector svref predicate nil sequence 0 end))) 385 (vector 386 (if key 387 (quicksortbody vector aref predicate key sequence 0 end) 388 (quicksortbody vector aref predicate nil sequence 0 end)))) 389 sequence)) 390 391 392 ;;; 393 ;;; main SORT and STABLESORT function calls 394 ;;; 395 ;;;  sort: quicksort and merge sort (only for lists) 396 ;;;  stablesort: merge sort (all types) 397 ;;; 398 399 (defun sort (sequence predicate &rest args &key key) 400 (sequence::seqdispatch sequence 401 (sortlist sequence predicate key) 402 (quicksort sequence predicate key) 403 (apply #'sequence:sort sequence predicate args))) 404 405 (defun stablesort (sequence predicate &rest args &key key) 406 (sequence::seqdispatch sequence 407 (sortlist sequence predicate key) 408 (mergesortvectors sequence predicate key) 409 (apply #'sequence:stablesort sequence predicate args)))
Note: See TracChangeset
for help on using the changeset viewer.