#lang racket
;;; バブルソート
(define (bsort s proc)
(define (_bsort s (acc '()))
(if (null? (cdr s))
`(,@acc ,(car s))
(let ((x (car s)) (x2 (cadr s)) (xs (cddr s)))
(_bsort `(,(if (proc x x2)
x2
x) ,@xs)
`(,@acc ,(if (proc x x2)
x
x2))))))
(let loop ((s s) (t (_bsort s)))
(if (equal? t s)
t
(loop t (_bsort t)))))
;;; 動作例
(bsort '(8 4 3 7 6 5 2 1) <)
;;; ノームソート
(define (gnomeSort vv proc)
(define (gs v w)
(cond ((null? v) (gs `(,(car w)) (cdr w)))
((null? w) (reverse v))
((proc (car v) (car w)) (gs `(,(car w) ,@v) (cdr w)))
(else (gs (cdr v) `(,(car w) ,(car v) ,@(cdr w))))))
(let ((x (car vv)) (xs (cdr vv)))
(gs `(,x) xs)))
;;; 動作例
(gnomeSort '(4 2 7 3) <)
;;; 選択ソート
(define (selSort xs proc)
(let loop ((xs xs) (acc '()))
(if (null? xs)
acc
(let ((x (apply proc xs)))
(loop (remove x xs) (cons x acc))))))
;;; 動作例
(selSort '(8 4 3 7 6 5 2 1) max)
;;; 挿入ソート
(define (insertionSort xs proc)
(define (insert item ls)
(let loop ((ls ls) (acc '()))
(if (null? ls)
`(,@acc ,item)
(let ((x (car ls)))
(if (proc item x)
`(,@acc ,item ,@ls)
(loop (cdr ls) `(,@acc ,(car ls))))))))
(foldr insert '() xs))
;;; 動作例
(insertionSort '(6 8 5 9 3 2 1 4 7) <)
;;; マージソート
(define (mergeSort xs proc)
(define (merge xs ys)
(let loop ((xs xs) (ys ys) (acc '()))
(cond ((null? xs) `(,@acc ,@ys))
((null? ys) `(,@acc ,@xs))
((proc (car xs) (car ys)) (loop (cdr xs) ys `(,@acc ,(car xs))))
(else (loop xs (cdr ys) `(,@acc ,(car ys)))))))
(define (split xs)
(split-at xs (quotient (length xs) 2)))
(define (msort xs)
(cond ((null? xs) '())
((null? (cdr xs)) xs)
(else (let-values (((as bs) (split xs)))
(merge (msort as) (msort bs))))))
(msort xs))
;;; 動作例
(mergeSort '(8 4 3 7 6 5 2 1) <)
;;; クイックソート
(define (qsort xs proc)
(if (null? xs)
'()
(let ((x (car xs)) (xs (cdr xs)))
`(,@(qsort (filter (lambda (y)
(proc y x)) xs) proc)
,x
,@(qsort (filter (lambda (y)
((compose not proc) y x)) xs) proc)))))
;;; 動作例
(qsort '(8 4 3 7 6 5 2 1) <)
;;; ストランドソート
(define (strandSort xs proc)
(define (merge xs ys)
(let loop ((xs xs) (ys ys) (acc '()))
(cond ((null? xs) `(,@acc ,@ys))
((null? ys) `(,@acc ,@xs))
((proc (car xs) (car ys)) (loop (cdr xs) ys `(,@acc ,(car xs))))
(else (loop xs (cdr ys) `(,@acc ,(car ys)))))))
(define (extractStrand x xs)
(if (null? xs)
(values `(,x) '())
(let ((x1 (car xs)) (xs (cdr xs)))
(if (proc x x1)
(let-values (((strand rest) (extractStrand x1 xs)))
(values (cons x strand) rest))
(let-values (((strand rest) (extractStrand x xs)))
(values strand (cons x1 rest)))))))
(let loop ((xs xs) (acc '()))
(if (null? xs)
acc
(let-values (((strand rest) (extractStrand (car xs) (cdr xs))))
(loop rest (merge acc strand))))))
;;; 動作例
(strandSort '(5 1 4 2 0 9 6 3 8 7) <)
ソートはANSI Common Lispには含まれてるが、Schemeの仕様には含まれていない。
が、各種Scheme実装はsort関数を提供してる事と思う。何故なら結構実装がメンド臭いからだ。そしてソーティング・アルゴリズムは意外と「これ」と言った決定打もない。
アルゴリズムの宿題としても有名で、コンピュータサイエンスでもはじめてアルゴリズムらしいアルゴリズムとして各技法が取り上げられる事も多いだろう。
本質的、かつ利便性で言うと、sort関数は高階関数じゃないとならない。従って、Lisp以降の「関数がファーストクラスオブジェクトで」「高階関数が扱える」プログラミング言語でも宿題としては格好の題材ではある。
一方、C言語みたいな高階関数が扱えないプログラミング言語でも標準ライブラリ関数の1つとしてクイックソート関数が付随してる。極めて使いづらいが。しかし、使いづらくても利便性から標準ライブラリとして提供せざるを得ないのだ。実装がメンド臭いから。
一番単純なのは、バブルソートだろう。実の事を言うと、これは「アルゴリズム」って程のアルゴリズムじゃない。単に先頭から、順次見ていって、今見てる要素と次の要素を比較して順序の大小がおかしければ入れ替えていくだけ、だ。
ただし、その過程は、一回行ったから、と言って整列は完了しない。もう一度先頭から見ていって同じ作業をしていく。それを何度も行うと、整列が完了するわけだ。
これは単純だけど、当然時間がかかる。
現代的な観点で言うと、まずは覚えておかなければならないのはクイックソートだろう。クイックソート一本覚えておけばまずは大丈夫だ。いや、覚えたければな。先程にも書いた通り、sortは大体実装が提供してて、実装が提供するsortより効率のいい関数は原則書けないだろう。言い換えると、sortを提供してない実装は使う価値がないのだ。だってメンド臭いんだもん(笑)。
あと、歴史的観点で覚えておいた方が良い、と言うのが数学者、フォン・ノイマンが提案したマージソートくらいか。取り敢えずこの3つくらい「教養として」押さえておけばいいだろ、と言う話である。
なお、上のソースはここにも置いておく。
