[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.
------ 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)))
			 (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?

(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.

(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
	     (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))
				  (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)))))))