From cb9f44065799e63ef73a177247393fc880e025ce Mon Sep 17 00:00:00 2001 From: sperber Date: Thu, 22 Jan 2004 19:52:15 +0000 Subject: [PATCH] Import sort code from s48-tuebingen/trunk, rev 573. --- scheme/sort/delndups.scm | 239 ++++++++ scheme/sort/interfaces.scm | 199 +++++++ scheme/sort/lmsort.scm | 386 +++++++++++++ scheme/sort/packages.scm | 71 +++ scheme/sort/sort.scm | 26 + scheme/sort/sort.txt | 1056 +++++++++++++++++++++++++++++++++++ scheme/sort/sortp.scm | 35 ++ scheme/sort/test.scm | 65 +++ scheme/sort/vbinsearch.scm | 34 ++ scheme/sort/vector-util.scm | 56 ++ scheme/sort/vhsort.scm | 117 ++++ scheme/sort/visort.scm | 76 +++ scheme/sort/vmsort.scm | 238 ++++++++ 13 files changed, 2598 insertions(+) create mode 100644 scheme/sort/delndups.scm create mode 100644 scheme/sort/interfaces.scm create mode 100644 scheme/sort/lmsort.scm create mode 100644 scheme/sort/packages.scm create mode 100644 scheme/sort/sort.scm create mode 100644 scheme/sort/sort.txt create mode 100644 scheme/sort/sortp.scm create mode 100644 scheme/sort/test.scm create mode 100644 scheme/sort/vbinsearch.scm create mode 100644 scheme/sort/vector-util.scm create mode 100644 scheme/sort/vhsort.scm create mode 100644 scheme/sort/visort.scm create mode 100644 scheme/sort/vmsort.scm diff --git a/scheme/sort/delndups.scm b/scheme/sort/delndups.scm new file mode 100644 index 0000000..12ba8ce --- /dev/null +++ b/scheme/sort/delndups.scm @@ -0,0 +1,239 @@ +;;; The SRFI-32 sort package -- delete neighboring duplicate elts +;;; Copyright (c) 1998 by Olin Shivers. +;;; This code is open-source; see the end of the file for porting and +;;; more copyright information. +;;; Olin Shivers 11/98. + +;;; Problem: +;;; vector-delete-neighbor-dups pushes N stack frames, where N is the number +;;; of elements in the answer vector. This is arguably a very efficient thing +;;; to do, but it might blow out on a system with a limited stack but a big +;;; heap. We could rewrite this to "chunk" up answers in temp vectors if we +;;; push more than a certain number of frames, then allocate a final answer, +;;; copying all the chunks into the answer. But it's much more complex code. + +;;; Exports: +;;; (list-delete-neighbor-dups = lis) -> list +;;; (list-delete-neighbor-dups! = lis) -> list +;;; (vector-delete-neighbor-dups = v [start end]) -> vector +;;; (vector-delete-neighbor-dups! = v [start end]) -> end' + +;;; These procedures delete adjacent duplicate elements from a list or +;;; a vector, using a given element equality procedure. The first or leftmost +;;; element of a run of equal elements is the one that survives. The list +;;; or vector is not otherwise disordered. +;;; +;;; These procedures are linear time -- much faster than the O(n^2) general +;;; duplicate-elt deletors that do not assume any "bunching" of elements. +;;; If you want to delete duplicate elements from a large list or vector, +;;; sort the elements to bring equal items together, then use one of these +;;; procedures -- for a total time of O(n lg n). + +;;; LIST-DELETE-NEIGHBOR-DUPS +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Below are multiple versions of the LIST-DELETE-NEIGHBOR-DUPS procedure, +;;; from simple to complex. RECUR's contract: Strip off any leading X's from +;;; LIS, and return that list neighbor-dup-deleted. +;;; +;;; The final version +;;; - shares a common subtail between the input & output list, up to 1024 +;;; elements; +;;; - Needs no more than 1024 stack frames. + +;;; Simplest version. +;;; - Always allocates a fresh list / never shares storage. +;;; - Needs N stack frames, if answer is length N. +(define (list-delete-neighbor-dups = lis) + (if (pair? lis) + (let ((x0 (car lis))) + (cons x0 (let recur ((x0 x0) (xs (cdr lis))) + (if (pair? xs) + (let ((x1 (car xs)) + (x2+ (cdr xs))) + (if (= x0 x1) + (recur x0 x2+) ; Loop, actually. + (cons x1 (recur x1 x2+)))) + xs)))) + lis)) + +;;; This version tries to use cons cells from input by sharing longest +;;; common tail between input & output. Still needs N stack frames, for ans +;;; of length N. +(define (list-delete-neighbor-dups = lis) + (if (pair? lis) + (let* ((x0 (car lis)) + (xs (cdr lis)) + (ans (let recur ((x0 x0) (xs xs)) + (if (pair? xs) + (let ((x1 (car xs)) + (x2+ (cdr xs))) + (if (= x0 x1) + (recur x0 x2+) + (let ((ans-tail (recur x1 x2+))) + (if (eq? ans-tail x2+) xs + (cons x1 ans-tail))))) + xs)))) + (if (eq? ans xs) lis (cons x0 ans))) + + lis)) + +;;; This version tries to share the longest common tail between input & output, +;;; but it also refuses to push more than 1024 stack frames (which bounds the +;;; length of the shared suffix, as well). Useful for enormous lists that +;;; might otherwise blow out your stack. It basically computes 1024-element +;;; chunks of the answer, and then strings these results together using +;;; SET-CDR! to point the last cons cell of each chunk to the first cons cell +;;; of the following chunk. + +(define (list-delete-neighbor-dups = lis) + (letrec ((lp (lambda (last-pair xs) + (format #t "lp(last-pair=~a, xs=~a)~%" last-pair xs) + (if (pair? xs) + (let ((x0 (car xs)) + (x1+ (cdr xs))) + (receive (chunk last-pair2 xs) (recur xs 2) + (format #t "<-recur: chunk=~a lp=~a xs=~a~%" + chunk last-pair2 xs) + (set-cdr! last-pair chunk) + (lp last-pair2 xs)))))) + + (kill (lambda (xs) + (let ((y (car xs))) + (values y (let lp ((xs (cdr xs))) + (if (pair? xs) + (let ((x0 (car xs)) + (x1+ (cdr xs))) + (if (= y x0) (lp x1+) x1+)) + '())))))) + + (recur (lambda (xs n) + (format #t "->recur(xs=~a, n=~a)~%" xs n) + (if (pair? xs) + (receive (x0 rest) (kill xs) + (if (pair? rest) + (if (< 1 n) + (receive (c lpr r) (recur rest (- n 1)) + (values (cons x0 c) lpr r)) + (receive (xn rest) (kill rest) + (let ((lpr (list xn))) + (values (cons x0 lpr) lpr rest)))) + + (values (list x0) '() '()))) + + (values '() '() '()))))) + (if (pair? lis) + (let ((x0 (car lis)) + (x1+ (cdr lis))) + (receive (chunk last-pair rest) (recur lis 2) + (lp last-pair rest) + chunk)) + lis))) + + + +;;; LIST-DELETE-NEIGHBOR-DUPS! +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This code runs in constant list space, constant stack, and also +;;; does only the minimum SET-CDR!'s necessary. + +(define (list-delete-neighbor-dups! = lis) + (if (pair? lis) + (let lp1 ((prev lis) (prev-elt (car lis)) (lis (cdr lis))) + (if (pair? lis) + (let ((lis-elt (car lis)) + (next (cdr lis))) + (if (= prev-elt lis-elt) + + ;; We found the first elts of a run of dups, so we know + ;; we're going to have to do a SET-CDR!. Scan to the end of + ;; the run, do the SET-CDR!, and loop on LP1. + (let lp2 ((lis next)) + (if (pair? lis) + (let ((lis-elt (car lis)) + (next (cdr lis))) + (if (= prev-elt lis-elt) + (lp2 next) + (begin (set-cdr! prev lis) + (lp1 lis lis-elt next)))) + (set-cdr! prev lis))) ; Ran off end => quit. + + (lp1 lis lis-elt next)))))) + lis) + + +(define (vector-delete-neighbor-dups elt= v . maybe-start+end) + (call-with-values + (lambda () (vector-start+end v maybe-start+end)) + (lambda (start end) + (if (< start end) + (let* ((x (vector-ref v start)) + (ans (let recur ((x x) (i start) (j 1)) + (if (< i end) + (let ((y (vector-ref v i)) + (nexti (+ i 1))) + (if (elt= x y) + (recur x nexti j) + (let ((ansvec (recur y nexti (+ j 1)))) + (vector-set! ansvec j y) + ansvec))) + (make-vector j))))) + (vector-set! ans 0 x) + ans) + '#())))) + + +;;; Packs the surviving elements to the left, in range [start,end'), +;;; and returns END'. +(define (vector-delete-neighbor-dups! elt= v . maybe-start+end) + (call-with-values + (lambda () (vector-start+end v maybe-start+end)) + (lambda (start end) + + (if (>= start end) + end + ;; To eliminate unnecessary copying (read elt i then write the value + ;; back at index i), we scan until we find the first dup. + (let skip ((j start) (vj (vector-ref v start))) + (let ((j+1 (+ j 1))) + (if (>= j+1 end) + end + (let ((vj+1 (vector-ref v j+1))) + (if (not (elt= vj vj+1)) + (skip j+1 vj+1) + + ;; OK -- j & j+1 are dups, so we're committed to moving + ;; data around. In lp2, v[start,j] is what we've done; + ;; v[k,end) is what we have yet to handle. + (let lp2 ((j j) (vj vj) (k (+ j 2))) + (let lp3 ((k k)) + (if (>= k end) + (+ j 1) ; Done. + (let ((vk (vector-ref v k)) + (k+1 (+ k 1))) + (if (elt= vj vk) + (lp3 k+1) + (let ((j+1 (+ j 1))) + (vector-set! v j+1 vk) + (lp2 j+1 vk k+1)))))))))))))))) + +;;; Copyright +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This code is +;;; Copyright (c) 1998 by Olin Shivers. +;;; The terms are: You may do as you please with this code, as long as +;;; you do not delete this notice or hold me responsible for any outcome +;;; related to its use. +;;; +;;; Blah blah blah. Don't you think source files should contain more lines +;;; of code than copyright notice? +;;; +;;; Code porting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; If your Scheme has a faster mechanism for handling optional arguments +;;; (e.g., Chez), you should definitely port over to it. Note that argument +;;; defaulting and error-checking are interleaved -- you don't have to +;;; error-check defaulted START/END args to see if they are fixnums that are +;;; legal vector indices for the corresponding vector, etc. + + diff --git a/scheme/sort/interfaces.scm b/scheme/sort/interfaces.scm new file mode 100644 index 0000000..b9d8311 --- /dev/null +++ b/scheme/sort/interfaces.scm @@ -0,0 +1,199 @@ +;;; Interface defs for the Scheme Underground sorting package, +;;; in the Scheme 48 module language. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list-delete-neighbor-dups = l -> list +;;; vector-delete-neighbor-dups = v [start end] -> vector +;;; vector-delete-neighbor-dups! = v [start end] -> vector +;;; + +(define-interface delete-neighbor-duplicates-interface + (export (list-delete-neighbor-dups + (proc ((proc (:value :value) :boolean) + :value) + :value)) + (vector-delete-neighbor-dups + (proc ((proc (:value :value) :boolean) + :vector + &opt + :exact-integer :exact-integer) + :vector)) + (vector-delete-neighbor-dups! + (proc ((proc (:value :value) :boolean) + :vector + &opt + :exact-integer :exact-integer) + :vector)))) + +;;; vector-binary-search elt< elt->key key v [start end] -> integer-or-false +;;; vector-binary-search3 c v [start end] -> integer-or-false + +(define-interface binary-searches-interface + (export vector-binary-search + vector-binary-search3)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list-sorted? l < -> boolean +;;; vector-sorted? v < [start end] -> boolean + +(define-interface sorted-interface + (export (list-sorted? (proc (:value (proc (:value :value) :boolean)) :boolean)) + (vector-sorted? (proc ((proc (:value :value) :boolean) + :vector + &opt :exact-integer :exact-integer) + :boolean)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list-merge-sort < l -> list +;;; list-merge-sort! < l -> list +;;; list-merge < lis lis -> list +;;; list-merge! < lis lis -> list + +(define-interface list-merge-sort-interface + (export ((list-merge-sort list-merge-sort!) + (proc ((proc (:value :value) :boolean) :value) :value)) + ((list-merge list-merge!) + (proc ((proc (:value :value) :boolean) :value :value) :value)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; vector-merge-sort < v [start end temp] -> vector +;;; vector-merge-sort! < v [start end temp] -> unspecific +;;; vector-merge < v1 v2 [start1 end1 start2 end2] -> vector +;;; vector-merge! < v v1 v2 [start0 start1 end1 start2 end2] -> unspecific + +(define-interface vector-merge-sort-interface + (export + (vector-merge-sort (proc ((proc (:value :value) :boolean) + :vector + &opt + :exact-integer :exact-integer + :vector) + :vector)) + (vector-merge-sort! (proc ((proc (:value :value) :boolean) + :vector + &opt + :exact-integer :exact-integer + :vector) + :unspecific)) + (vector-merge (proc ((proc (:value :value) :boolean) + :vector :vector + &opt + :exact-integer :exact-integer + :exact-integer :exact-integer) + :vector)) + (vector-merge! (proc ((proc (:value :value) :boolean) + :vector :vector :vector + &opt + :exact-integer :exact-integer :exact-integer + :exact-integer :exact-integer) + :unspecific)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; heap-sort < v [start end] -> vector +;;; heap-sort! < v -> unspecific + +(define-interface vector-heap-sort-interface + (export (heap-sort (proc ((proc (:value :value) :boolean) + :vector + &opt :exact-integer :exact-integer) + :vector)) + (heap-sort! (proc ((proc (:value :value) :boolean) :vector) :unspecific)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; insert-sort < v [start end] -> vector +;;; insert-sort! < v [start end] -> unspecific +;;; +;;; internal: +;;; %insert-sort! < v start end -> unspecific + +(define-interface vector-insertion-sort-interface + (export (insert-sort (proc ((proc (:value :value) :boolean) + :vector + &opt :exact-integer :exact-integer) + :vector)) + (insert-sort! (proc ((proc (:value :value) :boolean) + :vector + &opt :exact-integer :exact-integer) + :unspecific)))) + +(define-interface vector-insertion-sort-internal-interface + (export (%insert-sort! (proc ((proc (:value :value) :boolean) + :vector + :exact-integer :exact-integer) + :unspecific)))) + +;;; The general sort interface: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list-sorted? < l -> boolean +;;; +;;; list-merge < l1 l2 -> list +;;; list-merge! < l1 l2 -> list +;;; +;;; list-sort < l -> list +;;; list-sort! < l -> list +;;; list-stable-sort < l -> list +;;; list-stable-sort! < l -> list +;;; +;;; list-delete-neighbor-dups l = -> list +;;; +;;; vector-sorted? < v [start end] -> boolean +;;; +;;; vector-merge < v1 v2 [start1 end1 start2 end2] -> vector +;;; vector-merge! < v v1 v2 [start start1 end1 start2 end2] -> unspecific +;;; +;;; vector-sort < v [start end] -> vector +;;; vector-sort! < v -> unspecific +;;; +;;; vector-stable-sort < v [start end] -> vector +;;; vector-stable-sort! < v -> unspecific +;;; +;;; vector-delete-neighbor-dups v = [start end] -> vector + +(define-interface sort-interface + (compound-interface + sorted-interface + (export + + ((list-merge list-merge!) + (proc ((proc (:value :value) :boolean) :value :value) :value)) + + ((list-sort list-sort! list-stable-sort list-stable-sort!) + (proc ((proc (:value :value) :boolean) :value) :value)) + + (vector-merge (proc ((proc (:value :value) :boolean) + :vector :vector + &opt + :exact-integer :exact-integer + :exact-integer :exact-integer) + :vector)) + + (vector-merge! (proc ((proc (:value :value) :boolean) + :vector :vector :vector + &opt + :exact-integer :exact-integer :exact-integer + :exact-integer :exact-integer) + :unspecific)) + + ((vector-sort vector-stable-sort) + (proc ((proc (:value :value) :boolean) + :vector + &opt + :exact-integer :exact-integer) + :vector)) + + ((vector-sort! vector-stable-sort!) + (proc ((proc (:value :value) :boolean) :vector) :unspecific))) + + (list-delete-neighbor-dups + (proc ((proc (:value :value) :boolean) + :value) + :value)) + (vector-delete-neighbor-dups + (proc ((proc (:value :value) :boolean) + :vector + &opt + :exact-integer :exact-integer) + :vector)))) diff --git a/scheme/sort/lmsort.scm b/scheme/sort/lmsort.scm new file mode 100644 index 0000000..c661d00 --- /dev/null +++ b/scheme/sort/lmsort.scm @@ -0,0 +1,386 @@ +;;; list merge & list merge-sort -*- Scheme -*- +;;; Copyright (c) 1998 by Olin Shivers. +;;; This code is open-source; see the end of the file for porting and +;;; more copyright information. +;;; Olin Shivers + +;;; Exports: +;;; (list-merge < lis lis) -> list +;;; (list-merge! < lis lis) -> list +;;; (list-merge-sort < lis) -> list +;;; (list-merge-sort! < lis) -> list + +;;; A stable list merge sort of my own device +;;; Two variants: pure & destructive +;;; +;;; This list merge sort is opportunistic (a "natural" sort) -- it exploits +;;; existing order in the input set. Instead of recursing all the way down to +;;; individual elements, the leaves of the merge tree are maximal contiguous +;;; runs of elements from the input list. So the algorithm does very well on +;;; data that is mostly ordered, with a best-case time of O(n) when the input +;;; list is already completely sorted. In any event, worst-case time is +;;; O(n lg n). +;;; +;;; The destructive variant is "in place," meaning that it allocates no new +;;; cons cells at all; it just rearranges the pairs of the input list with +;;; SET-CDR! to order it. +;;; +;;; The interesting control structure is the combination recursion/iteration +;;; of the core GROW function that does an "opportunistic" DFS walk of the +;;; merge tree, adaptively subdividing in response to the length of the +;;; merges, without requiring any auxiliary data structures beyond the +;;; recursion stack. It's actually quite simple -- ten lines of code. +;;; -Olin Shivers 10/20/98 + +;;; (mlet ((var-list mv-exp) ...) body ...) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; A LET* form that handles multiple values. Move this into the two clients +;;; if you don't have a module system handy to restrict its visibility... +(define-syntax mlet ; Multiple-value LET* + (syntax-rules () + ((mlet ((() exp) rest ...) body ...) + (begin exp (mlet (rest ...) body ...))) + + ((mlet (((var) exp) rest ...) body ...) + (let ((var exp)) (mlet (rest ...) body ...))) + + ((mlet ((vars exp) rest ...) body ...) + (call-with-values (lambda () exp) + (lambda vars (mlet (rest ...) body ...)))) + + ((mlet () body ...) (begin body ...)))) + + +;;; (list-merge-sort < lis) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; A natural, stable list merge sort. +;;; - natural: picks off maximal contiguous runs of pre-ordered data. +;;; - stable: won't invert the order of equal elements in the input list. + +(define (list-merge-sort elt< lis) + + ;; (getrun lis) -> run runlen rest + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Pick a run of non-decreasing data off of non-empty list LIS. + ;; Return the length of this run, and the following list. + (define (getrun lis) + (let lp ((ans '()) (i 1) (prev (car lis)) (xs (cdr lis))) + (if (pair? xs) + (let ((x (car xs))) + (if (elt< x prev) + (values (append-reverse ans (cons prev '())) i xs) + (lp (cons prev ans) (+ i 1) x (cdr xs)))) + (values (append-reverse ans (cons prev '())) i xs)))) + + (define (append-reverse rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (lp (cdr rev-head) (cons (car rev-head) tail))))) + + (define (null-list? l) + (cond ((pair? l) #f) + ((null? l) #t) + (else (error "null-list?: argument out of domain" l)))) + + ;; (merge a b) -> list + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; List merge -- stably merge lists A (length > 0) & B (length > 0). + ;; This version requires up to |a|+|b| stack frames. + (define (merge a b) + (let recur ((x (car a)) (a a) + (y (car b)) (b b)) + (if (elt< y x) + (cons y (let ((b (cdr b))) + (if (pair? b) + (recur x a (car b) b) + a))) + (cons x (let ((a (cdr a))) + (if (pair? a) + (recur (car a) a y b) + b)))))) + + ;; (grow s ls ls2 u lw) -> [a la unused] + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; The core routine. Read the next 20 lines of comments & all is obvious. + ;; - S is a sorted list of length LS > 1. + ;; - LS2 is some power of two <= LS. + ;; - U is an unsorted list. + ;; - LW is a positive integer. + ;; Starting with S, and taking data from U as needed, produce + ;; a sorted list of *at least* length LW, if there's enough data + ;; (LW <= LS + length(U)), or use all of U if not. + ;; + ;; GROW takes maximal contiguous runs of data from U at a time; + ;; it is allowed to return a list *longer* than LW if it gets lucky + ;; with a long run. + ;; + ;; The key idea: If you want a merge operation to "pay for itself," the two + ;; lists being merged should be about the same length. Remember that. + ;; + ;; Returns: + ;; - A: The result list + ;; - LA: The length of the result list + ;; - UNUSED: The unused tail of U. + + (define (grow s ls ls2 u lw) ; The core of the sort algorithm. + (if (or (<= lw ls) (not (pair? u))) ; Met quota or out of data? + (values s ls u) ; If so, we're done. + (mlet (((ls2) (let lp ((ls2 ls2)) + (let ((ls2*2 (+ ls2 ls2))) + (if (<= ls2*2 ls) (lp ls2*2) ls2)))) + ;; LS2 is now the largest power of two <= LS. + ;; (Just think of it as being roughly LS.) + ((r lr u2) (getrun u)) ; Get a run, then + ((t lt u3) (grow r lr 1 u2 ls2))) ; grow it up to be T. + (grow (merge s t) (+ ls lt) ; Merge S & T, + (+ ls2 ls2) u3 lw)))) ; and loop. + + ;; Note: (LENGTH LIS) or any constant guaranteed + ;; to be greater can be used in place of INFINITY. + (if (pair? lis) ; Don't sort an empty list. + (mlet (((r lr tail) (getrun lis)) ; Pick off an initial run, + ((infinity) #o100000000) ; then grow it up maximally. + ((a la v) (grow r lr 1 tail infinity))) + a) + '())) + + +;;; (list-merge-sort! < lis) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; A natural, stable, destructive, in-place list merge sort. +;;; - natural: picks off maximal contiguous runs of pre-ordered data. +;;; - stable: won't invert the order of equal elements in the input list. +;;; - destructive, in-place: this routine allocates no extra working memory; +;;; it simply rearranges the list with SET-CDR! operations. + +(define (list-merge-sort! elt< lis) + ;; (getrun lis) -> runlen last rest + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Pick a run of non-decreasing data off of non-empty list LIS. + ;; Return the length of this run, the last cons cell of the run, + ;; and the following list. + (define (getrun lis) + (let lp ((lis lis) (x (car lis)) (i 1) (next (cdr lis))) + (if (pair? next) + (let ((y (car next))) + (if (elt< y x) + (values i lis next) + (lp next y (+ i 1) (cdr next)))) + (values i lis next)))) + + ;; (merge! a enda b endb) -> [m endm] + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Destructively and stably merge non-empty lists A & B. + ;; The last cons of A is ENDA. (The cdr of ENDA can be non-nil.) + ;; the last cons of B is ENDB. (The cdr of ENDB can be non-nil.) + ;; + ;; Return the first and last cons cells of the merged list. + ;; This routine is iterative & in-place: it runs in constant stack and + ;; doesn't allocate any cons cells. It is also tedious but simple; don't + ;; bother reading it unless necessary. + (define (merge! a enda b endb) + ;; The logic of these two loops is completely driven by these invariants: + ;; SCAN-A: (CDR PREV) = A. X = (CAR A). Y = (CAR B). + ;; SCAN-B: (CDR PREV) = B. X = (CAR A). Y = (CAR B). + (letrec ((scan-a (lambda (prev x a y b) ; Zip down A until we + (cond ((elt< y x) ; find an elt > (CAR B). + (set-cdr! prev b) + (let ((next-b (cdr b))) + (if (eq? b endb) + (begin (set-cdr! b a) enda) ; Done. + (scan-b b x a (car next-b) next-b)))) + + ((eq? a enda) (maybe-set-cdr! a b) endb) ; Done. + + (else (let ((next-a (cdr a))) ; Continue scan. + (scan-a a (car next-a) next-a y b)))))) + + (scan-b (lambda (prev x a y b) ; Zip down B while its + (cond ((elt< y x) ; elts are < (CAR A). + (if (eq? b endb) + (begin (set-cdr! b a) enda) ; Done. + (let ((next-b (cdr b))) ; Continue scan. + (scan-b b x a (car next-b) next-b)))) + + (else (set-cdr! prev a) + (if (eq? a enda) + (begin (maybe-set-cdr! a b) endb) ; Done. + (let ((next-a (cdr a))) + (scan-a a (car next-a) next-a y b))))))) + + ;; This guy only writes if he has to. Called at most once. + ;; Pointer equality rules; pure languages are for momma's boys. + (maybe-set-cdr! (lambda (pair val) (if (not (eq? (cdr pair) val)) + (set-cdr! pair val))))) + + (let ((x (car a)) (y (car b))) + (if (elt< y x) + + ;; B starts the answer list. + (values b (if (eq? b endb) + (begin (set-cdr! b a) enda) + (let ((next-b (cdr b))) + (scan-b b x a (car next-b) next-b)))) + + ;; A starts the answer list. + (values a (if (eq? a enda) + (begin (maybe-set-cdr! a b) endb) + (let ((next-a (cdr a))) + (scan-a a (car next-a) next-a y b)))))))) + + ;; (grow s ends ls ls2 u lw) -> [a enda la unused] + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; The core routine. + ;; - S is a sorted list of length LS > 1, with final cons cell ENDS. + ;; (CDR ENDS) doesn't have to be nil. + ;; - LS2 is some power of two <= LS. + ;; - U is an unsorted list. + ;; - LW is a positive integer. + ;; Starting with S, and taking data from U as needed, produce + ;; a sorted list of *at least* length LW, if there's enough data + ;; (LW <= LS + length(U)), or use all of U if not. + ;; + ;; GROW takes maximal contiguous runs of data from U at a time; + ;; it is allowed to return a list *longer* than LW if it gets lucky + ;; with a long run. + ;; + ;; The key idea: If you want a merge operation to "pay for itself," the two + ;; lists being merged should be about the same length. Remember that. + ;; + ;; Returns: + ;; - A: The result list (not properly terminated) + ;; - ENDA: The last cons cell of the result list. + ;; - LA: The length of the result list + ;; - UNUSED: The unused tail of U. + (define (grow s ends ls ls2 u lw) + (if (and (pair? u) (< ls lw)) + + ;; We haven't met the LW quota but there's still some U data to use. + (mlet (((ls2) (let lp ((ls2 ls2)) + (let ((ls2*2 (+ ls2 ls2))) + (if (<= ls2*2 ls) (lp ls2*2) ls2)))) + ;; LS2 is now the largest power of two <= LS. + ;; (Just think of it as being roughly LS.) + ((lr endr u2) (getrun u)) ; Get a run from U; + ((t endt lt u3) (grow u endr lr 1 u2 ls2)) ; grow it up to be T. + ((st end-st) (merge! s ends t endt))) ; Merge S & T, + (grow st end-st (+ ls lt) (+ ls2 ls2) u3 lw)) ; then loop. + + (values s ends ls u))) ; Done -- met LW quota or ran out of data. + + ;; Note: (LENGTH LIS) or any constant guaranteed + ;; to be greater can be used in place of INFINITY. + (if (pair? lis) + (mlet (((lr endr rest) (getrun lis)) ; Pick off an initial run. + ((infinity) #o100000000) ; Then grow it up maximally. + ((a enda la v) (grow lis endr lr 1 rest infinity))) + (set-cdr! enda '()) ; Nil-terminate answer. + a) ; We're done. + + '())) ; Don't sort an empty list. + + +;;; Merge +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; These two merge procedures are stable -- ties favor list A. + +(define (list-merge < a b) + (cond ((not (pair? a)) b) + ((not (pair? b)) a) + (else (let recur ((x (car a)) (a a) ; A is a pair; X = (CAR A). + (y (car b)) (b b)) ; B is a pair; Y = (CAR B). + (if (< y x) + + (let ((b (cdr b))) + (if (pair? b) + (cons y (recur x a (car b) b)) + (cons y a))) + + (let ((a (cdr a))) + (if (pair? a) + (cons x (recur (car a) a y b)) + (cons x b)))))))) + + +;;; This destructive merge does as few SET-CDR!s as it can -- for example, if +;;; the list is already sorted, it does no SET-CDR!s at all. It is also +;;; iterative, running in constant stack. + +(define (list-merge! < a b) + ;; The logic of these two loops is completely driven by these invariants: + ;; SCAN-A: (CDR PREV) = A. X = (CAR A). Y = (CAR B). + ;; SCAN-B: (CDR PREV) = B. X = (CAR A). Y = (CAR B). + (letrec ((scan-a (lambda (prev a x b y) ; Zip down A doing + (if (< y x) ; no SET-CDR!s until + (let ((next-b (cdr b))) ; we hit a B elt that + (set-cdr! prev b) ; has to be inserted. + (if (pair? next-b) + (scan-b b a x next-b (car next-b)) + (set-cdr! b a))) + + (let ((next-a (cdr a))) + (if (pair? next-a) + (scan-a a next-a (car next-a) b y) + (set-cdr! a b)))))) + + (scan-b (lambda (prev a x b y) ; Zip down B doing + (if (< y x) ; no SET-CDR!s until + (let ((next-b (cdr b))) ; we hit an A elt that + (if (pair? next-b) ; has to be + (scan-b b a x next-b (car next-b)) ; inserted. + (set-cdr! b a))) + + (let ((next-a (cdr a))) + (set-cdr! prev a) + (if (pair? next-a) + (scan-a a next-a (car next-a) b y) + (set-cdr! a b))))))) + + (cond ((not (pair? a)) b) + ((not (pair? b)) a) + + ;; B starts the answer list. + ((< (car b) (car a)) + (let ((next-b (cdr b))) + (if (null? next-b) + (set-cdr! b a) + (scan-b b a (car a) next-b (car next-b)))) + b) + + ;; A starts the answer list. + (else (let ((next-a (cdr a))) + (if (null? next-a) + (set-cdr! a b) + (scan-a a next-a (car next-a) b (car b)))) + a)))) + + +;;; Copyright +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This code is +;;; Copyright (c) 1998 by Olin Shivers. +;;; The terms are: You may do as you please with this code, as long as +;;; you do not delete this notice or hold me responsible for any outcome +;;; related to its use. +;;; +;;; Blah blah blah. + + +;;; Code tuning & porting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This is very portable code. It's R4RS with the following exceptions: +;;; - The R5RS multiple-value VALUES & CALL-WITH-VALUES procedures for +;;; handling multiple-value return. +;;; +;;; This code is *tightly* bummed as far as I can go in portable Scheme. +;;; +;;; - The fixnum arithmetic in LIST-MERGE-SORT! and COUNTED-LIST-MERGE! +;;; that could be safely switched over to unsafe, fixnum-specific ops, +;;; if you're sure that 2*maxlen is a fixnum, where maxlen is the length +;;; of the longest list you could ever have. +;;; +;;; - I typically write my code in a style such that every CAR and CDR +;;; application is protected by an upstream PAIR?. This is the case in this +;;; code, so all the CAR's and CDR's could safely switched over to unsafe +;;; versions. But check over the code before you do it, in case the source +;;; has been altered since I wrote this. diff --git a/scheme/sort/packages.scm b/scheme/sort/packages.scm new file mode 100644 index 0000000..24b7133 --- /dev/null +++ b/scheme/sort/packages.scm @@ -0,0 +1,71 @@ +;;; Package defs for the Scheme Underground sorting package, +;;; in the Scheme 48 module language. + +;;; The general sort package: + +(define-structure sort sort-interface + (open scheme + list-merge-sort + vector-heap-sort + vector-merge-sort + sorted + delete-neighbor-duplicates) + (files sort) + (optimize auto-integrate)) + +(define-structure sorted sorted-interface + (open scheme + vector-utils) + (files sortp) + (optimize auto-integrate)) + +(define-structure delete-neighbor-duplicates delete-neighbor-duplicates-interface + (open scheme + receiving + formats + vector-utils) + (files delndups) + (optimize auto-integrate)) + +(define-structure binary-searches binary-searches-interface + (open scheme + vector-utils) + (files vbinsearch)) + +(define-structure list-merge-sort list-merge-sort-interface + (open scheme + receiving + (subset signals (error))) + (files lmsort) + (optimize auto-integrate)) + +(define-structure vector-merge-sort vector-merge-sort-interface + (open scheme + receiving + vector-utils + vector-insertion-sort-internal) + (files vmsort) + (optimize auto-integrate)) + +(define-structure vector-heap-sort vector-heap-sort-interface + (open scheme + receiving + vector-utils) + (files vhsort) + (optimize auto-integrate)) + +(define-structures ((vector-insertion-sort vector-insertion-sort-interface) + (vector-insertion-sort-internal + vector-insertion-sort-internal-interface)) + (open scheme + vector-utils) + (files visort) + (optimize auto-integrate)) + +(define-structure vector-utils (export vector-copy + vector-portion-copy + vector-portion-copy! + vector-start+end + vectors-start+end-2) + (open scheme) + (files vector-util)) diff --git a/scheme/sort/sort.scm b/scheme/sort/sort.scm new file mode 100644 index 0000000..a0933e2 --- /dev/null +++ b/scheme/sort/sort.scm @@ -0,0 +1,26 @@ +;;; The SRFI-32 sort package -- general sort & merge procedures +;;; +;;; Copyright (c) 1998 by Olin Shivers. +;;; You may do as you please with this code, as long as you do not delete this +;;; notice or hold me responsible for any outcome related to its use. +;;; Olin Shivers 10/98. + +;;; This file just defines the general sort API in terms of some +;;; algorithm-specific calls. + +(define (list-sort < l) ; Sort lists by converting to + (let ((v (list->vector l))) ; a vector and sorting that. + (heap-sort! < v) + (vector->list v))) + +(define list-sort! list-merge-sort!) + +(define list-stable-sort list-merge-sort) +(define list-stable-sort! list-merge-sort!) + +(define vector-sort heap-sort) +(define vector-sort! heap-sort!) + +(define vector-stable-sort vector-merge-sort) +(define vector-stable-sort! vector-merge-sort!) + diff --git a/scheme/sort/sort.txt b/scheme/sort/sort.txt new file mode 100644 index 0000000..b514fc7 --- /dev/null +++ b/scheme/sort/sort.txt @@ -0,0 +1,1056 @@ +The SRFI-32 sort libraries -*- outline -*- +Olin Shivers +First draft: 1998/10/19 +Last update: 2002/7/21 + +[Todo: del-list-neighbor-dups! + vector-copy -> subvector + use srfi-23 for reporting errors + use srfi-16 for n-aries? + +Emacs should display this document in outline mode. Say c-h m for +instructions on how to move through it by sections (e.g., c-c c-n, c-c c-p). + +* Table of contents +------------------- +Abstract +Procedure index +Introduction +What's wrong with the current state of affairs? +Design rules + What vs. how + Consistency across function signatures + Data parameter first, less-than parameter after + Ordering, comparison functions & stability + All vector operations accept optional subrange parameters + Required vs. allowed side-effects +Procedure specification + Procedure naming and functionality + Types of parameters and return values + sort-lib - general sorting package + Algorithm-specific sorting packages +Algorithmic properties +Topics to be resolved during discussion phase +Porting and optimisation +References & Links +Acknowledgements +Copyright + + +* Abstract +---------- +Current Scheme sorting packages are, every one of them, surprisingly bad. I've +designed the API for a full-featured sort toolkit, which I propose as a SRFI. + +The spec comes with 1200 lines of high-quality reference code: tightly +written, highly commented, portable code, available for free. Implementors +want this code. It's better than what you have. + +------------------------------------------------------------------------------- +* Procedure index +----------------- +list-sorted? vector-sorted? + +list-merge vector-merge +list-sort vector-sort +list-stable-sort vector-stable-sort +list-delete-neighbor-dups vector-delete-neighbor-dups + +list-merge! vector-merge! +list-sort! vector-sort! +list-stable-sort! vector-stable-sort! +list-delete-neighbor-dups! vector-delete-neighbor-dups! + +quick-sort heap-sort insert-sort list-merge-sort vector-merge-sort +quick-sort! heap-sort! insert-sort! list-merge-sort! vector-merge-sort! +quick-sort3! + +vector-binary-search +vector-binary-search3 + +------------------------------------------------------------------------------- +* Introduction +-------------- +As I'll detail below, I wasn't very happy with the state of the Scheme +world for sorting and merging lists and vectors. So I have designed and +written a fairly comprehensive sorting & merging toolkit. It is + + - very portable, + + - much better code than what is currently in Elk, Gambit, Bigloo, + Scheme->C, MzScheme, RScheme, Scheme48, MIT Scheme, or slib, and + + - priced to move: free code. + +The package includes + - Vector insert sort (stable) + - Vector heap sort + - Vector quick sort (with median-of-3 pivot picking) + - Vector merge sort (stable) + - Pure and destructive list merge sort (stable) + - Stable vector and list merge + - Miscellaneous sort-related procedures: Vector and list merging, + sorted? predicates, vector binary search, vector and list + delete-equal-neighbor procedures. + - A general, non-algorithmic set of procedure names for general sorting + and merging. + +Scheme programmers may want to adopt this package. I'd like Scheme +implementors to adopt this code and its API -- in fact, the code is a bribe to +make it easy for implementors to converge on the suggested API. I mean, you'd +really have to be a boor to take this free code I wrote and mutate its +interface over to your incompatible, unportable API, wouldn't you? But you +could, of course -- it's freely available. More in the spirit of the offering, +you could make this API available, and then also write a little module +providing your old interface that is defined in terms of this API. "Scheme +implementors," in this context, includes slib, which is not a standalone +implementation of Scheme, but rather an influential collection of API's and +code. + +The code is tightly bummed. It is clearly written, and commented in my usual +voluminous style. This includes notes on porting and implementation-specific +optimisations. + + +------------------------------------------------------------------------------- +* What's wrong with the current state of affairs? +------------------------------------------------- + +It's just amazing to me that in 2002, sorting and merging hasn't been +completely put to bed. These are well-understood algorithms, each of them well +under a page of code. The straightforward algorithms are basic, core stuff -- +sophomore-level. But if you tour the major Scheme implementations out there on +the Net, you find badly written code that provides extremely spotty coverage +of the algorithm space. One implementation even has a buggy implementation +that has been in use for about 20 years. Another has an O(n^2) algorithm... +implemented in C for speed. + +Open source-code is a wonderful thing. In a couple of hours, I was able to +download and check the sources of 9 Scheme systems. Here are my notes from the +systems I checked. You can skip to the next section if you aren't morbidly +curious. + +slib + sorted? vector-or-list < + merge list1 list2 < + merge! list1 list2 < + sort vector-or-list < + sort! vector-or-list < + + Richard O'Keefe's stable list merge sort is right idea, but implemented + using gratuitous variable side effects. It also does redundant SET-CDR!s. + The vector sort converts to list, merge sorts, then reconverts + to vector. This is a bad idea -- non-local pointer chasing bad; vector + shuffling good. If you must allocate temp storage, might as well allocate + a temp vector and use vector merge sort. + +MIT Scheme + sort! vector < + merge-sort! vector < + quick-sort! vector < + + sort vector-or-list < + merge-sort vector-or-list < + quick-sort vector-or-list < + + Naive vector quicksort: loser, for worst-case performance reasons. + List sort by "list->vector; quicksort; vector->list," hence also loser. + A clever stable vector merge sort, albeit not very bummed. + +Scheme 48 & T + sort-list list < + sort-list! list < + list-merge! list1 list2 < + + Bob Nix's implementation of online merge-sort, written in the early 80's. + Conses unnecessary bookkeeping structure, which isn't necessary with a + proper recursive formulation. Also, does redundant SET-CDR!s. No vector + sort. Also, has a bug -- is claimed to be a stable sort, but isn't! To see + this, get the S48 code, and try + (define (my< x y) (< (abs x) (abs y))) + (list-merge! (list 0 2) (list -2) my<) ; -> (0 2 -2) + (list-merge! (list 2) (list 0 -2) my<) ; -> (0 -2 2) + This could be fixed very easily, but it isn't worth it given the + other problems with the algorithm. + +RScheme + vector-sort! vector < + sort collection < + + Good basic implementation of vector heapsort, which has O(n lg n) + worst-case time. Code ugly, needs tuning. List sort by "list->vector; + sort; vector->list." Nothing for stable sorting. + +MzScheme + quicksort lis < + mergesort alox < + + Sorts lists with (list->vector; quicksort; vector->list) -- but the core + quicksort is not available for vector sorting. Nothing for stable sorting. + Quicksort picks pivot naively, inducing O(n^2) worse-case behaviour on a + fairly common case: an already-sorted list. + +Bigloo, STK + sort vector-or-list < + Uses an O(n^2) algorithm... implemented in C for speed. Hmm. + (See runtime/Ieee/vector.scm and runtime/Clib/cvector.c) + +Gambit + sort-list list < + Nothing for vectors. Simple, slow, unstable merge sort for lists. + +Elk + Another naive quicksort. Lists handled by converting to vector. + sort vector-or-list < + sort! vector-or-list < + +Chez Scheme + merge < list1 list2 + merge! < list1 list2 + sort < list + sort! < list + + These are stable. I have not seen the source code. + +Common Lisp + sort sequence < [key] + stable-sort sequence < [key] + merge result-type sequence1 sequence2 < [key] + + The sort procedures are allowed, but not required, to be destructive. + +SML/NJ + sort: ('a*'a -> bool) -> 'a list -> 'a list + "Smooth applicative merge sort," which is stable. + There is also a highly bummed quicksort for vectors. + +The right solution: Implement a full toolbox of carefully written standard sort +routines. + +Having the source of all these above-cited Schemes available for study made +life a lot easier writing this code. I appreciate the authors making their +source available under such open terms. + + +------------------------------------------------------------------------------- +* Design rules +-------------- + +** What vs. how +=============== +There are two different interfaces: "what" (simple) & "how" (detailed). + + - Simple: you specify semantics: datatype (list or vector), + mutability, and stability. + + - Detailed: you specify the actual algorithm (quick, heap, + insert, merge). Different algorithms have different properties, + both semantic & pragmatic, so these exports are necessary. + + It is necessarily the case that the specifications of these procedures + make statements about execution "pragmatics." For example, the sole + distinction between heap sort and quick sort -- both of which are + provided by this library -- is one of execution time, which is not a + "semantic" distinction. Similar resource-use statements are made about + "iterative" procedures, meaning that they can execute on input of + arbitrary size in a constant number of stack frames. + +** Consistency across function signatures +========================================= +The two interfaces share common function signatures wherever +possible, to facilitate switching a given call from one procedure +to another. + +** Less-than parameter first, data parameter after +================================================== +These procedures uniformly observe the following parameter order: +the data to be sorted comes after the comparison function. +That is, we write + (sort < lis) +not + (sort lis <). + +With the sole exception of Chez Scheme, this is the exact opposite of +every sort function out there in current use in the Scheme world. (See +the summary of related APIs above.) However, it is consistent with common +practice across Scheme libraries in general to put the ordering function +first -- the "operation currying" convention. (E.g., consider FOR-EACH or +MAP or FIND.) + +The original draft of this SRFI used the data-first/comparison-last convention +for backwards compatibility -- a decision I made with internal misgivings. +Happily, however, the overwhelming response from the discussion phase +supported "cleaning up" this issue and re-converging the parameter order with +the general Scheme "op currying" convention. So the original decision was +inverted in favor of the comparison-first/data-last convention. + +** Ordering, comparison functions & stability +============================================= +These routines take a < comparison function, not a <= comparison +function, and they sort into increasing order. The difference between +a < spec and a <= spec comes up in three places: + - the definition of an ordered or sorted data set, + - the definition of a stable sorting algorithm, and + - correctness of quicksort. + ++ We say that a data set (a list or vector) is *sorted* or *ordered* + if it contains no adjacent pair of values ... X Y ... such that Y < X. + + In other words, scanning across the data never takes a "downwards" step. + + If you use a <= procedure where these algorithms expect a < + procedure, you may not get the answers you expect. For example, + the LIST-SORTED? function will return false if you pass it a <= comparison + function and an ordered list containing adjacent equal elements. + ++ A "stable" sort is one that preserves the pre-existing order of equal + elements. Suppose, for example, that we sort a list of numbers by + comparing their absolute values, i.e., using comparison function + (lambda (x y) (< (abs x) (abs y))) + If we sort a list that contains both 3 and -3: + ... 3 ... -3 ... + then a stable sort is an algorithm that will not swap the order + of these two elements, that is, the answer is guaranteed to to look like + ... 3 -3 ... + not + ... -3 3 ... + + Choosing < for the comparison function instead of <= affects how stability + is coded. Given an adjacent pair X Y, (< y x) means "Y should be moved in + front of X" -- otherwise, leave things as they are. So using a <= function + where a < function is expected will *invert* stability. + + This is due to the definition of equality, given a < comparator: + (and (not (< x y)) + (not (< y x))) + The definition is rather different, given a <= comparator: + (and (<= x y) + (<= y x)) + ++ A "stable" merge is one that reliably favors one of its data sets + when equal items appear in both data sets. *All merge operations in + this library are stable*, breaking ties between data sets in favor + of the first data set -- elements of the first list come before equal + elements in the second list. + + So, if we are merging two lists of numbers ordered by absolute value, + the stable merge operation LIST-MERGE + (list-merge (lambda (x y) (< (abs x) (abs y))) + '(0 -2 4 8 -10) '(-1 3 -4 7)) + reliably places the 4 of the first list before the equal-comparing -4 + of the second list: + (0 -1 -2 4 -4 7 8 -10) + ++ Some sort algorithms will *not work correctly* if given a <= when they + expect a < comparison (or vice-versa). For example, violating quicksort's + spec may cause it to produce wrong answers, diverge, raise an error, or do + some fourth thing. To see why, consider the left-scan part of the standard + quicksort partition step: + (let ((i (let scan ((i i)) (if (elt< (vector-ref v i) pivot) + (scan (+ i 1)) + i)))) + ...) + Consider applying this loop to a vector of all zeroes (hence, PIVOT, as + well, is zero), but erroneously using <= for the ELT< function. The loop + will scan right off the end of the vector, producing a vector-index error. + The guarantee that the scan loop will terminate before running off the end + of the vector depends critically upon ELT< performing as a true, irreflexive + < relation. Running off the end of the vector is only one of a variety of + possibly ways to lose -- other, variant implementations of quicksort can, + instead, loop forever on some data sets if ELT< is a <= predicate. + +In short, if your comparison function F answers true to (F x x), then + - using a stable sorting or merging algorithm will not give you a + stable sort or merge, + - LIST-SORTED? may surprise you, and + - quicksort may fail in a variety of possible ways. +Note that you can synthesize a < function from a <= function with + (lambda (x y) (not (<= y x))) +if need be. + +Precise definitions give sharp edges to tools, but require care in use. +"Measure twice, cut once." + +I have adopted the choice of < from Common Lisp. One would assume the definers +of Common Lisp had a good reason for adopting < instead of <=, but canvassing +several of the principal actors in the definition process has turned up no +better reason than "an arbitrary but consistent choice." At minimum, then, +this SRFI extends the coverage of that consistent choice. + +** All vector operations accept optional subrange parameters +============================================================ +The vector operations specified below all take optional START/END arguments +indicating a selected subrange of a vector's elements. If a START parameter or +START/END parameter pair is given to such a procedure, they must be exact, +non-negative integers, such that + 0 <= START <= END <= (VECTOR-LENGTH V) +where V is the related vector parameter. If not specified, they default to 0 +and the length of the vector, respectively. They are interpreted to select the +range [START,END), that is, all elements from index START (inclusive) up to, +but not including, index END. + +** Required vs. allowed side-effects +==================================== +LIST-SORT! and LIST-STABLE-SORT! are allowed, but not required, +to alter their arguments' cons cells to construct the result list. This is +consistent with the what-not-how character of the group of procedures +to which they belong (the "sort-lib" package). + +The LIST-DELETE-NEIGHBOR-DUPS!, LIST-MERGE! and LIST-MERGE-SORT! procedures, +on the other hand, provide specific algorithms, and, as such, explicitly +commit to the use of side-effects on their input lists in order to guarantee +their key algorithmic properties (e.g., linear-time operation, constant-space +stack use). + +------------------------------------------------------------------------------- +* Procedure specification +------------------------- +The procedures are split into several packages. In a Scheme system that has a +module or package system, these procedures should be contained in modules +named as follows: + Package name Functionality + ------------ ------------- + sort-lib General sorting for lists & vectors + sorted?-lib Sorted predicates for lists & vectors + list-merge-sort-lib List merge sort + vector-merge-sort-lib Vector merge sort + vector-heap-sort-lib Vector heap sort + vector-quick-sort-lib Vector quick sort + vector-insert-sort-lib Vector insertion sort + delndup-lib List and vector delete neighbor duplicates + binsearch-lib Vector binary search + +A Scheme system without a module system should provide all of the bindings +defined in all of these modules as components of the "SRFI-32" package. + +Note that there is no "list insert sort" package, as you might as well always +use list merge sort. The reference implementation's destructive list merge +sort will do fewer SET-CDR!s than a destructive insert sort. + +** Procedure naming and functionality +===================================== +Almost all of the procedures described below are variants of two basic +operations: sorting and merging. These procedures are consistently named +by composing a set of basic lexemes to indicate what they do. + +Lexeme Meaning +------ ------- +"sort" The procedure sorts its input data set by some < comparison function. + +"merge" The procedure merges two ordered data sets into a single ordered + result. + +"stable" This lexeme indicates that the sort is a stable one. + +"vector" The procedure operates upon vectors. + +"list" The procedure operates upon lists. + +"!" Procedures that end in "!" are allowed, and sometimes required, + to reuse their input storage to construct their answer. + +** Types of parameters and return values +======================================== +In the procedures specified below, + - A LIS parameter is a list; + + - A V parameter is a vector; + + - A < or = parameter is a procedure accepting two arguments taken from the + specified procedure's data set(s), and returning a boolean; + + - START and END parameters are exact, non-negative integers that + serve as vector indices selecting a subrange of some associated vector. + When specified, they must satisfy the relation + 0 <= start <= end <= (vector-length v) + where V is the associated vector. + +Passing values to procedures with these parameters that do not satisfy these +types is an error. + +If a procedure is said to return "unspecified," this means that nothing at all +is said about what the procedure returns, not even the number of return +values. Such a procedure is not even required to be consistent from call to +call in the nature or number of its return values. It is simply required to +return a value (or values) that may be passed to a command continuation, e.g. +as the value of an expression appearing as a non-terminal subform of a BEGIN +expression. Note that in R5RS, this restricts such a procedure to returning a +single value; non-R5RS systems may not even provide this restriction. + +** sort-lib - general sorting package +===================================== +This library provides basic sorting and merging functionality suitable for +general programming. The procedures are named by their semantic properties, +i.e., what they do to the data (sort, stable sort, merge, and so forth). + + Procedure Suggested algorithm + ------------------------------------------------------------------------- + list-sorted? < lis -> boolean + list-merge < lis1 lis2 -> list + list-merge! < lis1 lis2 -> list + list-sort < lis -> list (vector heap or quick) + list-sort! < lis -> list (list merge sort) + list-stable-sort < lis -> list (vector merge sort) + list-stable-sort! < lis -> list (list merge sort) + list-delete-neighbor-dups = lis -> list + list-delete-neighbor-dups! = lis -> list + + vector-sorted? < v [start end] -> boolean + vector-merge < v1 v2 [start1 end1 start2 end2] -> vector + vector-merge! < v v1 v2 [start start1 end1 start2 end2] -> unspecified + vector-sort < v [start end] -> vector (heap or quick sort) + vector-sort! < v [start end] -> unspecified (heap or quick sort) + vector-stable-sort < v [start end] -> vector (vector merge sort) + vector-stable-sort! < v [start end] -> unspecified (vector merge sort) + vector-delete-neighbor-dups = v [start end] -> vector + vector-delete-neighbor-dups! = target source [t-start s-start s-end] -> t-end + + LIST-SORTED? and VECTOR-SORTED? return true if their input list or vector + is in sorted order, as determined by their < comparison parameter. + + All four merge operations are stable: an element of the initial list LIS1 + or vector V1 will come before an equal-comparing element in the second + list LIS2 or vector V2 in the result. + + The procedures + LIST-MERGE + LIST-SORT + LIST-STABLE-SORT + LIST-DELETE-NEIGHBOR-DUPS + do not alter their inputs and are allowed to return a value that shares + a common tail with a list argument. + + The procedures + LIST-SORT! + LIST-STABLE-SORT! + are "linear update" operators -- they are allowed, but not required, to + alter the cons cells of their arguments to produce their results. + + On the other hand, the procedures + LIST-DELETE-NEIGHBOR-DUPS! + LIST-MERGE! + make only a single, iterative, linear-time pass over their argument lists, + using SET-CDR!s to rearrange the cells of the lists into the final result + -- they work "in place." Hence, any cons cell appearing in the result must + have originally appeared in an input. The intent of this + iterative-algorithm commitment is to allow the programmer to be sure that + if, for example, LIST-MERGE! is asked to merge two ten-million-element + lists, the operation will complete without performing some extremely + (possibly twenty-million) deep recursion. + + The vector procedures + VECTOR-SORT + VECTOR-STABLE-SORT + VECTOR-DELETE-NEIGHBOR-DUPS + do not alter their inputs, but allocate a fresh vector for their result, + of length END - START. + + The vector procedures + VECTOR-SORT! + VECTOR-STABLE-SORT! + sort their data in-place. (But note that VECTOR-STABLE-SORT! may + allocate temporary storage proportional to the size of the input -- + I am not aware of O(n lg n) stable vector-sorting algorithms that + run in constant space.) + + VECTOR-MERGE returns a vector of length (END1-START1)+(END2-START2). + + VECTOR-MERGE! writes its result into vector V, beginning at index START, + for indices less than END = START + (END1-START1) + (END2-START2). The + target subvector + V[start,end) + may not overlap either source subvector + V1[start1,end1) + V2[start2,end2). + + The ...-DELETE-NEIGHBOR-DUPS-... procedures: + These procedures delete adjacent duplicate elements from a list or a + vector, using a given element-equality procedure. The first/leftmost + element of a run of equal elements is the one that survives. The list or + vector is not otherwise disordered. + + These procedures are linear time -- much faster than the O(n^2) general + duplicate-element deletors that do not assume any "bunching" of elements + (such as the ones provided by SRFI-1). If you want to delete duplicate + elements from a large list or vector, you can sort the elements to bring + equal items together, then use one of these procedures, for a total time + of O(n lg n). + + The comparison function = passed to these procedures is always applied + (= x y) + where X comes before Y in the containing list or vector. + + - LIST-DELETE-NEIGHBOR-DUPS does not alter its input list; its answer + may share storage with the input list. + + - VECTOR-DELETE-NEIGHBOR-DUPS does not alter its input vector, but + rather allocates a fresh vector to hold the result. + + - LIST-DELETE-NEIGHBOR-DUPS! is permitted, but not required, to + mutate its input list in order to construct its answer. + + - VECTOR-DELETE-NEIGHBOR-DUPS! reuses its input vector to hold the + answer, packing its answer into the index range [start,end'), where + END' is the non-negative exact integer returned as its value. It + returns END' as its result. The vector is not altered outside the range + [start,end'). + + - VECTOR-DELETE-NEIGHBOR-DUPS! scans vector SOURCE in range + [S-START,S-END), writing its result to vector TARGET beginning at index + T-START. It returns exact, non-negative integer T-END, which indicates + that the results of the operation are found in index range + [T-START,T-END) of TARGET; elements of TARGET outside this range + are unaltered. + + It is an error for memory cell TARGET[T-START] to be a memory cell in + the region SOURCE[1 + S-START, S-END). In a Scheme implementation + that does not allow distinct vectors to share storage, this means + that one of the following must be true: + 1. (not (eq? source target)) + 2. t-start not-in [s-start + 1, s-end) + + - Examples: + (list-delete-neighbor-dups = '(1 1 2 7 7 7 0 -2 -2)) + => (1 2 7 0 -2) + + (vector-delete-neighbor-dups = '#(1 1 2 7 7 7 0 -2 -2)) + => #(1 2 7 0 -2) + + (vector-delete-neighbor-dups = '#(1 1 2 7 7 7 0 -2 -2) 3 7) + => #(7 0 -2) + + ;; Result left in v[3,9): + (let ((v (vector 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6))) + (cons (vector-delete-neighbor-dups! = v 3) + v)) + => (9 . #(0 0 0 1 2 3 4 5 6 4 4 5 5 6 6)) + + +** Algorithm-specific sorting packages +====================================== +These packages provide more specific sorting functionality, that is, +specific committment to particular algorithms that have particular +pragmatic consequences (such as memory locality, asymptotic running time) +beyond their semantic behaviour (sorting, stable sorting, merging, etc.). +Programmers that need a particular algorithm can use one of these packages. + +sorted?-lib - sorted predicates + list-sorted? < lis -> boolean + vector-sorted? < v [start end] -> boolean + + Return #f iff there is an adjacent pair ... X Y ... in the input + list or vector such that Y < X. The optional START/END range + arguments restrict VECTOR-SORTED? to the indicated subvector. + +list-merge-sort-lib - list merge sort + list-merge-sort < lis -> list + list-merge-sort! < lis -> list + list-merge lis1 < lis2 -> list + list-merge! lis1 < lis2 -> list + + The sort procedures sort their data using a list merge sort, which is + stable. (The reference implementation is, additionally, a "natural" sort. + See below for the properties of this algorithm.) + + The ! procedures are destructive -- they use SET-CDR!s to rearrange the + cells of the lists into the proper order. As such, they do not allocate + any extra cons cells -- they are "in place" sorts. Additionally, + LIST-MERGE! is iterative -- it can operate on arguments of arbitrary size + with a constant number of stack frames. + + The merge operations are stable: an element of LIS1 will come before an + equal-comparing element in LIS2 in the result list. + +vector-merge-sort-lib - vector merge sort + vector-merge-sort < v [start end temp] -> vector + vector-merge-sort! < v [start end temp] -> unspecified + vector-merge < v1 v2 [start1 end1 start2 end2] -> vector + vector-merge! < v v1 v2 [start start1 end1 start2 end2] -> unspecified + + The sort procedures sort their data using vector merge sort, which is + stable. (The reference implementation is, additionally, a "natural" sort. + See below for the properties of this algorithm.) + + The optional START/END arguments provide for sorting of subranges, and + default to 0 and the length of the corresponding vector. + + Merge-sorting a vector requires the allocation of a temporary "scratch" + work vector for the duration of the sort. This scratch vector can be + passed in by the client as the optional TEMP argument; if so, the supplied + vector must be of size >= END, and will not be altered outside the range + [start,end). If not supplied, the sort routines allocate one themselves. + + The merge operations are stable: an element of V1 will come before an + equal-comparing element in V2 in the result vector. + + VECTOR-MERGE-SORT! leaves its result in V[start,end). + + VECTOR-MERGE-SORT returns a vector of length END-START. + + VECTOR-MERGE returns a vector of length (END1-START1)+(END2-START2). + + VECTOR-MERGE! writes its result into vector V, beginning at index START, + for indices less than END = START + (END1-START1) + (END2-START2). The + target subvector + V[start,end) + may not overlap either source subvector + V1[start1,end1) + V2[start2,end2). + +vector-heap-sort-lib - vector heap sort + heap-sort < v [start end] -> vector + heap-sort! < v [start end] -> unspecified + + These procedures sort their data using heap sort, + which is not a stable sorting algorithm. + + HEAP-SORT returns a vector of length END-START. + HEAP-SORT! is in-place, leaving its result in V[start,end). + +vector-quick-sort-lib - vector quick sort + quick-sort < v [start end] -> vector + quick-sort! < v [start end] -> unspecified + quick-sort3! c v [start end] -> unspecified + + These procedures sort their data using quick sort, + which is not a stable sorting algorithm. + + QUICK-SORT returns a vector of length END-START. + QUICK-SORT! is in-place, leaving its result in V[start,end). + + QUICK-SORT3! is a variant of quick-sort that takes a three-way + comparison function C. C compares a pair of elements and returns + an exact integer whose sign indicates their relationship: + (c x y) < 0 => x x=y + (c x y) > 0 => x>y + To help remember the relationship between the sign of the result and + the relation, use the function - as the model for C: (- x y) < 0 + means that x < y; (- x y) > 0 means that x > y. + + The extra discrimination provided by the three-way comparison can + provide significant speedups when sorting data sets with many duplicates, + especially when the comparison function is relatively expensive (e.g., + comparing long strings). + + WARNING: Some sort algorithms, such as insertion sort or heap sort, + can tolerate being passed a <= comparison function when they expect a < + function -- insertion and merge sort may simply invert stability; and + heap sort will run a bit slower, but otherwise produce a correct answer. + + Quicksort, however, is much more critically sensitive to the distinction + between a < and a <= comparison. If QUICK-SORT or QUICK-SORT! expect a < + comparison function, and are erroneously given a <= function, they may, + depending on implementation, produce an unsorted result, go into an + infinite loop, cause a run-time error, occasionally produce a correct + result, or do some fifth thing. + + Implementors may wish to write QUICKSORT3! so that it (a) tests the + comparison function (by checking that (c v[start] v[start]) produces + false), or (b) is tolerant of an erroneous <= function, or (c) both. + Clients of this function, however, should not count on this. + +vector-insert-sort-lib - vector insertion sort + insert-sort < v [start end] -> vector + insert-sort! < v [start end] -> unspecified + + These procedures stably sort their data using insertion sort. + + INSERT-SORT returns a vector of length END-START. + INSERT-SORT! is in-place, leaving its result in V[start,end). + +delndup-lib - list and vector delete neighbor duplicates + list-delete-neighbor-dups = lis -> list + list-delete-neighbor-dups! = lis -> list + + vector-delete-neighbor-dups = v [start end] -> vector + vector-delete-neighbor-dups! = v [start end] -> end' + + These procedures delete adjacent duplicate elements from a list or + a vector, using a given element-equality procedure =. The first/leftmost + element of a run of equal elements is the one that survives. The list + or vector is not otherwise disordered. + + These procedures are linear time -- much faster than the O(n^2) general + duplicate-element deletors that do not assume any "bunching" of elements + (such as the ones provided by SRFI-1). If you want to delete duplicate + elements from a large list or vector, you can sort the elements to bring + equal items together, then use one of these procedures, for a total time + of O(n lg n). + + The comparison function = passed to these procedures is always applied + (= x y) + where X comes before Y in the containing list or vector. + + LIST-DELETE-NEIGHBOR-DUPS does not alter its input list; its answer + may share storage with the input list. + + VECTOR-DELETE-NEIGHBOR-DUPS does not alter its input vector, but + rather allocates a fresh vector to hold the result. + + LIST-DELETE-NEIGHBOR-DUPS! is permitted, but not required, to + mutate its input list in order to construct its answer. + + VECTOR-DELETE-NEIGHBOR-DUPS! reuses its input vector to hold the + answer, packing its answer into the index range [start,end'), where + END' is the non-negative exact integer returned as its value. It + returns END' as its result. The vector is not altered outside the range + [start,end'). + + Examples: + (list-delete-neighbor-dups = '(1 1 2 7 7 7 0 -2 -2)) + => (1 2 7 0 -2) + + (vector-delete-neighbor-dups = '#(1 1 2 7 7 7 0 -2 -2)) + => #(1 2 7 0 -2) + + (vector-delete-neighbor-dups = '#(1 1 2 7 7 7 0 -2 -2) 3 7) + => #(7 0 -2) + + ;; Result left in v[3,9): + (let ((v (vector 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6))) + (cons (vector-delete-neighbor-dups! = v 3) + v)) + => (9 . #(0 0 0 1 2 3 4 5 6 4 4 5 5 6 6)) + +binsearch-lib - vector binary search lib + vector-binary-search elt< elt->key key v [start end] -> integer-or-false + vector-binary-search3 c v [start end] -> integer-or-false + + VECTOR-BINARY-SEARCH searches vector V in range [START,END) (which + default to 0 and the length of V, respectively) for an element whose + associated key is equal to KEY. The procedure ELT->KEY is used to map + an element to its associated key. The elements of the vector are assumed + to be ordered by the ELT< relation on these keys. That is, + (vector-sorted? (lambda (x y) (elt< (elt->key x) (elt->key y))) + v start end) => true + An element E of V is a match for KEY if it's neither less nor greater + than the key: + (and (not (elt< (elt->key e) key)) + (not (elt< key (elt->key e)))) + If there is such an element, the procedure returns its index in the + vector as an exact integer. If there is no such element in the searched + range, the procedure returns false. + + (vector-binary-search < car 4 '#((1 . one) (3 . three) + (4 . four) (25 . twenty-five))) + => 2 + + (vector-binary-search < car 7 '#((1 . one) (3 . three) + (4 . four) (25 . twenty-five))) + => #f + + VECTOR-BINARY-SEARCH3 is a variant that uses a three-way comparison + function C. C compares its parameter to the search key, and returns an + exact integer whose sign indicates its relationship to the search key. + (c x) < 0 => x < search-key + (c x) = 0 => x = search-key + (c x) > 0 => x > search-key + + (vector-binary-search3 (lambda (elt) (- (car elt) 4)) + '#((1 . one) (3 . three) + (4 . four) (25 . twenty-five))) + => 2 + + Rationale: + - Why isn't VECTOR-BINARY-SEARCH's ELT->KEY computation simply absorbed + into the < function? It is separated out because the < function is + applied twice inside the binary-search inner loop, once with the search + key for the first argument and the element key for the second argument, + and once, with the reverse argument order. This is not necessary for + VECTOR-BINARY-SEARCH3. + + - When a comparison operation is able to produce a three-way + discrimination, the inner loop of the binary search can trim the number + of per-iteration comparisons from an average of 1.5 to a guaranteed + single comparison per iteration. This can be a significant savings when + searching with an expensive comparison operation (e.g., one that + uses string compare, sends email, references a database, or queries + a network service such as a web server). + + - Failure is signaled by false (rather than, say, -1) so that searches + can be used in conditional forms such as + (or (vector-binary-search ...) ...) + or + (cond ((vector-binary-search ...) => index-consumer) + ...) + +------------------------------------------------------------------------------- +* Algorithmic properties +------------------------ +Different sort and merge algorithms have different properties. +Choose the algorithm that matches your needs: + +Vector insert sort + Stable, but only suitable for small vectors -- O(n^2). + +Vector quick sort + Not stable. Is fast on average -- O(n lg n) -- but has bad worst-case + behaviour. Has good memory locality for big vectors (unlike heap sort). + A clever pivot-picking trick (median of three samples) helps avoid + worst-case behaviour, but pathological cases can still blow up. + +Vector heap sort + Not stable. Guaranteed fast -- O(n lg n) *worst* case. Poor locality + on large vectors. A very reliable workhorse. + +Vector merge sort + Stable. Not in-place -- requires a temporary buffer of equal size. + Fast -- O(n lg n) -- and has good memory locality for large vectors. + + The implementation of vector merge sort provided by this SRFI's reference + implementation is, additionally, a "natural" sort, meaning that it + exploits existing order in the input data, providing O(n) best case. + +Destructive list merge sort + Stable, fast and in-place (i.e., allocates no new cons cells). "Fast" + means O(n lg n) worse-case, and substantially better if the data + is already mostly ordered, all the way down to linear time for + a completely-ordered input list (i.e., it is a "natural" sort). + + Note that sorting lists involves chasing pointers through memory, which + can be a loser on modern machine architectures because of poor cache & + page locality. Pointer *writing*, which is what the SET-CDR!s of a + destructive list-sort algorithm do, is even worse, especially if your + Scheme has a generational GC -- the writes will thrash the write-barrier. + Sorting vectors has inherently better locality. + + This SRFI's destructive list merge and merge sort implementations are + opportunistic -- they avoid redundant SET-CDR!s, and try to take long + already-ordered runs of list structure as-is when doing the merges. + +Pure list merge sort + Stable and fast -- O(n lg n) worst-case, and possibly O(n), depending + upon the input list (see discussion above). + + +Algorithm Stable? Worst case Average case In-place +------------------------------------------------------ +Vector insert Yes O(n^2) O(n^2) Yes +Vector quick No O(n^2) O(n lg n) Yes +Vector heap No O(n lg n) O(n lg n) Yes +Vector merge Yes O(n lg n) O(n lg n) No +List merge Yes O(n lg n) O(n lg n) Either + + +------------------------------------------------------------------------------- +* Porting and optimisation +-------------------------- +This package should be trivial to port. + +This code is tightly bummed, as far as I can go in portable Scheme. + +You could speed up the vector code a lot by error-checking the procedure +parameters and then shifting over to fixnum-specific arithmetic and dangerous +vector-indexing and vector-setting primitives. The comments in the code +indicate where the initial error checks would have to be added. There are +several (QUOTIENT N 2)'s that could be changed to a fixnum right-shift, as +well, in both the list and vector code (SRFI 33 provides such an operator). +The code is designed to enable this -- each file usually exports one or two +"safe" procedures that end up calling an internal "dangerous" primitive. The +little exported cover procedures are where you move the error checks. + +This should provide *big* speedups. In fact, all the code bumming I've done +pretty much disappears in the noise unless you have a good compiler and also +can dump the vector-index checks and generic arithmetic -- so I've really just +set things up for you to exploit. + +The optional-arg parsing, defaulting, and error checking is done with a +portable R4RS macro. But if your Scheme has a faster mechanism (e.g., Chez), +you should definitely port over to it. Note that argument defaulting and +error-checking are interleaved -- you don't have to error-check defaulted +START/END args to see if they are fixnums that are legal vector indices for +the corresponding vector, etc. + + +------------------------------------------------------------------------------- +* References & Links +-------------------- + +This document, in HTML: + http://srfi.schemers.org/srfi-32/srfi-32.html + [This link may not be valid while the SRFI is in draft form.] + +This document, in simple text format: + http://srfi.schemers.org/srfi-32/srfi-32.txt + +Archive of SRFI-32 discussion-list email: + http://srfi.schemers.org/srfi-32/mail-archive/maillist.html + +SRFI web site: + http://srfi.schemers.org/ + +[CommonLisp] + Common Lisp: the Language + Guy L. Steele Jr. (editor). + Digital Press, Maynard, Mass., second edition 1990. + Available at http://www.elwood.com/alu/table/references.htm#cltl2 + + The Common Lisp "HyperSpec," produced by Kent Pitman, is essentially + the ANSI spec for Common Lisp: + http://www.xanalys.com/software_tools/reference/HyperSpec/ + +[R5RS] + Revised^5 Report on the Algorithmic Language Scheme, + R. Kelsey, W. Clinger, J. Rees (editors). + Higher-Order and Symbolic Computation, Vol. 11, No. 1, September, 1998. + and ACM SIGPLAN Notices, Vol. 33, No. 9, October, 1998. + + Available at http://www.schemers.org/Documents/Standards/ + + +------------------------------------------------------------------------------- +* Acknowledgements +------------------ + +I thank the authors of the open source I consulted when designing this +library, particularly Richard O'Keefe, Donovan Kolby and the MIT Scheme Team. + + +------------------------------------------------------------------------------- +* Copyright +----------- + +** SRFI text +============ +This document is copyright (C) Olin Shivers (1998, 1999). +All Rights Reserved. + +This document and translations of it may be copied and furnished to others, +and derivative works that comment on or otherwise explain it or assist in its +implementation may be prepared, copied, published and distributed, in whole or +in part, without restriction of any kind, provided that the above copyright +notice and this paragraph are included on all such copies and derivative +works. However, this document itself may not be modified in any way, such as +by removing the copyright notice or references to the Scheme Request For +Implementation process or editors, except as needed for the purpose of +developing SRFIs in which case the procedures for copyrights defined in the +SRFI process must be followed, or as required to translate it into languages +other than English. + +The limited permissions granted above are perpetual and will not be revoked by +the authors or their successors or assigns. + +This document and the information contained herein is provided on an "AS IS" +basis and THE AUTHORS AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE +INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF +MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. + +** Reference implementation +=========================== +Short summary: no restrictions. + +While I wrote all of this code myself, I read a lot of code before I began +writing. However, all such code is, itself, either open source or public +domain, rendering irrelevant any issue of "copyright taint." + +The natural merge sorts (pure list, destructive list, and vector) are not only +my own code, but are implementations of an algorithm of my own devising. They +run in O(n lg n) worst case, O(n) best case, and require only a logarithmic +number of stack frames. And they are stable. And the destructive-list variant +allocates zero cons cells; it simply rearranges the cells of the input list. + +Hence the reference implementation is + Copyright (c) 1998 by Olin Shivers. +and made available under the same copyright as the SRFI text (see above). diff --git a/scheme/sort/sortp.scm b/scheme/sort/sortp.scm new file mode 100644 index 0000000..ffe0b7e --- /dev/null +++ b/scheme/sort/sortp.scm @@ -0,0 +1,35 @@ +;;; The SRFI-?? sort package -- sorted predicates +;;; Olin Shivers 10/98. +;;; +;;; (list-sorted? < lis) -> boolean +;;; (vector-sorted? < v [start end]) -> boolean + +(define (list-sorted? < list) + (or (not (pair? list)) + (let lp ((prev (car list)) (tail (cdr list))) + (or (not (pair? tail)) + (let ((next (car tail))) + (and (not (< next prev)) + (lp next (cdr tail)))))))) + +(define (vector-sorted? elt< v . maybe-start+end) + (call-with-values + (lambda () (vector-start+end v maybe-start+end)) + (lambda (start end) + (or (>= start end) ; Empty range + (let lp ((i (+ start 1)) (vi-1 (vector-ref v start))) + (or (>= i end) + (let ((vi (vector-ref v i))) + (and (not (elt< vi vi-1)) + (lp (+ i 1) vi))))))))) + +;;; Copyright and porting non-notices +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Give me a break. It's fifteen lines of code. I place this code in the +;;; public domain; help yourself. +;;; +;;; If your Scheme has a faster mechanism for handling optional arguments +;;; (e.g., Chez), you should definitely port over to it. Note that argument +;;; defaulting and error-checking are interleaved -- you don't have to +;;; error-check defaulted START/END args to see if they are fixnums that are +;;; legal vector indices for the corresponding vector, etc. diff --git a/scheme/sort/test.scm b/scheme/sort/test.scm new file mode 100644 index 0000000..24a8329 --- /dev/null +++ b/scheme/sort/test.scm @@ -0,0 +1,65 @@ +;;; Little test harness, 'cause I'm paraoid about tricky code. +;;; It's scsh specific -- Scheme 48 random-number stuff & the mail-notification +;;; stuff. + +(define r (make-random 42)) +(define (rand n) (modulo (r) n)) + +;;; For testing stable sort -- 3 & -3 compare the same. +(define (my< x y) (< (abs x) (abs y))) + +(define (unstable-sort-test v) ; quick & heap vs simple insert + (let ((v1 (vector-copy v)) + (v2 (vector-copy v)) + (v3 (vector-copy v)) + (v4 (vector-copy v))) + (quick-sort! < v1) + (quick-sort3! - v1) + (heap-sort! < v2) + (insert-sort! < v3) + (and (or (not (equal? v1 v2)) + (not (equal? v1 v3)) + (not (equal? v1 v4)) + (not (vector-sorted? < v1))) + (list v v1 v2 v3 v4)))) + +(define (stable-sort-test v) ; insert, list & vector merge sorts + (let ((v1 (vector-copy v)) + (v2 (vector-copy v)) + (v3 (list->vector (list-merge-sort! my< (vector->list v)))) + (v4 (list->vector (list-merge-sort my< (vector->list v))))) + (vector-merge-sort! my< v1) + (insert-sort! my< v2) + (and (or (not (equal? v1 v2)) + (not (equal? v1 v3)) + (not (equal? v1 v4)) + (not (vector-sorted? my< v1))) + (list v v1 v2 v3 v4)))) + +(define (do-test max-size) + (let lp ((i 0)) + (let ((i (cond ((= i 1000) + (write-char #\.) + (force-output) + 0) + (else (+ i 1)))) + (v (random-vector (rand max-size)))) + (cond ((unstable-sort-test v) => (lambda (x) (cons 'u x))) + ((stable-sort-test v) => (lambda (x) (cons 's x))) + (else (lp i)))))) + +(define (test-n-mail max-size) + (let ((losers (do-test max-size)) + (email-address "shivers@cc.gatech.edu")) + (run (mail -s "sort lost" ,email-address) (<< ,losers)))) + +(define (random-vector size) + (let ((v (make-vector size))) + (fill-vector-randomly! v (* 10 size)) + v)) + +(define (fill-vector-randomly! v range) + (let ((half (quotient range 2))) + (do ((i (- (vector-length v) 1) (- i 1))) + ((< i 0)) + (vector-set! v i (- (rand range) half))))) diff --git a/scheme/sort/vbinsearch.scm b/scheme/sort/vbinsearch.scm new file mode 100644 index 0000000..8407260 --- /dev/null +++ b/scheme/sort/vbinsearch.scm @@ -0,0 +1,34 @@ +;;; The SRFI-32 sort package -- binary search -*- Scheme -*- +;;; Copyright (c) 1998 by Olin Shivers. +;;; This code is in the public domain. +;;; Olin Shivers 98/11 + +;;; Returns the index of the matching element. +;;; (vector-binary-search < car 4 '#((1 . one) (3 . three) +;;; (4 . four) (25 . twenty-five))) +;;; => 2 + +(define (vector-binary-search key< elt->key key v . maybe-start+end) + (call-with-values + (lambda () (vector-start+end v maybe-start+end)) + (lambda (start end) + (let lp ((left start) (right end)) ; Search V[left,right). + (and (< left right) + (let* ((m (quotient (+ left right) 2)) + (elt (vector-ref v m)) + (elt-key (elt->key elt))) + (cond ((key< key elt-key) (lp left m)) + ((key< elt-key key) (lp (+ m 1) right)) + (else m)))))))) + +(define (vector-binary-search3 compare v . maybe-start+end) + (call-with-values + (lambda () (vector-start+end v maybe-start+end)) + (lambda (start end) + (let lp ((left start) (right end)) ; Search V[left,right). + (and (< left right) + (let* ((m (quotient (+ left right) 2)) + (sign (compare (vector-ref v m)))) + (cond ((> sign 0) (lp left m)) + ((< sign 0) (lp (+ m 1) right)) + (else m)))))))) diff --git a/scheme/sort/vector-util.scm b/scheme/sort/vector-util.scm new file mode 100644 index 0000000..c2f0619 --- /dev/null +++ b/scheme/sort/vector-util.scm @@ -0,0 +1,56 @@ +(define (vector-portion-copy vec start end) + (let* ((len (vector-length vec)) + (new-len (- end start)) + (new (make-vector new-len))) + (do ((i start (+ i 1)) + (j 0 (+ j 1))) + ((= i end) new) + (vector-set! new j (vector-ref vec i))))) + +(define (vector-copy vec) + (vector-portion-copy vec 0 (vector-length vec))) + +(define (vector-portion-copy! target src start end) + (let ((len (- end start))) + (do ((i (- len 1) (- i 1)) + (j (- end 1) (- j 1))) + ((< i 0)) + (vector-set! target i (vector-ref src j))))) + +(define (has-element list index) + (cond + ((zero? index) + (if (pair? list) + (values #t (car list)) + (values #f #f))) + ((null? list) + (values #f #f)) + (else + (has-element (cdr list) (- index 1))))) + +(define (list-ref-or-default list index default) + (call-with-values + (lambda () (has-element list index)) + (lambda (has? maybe) + (if has? + maybe + default)))) + +(define (vector-start+end vector maybe-start+end) + (let ((start (list-ref-or-default maybe-start+end + 0 0)) + (end (list-ref-or-default maybe-start+end + 1 (vector-length vector)))) + (values start end))) + +(define (vectors-start+end-2 vector-1 vector-2 maybe-start+end) + (let ((start-1 (list-ref-or-default maybe-start+end + 0 0)) + (end-1 (list-ref-or-default maybe-start+end + 1 (vector-length vector-1))) + (start-2 (list-ref-or-default maybe-start+end + 2 0)) + (end-2 (list-ref-or-default maybe-start+end + 3 (vector-length vector-2)))) + (values start-1 end-1 + start-2 end-2))) diff --git a/scheme/sort/vhsort.scm b/scheme/sort/vhsort.scm new file mode 100644 index 0000000..ebad910 --- /dev/null +++ b/scheme/sort/vhsort.scm @@ -0,0 +1,117 @@ +;;; The SRFI-32 sort package -- vector heap sort -*- Scheme -*- +;;; Copyright (c) 2002 by Olin Shivers. +;;; This code is open-source; see the end of the file for porting and +;;; more copyright information. +;;; Olin Shivers 10/98. + +;;; Exports: +;;; (heap-sort! elt< v [start end]) -> unspecified +;;; (heap-sort elt< v [start end]) -> vector + +;;; Two key facts +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; If a heap structure is embedded into a vector at indices [start,end), then: +;;; 1. The two children of index k are start + 2*(k-start) + 1 = k*2-start+1 +;;; and start + 2*(k-start) + 2 = k*2-start+2. +;;; +;;; 2. The first index of a leaf node in the range [start,end) is +;;; first-leaf = floor[(start+end)/2] +;;; (You can deduce this from fact #1 above.) +;;; Any index before FIRST-LEAF is an internal node. + +(define (really-heap-sort! elt< v start end) + ;; Vector V contains a heap at indices [START,END). The heap is in heap + ;; order in the range (I,END) -- i.e., every element in this range is >= + ;; its children. Bubble HEAP[I] down into the heap to impose heap order on + ;; the range [I,END). + (define (restore-heap! end i) + (let* ((vi (vector-ref v i)) + (first-leaf (quotient (+ start end) 2)) ; Can fixnum overflow. + (final-k (let lp ((k i)) + (if (>= k first-leaf) + k ; Leaf, so done. + (let* ((k*2-start (+ k (- k start))) ; Don't overflow. + (child1 (+ 1 k*2-start)) + (child2 (+ 2 k*2-start)) + (child1-val (vector-ref v child1))) + (receive (max-child max-child-val) + (if (< child2 end) + (let ((child2-val (vector-ref v child2))) + (if (elt< child2-val child1-val) + (values child1 child1-val) + (values child2 child2-val))) + (values child1 child1-val)) + (cond ((elt< vi max-child-val) + (vector-set! v k max-child-val) + (lp max-child)) + (else k)))))))) ; Done. + (vector-set! v final-k vi))) + + ;; Put the unsorted subvector V[start,end) into heap order. + (let ((first-leaf (quotient (+ start end) 2))) ; Can fixnum overflow. + (do ((i (- first-leaf 1) (- i 1))) + ((< i start)) + (restore-heap! end i))) + + (do ((i (- end 1) (- i 1))) + ((<= i start)) + (let ((top (vector-ref v start))) + (vector-set! v start (vector-ref v i)) + (vector-set! v i top) + (restore-heap! i start)))) + +;;; Here are the two exported interfaces. + +(define (heap-sort! elt< v . maybe-start+end) + (call-with-values + (lambda () (vector-start+end v maybe-start+end)) + (lambda (start end) + (really-heap-sort! elt< v start end)))) + +(define (heap-sort elt< v . maybe-start+end) + (call-with-values + (lambda () (vector-start+end v maybe-start+end)) + (lambda (start end) + (let ((ans (vector-portion-copy v start end))) + (really-heap-sort! elt< ans 0 (- end start)) + ans)))) + +;;; Notes on porting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Bumming the code for speed +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; If you can use a module system to lock up the internal function +;;; REALLY-HEAP-SORT! so that it can only be called from HEAP-SORT and +;;; HEAP-SORT!, then you can hack the internal functions to run with no safety +;;; checks. The safety checks performed by the exported functions HEAP-SORT & +;;; HEAP-SORT! guarantee that there will be no type errors or array-indexing +;;; errors. In addition, with the exception of the two computations of +;;; FIRST-LEAF, all arithmetic will be fixnum arithmetic that never overflows +;;; into bignums, assuming your Scheme provides that you can't allocate an +;;; array so large you might need a bignum to index an element, which is +;;; definitely the case for every implementation with which I am familiar. +;;; +;;; If you want to code up the first-leaf = (quotient (+ s e) 2) computation +;;; so that it will never fixnum overflow when S & E are fixnums, you can do +;;; it this way: +;;; - compute floor(e/2), which throws away e's low-order bit. +;;; - add e's low-order bit to s, and divide that by two: +;;; floor[(s + e mod 2) / 2] +;;; - add these two parts together. +;;; giving you +;;; (+ (quotient e 2) +;;; (quotient (+ s (modulo e 2)) 2)) +;;; If we know that e & s are fixnums, and that 0 <= s <= e, then this +;;; can only fixnum-overflow when s = e = max-fixnum. Note that the +;;; two divides and one modulo op can be done very quickly with two +;;; right-shifts and a bitwise and. +;;; +;;; I suspect there has never been a heapsort written in the history of +;;; the world in C that got this detail right. +;;; +;;; If your Scheme has a faster mechanism for handling optional arguments +;;; (e.g., Chez), you should definitely port over to it. Note that argument +;;; defaulting and error-checking are interleaved -- you don't have to +;;; error-check defaulted START/END args to see if they are fixnums that are +;;; legal vector indices for the corresponding vector, etc. diff --git a/scheme/sort/visort.scm b/scheme/sort/visort.scm new file mode 100644 index 0000000..486fd46 --- /dev/null +++ b/scheme/sort/visort.scm @@ -0,0 +1,76 @@ +;;; The SRFI-?? sort package -- stable vector insertion sort -*- Scheme -*- +;;; Copyright (c) 1998 by Olin Shivers. +;;; This code is open-source; see the end of the file for porting and +;;; more copyright information. +;;; Olin Shivers 10/98. + +;;; Exports: +;;; insert-sort < v [start end] -> vector +;;; insert-sort! < v [start end] -> unspecific +;;; +;;; %insert-sort! is also called from vqsort.scm's quick-sort function. + +(define (insert-sort elt< v . maybe-start+end) + (call-with-values + (lambda () (vector-start+end v maybe-start+end)) + (lambda (start end) + (let ((ans (vector-portion-copy v start end))) + (%insert-sort! elt< ans 0 (- end start)) + ans)))) + +(define (insert-sort! < v . maybe-start+end) + (call-with-values + (lambda () (vector-start+end v maybe-start+end)) + (lambda (start end) + (%insert-sort! < v start end)))) + +(define (%insert-sort! elt< v start end) + (do ((i (+ 1 start) (+ i 1))) ; Invariant: [start,i) is sorted. + ((>= i end)) + (let ((val (vector-ref v i))) + (vector-set! v (let lp ((j i)) ; J is the location of the + (if (<= j start) + start ; "hole" as it bubbles down. + (let* ((j-1 (- j 1)) + (vj-1 (vector-ref v j-1))) + (cond ((elt< val vj-1) + (vector-set! v j vj-1) + (lp j-1)) + (else j))))) + val)))) + +;;; Copyright +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This code is +;;; Copyright (c) 1998 by Olin Shivers. +;;; The terms are: You may do as you please with this code, as long as +;;; you do not delete this notice or hold me responsible for any outcome +;;; related to its use. +;;; +;;; Blah blah blah. Don't you think source files should contain more lines +;;; of code than copyright notice? + + +;;; Code tuning & porting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; This code is tightly bummed as far as I can go in portable Scheme. +;;; +;;; The code can be converted to use unsafe vector-indexing and +;;; fixnum-specific arithmetic ops -- the safety checks done on entry to +;;; INSERT-SORT and INSERT-SORT! are sufficient to guarantee nothing bad will +;;; happen. However, note that if you alter %INSERT-SORT! to use dangerous +;;; primitives, you must ensure it is only called from clients that guarantee +;;; to observe its preconditions. In the SRFI-?? reference implementation, +;;; %INSERT-SORT! is only called from INSERT-SORT! and the quick-sort code in +;;; vqsort.scm, and the preconditions are guaranteed for these two clients. +;;; This should provide *big* speedups. In fact, all the code bumming I've +;;; done pretty much disappears in the noise unless you have a good compiler +;;; and also can dump the vector-index checks and generic arithmetic -- so +;;; I've really just set things up for you to exploit. +;;; +;;; If your Scheme has a faster mechanism for handling optional arguments +;;; (e.g., Chez), you should definitely port over to it. Note that argument +;;; defaulting and error-checking are interleaved -- you don't have to +;;; error-check defaulted START/END args to see if they are fixnums that are +;;; legal vector indices for the corresponding vector, etc. diff --git a/scheme/sort/vmsort.scm b/scheme/sort/vmsort.scm new file mode 100644 index 0000000..e17532a --- /dev/null +++ b/scheme/sort/vmsort.scm @@ -0,0 +1,238 @@ +;;; The SRFI-32 sort package -- stable vector merge & merge sort -*- Scheme -*- +;;; Copyright (c) 1998 by Olin Shivers. +;;; This code is open-source; see the end of the file for porting and +;;; more copyright information. +;;; Olin Shivers 10/98. + +;;; Exports: +;;; (vector-merge < v1 v2 [start1 end1 start2 end2]) -> vector +;;; (vector-merge! < v v1 v2 [start0 start1 end1 start2 end2]) -> unspecific +;;; +;;; (vector-merge-sort < v [start end temp]) -> vector +;;; (vector-merge-sort! < v [start end temp]) -> unspecific + + +;;; Merge +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; (vector-merge < v1 v2 [start1 end1 start2 end2]) -> vector +;;; (vector-merge! < v v1 v2 [start start1 end1 start2 end2]) -> unspecific +;;; +;;; Stable vector merge -- V1's elements come out ahead of equal V2 elements. + +(define (vector-merge < v1 v2 . maybe-starts+ends) + (call-with-values + (lambda () (vectors-start+end-2 v1 v2 maybe-starts+ends)) + (lambda (start1 end1 start2 end2) + (let ((ans (make-vector (+ (- end1 start1) (- end2 start2))))) + (%vector-merge! < ans v1 v2 0 start1 end1 start2 end2) + ans)))) + +(define (vector-merge! < v v1 v2 . maybe-starts+ends) + (call-with-values + (lambda () + (if (pair? maybe-starts+ends) + (values (car maybe-starts+ends) + (cdr maybe-starts+ends)) + (values 0 + '()))) + (lambda (start rest) + (call-with-values + (lambda () (vectors-start+end-2 v1 v2 rest)) + (lambda (start1 end1 start2 end2) + (%vector-merge! < v v1 v2 start start1 end1 start2 end2)))))) + + +;;; This routine is not exported. The code is tightly bummed. +;;; +;;; If these preconditions hold, the routine can be bummed to run with +;;; unsafe vector-indexing and fixnum arithmetic ops: +;;; - V V1 V2 are vectors. +;;; - START0 START1 END1 START2 END2 are fixnums. +;;; - (<= 0 START0 END0 (vector-length V), +;;; where end0 = start0 + (end1 - start1) + (end2 - start2) +;;; - (<= 0 START1 END1 (vector-length V1)) +;;; - (<= 0 START2 END2 (vector-length V2)) +;;; If you put these error checks in the two client procedures above, you can +;;; safely convert this procedure to use unsafe ops -- which is why it isn't +;;; exported. This will provide *huge* speedup. + +(define (%vector-merge! elt< v v1 v2 start start1 end1 start2 end2) + (letrec ((vblit (lambda (fromv j i end) ; Blit FROMV[J,END) to V[I,?]. + (let lp ((j j) (i i)) + (vector-set! v i (vector-ref fromv j)) + (let ((j (+ j 1))) + (if (< j end) (lp j (+ i 1)))))))) + + (cond ((<= end1 start1) (if (< start2 end2) (vblit v2 start2 start))) + ((<= end2 start2) (vblit v1 start1 start)) + + ;; Invariants: I is next index of V to write; X = V1[J]; Y = V2[K]. + (else (let lp ((i start) + (j start1) (x (vector-ref v1 start1)) + (k start2) (y (vector-ref v2 start2))) + (let ((i1 (+ i 1))) ; "i+1" is a complex number in R4RS! + (if (elt< y x) + (let ((k (+ k 1))) + (vector-set! v i y) + (if (< k end2) + (lp i1 j x k (vector-ref v2 k)) + (vblit v1 j i1 end1))) + (let ((j (+ j 1))) + (vector-set! v i x) + (if (< j end1) + (vblit v2 k i1 end2) + (lp i1 j (vector-ref v1 j) k y)))))))))) + + +;;; (vector-merge-sort < v [start end temp]) -> vector +;;; (vector-merge-sort! < v [start end temp]) -> unspecific +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Stable natural vector merge sort + +(define (vector-merge-sort! < v . maybe-args) + (call-with-values + (lambda () (vector-start+end v maybe-args)) + (lambda (start end) + (let ((temp (if (and (pair? maybe-args) ; kludge + (pair? (cdr maybe-args)) + (pair? (cddr maybe-args))) + (caddr maybe-args) + (vector-copy v)))) + (%vector-merge-sort! < v start end temp))))) + +(define (vector-merge-sort < v . maybe-args) + (let ((ans (vector-copy v))) + (apply vector-merge-sort! < ans maybe-args) + ans)) + + +;;; %VECTOR-MERGE-SORT! is not exported. +;;; Preconditions: +;;; V TEMP vectors +;;; START END fixnums +;;; START END legal indices for V and TEMP +;;; If these preconditions are ensured by the cover functions, you +;;; can safely change this code to use unsafe fixnum arithmetic and vector +;;; indexing ops, for *huge* speedup. + +;;; This merge sort is "opportunistic" -- the leaves of the merge tree are +;;; contiguous runs of already sorted elements in the vector. In the best +;;; case -- an already sorted vector -- it runs in linear time. Worst case +;;; is still O(n lg n) time. + +(define (%vector-merge-sort! elt< v0 l r temp0) + (define (xor a b) (not (eq? a b))) + + ;; Merge v1[l,l+len1) and v2[l+len1,l+len1+len2) into target[l,l+len1+len2) + ;; Merge left-to-right, so that TEMP may be either V1 or V2 + ;; (that this is OK takes a little bit of thought). + ;; V2=TARGET? is true if V2 and TARGET are the same, which allows + ;; merge to punt the final blit half of the time. + + (define (merge target v1 v2 l len1 len2 v2=target?) + (letrec ((vblit (lambda (fromv j i end) ; Blit FROMV[J,END) to TARGET[I,?] + (let lp ((j j) (i i)) ; J < END. The final copy. + (vector-set! target i (vector-ref fromv j)) + (let ((j (+ j 1))) + (if (< j end) (lp j (+ i 1)))))))) + + (let* ((r1 (+ l len1)) + (r2 (+ r1 len2))) + ; Invariants: + (let lp ((n l) ; N is next index of + (j l) (x (vector-ref v1 l)) ; TARGET to write. + (k r1) (y (vector-ref v2 r1))) ; X = V1[J] + (let ((n+1 (+ n 1))) ; Y = V2[K] + (if (elt< y x) + (let ((k (+ k 1))) + (vector-set! target n y) + (if (< k r2) + (lp n+1 j x k (vector-ref v2 k)) + (vblit v1 j n+1 r1))) + (let ((j (+ j 1))) + (vector-set! target n x) + (if (< j r1) + (lp n+1 j (vector-ref v1 j) k y) + (if (not v2=target?) (vblit v2 k n+1 r2)))))))))) + + + ;; Might hack GETRUN so that if the run is short it pads it out to length + ;; 10 with insert sort... + + ;; Precondition: l < r. + (define (getrun v l r) + (let lp ((i (+ l 1)) (x (vector-ref v l))) + (if (>= i r) + (- i l) + (let ((y (vector-ref v i))) + (if (elt< y x) + (- i l) + (lp (+ i 1) y)))))) + + ;; RECUR: Sort V0[L,L+LEN) for some LEN where 0 < WANT <= LEN <= (R-L). + ;; That is, sort *at least* WANT elements in V0 starting at index L. + ;; May put the result into either V0[L,L+LEN) or TEMP0[L,L+LEN). + ;; Must not alter either vector outside this range. + ;; Return: + ;; - LEN -- the number of values we sorted + ;; - ANSVEC -- the vector holding the value + ;; - ANS=V0? -- tells if ANSVEC is V0 or TEMP + ;; + ;; LP: V[L,L+PFXLEN) holds a sorted prefix of V0. + ;; TEMP = if V = V0 then TEMP0 else V0. (I.e., TEMP is the other vec.) + ;; PFXLEN2 is a power of 2 <= PFXLEN. + ;; Solve RECUR's problem. + (if (< l r) ; Don't try to sort an empty range. + (receive (ignored-len ignored-ansvec ansvec=v0?) + (let recur ((l l) (want (- r l))) + (let ((len (- r l))) + (let lp ((pfxlen (getrun v0 l r)) (pfxlen2 1) + (v v0) (temp temp0) + (v=v0? #t)) + (if (or (>= pfxlen want) (= pfxlen len)) + (values pfxlen v v=v0?) + (let ((pfxlen2 (let lp ((j pfxlen2)) + (let ((j*2 (+ j j))) + (if (<= j pfxlen) (lp j*2) j)))) + (tail-len (- len pfxlen))) + ;; PFXLEN2 is now the largest power of 2 <= PFXLEN. + ;; (Just think of it as being roughly PFXLEN.) + (receive (nr-len nr-vec nrvec=v0?) + (recur (+ pfxlen l) pfxlen2) + (merge temp v nr-vec l pfxlen nr-len + (xor nrvec=v0? v=v0?)) + (lp (+ pfxlen nr-len) (+ pfxlen2 pfxlen2) + temp v (not v=v0?)))))))) + (if (not ansvec=v0?) (vector-portion-copy! v0 temp0 l r))))) + + +;;; Copyright +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This code is +;;; Copyright (c) 1998 by Olin Shivers. +;;; The terms are: You may do as you please with this code, as long as +;;; you do not delete this notice or hold me responsible for any outcome +;;; related to its use. +;;; +;;; Blah blah blah. Don't you think source files should contain more lines +;;; of code than copyright notice? + + +;;; Code tuning & porting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This code is *tightly* bummed as far as I can go in portable Scheme. +;;; +;;; The two internal primitives that do the real work can be converted to +;;; use unsafe vector-indexing and fixnum-specific arithmetic ops *if* you +;;; alter the four small cover functions to enforce the invariants. This should +;;; provide *big* speedups. In fact, all the code bumming I've done pretty +;;; much disappears in the noise unless you have a good compiler and also +;;; can dump the vector-index checks and generic arithmetic -- so I've really +;;; just set things up for you to exploit. +;;; +;;; The optional-arg parsing, defaulting, and error checking is done with a +;;; portable R4RS macro. But if your Scheme has a faster mechanism (e.g., +;;; Chez), you should definitely port over to it. Note that argument defaulting +;;; and error-checking are interleaved -- you don't have to error-check +;;; defaulted START/END args to see if they are fixnums that are legal vector +;;; indices for the corresponding vector, etc.