home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / msort.scm < prev    next >
Text File  |  2000-03-16  |  2KB  |  65 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: msort.scm,v 14.7 2000/03/16 17:09:11 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Merge Sort
  23. ;;; package: ()
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;; This merge sort is stable for partial orders (for predicates like
  28. ;; <=, rather than like <).
  29.  
  30. (define (merge-sort obj pred)
  31.   (if (vector? obj)
  32.       (merge-sort! (vector-copy obj) pred)
  33.       (vector->list (merge-sort! (list->vector obj) pred))))
  34.  
  35. (define (merge-sort! v pred)
  36.   (if (not (vector? v))
  37.       (error:wrong-type-argument v "vector" 'MERGE-SORT!))
  38.   (let sort-subvector
  39.       ((v v)
  40.        (temp (vector-copy v))
  41.        (low 0)
  42.        (high (vector-length v)))
  43.     (if (fix:> (fix:- high low) 1)
  44.     (let ((middle (fix:quotient (fix:+ low high) 2)))
  45.       ;; Sort each half of (V,LOW,HIGH) into the corresponding
  46.       ;; half of TEMP.
  47.       (sort-subvector temp v low middle)
  48.       (sort-subvector temp v middle high)
  49.       ;; Merge the two halves of TEMP back into V.
  50.       (let merge ((p low) (p1 low) (p2 middle))
  51.         (if (fix:< p high)
  52.         (if (and (fix:< p1 middle)
  53.              (or (fix:= p2 high)
  54.                  (pred (vector-ref temp p1)
  55.                    (vector-ref temp p2))))
  56.             (begin
  57.               (vector-set! v p (vector-ref temp p1))
  58.               (merge (fix:+ p 1) (fix:+ p1 1) p2))
  59.             (begin
  60.               (vector-set! v p (vector-ref temp p2))
  61.               (merge (fix:+ p 1) p1 (fix:+ p2 1)))))))))
  62.   v)
  63.  
  64. (define sort merge-sort)
  65. (define sort! merge-sort!)