fork download
copy 
  1. #lang racket
  2.  
  3. ;;; バブルソート
  4. (define (bsort s proc)
  5.   (define (_bsort s (acc '()))
  6.     (if (null? (cdr s))
  7.         `(,@acc ,(car s))
  8.         (let ((x (car s)) (x2 (cadr s)) (xs (cddr s)))
  9.           (_bsort `(,(if (proc x x2)
  10.                          x2
  11.                          x) ,@xs)
  12.                   `(,@acc ,(if (proc x x2)
  13.                                x
  14.                                x2))))))
  15.   (let loop ((s s) (t (_bsort s)))
  16.     (if (equal? t s)
  17.         t
  18.         (loop t (_bsort t)))))
  19.  
  20. ;;; 動作例
  21. (bsort '(8 4 3 7 6 5 2 1) <)
  22.  
  23.  
  24. ;;; ノームソート
  25. (define (gnomeSort vv proc)
  26.   (define (gs v w)
  27.     (cond ((null? v) (gs `(,(car w)) (cdr w)))
  28.           ((null? w) (reverse v))
  29.           ((proc (car v) (car w)) (gs `(,(car w) ,@v) (cdr w)))
  30.           (else (gs (cdr v) `(,(car w) ,(car v) ,@(cdr w))))))
  31.   (let ((x (car vv)) (xs (cdr vv)))
  32.     (gs `(,x) xs)))
  33.  
  34. ;;; 動作例
  35. (gnomeSort '(4 2 7 3) <)
  36.  
  37.  
  38. ;;; 選択ソート
  39. (define (selSort xs proc)
  40.   (let loop ((xs xs) (acc '()))
  41.     (if (null? xs)
  42.         acc
  43.         (let ((x (apply proc xs)))
  44.           (loop (remove x xs) (cons x acc))))))
  45.  
  46. ;;; 動作例
  47. (selSort '(8 4 3 7 6 5 2 1) max)
  48.  
  49.  
  50. ;;; 挿入ソート
  51. (define (insertionSort xs proc)
  52.   (define (insert item ls)
  53.     (let loop ((ls ls) (acc '()))
  54.       (if (null? ls)
  55.           `(,@acc ,item)
  56.           (let ((x (car ls)))
  57.             (if (proc item x)
  58.                 `(,@acc ,item ,@ls)
  59.                 (loop (cdr ls) `(,@acc ,(car ls))))))))
  60.   (foldr insert '() xs))
  61.  
  62. ;;; 動作例
  63. (insertionSort '(6 8 5 9 3 2 1 4 7) <)
  64.  
  65.  
  66. ;;; マージソート
  67. (define (mergeSort xs proc)
  68.   (define (merge xs ys)
  69.     (let loop ((xs xs) (ys ys) (acc '()))
  70.       (cond ((null? xs) `(,@acc ,@ys))
  71.             ((null? ys) `(,@acc ,@xs))
  72.             ((proc (car xs) (car ys)) (loop (cdr xs) ys `(,@acc ,(car xs))))
  73.             (else (loop xs (cdr ys) `(,@acc ,(car ys)))))))
  74.   (define (split xs)
  75.     (split-at xs (quotient (length xs) 2)))
  76.   (define (msort xs)
  77.     (cond ((null? xs) '())
  78.           ((null? (cdr xs)) xs)
  79.           (else (let-values (((as bs) (split xs)))
  80.                   (merge (msort as) (msort bs))))))
  81.   (msort xs))
  82.  
  83. ;;; 動作例
  84. (mergeSort '(8 4 3 7 6 5 2 1) <)
  85.  
  86.  
  87. ;;; クイックソート
  88. (define (qsort xs proc)
  89.   (if (null? xs)
  90.       '()
  91.       (let ((x (car xs)) (xs (cdr xs)))
  92.         `(,@(qsort (filter (lambda (y)
  93.                              (proc y x)) xs) proc)
  94.           ,x
  95.           ,@(qsort (filter (lambda (y)
  96.                              ((compose not proc) y x)) xs) proc)))))
  97.  
  98. ;;; 動作例
  99. (qsort '(8 4 3 7 6 5 2 1) <)
  100.  
  101.  
  102. ;;; ストランドソート
  103. (define (strandSort xs proc)
  104.   (define (merge xs ys)
  105.     (let loop ((xs xs) (ys ys) (acc '()))
  106.       (cond ((null? xs) `(,@acc ,@ys))
  107.             ((null? ys) `(,@acc ,@xs))
  108.             ((proc (car xs) (car ys)) (loop (cdr xs) ys `(,@acc ,(car xs))))
  109.             (else (loop xs (cdr ys) `(,@acc ,(car ys)))))))
  110.   (define (extractStrand x xs)
  111.     (if (null? xs)
  112.         (values `(,x) '())
  113.         (let ((x1 (car xs)) (xs (cdr xs)))
  114.           (if (proc x x1)
  115.               (let-values (((strand rest) (extractStrand x1 xs)))
  116.                 (values (cons x strand) rest))
  117.               (let-values (((strand rest) (extractStrand x xs)))
  118.                 (values strand (cons x1 rest)))))))
  119.   (let loop ((xs xs) (acc '()))
  120.     (if (null? xs)
  121.         acc
  122.         (let-values (((strand rest) (extractStrand (car xs) (cdr xs))))
  123.           (loop rest (merge acc strand))))))
  124.  
  125. ;;; 動作例
  126. (strandSort '(5 1 4 2 0 9 6 3 8 7) <)
Success #stdin #stdout 0.55s 84852KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/yDMrfZ
language:
Racket (racket 7.0)
created:
2 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!