From 91f06f6e0aad248090751ce980e5c131107489b6 Mon Sep 17 00:00:00 2001
From: moculus <none@none>
Date: Sat, 11 Aug 2007 04:55:03 +0000
Subject: [PATCH] --HG-- branch : pmacs2

---
 code_examples/sorts.scm | 134 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 134 insertions(+)
 create mode 100644 code_examples/sorts.scm

diff --git a/code_examples/sorts.scm b/code_examples/sorts.scm
new file mode 100644
index 0000000..a285ec1
--- /dev/null
+++ b/code_examples/sorts.scm
@@ -0,0 +1,134 @@
+;;; (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?)
+    (cond
+         ((null? seq)
+             #t)
+         ((vector? seq)
+             (let ((n (vector-length seq)))
+                 (if (<= n 1)
+                     #t
+                     (do ((i 1 (+ i 1)))
+                         ((or (= i n)
+                              (less? (vector-ref seq (- i 1))
+                                     (vector-ref seq i)))
+                             (= i n)) )) ))
+         (else
+             (let loop ((last (car seq)) (next (cdr seq)))
+                 (or (null? next)
+                     (and (not (less? (car next) last))
+                          (loop (car next) (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 vectors.  See below.
+
+(define (merge a b less?)
+    (cond
+         ((null? a) b)
+         ((null? b) a)
+         (else (let loop ((x (car a)) (a (cdr a)) (y (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? y x)
+                 (if (null? b)
+                     (cons y (cons x a))
+                     (cons y (loop x a (car b) (cdr b)) ))
+                 ;; x <= y
+                 (if (null? a)
+                     (cons x (cons y b))
+                     (cons x (loop (car a) (cdr a) y b)) )) )) ))
+
+
+;;; (merge! a b less?)
+;;; 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 vectors.
+
+(define (merge! a b less?)
+    (define (loop r a b)
+         (if (less? (car b) (car a))
+             (begin
+                 (set-cdr! r b)
+                 (if (null? (cdr b))
+                     (set-cdr! b a)
+                     (loop b a (cdr b)) ))
+             ;; (car a) <= (car b)
+             (begin
+                 (set-cdr! r a)
+                 (if (null? (cdr a))
+                     (set-cdr! a b)
+                     (loop a (cdr a) b)) )) )
+    (cond
+         ((null? a) b)
+         ((null? b) a)
+         ((less? (car b) (car a))
+             (if (null? (cdr b))
+                 (set-cdr! b a)
+                 (loop b a (cdr b)))
+             b)
+         (else ; (car a) <= (car b)
+             (if (null? (cdr a))
+                 (set-cdr! a b)
+                 (loop a (cdr a) b))
+             a)))
+
+
+
+;;; (sort! sequence less?)
+;;; sorts the list or vector 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.
+
+(define (sort! seq less?)
+    (define (step n)
+         (cond
+             ((> n 2)
+                 (let* ((j (quotient n 2))
+                        (a (step j))
+                        (k (- n j))
+                        (b (step k)))
+                     (merge! a b less?)))
+             ((= n 2)
+                 (let ((x (car seq))
+                       (y (cadr seq))
+                       (p seq))
+                     (set! seq (cddr seq))
+                     (if (less? y x) (begin
+                         (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
+                 '()) ))
+    (if (vector? seq)
+         (let ((n (vector-length seq))
+               (vector seq))                     ; save original vector
+             (set! seq (vector->list seq))       ; convert to list
+             (do ((p (step n) (cdr p))           ; sort list destructively
+                  (i 0 (+ i 1)))                         ; and store elements back
+                 ((null? p) vector)              ; in original vector
+                 (vector-set! vector i (car p)) ))
+         ;; otherwise, assume it is a list
+         (step (length seq)) ))
+
+
+;;; (sort sequence less?)
+;;; sorts a vector or list non-destructively.  It does this by sorting a
+;;; copy of the sequence
+(define (sort seq less?)
+    (if (vector? seq)
+         (list->vector (sort! (vector->list seq) less?))
+         (sort! (append seq '()) less?)))