module/slib/sort.scm

   1 ;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
   2 ;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
   3 ;;;
   4 ;;; This code is in the public domain.
   5
   6 ;;; Updated: 11 June 1991
   7 ;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
   8 ;;; Updated: 19 June 1995
   9
  10 ;;; (sorted? sequence less?)
  11 ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
  12 ;;; such that for all 1 <= i <= m,
  13 ;;;     (not (less? (list-ref list i) (list-ref list (- i 1)))).
  14
  15 (define (sort:sorted? seq less?)
  16     (cond
  17         ((null? seq)
  18             #t)
  19         ((vector? seq)
  20             (let ((n (vector-length seq)))
  21                 (if (<= n 1)
  22                     #t
  23                     (do ((i 1 (+ i 1)))
  24                         ((or (= i n)
  25                              (less? (vector-ref seq i)
  26                                     (vector-ref seq (- i 1))))
  27                             (= i n)) )) ))
  28         (else
  29             (let loop ((last (car seq)) (next (cdr seq)))
  30                 (or (null? next)
  31                     (and (not (less? (car next) last))
  32                          (loop (car next) (cdr next)) )) )) ))
  33
  34
  35 ;;; (merge a b less?)
  36 ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
  37 ;;; and returns a new list in which the elements of a and b have been stably
  38 ;;; interleaved so that (sorted? (merge a b less?) less?).
  39 ;;; Note:  this does _not_ accept vectors.  See below.
  40
  41 (define (sort:merge a b less?)
  42     (cond
  43         ((null? a) b)
  44         ((null? b) a)
  45         (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
  46             ;; The loop handles the merging of non-empty lists.  It has
  47             ;; been written this way to save testing and car/cdring.
  48             (if (less? y x)
  49                 (if (null? b)
  50                     (cons y (cons x a))
  51                     (cons y (loop x a (car b) (cdr b)) ))
  52                 ;; x <= y
  53                 (if (null? a)
  54                     (cons x (cons y b))
  55                     (cons x (loop (car a) (cdr a) y b)) )) )) ))
  56
  57
  58 ;;; (merge! a b less?)
  59 ;;; takes two sorted lists a and b and smashes their cdr fields to form a
  60 ;;; single sorted list including the elements of both.
  61 ;;; Note:  this does _not_ accept vectors.
  62
  63 (define (sort:merge! a b less?)
  64     (define (loop r a b)
  65         (if (less? (car b) (car a))
  66             (begin
  67                 (set-cdr! r b)
  68                 (if (null? (cdr b))
  69                     (set-cdr! b a)
  70                     (loop b a (cdr b)) ))
  71             ;; (car a) <= (car b)
  72             (begin
  73                 (set-cdr! r a)
  74                 (if (null? (cdr a))
  75                     (set-cdr! a b)
  76                     (loop a (cdr a) b)) )) )
  77     (cond
  78         ((null? a) b)
  79         ((null? b) a)
  80         ((less? (car b) (car a))
  81             (if (null? (cdr b))
  82                 (set-cdr! b a)
  83                 (loop b a (cdr b)))
  84             b)
  85         (else ; (car a) <= (car b)
  86             (if (null? (cdr a))
  87                 (set-cdr! a b)
  88                 (loop a (cdr a) b))
  89             a)))
  90
  91
  92
  93 ;;; (sort! sequence less?)
  94 ;;; sorts the list or vector sequence destructively.  It uses a version
  95 ;;; of merge-sort invented, to the best of my knowledge, by David H. D.
  96 ;;; Warren, and first used in the DEC-10 Prolog system.  R. A. O'Keefe
  97 ;;; adapted it to work destructively in Scheme.
  98
  99 (define (sort:sort! seq less?)
 100     (define (step n)
 101         (cond
 102             ((> n 2)
 103                 (let* ((j (quotient n 2))
 104                        (a (step j))
 105                        (k (- n j))
 106                        (b (step k)))
 107                     (sort:merge! a b less?)))
 108             ((= n 2)
 109                 (let ((x (car seq))
 110                       (y (cadr seq))
 111                       (p seq))
 112                     (set! seq (cddr seq))
 113                     (if (less? y x) (begin
 114                         (set-car! p y)
 115                         (set-car! (cdr p) x)))
 116                     (set-cdr! (cdr p) '())
 117                     p))
 118             ((= n 1)
 119                 (let ((p seq))
 120                     (set! seq (cdr seq))
 121                     (set-cdr! p '())
 122                     p))
 123             (else
 124                 '()) ))
 125     (if (vector? seq)
 126         (let ((n (vector-length seq))
 127               (vec seq))
 128           (set! seq (vector->list seq))
 129           (do ((p (step n) (cdr p))
 130                (i 0 (+ i 1)))
 131               ((null? p) vec)
 132             (vector-set! vec i (car p)) ))
 133         ;; otherwise, assume it is a list
 134         (step (length seq)) ))
 135
 136 ;;; (sort sequence less?)
 137 ;;; sorts a vector or list non-destructively.  It does this by sorting a
 138 ;;; copy of the sequence.  My understanding is that the Standard says
 139 ;;; that the result of append is always "newly allocated" except for
 140 ;;; sharing structure with "the last argument", so (append x '()) ought
 141 ;;; to be a standard way of copying a list x.
 142
 143 (define (sort:sort seq less?)
 144     (if (vector? seq)
 145         (list->vector (sort:sort! (vector->list seq) less?))
 146         (sort:sort! (append seq '()) less?)))
 147
 148 ;;; eof
 149
 150 (define sorted? sort:sorted?)
 151 (define merge sort:merge)
 152 (define merge! sort:merge!)
 153 (define sort sort:sort)
 154 (define sort! sort:sort!)