fork download
copy 
  1. ; hoare's partition
  2.  
  3. (define (range . args)
  4.   (case (length args)
  5.     ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
  6.     ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
  7.     ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
  8.            (let loop ((x(car args)) (xs '()))
  9.              (if (le? (cadr args) x)
  10.                  (reverse xs)
  11.                  (loop (+ x (caddr args)) (cons x xs))))))
  12.     (else (error 'range "unrecognized arguments"))))
  13.  
  14. (define-syntax do-until
  15.   (syntax-rules (loop)
  16.     ((do-until body ... condition)
  17.       (let loop () body ... (unless condition (loop))))))
  18.  
  19. (define (le? lt? x y) (not (lt? y x)))
  20.  
  21. (define (swap! ary i j)
  22.   (let ((t (vector-ref ary i)))
  23.     (vector-set! ary i (vector-ref ary j))
  24.     (vector-set! ary j t)
  25.     ary))
  26.  
  27. (define (partition lt? ary lo hi)
  28.   (let ((x (vector-ref ary lo)) (i (- lo 1)) (j hi))
  29.     (let forever ()
  30.       (do-until (set! j (- j 1)) (le? lt? (vector-ref ary j) x))
  31.       (do-until (set! i (+ i 1)) (le? lt? x (vector-ref ary i)))
  32.       (when (< i j) (swap! ary i j) (forever)))
  33.     (values j ary)))
  34.  
  35. (define (quicksort lt? ary lo hi)
  36.   (if (< (+ lo 1) hi)
  37.       (call-with-values
  38.         (lambda ()
  39.           (partition lt? ary lo hi))
  40.         (lambda (p ary)
  41.           (cond ((< (- p lo) (- hi p))
  42.                   (quicksort lt? ary lo (+ p 1))
  43.                   (quicksort lt? ary (+ p 1) hi))
  44.           (else (quicksort lt? ary (+ p 1) hi)
  45.                 (quicksort lt? ary lo (+ p 1))))))
  46.       ary))
  47.  
  48. (display (quicksort < '#(4 9 1 8 2 7 5 6 3) 0 9)) (newline)
  49.  
  50. (define (sorted? lt? ary)
  51.   (let ((len (vector-length ary)))
  52.     (let loop ((i (- len 1)))
  53.       (if (zero? i) #t
  54.         (if (lt? (vector-ref ary (- i 1))
  55.                  (vector-ref ary i))
  56.             (loop (- i 1))
  57.             #f)))))
  58.  
  59. (define (shuffle ary)
  60.   (do ((v ary) (n (vector-length ary) (- n 1)))
  61.       ((zero? n) ary)
  62.     (let* ((r (random n)) (t (vector-ref ary r)))
  63.       (vector-set! ary r (vector-ref ary (- n 1)))
  64.       (vector-set! ary (- n 1) t))))
  65.  
  66. (define (test-quicksort k n)
  67.   (let ((ary (list->vector (range k))))
  68.     (do ((n n (- n 1))) ((zero? n))
  69.       (quicksort < ary 0 k)
  70.       (unless (sorted? < ary)
  71.         (display "ERROR ") (display ary) (newline))
  72.       (shuffle ary))))
  73.  
  74. (test-quicksort 1000 10)
Success #stdin #stdout 6.06s 10200KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
#(1 2 3 4 5 6 7 8 9)
https://ideone.com/ttjYgA
language:
Scheme (guile 2.2.4)
created:
7 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!