scsh-0.6/scheme/big/sort.scm

152 lines
5.6 KiB
Scheme

;;; Copyright (c) 1985 Yale University
;;; Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
;;; This material was developed by the T Project at the Yale
;;; University Computer Science Department. Permission to copy this
;;; software, to redistribute it, and to use it for any purpose is
;;; granted, subject to the following restric- tions and
;;; understandings.
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;; 2. Users of this software agree to make their best efforts (a) to return
;;; to the T Project at Yale any improvements or extensions that they make,
;;; so that these may be included in future releases; and (b) to inform
;;; the T Project of noteworthy uses of this software.
;;; 3. All materials developed as a consequence of the use of this software
;;; shall duly acknowledge such use, in accordance with the usual standards
;;; of acknowledging credit in academic research.
;;; 4. Yale has made no warrantee or representation that the operation of
;;; this software will be error-free, and Yale is under no obligation to
;;; provide any services, by way of maintenance, update, or otherwise.
;;; 5. In conjunction with products arising from the use of this material,
;;; there shall be no use of the name of the Yale University nor of any
;;; adaptation thereof in any advertising, promotional, or sales literature
;;; without prior written consent from Yale in each case.
;;;
;;; We gratefully acknowledge Bob Nix
;;; SORT:ONLINE-MERGE-SORT!
;;; =======================
;;; On-Line Merge sort, a fast and stable algorithm for sorting a list.
;;; This is a very neat algorithm! Consider the following code:
;;;
;;; (DEFINE (MERGE-SORT L)
;;; (IF (NULL? (CDR L))
;;; L
;;; (MERGE (MERGE-SORT (FIRST-HALF-OF L))
;;; (MERGE-SORT (SECOND-HALF-OF L)))))
;;;
;;; The nested calls to MERGE above form a binary tree, with MERGE's of
;;; singleton lists at the leaves, and a MERGE of two lists of size N/2 at
;;; the top. The algorithm below traverses this MERGE-tree in post-order,
;;; moving from the lower left hand corner to the right.
;;;
;;; This algorithm sorts N objects with about NlgN+2N comparisons and exactly
;;; lgN conses. The algorithm used is a version of mergesort that is
;;; amenable to Lisp's data accessing primitives. The first phase of the
;;; algorithm is an "addition" phase in which each element X is added to
;;; a list of lists of sorted runs B in much the same manner as a one is
;;; added to a binary number. If the first "digit" of B is 0, i.e. the first
;;; list in B is NIL, then the element to be added becomes the first digit
;;; of B. If that digit is non empty then you merge the digit with X and
;;; recurse on the rest of B -- setting the first digit of B to be zero.
;;; For example:
;;;
;;; Reversed LIST B
;;; Binary # Each sublist is sorted.
;;;
;;; 0000 ()
;;; 1000 ((x))
;;; 0100 (() (x x))
;;; 1100 ((x) (x x))
;;; 0010 (() () (x x x x))
;;; 1010 ((x) () (x x x x))
;;; 0110 (() (x x) (x x x x))
;;; 1110 ((x) (x x) (x x x x))
;;; 0001 (() () () (x x x x x x x x))
;;; 1001 ((x) () () (x x x x x x x x))
;;;
;;; The algorithm then merges the sublists of these lists into
;;; one list, and returns that list.
;;;
;;; To see the algorithm in action, trace LIST-MERGE!.
;;;
;;; Returns list L sorted using OBJ-< for comparisons.
(define (sort-list l obj-<)
(cond ((or (null? l)
(null? (cdr l)))
l)
(else
(online-merge-sort! (append l '()) ; copy-list
obj-<))))
;;; Returns list L sorted using OBJ-< for comparisons.
;;; L is destructively altered.
(define (sort-list! l obj-<)
(cond ((or (null? l)
(null? (cdr l)))
l)
(else
(online-merge-sort! l obj-<))))
;;; The real sort procedure. Elements of L are added to B, a list of sorted
;;; lists as defined above. When all elements of L have been added to B
;;; the sublists of B are merged together to get the desired sorted list.
(define (online-merge-sort! l obj-<)
(let ((b (cons '() '())))
(let loop ((l l))
(cond ((null? l)
(do ((c (cddr b) (cdr c))
(r (cadr b) (list-merge! (car c) r obj-<)))
((null? c)
r)))
(else
(let ((new-l (cdr l)))
(set-cdr! l '())
(add-to-sorted-lists l b obj-<)
(loop new-l)))))))
;;; X is a list that is merged into B, the list of sorted lists.
(define (add-to-sorted-lists x b obj-<)
(let loop ((x x) (b b))
(let ((l (cdr b)))
(cond ((null? l)
(set-cdr! b (cons x '())))
((null? (car l))
(set-car! l x))
(else
(let ((y (list-merge! x (car l) obj-<)))
(set-car! l '())
(loop y l)))))))
;;; Does a stable side-effecting merge of L1 and L2.
(define (list-merge! l1 l2 obj-<)
(cond ((null? l1) l2)
((null? l2) l1)
((obj-< (car l1) (car l2))
(real-list-merge! l2 (cdr l1) obj-< l1)
l1)
(else
(real-list-merge! l1 (cdr l2) obj-< l2)
l2)))
;;; Does the real work of LIST-MERGE!. L1 is assumed to be non-empty.
(define (real-list-merge! l1 l2 obj-< prev)
(let loop ((a l1) (b l2) (prev prev))
(cond ((null? b)
(set-cdr! prev a))
((obj-< (car a) (car b))
(set-cdr! prev a)
(loop b (cdr a) a))
(else
(set-cdr! prev b)
(loop a (cdr b) b)))))