home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 2: PC / frozenfish_august_1995.bin / bbs / d09xx / d0963.lha / SIOD / scm / sort.scm < prev    next >
Text File  |  1993-06-18  |  3KB  |  63 lines
  1. (define (sort! x . y)
  2.         (define test <=)
  3.         (define (interchange x i j)
  4.                 (define tmp (vector-ref x i))
  5.                 (vector-set! x i (vector-ref x j))
  6.                 (vector-set! x j tmp))
  7.         (define (qsort x m n)
  8.                 (if (< m n)
  9.                     (do ((i m)
  10.                          (j (1+ n))
  11.                          (k (begin (interchange x
  12.                                                 m
  13.                                                 (quotient (+ m n) 
  14.                                                           2))  
  15.                                    (vector-ref x m))))
  16.                         ((>= i j) (interchange x m j)
  17.                                   (qsort x m (-1+ j))
  18.                                   (qsort x (1+ j) n) x)
  19.                         (set! i (1+ i))
  20.                         (do () 
  21.                             ((or (test k (vector-ref x i)) 
  22.                                  (>= i n)))
  23.                             (set! i (1+ i)))
  24.                         (set! j (-1+ j))
  25.                         (do () 
  26.                             ((or (test (vector-ref x j) k)
  27.                                  (<= j m)))
  28.                             (set! j (-1+ j)))
  29.                         (if (< i j)
  30.                             (interchange x i j)))))
  31.         (define (m-s x y)
  32.                 (define res (list 'dummy))
  33.                 (do ((ptr res (cdr ptr))
  34.                      (done #f))
  35.                     (done (cdr res))
  36.                     (cond ((null? x) (set-cdr! ptr y)
  37.                                      (set! done #t))
  38.                           ((null? y) (set-cdr! ptr x)
  39.                                      (set! done #t))
  40.                           ((test (car x) (car y))
  41.                            (set-cdr! ptr x)
  42.                            (set! x (cdr x)))
  43.                           (else (set-cdr! ptr y)
  44.  
  45.                                 (set! y (cdr y))))))
  46.         (define (mer-so x)
  47.                 (if (or (null? x) (null? (cdr x))) 
  48.                     x
  49.                     (m-s x
  50.                          (mer-so (do ((ptr (cdr x) (cdr ptr))
  51.                                       (y (cddr x) (cdr y)))
  52.                                      ((or (null? y)
  53.                                           (test (car y) (car ptr))) 
  54.                                       (set-cdr! ptr nil) y))))))
  55.         (if (pair? y)
  56.             (if (proc? (car y))
  57.                 (set! test (car y))
  58.                 (error "second arg to sort! must be a procedure" (car y))))
  59.         (cond ((vector? x) (qsort x 0 (-1+ (vector-length x))) x)
  60.               ((pair? x) (mer-so x))
  61.               (else (error "first arg to sort! must be a vector or a list" x))))
  62.       
  63.