vallog: sort

ラベル sort の投稿を表示しています。すべての投稿を表示

2014/08/16

ソートあるごりずむ

バブルソートよりも非効率なソートアルゴリズムを探して ―― ストゥージソートとスローソート - Line 1: Error: Invalid Blog('by Esehara' )

miracle sortステキ過ぎるｗ
ボゴソート、ボゾソート、ストゥージソート、スリープソート、いいですね。パーミューテーションソートもなかなかですよ。ちなみに僕はビーズソートが好きです。

他にもいくつか。

vallog: sort

ロゼッタコードとか、ウィキペディアのソートのページとか眺めると面白いです。

追記

ソートされていない要素を排除する「スターリンソート」というものがあるそうですね。笑

2013/07/06

Gaucheで各種ソートアルゴリズム

ソートアルゴリズムって、ふざけたもの含めて結構あるんだなー。ふざけてる系がすごく面白い。ボゴソートとかボゾソートとかパーミューテーションソートとか（笑）あとは基数ソート、ビーズズートなんかのバケツっぽいのが好きだなあ。スパゲティソートもいいなあ（ｗ
Wikipediaにあったソート。ソートじゃないのも入ってるかも。

Gauche

Gaucheで書いてみたのが、今んとこ以下のもの。

気が向いたらsortカテゴリで追加していこうかな。

vallog: sort

ところでGaucheのsortはイントロソートの親戚なのかな？

Island Life - ソート

Gaucheの組み込みの(Cで実装された)ソートはデフォルトではQuick Sortで始めて、再帰の深さが ceiling(2*log(N)) を越えた時にHeap Sortにスイッチするようにしてる。

Introsort - Wikipedia, the free encyclopedia

参考

Gaucheでstrand sort

Strand sort - Wikipedia

その他のソート

vallog:sort

ソース

strand.scm

