;; sort

;; Peter Szolovits (psz@mit.edu)
;; Last modified 10/8/96

;; The procedures sort and sort!, defined at the end, perform nondestructive
;; and destructive sorts of their inputs, respectively.  A destructive sort
;; modifies the input; nondestructive leaves it alone and returns a sorted copy.

;; sort-list! is a transliteration of the list sorting algorithm originally
;; implemented in PDP-10 assembler for MacLisp by GLS (Guy Steele) based on Lisp
;; code by MJF.
;; sort-list, implemented by PSZ, uses the same idea but copies the list as it
;; is sorting it.  The implementation uses continuation-passing style to avoid
;; having to return multiple values in a data structure.
;; sort-vector! is an implementation of quicksort by TLP (Tomas Lozano-Perez);
;; its non-destructive version simply applies the destructive one to a copy of
;; the input.

(define (sort-list! c lessp-predicate)
  (let ((f (cons '() '())))
    (define (iter tt s)
      ;; (newline) (display s)
      (if (null? c)
          s
          (iter (+ tt 1)
                (mmerge s (mprefx tt)))))
    (define (pop-c!)
      (let ((ans c)
            (rest (cdr c)))
        (set-cdr! c '())
        (set! c rest)
        ans))
    (define (mprefx tt)
      (cond ((null? c) '())
            ((< tt 1)
             (pop-c!))
            (else
             (mmerge (mprefx (- tt 1)) (mprefx (- tt 1))))))
    (define (mmerge a b)
      ;; (newline) (display (list 'merge a b))
      (let ((r f))
        (define (iter)
          (cond ((null? a)
                 (set-cdr! r b)
                 (cdr f))
                ((null? b)
                 (set-cdr! r a)
                 (cdr f))
                ((lessp-predicate (car b) (car a))
                 (let ((old-r r))
                   (set! r b)
                   (set-cdr! old-r r)
                   (set! b (cdr b))
                   (iter)))
                (else
                 (let ((old-r r))
                   (set! r a)
                   (set-cdr! old-r r)
                   (set! a (cdr a))
                   (iter)))))
        (iter)))
    (iter -1 '())))

(define (sort-list c lessp-predicate)
  (define (iter c tt s)
    (define (mprefx c tt continuation)
      (cond ((null? c)
             (continuation '() c))
            ((< tt 1)
             (continuation (list (car c)) (cdr c)))
            (else
             (mprefx c
                     (- tt 1)
                     (lambda (ans1 rest)
                       (mprefx rest
                               (- tt 1)
                               (lambda (ans2 rest)
                                 (continuation (mmerge ans1 ans2)
                                               rest))))))))
    (if (null? c)
        s
        (mprefx c tt (lambda (ans rest)
                       (iter rest (+ tt 1) (mmerge s ans))))))
  (define (mmerge a b)
    (cond ((null? a) b)
          ((null? b) a)
          ((lessp-predicate (car a) (car b))
           (cons (car a)
                 (mmerge (cdr a) b)))
          (else
           (cons (car b)
                 (mmerge a (cdr b))))))
  (iter c -1 '()))

;;;; Quick Sort
;;;; Hacked for scc by tlp, 6/27/95


(define (vector-copy vector)
  (list->vector (vector->list vector)))

(define (sort-vector! vector predicate)

  (define (exchange! i j)
    (let ((ith-element (vector-ref vector i)))
      (vector-set! vector i (vector-ref vector j))
      (vector-set! vector j ith-element)))

  (define (outer-loop l r)
    (if (> r l)
        (if (= r (+ 1 l)) 
            (if (predicate (vector-ref vector r)
                           (vector-ref vector l))
                (exchange! l r))
            (let ((lth-element (vector-ref vector l)))

              (define (increase-i i)
                (if (or (> i r)
                        (predicate lth-element (vector-ref vector i)))
                    i
                    (increase-i (+ 1 i))))

              (define (decrease-j j)
                (if (or (<= j l)
                        (not (predicate lth-element (vector-ref vector j))))
                    j
                    (decrease-j (- j 1))))

              (define (inner-loop i j)
                (if (< i j)             ;used to be <=
                    (begin (exchange! i j)
                           (inner-loop (increase-i (+ 1 i))
                                       (decrease-j (- j 1))))
                    (begin (if (> j l)
                               (exchange! j l))
                           (outer-loop (+ 1 j) r)
                           (outer-loop l (- j 1)))))

              (inner-loop (increase-i (+ 1 l))
                          (decrease-j r))))))

  (if (not (vector? vector))
      (error "SORT! works on vectors only" ""))
  (outer-loop 0 (- (vector-length vector) 1))
  vector)

(define (sort stuff predicate)
  (if (vector? stuff)
      (sort! (vector-copy stuff) predicate)
      (sort-list stuff predicate)))

(define (sort! stuff predicate)
  (if (vector? stuff)
    (sort-vector! stuff predicate)
    (sort-list! stuff predicate)))