194 lines
6.3 KiB
Scheme
194 lines
6.3 KiB
Scheme
;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
|
|
;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
|
|
;;;
|
|
;;; This code is in the public domain.
|
|
|
|
;;; Updated: 11 June 1991
|
|
;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
|
|
;;; Updated: 19 June 1995
|
|
;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
|
|
;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
|
|
;;; jaffer: 2006-10-08:
|
|
;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument.
|
|
;;; jaffer: 2006-11-05:
|
|
;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once
|
|
;;; per element.
|
|
|
|
;(require 'array)
|
|
|
|
;;; (sorted? sequence less?)
|
|
;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
|
|
;;; such that for all 1 <= i <= m,
|
|
;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
|
|
;@
|
|
(define (sorted? seq less? . opt-key)
|
|
(define key (if (null? opt-key) identity (car opt-key)))
|
|
(cond ((null? seq) #t)
|
|
((array? seq)
|
|
(let ((dimax (+ -1 (car (array-dimensions seq)))))
|
|
(or (<= dimax 1)
|
|
(let loop ((idx (+ -1 dimax))
|
|
(last (key (array-ref seq dimax))))
|
|
(or (negative? idx)
|
|
(let ((nxt (key (array-ref seq idx))))
|
|
(and (less? nxt last)
|
|
(loop (+ -1 idx) nxt))))))))
|
|
((null? (cdr seq)) #t)
|
|
(else
|
|
(let loop ((last (key (car seq)))
|
|
(next (cdr seq)))
|
|
(or (null? next)
|
|
(let ((nxt (key (car next))))
|
|
(and (not (less? nxt last))
|
|
(loop nxt (cdr next)))))))))
|
|
|
|
;;; (merge a b less?)
|
|
;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
|
|
;;; and returns a new list in which the elements of a and b have been stably
|
|
;;; interleaved so that (sorted? (merge a b less?) less?).
|
|
;;; Note: this does _not_ accept arrays. See below.
|
|
;@
|
|
(define (merge a b less? . opt-key)
|
|
(define key (if (null? opt-key) identity (car opt-key)))
|
|
(cond ((null? a) b)
|
|
((null? b) a)
|
|
(else
|
|
(let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
|
|
(y (car b)) (ky (key (car b))) (b (cdr b)))
|
|
;; The loop handles the merging of non-empty lists. It has
|
|
;; been written this way to save testing and car/cdring.
|
|
(if (less? ky kx)
|
|
(if (null? b)
|
|
(cons y (cons x a))
|
|
(cons y (loop x kx a (car b) (key (car b)) (cdr b))))
|
|
;; x <= y
|
|
(if (null? a)
|
|
(cons x (cons y b))
|
|
(cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
|
|
|
|
(define (sort:merge! a b less? key)
|
|
(define (loop r a kcara b kcarb)
|
|
(cond ((less? kcarb kcara)
|
|
(set-cdr! r b)
|
|
(if (null? (cdr b))
|
|
(set-cdr! b a)
|
|
(loop b a kcara (cdr b) (key (cadr b)))))
|
|
(else ; (car a) <= (car b)
|
|
(set-cdr! r a)
|
|
(if (null? (cdr a))
|
|
(set-cdr! a b)
|
|
(loop a (cdr a) (key (cadr a)) b kcarb)))))
|
|
(cond ((null? a) b)
|
|
((null? b) a)
|
|
(else
|
|
(let ((kcara (key (car a)))
|
|
(kcarb (key (car b))))
|
|
(cond
|
|
((less? kcarb kcara)
|
|
(if (null? (cdr b))
|
|
(set-cdr! b a)
|
|
(loop b a kcara (cdr b) (key (cadr b))))
|
|
b)
|
|
(else ; (car a) <= (car b)
|
|
(if (null? (cdr a))
|
|
(set-cdr! a b)
|
|
(loop a (cdr a) (key (cadr a)) b kcarb))
|
|
a))))))
|
|
|
|
;;; takes two sorted lists a and b and smashes their cdr fields to form a
|
|
;;; single sorted list including the elements of both.
|
|
;;; Note: this does _not_ accept arrays.
|
|
;@
|
|
(define (merge! a b less? . opt-key)
|
|
(sort:merge! a b less? (if (null? opt-key) identity (car opt-key))))
|
|
|
|
(define (sort:sort-list! seq less? key)
|
|
(define keyer (if key car identity))
|
|
(define (step n)
|
|
(cond ((> n 2) (let* ((j (quotient n 2))
|
|
(a (step j))
|
|
(k (- n j))
|
|
(b (step k)))
|
|
(sort:merge! a b less? keyer)))
|
|
((= n 2) (let ((x (car seq))
|
|
(y (cadr seq))
|
|
(p seq))
|
|
(set! seq (cddr seq))
|
|
(cond ((less? (keyer y) (keyer x))
|
|
(set-car! p y)
|
|
(set-car! (cdr p) x)))
|
|
(set-cdr! (cdr p) '())
|
|
p))
|
|
((= n 1) (let ((p seq))
|
|
(set! seq (cdr seq))
|
|
(set-cdr! p '())
|
|
p))
|
|
(else '())))
|
|
(define (key-wrap! lst)
|
|
(cond ((null? lst))
|
|
(else (set-car! lst (cons (key (car lst)) (car lst)))
|
|
(key-wrap! (cdr lst)))))
|
|
(define (key-unwrap! lst)
|
|
(cond ((null? lst))
|
|
(else (set-car! lst (cdar lst))
|
|
(key-unwrap! (cdr lst)))))
|
|
(cond (key
|
|
(key-wrap! seq)
|
|
(set! seq (step (length seq)))
|
|
(key-unwrap! seq)
|
|
seq)
|
|
(else
|
|
(step (length seq)))))
|
|
|
|
(define (rank-1-array->list array)
|
|
(define dimensions (array-dimensions array))
|
|
(do ((idx (+ -1 (car dimensions)) (+ -1 idx))
|
|
(lst '() (cons (array-ref array idx) lst)))
|
|
((< idx 0) lst)))
|
|
|
|
;;; (sort! sequence less?)
|
|
;;; sorts the list, array, or string sequence destructively. It uses
|
|
;;; a version of merge-sort invented, to the best of my knowledge, by
|
|
;;; David H. D. Warren, and first used in the DEC-10 Prolog system.
|
|
;;; R. A. O'Keefe adapted it to work destructively in Scheme.
|
|
;;; A. Jaffer modified to always return the original list.
|
|
;@
|
|
(define (sort! seq less? . opt-key)
|
|
(define key (if (null? opt-key) #f (car opt-key)))
|
|
(cond ((array? seq)
|
|
(let ((dims (array-dimensions seq)))
|
|
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
|
|
(cdr sorted))
|
|
(i 0 (+ i 1)))
|
|
((null? sorted) seq)
|
|
(array-set! seq (car sorted) i))))
|
|
(else ; otherwise, assume it is a list
|
|
(let ((ret (sort:sort-list! seq less? key)))
|
|
(if (not (eq? ret seq))
|
|
(do ((crt ret (cdr crt)))
|
|
((eq? (cdr crt) seq)
|
|
(set-cdr! crt ret)
|
|
(let ((scar (car seq)) (scdr (cdr seq)))
|
|
(set-car! seq (car ret)) (set-cdr! seq (cdr ret))
|
|
(set-car! ret scar) (set-cdr! ret scdr)))))
|
|
seq))))
|
|
|
|
;;; (sort sequence less?)
|
|
;;; sorts a array, string, or list non-destructively. It does this
|
|
;;; by sorting a copy of the sequence. My understanding is that the
|
|
;;; Standard says that the result of append is always "newly
|
|
;;; allocated" except for sharing structure with "the last argument",
|
|
;;; so (append x '()) ought to be a standard way of copying a list x.
|
|
;@
|
|
(define (sort seq less? . opt-key)
|
|
(define key (if (null? opt-key) #f (car opt-key)))
|
|
(cond ((array? seq)
|
|
(let ((dims (array-dimensions seq)))
|
|
(define newra (apply make-array seq dims))
|
|
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
|
|
(cdr sorted))
|
|
(i 0 (+ i 1)))
|
|
((null? sorted) newra)
|
|
(array-set! newra (car sorted) i))))
|
|
(else (sort:sort-list! (append seq '()) less? key))))
|