#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) <)
I2xhbmcgcmFja2V0Cgo7Ozsg44OQ44OW44Or44K944O844OICihkZWZpbmUgKGJzb3J0IHMgcHJvYykKICAoZGVmaW5lIChfYnNvcnQgcyAoYWNjICcoKSkpCiAgICAoaWYgKG51bGw/IChjZHIgcykpCiAgICAgICAgYCgsQGFjYyAsKGNhciBzKSkKICAgICAgICAobGV0ICgoeCAoY2FyIHMpKSAoeDIgKGNhZHIgcykpICh4cyAoY2RkciBzKSkpCiAgICAgICAgICAoX2Jzb3J0IGAoLChpZiAocHJvYyB4IHgyKQogICAgICAgICAgICAgICAgICAgICAgICAgeDIKICAgICAgICAgICAgICAgICAgICAgICAgIHgpICxAeHMpCiAgICAgICAgICAgICAgICAgIGAoLEBhY2MgLChpZiAocHJvYyB4IHgyKQogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgeAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgeDIpKSkpKSkKICAobGV0IGxvb3AgKChzIHMpICh0IChfYnNvcnQgcykpKQogICAgKGlmIChlcXVhbD8gdCBzKQogICAgICAgIHQKICAgICAgICAobG9vcCB0IChfYnNvcnQgdCkpKSkpCgo7Ozsg5YuV5L2c5L6LCihic29ydCAnKDggNCAzIDcgNiA1IDIgMSkgPCkKCgo7Ozsg44OO44O844Og44K944O844OICihkZWZpbmUgKGdub21lU29ydCB2diBwcm9jKQogIChkZWZpbmUgKGdzIHYgdykKICAgIChjb25kICgobnVsbD8gdikgKGdzIGAoLChjYXIgdykpIChjZHIgdykpKQogICAgICAgICAgKChudWxsPyB3KSAocmV2ZXJzZSB2KSkKICAgICAgICAgICgocHJvYyAoY2FyIHYpIChjYXIgdykpIChncyBgKCwoY2FyIHcpICxAdikgKGNkciB3KSkpCiAgICAgICAgICAoZWxzZSAoZ3MgKGNkciB2KSBgKCwoY2FyIHcpICwoY2FyIHYpICxAKGNkciB3KSkpKSkpCiAgKGxldCAoKHggKGNhciB2dikpICh4cyAoY2RyIHZ2KSkpCiAgICAoZ3MgYCgseCkgeHMpKSkKCjs7OyDli5XkvZzkvosKKGdub21lU29ydCAnKDQgMiA3IDMpIDwpCgoKOzs7IOmBuOaKnuOCveODvOODiAooZGVmaW5lIChzZWxTb3J0IHhzIHByb2MpCiAgKGxldCBsb29wICgoeHMgeHMpIChhY2MgJygpKSkKICAgIChpZiAobnVsbD8geHMpCiAgICAgICAgYWNjCiAgICAgICAgKGxldCAoKHggKGFwcGx5IHByb2MgeHMpKSkKICAgICAgICAgIChsb29wIChyZW1vdmUgeCB4cykgKGNvbnMgeCBhY2MpKSkpKSkKCjs7OyDli5XkvZzkvosKKHNlbFNvcnQgJyg4IDQgMyA3IDYgNSAyIDEpIG1heCkKCgo7Ozsg5oy/5YWl44K944O844OICihkZWZpbmUgKGluc2VydGlvblNvcnQgeHMgcHJvYykKICAoZGVmaW5lIChpbnNlcnQgaXRlbSBscykKICAgIChsZXQgbG9vcCAoKGxzIGxzKSAoYWNjICcoKSkpCiAgICAgIChpZiAobnVsbD8gbHMpCiAgICAgICAgICBgKCxAYWNjICxpdGVtKQogICAgICAgICAgKGxldCAoKHggKGNhciBscykpKQogICAgICAgICAgICAoaWYgKHByb2MgaXRlbSB4KQogICAgICAgICAgICAgICAgYCgsQGFjYyAsaXRlbSAsQGxzKQogICAgICAgICAgICAgICAgKGxvb3AgKGNkciBscykgYCgsQGFjYyAsKGNhciBscykpKSkpKSkpCiAgKGZvbGRyIGluc2VydCAnKCkgeHMpKQoKOzs7IOWLleS9nOS+iwooaW5zZXJ0aW9uU29ydCAnKDYgOCA1IDkgMyAyIDEgNCA3KSA8KQoKCjs7OyDjg57jg7zjgrjjgr3jg7zjg4gKKGRlZmluZSAobWVyZ2VTb3J0IHhzIHByb2MpCiAgKGRlZmluZSAobWVyZ2UgeHMgeXMpCiAgICAobGV0IGxvb3AgKCh4cyB4cykgKHlzIHlzKSAoYWNjICcoKSkpCiAgICAgIChjb25kICgobnVsbD8geHMpIGAoLEBhY2MgLEB5cykpCiAgICAgICAgICAgICgobnVsbD8geXMpIGAoLEBhY2MgLEB4cykpCiAgICAgICAgICAgICgocHJvYyAoY2FyIHhzKSAoY2FyIHlzKSkgKGxvb3AgKGNkciB4cykgeXMgYCgsQGFjYyAsKGNhciB4cykpKSkKICAgICAgICAgICAgKGVsc2UgKGxvb3AgeHMgKGNkciB5cykgYCgsQGFjYyAsKGNhciB5cykpKSkpKSkKICAoZGVmaW5lIChzcGxpdCB4cykKICAgIChzcGxpdC1hdCB4cyAocXVvdGllbnQgKGxlbmd0aCB4cykgMikpKQogIChkZWZpbmUgKG1zb3J0IHhzKQogICAgKGNvbmQgKChudWxsPyB4cykgJygpKQogICAgICAgICAgKChudWxsPyAoY2RyIHhzKSkgeHMpCiAgICAgICAgICAoZWxzZSAobGV0LXZhbHVlcyAoKChhcyBicykgKHNwbGl0IHhzKSkpCiAgICAgICAgICAgICAgICAgIChtZXJnZSAobXNvcnQgYXMpIChtc29ydCBicykpKSkpKQogIChtc29ydCB4cykpCgo7Ozsg5YuV5L2c5L6LCihtZXJnZVNvcnQgJyg4IDQgMyA3IDYgNSAyIDEpIDwpCgoKOzs7IOOCr+OCpOODg+OCr+OCveODvOODiAooZGVmaW5lIChxc29ydCB4cyBwcm9jKQogIChpZiAobnVsbD8geHMpCiAgICAgICcoKQogICAgICAobGV0ICgoeCAoY2FyIHhzKSkgKHhzIChjZHIgeHMpKSkKICAgICAgICBgKCxAKHFzb3J0IChmaWx0ZXIgKGxhbWJkYSAoeSkKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAocHJvYyB5IHgpKSB4cykgcHJvYykKICAgICAgICAgICx4CiAgICAgICAgICAsQChxc29ydCAoZmlsdGVyIChsYW1iZGEgKHkpCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgKChjb21wb3NlIG5vdCBwcm9jKSB5IHgpKSB4cykgcHJvYykpKSkpCgo7Ozsg5YuV5L2c5L6LCihxc29ydCAnKDggNCAzIDcgNiA1IDIgMSkgPCkKCgo7Ozsg44K544OI44Op44Oz44OJ44K944O844OICihkZWZpbmUgKHN0cmFuZFNvcnQgeHMgcHJvYykKICAoZGVmaW5lIChtZXJnZSB4cyB5cykKICAgIChsZXQgbG9vcCAoKHhzIHhzKSAoeXMgeXMpIChhY2MgJygpKSkKICAgICAgKGNvbmQgKChudWxsPyB4cykgYCgsQGFjYyAsQHlzKSkKICAgICAgICAgICAgKChudWxsPyB5cykgYCgsQGFjYyAsQHhzKSkKICAgICAgICAgICAgKChwcm9jIChjYXIgeHMpIChjYXIgeXMpKSAobG9vcCAoY2RyIHhzKSB5cyBgKCxAYWNjICwoY2FyIHhzKSkpKQogICAgICAgICAgICAoZWxzZSAobG9vcCB4cyAoY2RyIHlzKSBgKCxAYWNjICwoY2FyIHlzKSkpKSkpKQogIChkZWZpbmUgKGV4dHJhY3RTdHJhbmQgeCB4cykKICAgIChpZiAobnVsbD8geHMpCiAgICAgICAgKHZhbHVlcyBgKCx4KSAnKCkpCiAgICAgICAgKGxldCAoKHgxIChjYXIgeHMpKSAoeHMgKGNkciB4cykpKQogICAgICAgICAgKGlmIChwcm9jIHggeDEpCiAgICAgICAgICAgICAgKGxldC12YWx1ZXMgKCgoc3RyYW5kIHJlc3QpIChleHRyYWN0U3RyYW5kIHgxIHhzKSkpCiAgICAgICAgICAgICAgICAodmFsdWVzIChjb25zIHggc3RyYW5kKSByZXN0KSkKICAgICAgICAgICAgICAobGV0LXZhbHVlcyAoKChzdHJhbmQgcmVzdCkgKGV4dHJhY3RTdHJhbmQgeCB4cykpKQogICAgICAgICAgICAgICAgKHZhbHVlcyBzdHJhbmQgKGNvbnMgeDEgcmVzdCkpKSkpKSkKICAobGV0IGxvb3AgKCh4cyB4cykgKGFjYyAnKCkpKQogICAgKGlmIChudWxsPyB4cykKICAgICAgICBhY2MKICAgICAgICAobGV0LXZhbHVlcyAoKChzdHJhbmQgcmVzdCkgKGV4dHJhY3RTdHJhbmQgKGNhciB4cykgKGNkciB4cykpKSkKICAgICAgICAgIChsb29wIHJlc3QgKG1lcmdlIGFjYyBzdHJhbmQpKSkpKSkKCjs7OyDli5XkvZzkvosKKHN0cmFuZFNvcnQgJyg1IDEgNCAyIDAgOSA2IDMgOCA3KSA8KQ==