ikarus/scheme/ikarus.sort.ss

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007  Abdulaziz Ghuloum
;;; 
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; 
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(library (ikarus.sort)
  (export list-sort vector-sort vector-sort!)
  (import 
    (except (ikarus) list-sort vector-sort vector-sort!))

    
  (module UNSAFE  
    (fx<? fx<=? fx>? fx>=? fx=? 
     fx+ fx- fxarithmetic-shift-right
     vector-ref vector-set! car cdr)
    (import 
      (rename (ikarus system $pairs)
        ($car    car)
        ($cdr    cdr))
      (rename (ikarus system $vectors) 
        ($vector-ref    vector-ref)
        ($vector-set!   vector-set!))
      (rename (ikarus system $fx) 
        ($fxsra    fxarithmetic-shift-right)
        ($fx+      fx+)
        ($fx-      fx-)
        ($fx<      fx<?)
        ($fx>      fx>?)
        ($fx>=     fx>=?)
        ($fx<=     fx<=?)
        ($fx=      fx=?))))

  (define (list-sort proc ls) 
    (import UNSAFE)
    (define race
      (lambda (h t ls n)
        (if (pair? h)
            (let ([h (cdr h)])
               (if (pair? h)
                   (if (not (eq? h t))
                       (race (cdr h) (cdr t) ls (fx+ n 2))
                       (die 'list-sort "circular list" ls))
                   (if (null? h)
                       (fx+ n 1)
                       (die 'list-sort "not a proper list" ls))))
            (if (null? h)
                n
                (die 'list-sort "not a proper list" ls)))))
    (unless (procedure? proc)
      (die 'list-sort "not a procedure" proc))
    (let ([n (race ls ls ls 0)])
      (cond
        [(fx< n 2) ls]
        [else
         (let f ([v (make-vector n)] [ls ls] [i 0])
           (cond
             [(null? ls) 
              (vector-sort! proc v)
              (vector->list v)]
             [else 
              (vector-set! v i (car ls))
              (f v (cdr ls) (fx+ i 1))]))])))

  (module (vector-sort vector-sort!)
   
    (import UNSAFE) 

    (define (copy-subrange! src dst si di dj) 
      (vector-set! dst di (vector-ref src si)) 
      (let ([di (fx+ di 1)])
        (when (fx<=? di dj)
          (copy-subrange! src dst (fx+ si 1) di dj))))
    
    (define (do-merge-a! proc src skr ri rj ai aj bi bj b0)
      (let ([a0 (vector-ref skr ai)]
            [ai (fx+ ai 1)])
        (cond
          [(proc b0 a0)
           (vector-set! src ri b0)
           (let ([ri (fx+ ri 1)])
             (cond
               [(fx<=? bi bj)
                (do-merge-b! proc src skr ri rj ai aj bi bj a0)]
               [else
                (vector-set! src ri a0)
                (let ([ri (fx+ ri 1)])
                  (cond
                    [(fx<=? ri rj)
                     (copy-subrange! skr src ai ri rj)]))]))]
          [else
           (vector-set! src ri a0)
           (let ([ri (fx+ ri 1)])
             (cond
               [(fx<=? ai aj)
                (do-merge-a! proc src skr ri rj ai aj bi bj b0)]
               [else
                (vector-set! src ri b0)
                (let ([ri (fx+ ri 1)])
                  (cond
                    [(fx<=? ri rj)
                     (copy-subrange! skr src bi ri rj)]))]))])))
    
    
    (define (do-merge-b! proc src skr ri rj ai aj bi bj a0)
      (let ([b0 (vector-ref skr bi)]
            [bi (fx+ bi 1)])
        (cond
          [(proc b0 a0)
           (vector-set! src ri b0)
           (let ([ri (fx+ ri 1)])
             (cond
               [(fx<=? bi bj)
                (do-merge-b! proc src skr ri rj ai aj bi bj a0)]
               [else
                (vector-set! src ri a0)
                (let ([ri (fx+ ri 1)])
                  (cond
                    [(fx<=? ri rj)
                     (copy-subrange! skr src ai ri rj)]))]))]
          [else
           (vector-set! src ri a0)
           (let ([ri (fx+ ri 1)])
             (cond
               [(fx<=? ai aj)
                (do-merge-a! proc src skr ri rj ai aj bi bj b0)]
               [else
                (vector-set! src ri b0)
                (let ([ri (fx+ ri 1)])
                  (cond
                    [(fx<=? ri rj)
                     (copy-subrange! skr src bi ri rj)]))]))])))
    
    (define (do-merge! proc src skr ri rj ai aj bi bj)
      (let ([a0 (vector-ref skr ai)]
            [b0 (vector-ref skr bi)]
            [ai (fx+ ai 1)]
            [bi (fx+ bi 1)])
        (cond
          [(proc b0 a0)
           (vector-set! src ri b0)
           (let ([ri (fx+ ri 1)])
             (cond
               [(fx<=? bi bj)
                (do-merge-b! proc src skr ri rj ai aj bi bj a0)]
               [else
                (vector-set! src ri a0) 
                (let ([ri (fx+ ri 1)])
                  (cond
                    [(fx<=? ri rj) 
                     (copy-subrange! skr src ai ri rj)]))]))]
          [else
           (vector-set! src ri a0)
           (let ([ri (fx+ ri 1)])
             (cond
               [(fx<=? ai aj)
                (do-merge-a! proc src skr ri rj ai aj bi bj b0)]
               [else
                (vector-set! src ri b0)
                (let ([ri (fx+ ri 1)])
                  (cond
                    [(fx<=? ri rj)
                     (copy-subrange! skr src bi ri rj)]))]))])))
    
    (define (do-sort! proc src skr i k)
      ; sort src[i .. k] inclusive in place
      (cond
        [(fx<? i k)
         (let ([j (fxarithmetic-shift-right (fx+ i k) 1)])
           (do-sort! proc skr src i j)
           (do-sort! proc skr src (fx+ j 1) k)
           (do-merge! proc src skr i k i j (fx+ j 1) k))]))
    
    (define (vector-copy v)
      (let ([n (vector-length v)])
        (let f ([v v] [r (make-vector n)] [n n] [i 0])
          (cond
            [(fx=? i n) r]
            [else 
             (vector-set! r i (vector-ref v i))
             (f v r n (fx+ i 1))]))))
    
    (define (vector-sort proc src)
      (unless (procedure? proc) 
        (die 'vector-sort "not a procedure" proc))
      (unless (vector? src) 
        (die 'vector-sort "not a vector" src))
      (let ([src (vector-copy src)]
            [skr (vector-copy src)])
        (do-sort! proc src skr 0 (fx- (vector-length src) 1))
        src))
    
    (define (vector-sort! proc src)
      (unless (procedure? proc) 
        (die 'vector-sort! "not a procedure" proc))
      (unless (vector? src) 
        (die 'vector-sort! "not a vector" src))
      (let ([skr (vector-copy src)])
        (do-sort! proc src skr 0 (fx- (vector-length src) 1))
        src)))
    
  )