[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Package for sorting vectors
I fixed up the old vector sorting package. I also wrote a stable heapsort
for it. Two caveats:
1. You have to compile with macro support from the Yale loop package.
2. I have checked this code out as carefully as I can. I am nonetheless
nervous -- getting sorting algorithms right is notoriously tricky.
Let me know if you find a bug.
-Olin
------ sortv.t ------
(herald sortv)
;;; Quicksort, heap sort, insertion sort, and remove-duplicates for vectors.
;;; This was hacked from Bob Nix's code.
;;; Heap sort was written from scratch. It is stable.
;;; Olin Shivers (shivers@cs.cmu.edu) 2/89
;;;
;;; This must be compiled with macro support from the Yale loop package.
;;; quicksort!
;;; ===============
;;; Hoare's QuickSort for vectors.
(define (quicksort! v obj-<)
(labels (((qsort v obj-< start end)
(if (fx> (fx- end start) 10)
(let ((middle (quicksort!:partition v start end obj-<)))
; I don't understand the point of this conditional. Olin
(cond ((fx< (fx- middle start) (fx- end middle))
(qsort v obj-< (fx+ 1 middle) end)
(qsort v obj-< start (fx- middle 1)))
(t
(qsort v obj-< start (fx- middle 1))
(qsort v obj-< (fx+ 1 middle) end)))))))
(qsort v obj-< 0 (fx- (vector-length v) 1))
(insertion-sort! v obj-<)))
(define (quicksort!:partition v start end obj-<)
(loop (initial (middle (fixnum-ashr (fx+ start end) 1)) ; bummed /2
(value nil)
(l start)
(r (fx+ 1 end)))
;; Pick the median of v_start v_middle and v_end for the comparison
;; key: put it in v_start.
(before (if (obj-< (vref v start) (vref v middle))
(if (not (obj-< (vref v middle) (vref v end)))
(if (obj-< (vref v start) (vref v end))
(set middle end)
(set middle start)))
(if (obj-< (vref v start) (vref v end))
(set middle start)
(if (obj-< (vref v middle) (vref v end))
(set middle end))))
(set value (vref v middle))
(set (vref v middle) (vref v start))
(set (vref v start) value))
;; Skip past left and right elts on the correct side of the partition
(next (l (loop (incr l in l)
(while (obj-< (vref v l) value))
(result l)))
(r (loop (decr r in r)
(while (obj-< value (vref v r)))
(result r))))
(while (fx< l r))
;; Swap v_l and v_r
(do (set (vref v l) (swap (vref v r) (vref v l))))
;; Swap v_start and v_r
(after (set (vref v start) (swap (vref v r) (vref v start))))
(result r)))
;;; insertion-sort!
;;; ====================
;;; Insertion sort, used to clean up the almost sorted results
;;; of quicksort.
(define (insertion-sort! v obj-<)
(loop (step j .in 1 to (vector-length v))
(bind (vj (vref v j)))
(do (loop (decr i in. j to 0)
(bind (vi (vref v i)))
(while (obj-< vj vi))
(do (set (vref v (fx+ 1 i)) vi))
(result (set (vref v (fx+ 1 i)) vj))))
(result v)))
;;; vector-remove-duplicates!
;;; ==============================
;;; Remove duplicates from a sorted vector. The definition for
;;; vectors copies the non-duplicates to the front of the vector,
;;; and returns the number of non-duplicates. This has a rather
;;; bogus definition for vectors, but what should it do?
;;; N.B. VECTOR ARG MUST BE SORTED.
(define (vector-remove-duplicates! sv obj-<)
(if (fx= (vector-length sv) 0) 0
(loop (initial (lui 0) (lu (vref sv 0))) ; lu is last uniq elt seen
(step i .in 1 to (vector-length sv))
(bind (svi (vref sv i)))
(when (obj-< lu svi)) ; New unique elt
(next (lui (fx+ lui 1))
(lu svi))
(do (set (vref sv lui) lu))
(result (fx+ 1 lui)))))
;;; vector-remove-duplicates
;;; ========================
;;; Non-destructive version of VECTOR-REMOVE-DUPLICATES.
;;; Makes 2 passes over the vector, the first to count the number of non-dups,
;;; and the the second to install them in the result vector.
;;; N.B. VECTOR ARG MUST BE SORTED.
(define (vector-remove-duplicates sv obj-<)
(if (fx= (vector-length sv) 0) (make-vector 0) ; special case 0-elt vecs
;; First, find out how many unique elements there are...
(loop (initial (numelts 1) (lu (vref sv 0))) ; lu is last uniq elt seen
(step i .in 1 to (vector-length sv))
(bind (vi (vref sv i)))
(when (obj-< lu vi)) ; new unique elt
(next (numelts (fx+ numelts 1)) (lu vi))
;; ...then, make the new vector, and stash the elements
(result
(loop (initial (ans (make-vector numelts))
(ui 0) ; unique count
(lu (vref sv 0)))
(before (set (vref ans 0) lu))
(step i .in 1 to (vector-length sv))
(bind (vi (vref sv i)))
(when (obj-< lu vi)) ; new unique elt
(next (ui (fx+ ui 1))
(lu vi))
(do (set (vref ans ui) lu))
(result ans))))))
;;; Heap sort. Heap sort is nice because:
;;; 1. It is stable (the order of = elts isn't altered)
;;; 2. Worst case is n log(n) (quicksort has n^2 worst case)
(define (heap-sort! v obj-<)
(let ((vlen (vector-length v)))
(if (fx> vlen 1) ; 0 & 1 elt vecs are already sorted.
(let ((heapify
(lambda (root end)
(let ((root-val (vref v root))
(leaf-bound (fixnum-ashr (fx- end 1) 1))) ;last non-lf
(iterate iter ((j root))
(if (fx< leaf-bound j)
(set (vref v j) root-val)
(receive (son-ind son-val)
(let* ((i1 (fx+ (fixnum-ashl j 1) 1))
(v1 (vref v i1))
(i2 (fx+ i1 1)))
(if (fx< end i2)
(return i1 v1)
(let ((v2 (vref v i2)))
(if (obj-< v2 v1) ; prefer right son
(return i1 v1); if tie for stability
(return i2 v2)))))
(cond ((obj-< root-val son-val)
(set (vref v j) son-val)
(iter son-ind))
(else
(set (vref v j) root-val))))))))))
;; Put the vector into heap order
(let ((end (fx- vlen 1)))
(loop (decr i .in. (fixnum-ashr (fx- end 1) 1) to 0)
(do (heapify i end))))
;; Pull out the elements in decreasing order.
(loop (decr i in vlen to 0)
(do (set (vref v i) (swap (vref v 0) (vref v i)))
(heapify 0 (fx- i 1)))))))
v)