Gaucheでradix sort

• 基数ソート - Wikipedia

その他のソート

• vallog:sort

ソース

• radix.scm

(define (radix-sort ls :optional (base 10))
  (define (digit-count num)
    (x->integer (ceiling (/ (log num)(log base)))))
  (define (digit-of index num)
    (modulo (quotient num (expt base index)) base))
  (define (list-set! ls n obj)
    (let/cc hop
      (let rec ((l ls)(n n))
        (if (zero? n)
            (begin (set! (car l) obj)
                   (hop ls))
            (rec (cdr l)(- n 1))))))
  (set! (setter list-ref) list-set!)
  (let1 count (digit-count (abs (apply max ls)))
    (let rec ((ls ls)(index 0))
      (if (< index count)
          (let1 buckets (make-list base '())
            (for-each
             (^e (let1 digit (digit-of index e)
                   (set! (list-ref buckets digit)
                         (cons e (list-ref buckets digit)))))
             ls)
            (rec (apply append (map reverse buckets))(+ index 1)))
          ls))))


(use gauche.sequence)

(define (test sorter n)
  (for-each (^i (let1 ls (shuffle (iota (expt 10 i)))
                  (print "; length = " (expt 10 i))
                  (time (sorter ls))
                  (print)))
            (iota n 2)))


(test radix-sort 6)
; length = 100
;(time (sorter ls))
; real   0.000
; user   0.000
; sys    0.000

; length = 1000
;(time (sorter ls))
; real   0.004
; user   0.000
; sys    0.000

; length = 10000
;(time (sorter ls))
; real   0.084
; user   0.080
; sys    0.000

; length = 100000
;(time (sorter ls))
; real   1.034
; user   1.030
; sys    0.010

; length = 1000000
;(time (sorter ls))
; real  13.469
; user  13.400
; sys    0.040

; length = 10000000
;(time (sorter ls))
; real 242.686
; user 241.360
; sys    0.610

;; vector version
(use srfi-43)
(define (radix-sort ls :optional (base 10))
  (define (digit-count num)
    (x->integer (ceiling (/ (log num)(log base)))))
  (define (digit-of index num)
    (modulo (quotient num (expt base index)) base))
  (define (put-buckets! vect buckets index)
    (vector-for-each
     (^(_ e)
       (let1 digit (digit-of index e)
         (vector-set! buckets digit
                      (cons e (vector-ref buckets digit)))))
     vect))
  (let ((buckets (make-vector base '()))
        (v (list->vector ls)))
    (dotimes (index (digit-count (abs (apply max ls))))
      (put-buckets! v buckets index)
      (set! v (list->vector (apply append (map reverse (vector->list buckets)))))
      (set! buckets (make-vector base '())))
    (vector->list v)))

(test radix-sort 6)

; length = 100
;(time (sorter ls))
; real   0.000
; user   0.010
; sys    0.000

; length = 1000
;(time (sorter ls))
; real   0.001
; user   0.000
; sys    0.000

; length = 10000
;(time (sorter ls))
; real   0.015
; user   0.020
; sys    0.000

; length = 100000
;(time (sorter ls))
; real   0.203
; user   0.210
; sys    0.000

; length = 1000000
;(time (sorter ls))
; real   2.309
; user   2.300
; sys    0.000

; length = 10000000
GC Warning: Repeated allocation of very large block (appr. size 80003072):
    May lead to memory leak and poor performance.
GC Warning: Repeated allocation of very large block (appr. size 80003072):
    May lead to memory leak and poor performance.
;(time (sorter ls))
; real  65.467
; user  35.900
; sys    3.370

参考

• いろいろなソートアルゴリズム
• Sorting algorithms/Radix sort - Rosetta Code

追記

GaucheのHEADで試したら、list-refのsetterを登録するところで、

*** ERROR: can't change the locked setter of procedure #

ということだった。試しに(setter list-ref)したらlist-set!があった。ということで、list-set!と(set! (setter list-ref) list-set!)を削除。

;; Gauche HEAD ver (Exists list-set!)
(define (radix-sort ls :optional (base 10))
  (define (digit-count num)
    (x->integer (ceiling (/ (log num)(log base)))))
  (define (digit-of index num)
    (modulo (quotient num (expt base index)) base))
  (let1 count (digit-count (abs (apply max ls)))
    (let rec ((ls ls)(index 0))
      (if (< index count)
          (let1 buckets (make-list base '())
            (for-each
             (^e (let1 digit (digit-of index e)
                   (set! (list-ref buckets digit)
                         (cons e (list-ref buckets digit)))))
             ls)
            (rec (apply append (map reverse buckets))(+ index 1)))
          ls))))