; introspective sort

(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 (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 (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-syntax do-until
  (syntax-rules (loop)
    ((do-until body ... condition)
      (let loop () body ... (unless condition (loop))))))

(define (insertsort lt? ary lo hi)
  (do ((i (+ lo 1) (+ i 1))) ((= i hi) ary)
    (let ((t (vector-ref ary i)))
      (do ((j (- i 1) (- j 1)))
          ((or (< j lo) (lt? (vector-ref ary j) t))
            (vector-set! ary (+ j 1) t))
        (vector-set! ary (+ j 1) (vector-ref ary j))))))

(define (siftdown lt? ary i n lo)
  (let ((d (vector-ref ary (+ lo i -1))))
    (let loop ()
      (when (<= i (quotient n 2))
        (let ((c (* 2 i)))
          (when (and (< c n)
                     (lt? (vector-ref ary (+ lo c -1))
                          (vector-ref ary (+ lo c))))
            (set! c (+ c 1)))
          (when (lt? d (vector-ref ary (+ lo c -1)))
            (vector-set! ary (+ lo i -1)
              (vector-ref ary (+ lo c -1)))
            (set! i c) (loop)))))
    (vector-set! ary (+ lo i -1) d))
  ary)

(define (heapsort lt? ary lo hi)
  (let ((n (- hi lo)))
    (do ((i (quotient n 2) (- i 1))) ((< i 1))
      (siftdown lt? ary i n lo))
    (do ((i n (- i 1))) ((= i 1))
      (let ((t (vector-ref ary lo)))
        (vector-set! ary lo
          (vector-ref ary (+ lo i -1)))
        (vector-set! ary (+ lo i -1) t))
      (siftdown lt? ary 1 (- i 1) lo)))
  ary)

(define (median-of-three lt? ary lo hi)
  (let* ((mid (quotient (+ lo hi) 2))
         (lo-val (vector-ref ary lo))
         (mid-val (vector-ref ary mid))
         (hi-val (vector-ref ary (- hi 1))))
    (if (lt? lo-val mid-val)
        (if (lt? mid-val hi-val) mid
          (if (lt? lo-val hi-val) (- hi 1) lo))
        (if (lt? lo-val hi-val) lo
          (if (lt? mid-val hi-val) (- hi 1) mid)))))

(define (partition lt? ary lo hi)
  (let ((part (median-of-three lt? ary lo hi)))
    (let ((t (vector-ref ary part)))
      (vector-set! ary part (vector-ref ary lo))
      (vector-set! ary lo t)))
  (let ((x (vector-ref ary lo)) (i (- lo 1)) (j hi))
    (let forever ()
      (do-until (set! j (- j 1)) (not (lt? x (vector-ref ary j))))
      (do-until (set! i (+ i 1)) (not (lt? (vector-ref ary i) x)))
      (when (< i j)
        (let ((t (vector-ref ary i)))
          (vector-set! ary i (vector-ref ary j))
          (vector-set! ary j t))
        (forever)))
    (values j ary)))

(define cutoff 15)

(define (quicksort lt? ary lo hi)
  (if (< cutoff (- hi lo))
      (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))

(define k 2)

(define (introsort lt? ary lo hi depth)
  (when (< cutoff (- hi lo))
    (if (zero? depth) (heapsort lt? ary lo hi)
      (call-with-values
        (lambda () (partition lt? ary lo hi))
        (lambda (p ary)
          (cond ((< (- p lo) (- hi p))
                  (introsort lt? ary lo (+ p 1) (- depth 1))
                  (introsort lt? ary (+ p 1) hi (- depth 1)))
          (else (introsort lt? ary (+ p 1) hi (- depth 1))
                (introsort lt? ary lo (+ p 1) (- depth 1))))))))
  ary)

(define (sort lt? ary)
  (let* ((len (vector-length ary))
         (depth (* k (round (log len)))))
    (introsort lt? ary 0 len depth)
    (insertsort lt? ary 0 len)))

(display (sort < (shuffle (list->vector (range 1000))))) (newline)