; 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)