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 
    (ikarus system $fx)
    (except (ikarus) list-sort vector-sort vector-sort!))
  
  (module (sort-tail)
    (define (merge1 <? a1 ls1 ls2) 
      (cond
        [(null? ls2) ls1]
        [else
         (let ([a2 (car ls2)])
           (cond
             [(<? a2 a1) 
              (cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
             [else
              (cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
    
    (define (merge2 <? a2 ls1 ls2) 
      (cond
        [(null? ls1) ls2]
        [else
         (let ([a1 (car ls1)])
           (cond
             [(<? a2 a1) 
              (cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
             [else
              (cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
  
    (define (merge <? ls1 ls2) 
      (cond
        [(null? ls2) ls1]
        [else 
         (let ([a1 (car ls1)] [a2 (car ls2)])
           (cond
             [(<? a2 a1) 
              (cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
             [else
              (cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
  
    (define (sort-head <? ls n)
      (cond
        [($fx= n 0) (values '() ls)]
        [($fx= n 1)
         (values (cons (car ls) '()) (cdr ls))]
        [else
         (let-values ([(sorted-head tail) 
                       (sort-head <? ls ($fxsra n 1))])
           (let-values ([(sorted-tail tail) 
                         (sort-head <? tail ($fx- n ($fxsra n 1)))])
             (values (merge <? sorted-head sorted-tail) tail)))]))
  
    (define (sort-tail <? ls n) 
      (cond
        [($fx<= n 1) ls]
        [else
         (let-values ([(sorted-head tail) 
                       (sort-head <? ls ($fxsra n 1))])
            (merge <? sorted-head 
              (sort-tail <? tail ($fx- n ($fxsra n 1)))))])))

  (define (list-sort <? ls) 
    (unless (procedure? <?)
      (die 'list-sort "not a procedure" <?))
    (sort-tail <? ls (length ls)))


  (module (vector-sort vector-sort!)
    (module UNSAFE  
      (fx<? fx<=? fx>? fx>=? fx=? 
       fx+ fx- fxarithmetic-shift-right
       vector-ref vector-set!)
      (import 
        (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=?))))
   
    (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)))
    
  )