(define (strand-sort ls)
  (define (merge ls1 ls2)
    (let rec ((ls1 ls1)(ls2 ls2)(acc '()))
      (cond ((null? ls1)
             (reverse (append (reverse ls2) acc)))
            ((null? ls2)
             (reverse (append (reverse ls1) acc)))
            ((< (car ls1)(car ls2))
             (rec (cdr ls1) ls2 (cons (car ls1) acc)))
            (else (rec ls1 (cdr ls2)(cons (car ls2) acc))))))
  (define (filter-sorted-elements ls)
    (if (null? ls)
        '()
        (let rec ((ls (cdr ls))(sorted (list (car ls)))(acc '()))
          (if (null? ls)
              (values (reverse sorted)
                      (reverse acc))
              (let1 sorted? (< (car sorted)(car ls))
                (rec (cdr ls)
                     (if sorted?
                         (cons (car ls)
                               sorted)
                         sorted)
                     (if sorted?
                         acc
                         (cons (car ls) acc))))))))
  ;; body
  (let rec ((ls ls)(acc '()))
    (if (null? ls)
        acc
        (receive (sorted rest)
            (filter-sorted-elements ls)
          (rec rest (merge sorted acc))))))


(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 strand-sort 5)
; length = 100
;(time (sorter ls))
; real   0.000
; user   0.000
; sys    0.000

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

; length = 10000
;(time (sorter ls))
; real   0.215
; user   0.210
; sys    0.010

; length = 100000
;(time (sorter ls))
; real   6.727
; user   6.710
; sys    0.000

; length = 1000000
;(time (sorter ls))
; real 205.260
; user 204.550
; sys    0.100

Gaucheでbogo sort

これはsleep sortを見て以来の衝撃だな・・・。

ボゴソート - Wikipedia

その他のソート

vallog:sort

ソース

bogo.scm

(use gauche.sequence)

(define (bogo-sort ls)
  (if (apply < ls)
      ls
      (bogo-sort (shuffle ls))))


(define data-5 (shuffle (iota 5)))
(define data-10 (shuffle (iota 10)))
(define data-15 (shuffle (iota 15)))

(time (bogo-sort data-5))
;(time (bogo-sort data-5))
; real   0.001
; user   0.000
; sys    0.000

(time (bogo-sort data-10))
;(time (bogo-sort data-10))
; real  12.053
; user  12.010
; sys    0.000

Gaucheでmerge sort

マージソート - Wikipedia

その他のソート

vallog:sort

ソース

merge.scm

(use srfi-1)
(define (merge-sort ls)
  (define (merge ls1 ls2)
    (let rec ((ls1 ls1)(ls2 ls2)(acc '()))
      (cond ((null? ls1)
             (reverse (append (reverse ls2) acc)))
            ((null? ls2)
             (reverse (append (reverse ls1) acc)))
            ((< (car ls1)(car ls2))
             (rec (cdr ls1) ls2 (cons (car ls1) acc)))
            (else (rec ls1 (cdr ls2)(cons (car ls2) acc))))))
  (if (or (null? ls)
          (null? (cdr ls)))
      ls
      (let1 split-index (quotient (length ls) 2)
        (receive (head tail)
            (split-at ls split-index)
          (merge (merge-sort head)
                 (merge-sort tail))))))



(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 merge-sort 6)


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

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

; length = 10000
;(time (sorter ls))
; real   0.025
; user   0.030
; sys    0.000

; length = 100000
;(time (sorter ls))
; real   0.288
; user   0.280
; sys    0.000

; length = 1000000
;(time (sorter ls))
; real   3.422
; user   3.370
; sys    0.030

; length = 10000000
;(time (sorter ls))
; real  40.993
; user  40.620
; sys    0.240

Gaucheでselection sort

選択ソート - Wikipedia

その他のソート

vallog:sort

ソース

selection.scm

(use srfi-43)
(define (selection-sort ls)
  (define (vector-min-index vect start-index)
    (do ((i start-index (+ i 1))
         (min-value +inf.0)
         (min-index 0))
        ((= i (vector-length vect))(values min-index min-value))
      (when (< (vector-ref vect i) min-value)
        (set! min-value (vector-ref vect i))
        (set! min-index i))))
  ;; body
  (do ((i 0 (+ i 1))
       (vect (list->vector ls)))
      ((= i (length ls))(vector->list vect))
    (vector-swap! vect i (vector-min-index vect i))))


(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 selection-sort 4)
; length = 100
;(time (sorter ls))
; real   0.001
; user   0.000
; sys    0.000

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

; length = 10000
;(time (sorter ls))
; real   2.614
; user   2.610
; sys    0.000

; length = 100000
;(time (sorter ls))
; real 255.403
; user 254.710
; sys    0.020

Gaucheでbozo sort

ボゾソート - Wikipedia

これもボゴソートと同じ類か（笑）

その他のソート

vallog:sort

ソース

bozo.scm

(use srfi-43)
(use srfi-27)

(define (bozo-sort ls)
  (random-source-randomize! default-random-source)
  (let ((vect (list->vector ls))
        (len (length ls)))
    (until (apply < (vector->list vect))
      (vector-swap! vect
                    (random-integer len)
                    (random-integer len)))
    (vector->list vect)))


(use gauche.sequence)

(dotimes (10)
  (let1 data (shuffle (iota 10))
    (time (bozo-sort data))
    (print)))

;(time (bozo-sort data))
; real  30.852
; user  30.740
; sys    0.000

;(time (bozo-sort data))
; real   0.862
; user   0.860
; sys    0.000

;(time (bozo-sort data))
; real   5.286
; user   5.280
; sys    0.000

;(time (bozo-sort data))
; real   0.598
; user   0.600
; sys    0.000

;(time (bozo-sort data))
; real   2.561
; user   2.560
; sys    0.000

;(time (bozo-sort data))
; real   4.554
; user   4.540
; sys    0.000

;(time (bozo-sort data))
; real   4.434
; user   4.420
; sys    0.000

;(time (bozo-sort data))
; real  12.168
; user  12.130
; sys    0.000

;(time (bozo-sort data))
; real  11.710
; user  11.670
; sys    0.000

;(time (bozo-sort data))
; real  20.846
; user  20.790
; sys    0.000

Gaucheでstooge sort

ストゥージソート - Wikipedia

その他のソート

vallog:sort

ソース

stooge.scm

(use srfi-43)

(define (stooge-sort ls)
  (let1 vect (list->vector ls)
    (let rec ((head 0)(tail (- (vector-length vect) 1)))
      (when (< (vector-ref vect tail)
               (vector-ref vect head))
        (vector-swap! vect head tail))
      (when (<= 3 (+ (- tail head) 1))
        (let1 index-of-1/3 (quotient (+ (- tail head) 1) 3)
          (rec head (- tail index-of-1/3))
          (rec (+ head index-of-1/3) tail)
          (rec head (- tail index-of-1/3))))
      vect)))

(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 stooge-sort 2)

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

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

Gaucheでbead sort（ビーズソート）

Sorting algorithms/Bead sort - Rosetta Code

これすごく面白かった。rosetta codeのracketのソースを参考にしたんだけど、そのコードに出てくるcolumnって手続きが目からウロコだった。これはビーズを通したヒモを立てることそのものだ。かっこいい。自分で書く時には末尾再帰にして名前もbead-downにした。

ここの図解がわかりやすい。

スパゲティ・ソートとビーズ・ソート - kdoo

その他のソート

vallog:sort

ソース

bead.scm

(define (bead-sort ls)
  (define (bead-down ls)
    (let rec ((ls (remove null? ls))(acc '()))
      (if (null? ls)
          (reverse acc)
          (rec (remove null? (map cdr ls))
               (cons (map car ls) acc)))))
  ;; body
  (map length (bead-down (bead-down (map (cut make-list <> 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 bead-sort 3)

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

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

; length = 10000
;(time (sorter ls))
; real  49.590
; user  47.500
; sys    1.380

Gaucheでpermutation sort

Sorting algorithms/Permutation sort - Rosetta Code

その他のソート

vallog:sort

ソース

permutation.scm

(use util.combinations)

(define (permutation-sort ls)
  (if (or (null? ls)
          (null? (cdr ls)))
      ls
      (let rec ((candidates (permutations* ls)))
        (if (apply <= (car candidates))
            (car candidates)
            (rec (cdr candidates))))))


(use gauche.sequence)
(dotimes (i 11)
  (let1 data (shuffle (iota i))
    (time (permutation-sort data))
    (print)))


;(time (permutation-sort data))
; real   0.000
; user   0.000
; sys    0.000

;(time (permutation-sort data))
; real   0.000
; user   0.000
; sys    0.000

;(time (permutation-sort data))
; real   0.000
; user   0.000
; sys    0.000

;(time (permutation-sort data))
; real   0.000
; user   0.000
; sys    0.000

;(time (permutation-sort data))
; real   0.000
; user   0.000
; sys    0.000

;(time (permutation-sort data))
; real   0.000
; user   0.000
; sys    0.000

;(time (permutation-sort data))
; real   0.002
; user   0.000
; sys    0.000

;(time (permutation-sort data))
; real   0.011
; user   0.010
; sys    0.000

;(time (permutation-sort data))
; real   0.084
; user   0.080
; sys    0.000

;(time (permutation-sort data))
; real   0.760
; user   0.750
; sys    0.010

;(time (permutation-sort data))
; real  10.210
; user  10.180
; sys    0.000

2013/07/05

Gaucheでquick sort

クイックソート - Wikipedia

自分も書いてみた。

ふつうにクイックソートをSchemeで書いた - (define -ayalog ’())

書いたといっても、検索して出てきたshiroさんが書いたクイックソートのコードを参考にした。match使ってないだけ。

その他のソート

vallog:sort

ソース

quick.scm

(use srfi-1)

(define (quick-sort ls)
  (if (null? ls)
      '()
      (receive (ws ys)
          (partition (pa$ > (car ls))(cdr ls))
        (append (quick-sort ws)
                (list (car ls))
                (quick-sort ys)))))


(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 quick-sort 6)
; length = 100
;(time (sorter ls))
; real   0.001
; user   0.000
; sys    0.000

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

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

; length = 100000
;(time (sorter ls))
; real   0.737
; user   0.730
; sys    0.000

; length = 1000000
;(time (sorter ls))
; real   9.191
; user   9.110
; sys    0.050

; length = 10000000
;(time (sorter ls))
; real 124.532
; user 123.700
; sys    0.450

2011/07/31

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

参考

追記

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))))

Gaucheでbucket sort

その他のソート

vallog:sort

ソース

バケットソート - Wikipedia

(define (bucket-sort ls)
  (let* ((min (apply min ls))
         (max (apply max ls))
         (buckets (make-vector (+ (- max min) 1) '())))
    (for-each (lambda (e)
                (let ((i (- e min)))
                  (vector-set! buckets i
                               (cons e (vector-ref buckets i)))))
                ls)
    (apply append (vector->list buckets))))


;;
;; test
;;

(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 bucket-sort 6)
; length = 100
;(time (sorter ls))
; real   0.000
; user   0.000
; sys    0.000

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

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

; length = 100000
;(time (sorter ls))
; real   0.043
; user   0.040
; sys    0.000

; length = 1000000
;(time (sorter ls))
; real   1.032
; user   0.490
; sys    0.090

; length = 10000000
;(time (sorter ls))
; real   8.767
; user   8.490
; sys    0.240

参考

Gaucheでbubble sort

その他のソート

vallog:sort

ソース

bubble.scm

準備

(use math.mt-random)
(use srfi-1)

(define data
  '(1 0 9 2 8 4 3 6 7 8 9 5 0 1 2 3))

(define rand
  (let1 m (make <mersenne-twister> :seed (sys-time))
    (^n (mt-random-integer m n))))

(define (make-rand-list n)
  (list-tabulate n (^_ (rand n))))

汚いけど末尾再帰で

(define (bubble-sort ls)
  (define (pass1 ls)
    (let rec ((ls ls)(acc '()))
      (cond ((null? (cdr ls))(reverse (cons (car ls) acc)))
            ((< (cadr ls)(car ls))
             (rec (cons (car ls)(cddr ls))(cons (cadr ls) acc)))
            (else (rec (cdr ls)(cons (car ls) acc))))))
  (let rec ((ls ls)(i (- (length ls) 1)))
    (if (or (null? ls)(zero? i))
        ls
        (rec (pass1 ls) (- i 1)))))

(bubble-sort data)
;; -> (0 0 1 1 2 2 3 3 4 5 6 7 8 8 9 9)

(time (bubble-sort (make-rand-list 1000)))
;(time (bubble-sort (make-rand-list 1000)))
; real   0.698
; user   0.687
; sys    0.015


(time (bubble-sort (make-rand-list 10000))
      (undefined))
;(time (bubble-sort (make-rand-list 10000)) (undefined))
; real  68.651
; user  68.250
; sys    0.203

vector + 副作用で

(define (bubble-sort! v)
  (let ((len (vector-length v)))
    (dotimes (_ len)
      (dotimes (i len)
        (when (< (+ i 1) len)
          (let ((cur (vector-ref v i))
                (next (vector-ref v (+ i 1))))
            (when (< next cur)
              (vector-set! v (+ i 1) cur)
              (vector-set! v i next)))))))
  v)

(let ((v (list->vector data)))
  (bubble-sort! v))
;; -> #(0 0 1 1 2 2 3 3 4 5 6 7 8 8 9 9)

(time
 (let ((v (list->vector (make-rand-list 1000))))
   (vector->list (bubble-sort! v))))
;(time (let ((v (list->vector (make-rand-list 1000)))) (bubble-sort! v)))
; real   0.698
; user   0.703
; sys    0.000


(time
 (let ((v (list->vector (make-rand-list 10000))))
   (vector->list (bubble-sort! v))
   (undefined)))
;(time (let ((v (list->vector (make-rand-list 10000)))) (vector->list (b ...
; real  67.471
; user  66.531
; sys    0.016

vector + 副作用版が速いだろうと思ったけど、末尾再帰版とほとんど変わらなかった。

参考

登録: 投稿 (Atom)

2014/08/16

追記

2013/07/06

Gauche

参考

その他のソート

ソース

その他のソート

ソース

その他のソート

ソース

その他のソート

ソース

その他のソート

ソース

その他のソート

ソース

その他のソート

ソース

その他のソート

ソース

2013/07/05

その他のソート

ソース

2011/07/31

その他のソート

ソース

参考

追記

その他のソート

ソース

参考

その他のソート

ソース

参考

KPF

9LISP