; hoare's partition

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(define-syntax do-until
  (syntax-rules (loop)
    ((do-until body ... condition)
      (let loop () body ... (unless condition (loop))))))

(define (le? lt? x y) (not (lt? y x)))

(define (swap! ary i j)
  (let ((t (vector-ref ary i)))
    (vector-set! ary i (vector-ref ary j))
    (vector-set! ary j t)
    ary))

(define (partition lt? ary lo hi)
  (let ((x (vector-ref ary lo)) (i (- lo 1)) (j hi))
    (let forever ()
      (do-until (set! j (- j 1)) (le? lt? (vector-ref ary j) x))
      (do-until (set! i (+ i 1)) (le? lt? x (vector-ref ary i)))
      (when (< i j) (swap! ary i j) (forever)))
    (values j ary)))

(define (quicksort lt? ary lo hi)
  (if (< (+ lo 1) hi)
      (call-with-values
        (lambda ()
          (partition lt? ary lo hi))
        (lambda (p ary)
          (cond ((< (- p lo) (- hi p))
                  (quicksort lt? ary lo (+ p 1))
                  (quicksort lt? ary (+ p 1) hi))
          (else (quicksort lt? ary (+ p 1) hi)
                (quicksort lt? ary lo (+ p 1))))))
      ary))

(display (quicksort < '#(4 9 1 8 2 7 5 6 3) 0 9)) (newline)

(define (sorted? lt? ary)
  (let ((len (vector-length ary)))
    (let loop ((i (- len 1)))
      (if (zero? i) #t
        (if (lt? (vector-ref ary (- i 1))
                 (vector-ref ary i))
            (loop (- i 1))
            #f)))))

(define (shuffle ary)
  (do ((v ary) (n (vector-length ary) (- n 1)))
      ((zero? n) ary)
    (let* ((r (random n)) (t (vector-ref ary r)))
      (vector-set! ary r (vector-ref ary (- n 1)))
      (vector-set! ary (- n 1) t))))

(define (test-quicksort k n)
  (let ((ary (list->vector (range k))))
    (do ((n n (- n 1))) ((zero? n))
      (quicksort < ary 0 k)
      (unless (sorted? < ary)
        (display "ERROR ") (display ary) (newline))
      (shuffle ary))))

(test-quicksort 1000 10)