(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "SORT" ( USE "LISP" "PT")))
(il:filecreated "11-Dec-88 19:24:36" il:{qv}<idl>next>sorter.\;6 14737
il:|changes| il:|to:| (il:vars il:sortercoms) (il:functions binary-search recursive-binary-search index-sort index-recursive-quick-sort index-recursive-find-kth quick-sort find-median find-median-index generic-recursive-quick-sort apply-key generic-recursive-find-kth generic-median-of-three index-median-of-three generic-insertion-sort index-insertion-sort)
(xcl:file-environments "SORTER")
il:|previous| il:|date:| "11-Dec-88 17:44:50" il:{qv}<idl>next>sorter.\;5)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:sortercoms)
(il:rpaqq il:sortercoms ((il:functions apply-key) (il:coms (il:* il:|;;| "Sorting") (il:variables *min-quicksort-bin-size*) (il:functions quick-sort index-sort) (il:functions find-median find-median-index) (il:functions generic-recursive-quick-sort index-recursive-quick-sort) (il:functions generic-recursive-find-kth index-recursive-find-kth) (il:functions generic-median-of-three index-median-of-three) (il:functions generic-insertion-sort index-insertion-sort)) (il:coms (il:* il:|;;| "Searching") (il:functions binary-search recursive-binary-search)) (il:* il:|;;| "debugging") (il:functions test-find-median) (eval-when (load) (il:p (export (quote (quick-sort index-sort find-median find-median-index generic-recursive-quick-sort index-recursive-quick-sort generic-recursive-find-kth index-recursive-find-kth binary-search)) (find-package "SORT")))) (xcl:file-environments "SORTER")))
(defmacro apply-key (key place-form) (once-only (place-form) (il:bquote (if (il:\\\, key) (funcall (il:\\\, key) (il:\\\, place-form)) (il:\\\, place-form)))))
(il:* il:|;;| "Sorting")
(defconstant *min-quicksort-bin-size* 10)
(defun quick-sort (vector predicate &key key (start 0) (end (length vector))) (il:* il:|;;| "use quick sort to find the median. VECTOR is side-effected by this operation") (generic-recursive-quick-sort vector predicate key start end))
(defun index-sort (vector predicate &key key indices (start 0) (end (length vector))) (let ((length (- end start))) (if (null indices) (progn (setq indices (make-array length)) (do ((i start (1+ i)) (j 0 (1+ j))) ((eq j length)) (setf (aref indices j) i))) (if (not (eq (length indices) length)) (error "Index vector of incorrect length: ~s" indices))) (index-recursive-quick-sort vector indices predicate key 0 length)))
(defun find-median (vector predicate &key key (start 0) (end (length vector))) (il:* il:|;;| "use quick sort to find the median. VECTOR is side-effected by this operation") (let* ((length (- end start)) (lower-median-index (+ start (if (oddp length) (truncate (1- length) 2) (1- (truncate length 2))))) (upper-median-index (if (oddp length) lower-median-index (1+ lower-median-index)))) (generic-recursive-find-kth vector predicate key start end lower-median-index upper-median-index) (if (eq lower-median-index upper-median-index) (aref vector lower-median-index) (/ (+ (aref vector lower-median-index) (aref vector upper-median-index)) 2))))
(defun find-median-index (vector predicate &key key (start 0) (end (length vector))) (let* ((length (- end start)) (lower-median-index (if (oddp length) (truncate (1- length) 2) (1- (truncate length 2)))) (upper-median-index (if (oddp length) lower-median-index (1+ lower-median-index))) (indices (make-array length))) (do ((i start (1+ i)) (j 0 (1+ j))) ((eq j length)) (setf (aref indices j) i)) (index-recursive-find-kth vector indices predicate key 0 length lower-median-index upper-median-index) (values (aref indices lower-median-index) (aref indices upper-median-index))))
(defun generic-recursive-quick-sort (vector comparator key lower upper) (if (> (- upper lower) *min-quicksort-bin-size*) (progn (il:* il:|;;| "Find the median of three") (generic-median-of-three vector comparator key lower upper) (il:* il:|;;| "Perform the partitioning. At this point array[(1+ LOWER)] <= array[LOWER] <= array[(1- UPPER)] ") (let ((i (1+ lower)) (j (1- upper)) (split-value (apply-key key (aref vector lower)))) (loop (loop (incf i) (if (not (funcall comparator (apply-key key (aref vector i)) split-value)) (return nil))) (loop (decf j) (if (not (funcall comparator split-value (apply-key key (aref vector j)))) (return nil))) (cond ((> j i) (rotatef (aref vector i) (aref vector j))) (t (return nil)))) (rotatef (aref vector lower) (aref vector j)) (il:* il:|;;| "Now work recursively on the larger then the smaller subvector.") (if (> (- j lower) (- upper i)) (progn (generic-recursive-quick-sort vector comparator key i upper) (generic-recursive-quick-sort vector comparator key lower j)) (progn (generic-recursive-quick-sort vector comparator key lower j) (generic-recursive-quick-sort vector comparator key i upper))))) (generic-insertion-sort vector comparator key lower upper)))
(defun index-recursive-quick-sort (vector indices comparator key lower upper) (if (> (- upper lower) *min-quicksort-bin-size*) (progn (il:* il:|;;| "Find the median of three") (index-median-of-three vector indices comparator key lower upper) (il:* il:|;;| "Perform the partitioning. At this point array[(1+ LOWER)] <= array[LOWER] <= array[(1- UPPER)] ") (let ((i (1+ lower)) (j (1- upper)) (split-value (apply-key key (aref vector (aref indices lower))))) (loop (loop (incf i) (if (not (funcall comparator (apply-key key (aref vector (aref indices i))) split-value)) (return nil))) (loop (decf j) (if (not (funcall comparator split-value (apply-key key (aref vector (aref indices j))))) (return nil))) (cond ((> j i) (rotatef (aref indices i) (aref indices j))) (t (return nil)))) (rotatef (aref indices lower) (aref indices j)) (il:* il:|;;| "Finished partitioning, now recurse") (if (> (- j lower) (- upper i)) (progn (index-recursive-quick-sort vector indices comparator key i upper) (index-recursive-quick-sort vector indices comparator key lower j)) (progn (index-recursive-quick-sort vector indices comparator key lower j) (index-recursive-quick-sort vector indices comparator key i upper))))) (index-insertion-sort vector indices comparator key lower upper)))
(defun generic-recursive-find-kth (vector comparator key lower upper lower-kth-index upper-kth-index) (if (> (- upper lower) *min-quicksort-bin-size*) (progn (il:* il:|;;| "Find the median of three") (generic-median-of-three vector comparator key lower upper) (il:* il:|;;| "Perform the partitioning. At this point array[(1+ LOWER)] <= array[LOWER] <= array[(1- UPPER)] ") (let ((i (1+ lower)) (j (1- upper)) (split-value (apply-key key (aref vector lower)))) (loop (loop (incf i) (if (not (funcall comparator (apply-key key (aref vector i)) split-value)) (return nil))) (loop (decf j) (if (not (funcall comparator split-value (apply-key key (aref vector j)))) (return nil))) (cond ((> j i) (rotatef (aref vector i) (aref vector j))) (t (return nil)))) (rotatef (aref vector lower) (aref vector j)) (il:* il:|;;| "Finished partitioning, now recurse") (cond ((< upper-kth-index j) (generic-recursive-find-kth vector comparator key lower j lower-kth-index upper-kth-index)) ((>= lower-kth-index i) (generic-recursive-find-kth vector comparator key i upper lower-kth-index upper-kth-index)) (il:* il:|;;| "Must have j <= UPPER-KTH-INDEX, i > LOWER-KTH-INDEX, LOWER-KTH-INDEX <= UPPER-KTH-INDEX, j < i") ((< lower-kth-index j) (generic-recursive-find-kth vector comparator key lower (1+ j) lower-kth-index upper-kth-index)) (t (generic-recursive-find-kth vector comparator key (1- i) upper lower-kth-index upper-kth-index))))) (generic-insertion-sort vector comparator key lower upper)))
(defun index-recursive-find-kth (vector indices comparator key lower upper lower-kth-index upper-kth-index) (if (> (- upper lower) *min-quicksort-bin-size*) (progn (il:* il:|;;| "Find the median of three") (index-median-of-three vector indices comparator key lower upper) (il:* il:|;;| "Perform the partitioning. At this point array[(1+ LOWER)] <= array[LOWER] <= array[(1- UPPER)] ") (let ((i (1+ lower)) (j (1- upper)) (split-value (apply-key key (aref vector (aref indices lower))))) (loop (loop (incf i) (if (not (funcall comparator (apply-key key (aref vector (aref indices i))) split-value)) (return nil))) (loop (decf j) (if (not (funcall comparator split-value (apply-key key (aref vector (aref indices j))))) (return nil))) (cond ((> j i) (rotatef (aref indices i) (aref indices j))) (t (return nil)))) (rotatef (aref indices lower) (aref indices j)) (il:* il:|;;| "Finished partitioning, now recurse") (cond ((< upper-kth-index j) (index-recursive-find-kth vector indices comparator key lower j lower-kth-index upper-kth-index)) ((>= lower-kth-index i) (index-recursive-find-kth vector indices comparator key i upper lower-kth-index upper-kth-index)) (il:* il:|;;| "Must have j <= UPPER-KTH-INDEX, i > LOWER-KTH-INDEX, LOWER-KTH-INDEX <= UPPER-KTH-INDEX, j < i") ((< lower-kth-index j) (index-recursive-find-kth vector indices comparator key lower (1+ j) lower-kth-index upper-kth-index)) (t (index-recursive-find-kth vector indices comparator key (1- i) upper lower-kth-index upper-kth-index))))) (index-insertion-sort vector indices comparator key lower upper)))
(defun generic-median-of-three (vector comparator key lower upper) (let ((up-index (1- upper)) (md-index (truncate (+ lower upper) 2)) (lw-index+1 (1+ lower))) (rotatef (aref vector md-index) (aref vector lw-index+1)) (if (funcall comparator (apply-key key (aref vector up-index)) (apply-key key (aref vector lw-index+1))) (rotatef (aref vector lw-index+1) (aref vector up-index))) (if (funcall comparator (apply-key key (aref vector up-index)) (apply-key key (aref vector lower))) (rotatef (aref vector lower) (aref vector up-index))) (if (funcall comparator (apply-key key (aref vector lower)) (apply-key key (aref vector lw-index+1))) (rotatef (aref vector lw-index+1) (aref vector lower)))))
(defun index-median-of-three (vector indices comparator key lower upper) (let ((up-index (1- upper)) (md-index (truncate (+ lower upper) 2)) (lw-index+1 (1+ lower))) (rotatef (aref indices md-index) (aref indices lw-index+1)) (if (funcall comparator (apply-key key (aref vector (aref indices up-index))) (apply-key key (aref vector (aref indices lw-index+1)))) (rotatef (aref indices lw-index+1) (aref indices up-index))) (if (funcall comparator (apply-key key (aref vector (aref indices up-index))) (apply-key key (aref vector (aref indices lower)))) (rotatef (aref indices lower) (aref indices up-index))) (if (funcall comparator (apply-key key (aref vector (aref indices lower))) (apply-key key (aref vector (aref indices lw-index+1)))) (rotatef (aref indices lw-index+1) (aref indices lower)))))
(defun generic-insertion-sort (vector comparator key lower upper) (il:* il:|;;| "SORT vector in ascending order; Vector is side-effected. ") (il:* il:|;;| "Loop Invariant: Vector[Lower,..,i-1] are correctly ordered.") (do ((i (1+ lower) (1+ i))) ((eq i upper) vector) (do* ((ith-element (aref vector i)) (ith-comparator (apply-key key ith-element)) (j i (1- j)) temp) ((or (eq j lower) (il:* il:|;;| "(>= ith-comparator (funcall key (setq temp (aref vector (1- j)))))") (not (funcall comparator ith-comparator (apply-key key (setq temp (aref vector (1- j))))))) (setf (aref vector j) ith-element)) (setf (aref vector j) temp))))
(defun index-insertion-sort (vector indices comparator key lower upper) (il:* il:|;;| "SORT vector in ascending order; Vector is side-effected. ") (il:* il:|;;| "Loop Invariant: Vector[Indices[Lower],..,Indices[i-1]] are correctly ordered.") (do ((i (1+ lower) (1+ i))) ((eq i upper) indices) (do* ((ith-index (aref indices i)) (ith-comparator (apply-key key (aref vector ith-index))) (j i (1- j)) temp-index) ((or (eq j lower) (not (funcall comparator ith-comparator (apply-key key (aref vector (setq temp-index (aref indices (1- j)))))))) (setf (aref indices j) ith-index)) (setf (aref indices j) temp-index))))
(il:* il:|;;| "Searching")
(defun binary-search (item vector predicate &key key (start 0) (end (length vector)) (interpolate-p nil)) (recursive-binary-search item vector predicate key start end interpolate-p))
(defun recursive-binary-search (item vector predicate key lower upper interpolate-p) (if (> (- upper lower) 1) (let* ((mid-point (truncate (+ lower upper) 2)) (candidate (apply-key key (aref vector mid-point)))) (if (funcall predicate item candidate) (il:* il:|;;| "item < candidate") (recursive-binary-search item vector predicate key lower mid-point interpolate-p) (il:* il:|;;| "item >= candidate") (recursive-binary-search item vector predicate key mid-point upper interpolate-p))) (let ((candidate (apply-key key (aref vector lower)))) (cond ((funcall predicate item candidate) (if interpolate-p lower)) ((funcall predicate candidate item) (if interpolate-p (1+ lower))) (t lower)))))
(il:* il:|;;| "debugging")
(defun test-find-median (p n) (dotimes (i n) (format t "Iteration ~d~%" i) (let ((array (make-array p)) (median-index (if (oddp p) (truncate (1- p) 2) (truncate p 2))) median median-low median-high true-median true-median-low true-median-high) (dotimes (j p) (setf (aref array j) (random 1.0))) (find-median array (quote identity)) (cond ((oddp p) (setq median-low (setq median-high (aref array median-index))) (setq median median-low)) (t (setq median-low (aref array (1- median-index)) median-high (aref array median-index)) (setq median (/ (+ median-low median-high) 2.0)))) (sort array (quote <)) (cond ((oddp p) (setq true-median-low (setq true-median-high (aref array median-index))) (setq true-median true-median-low)) (t (setq true-median-low (aref array (1- median-index)) true-median-high (aref array median-index)) (setq true-median (/ (+ true-median-low true-median-high) 2.0)))) (unless (= median true-median) (format t "Medians don't agree~%true: ~s computed: ~s~%" true-median median) (if (oddp p) (format t "Median elements (~d) are~%true: ~s computed: ~s~%" median-index true-median-low median-low) (format t "Median elements (~d ~d) are~%low: ~s , ~s high: ~s , ~s~%" (1- median-index) median-index true-median-low median-low true-median-high median-high)) (xcl:help)))))
(eval-when (load)
(export (quote (quick-sort index-sort find-median find-median-index generic-recursive-quick-sort index-recursive-quick-sort generic-recursive-find-kth index-recursive-find-kth binary-search)) (find-package "SORT"))
)
(xcl:define-file-environment "SORTER" :package (xcl:defpackage "SORT" (:use "LISP" "PT")) :readtable "XCL" :compiler :compile-file)
(il:putprops il:sorter il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop