; engineering a sort function
(define-syntax while
(syntax-rules ()
((while pred? body ...)
(do () ((not pred?)) body ...))))
(define-syntax assign!
(syntax-rules ()
((assign! var expr)
(begin (set! var expr) var))))
(define (vector-sort! vec comp)
(define len (vector-length vec))
(define-syntax v (syntax-rules () ((v k) (vector-ref vec k))))
(define-syntax v! (syntax-rules () ((v! k x) (vector-set! vec k x))))
(define-syntax cmp (syntax-rules () ((cmp a b) (comp (v a) (v b)))))
(define-syntax lt? (syntax-rules () ((lt? a b) (negative? (cmp a b)))))
(define-syntax swap! (syntax-rules () ((swap! a b)
(let ((t (v a))) (v! a (v b)) (v! b t)))))
(define (vecswap! a b s)
(do ((a a (+ a 1)) (b b (+ b 1)) (s s (- s 1))) ((zero? s))
(swap! a b)))
(define (med3 a b c)
(if (lt? b c)
(if (lt? b a) (if (lt? c a) c a) b)
(if (lt? c a) (if (lt? b a) b a) c)))
(define (pv-init a n)
(let ((pm (+ a (quotient n 2))))
(when (> n 7)
(let ((pl a) (pn (+ a n -1)))
(when (> n 40)
(let ((s (quotient n 8)))
(set! pl (med3 pl (+ pl s) (+ pl s s)))
(set! pm (med3 (- pm s) pm (+ pm s)))
(set! pn (med3 (- pn s s) (- pn s) pn))))
(set! pm (med3 pl pm pn))))
pm))
(let qsort ((a 0) (n len))
(if (< n 7)
(do ((pm (+ a 1) (+ pm 1))) ((not (< pm (+ a n))))
(do ((pl pm (- pl 1)))
((not (and (> pl a) (> (cmp (- pl 1) pl) 0))))
(swap! pl (- pl 1))))
(let ((pv (pv-init a n)) (r #f)
(pa a) (pb a) (pc (+ a n -1)) (pd (+ a n -1)))
(swap! a pv) (set! pv a)
(let loop ()
(while (and (<= pb pc) (<= (assign! r (cmp pb pv)) 0))
(when (= r 0) (swap! pa pb) (set! pa (+ pa 1)))
(set! pb (+ pb 1)))
(while (and (>= pc pb) (>= (assign! r (cmp pc pv)) 0))
(when (= r 0) (swap! pc pd) (set! pd (- pd 1)))
(set! pc (- pc 1)))
(unless (> pb pc)
(swap! pb pc) (set! pb (+ pb 1)) (set! pc (- pc 1)) (loop)))
(let ((pn (+ a n)))
(let ((s (min (- pa a) (- pb pa)))) (vecswap! a (- pb s) s))
(let ((s (min (- pd pc) (- pn pd 1)))) (vecswap! pb (- pn s) s))
(let ((s (- pb pa))) (when (> s 1) (qsort a s)))
(let ((s (- pd pc))) (when (> s 1) (qsort (- pn s) s))))))))
(define rand
(let* ((a 3141592653) (c 2718281829)
(m (expt 2 35)) (x 5772156649)
(next (lambda ()
(let ((x-prime (modulo (+ (* a x) c) m)))
(set! x x-prime) x-prime)))
(k 103)
(v (list->vector (reverse
(let loop ((i k) (vs (list x)))
(if (= i 1) vs
(loop (- i 1) (cons (next) vs)))))))
(y (next))
(init (lambda (s)
(set! x s) (vector-set! v 0 x)
(do ((i 1 (+ i 1))) ((= i k))
(vector-set! v i (next))))))
(lambda seed
(cond ((null? seed)
(let* ((j (quotient (* k y) m))
(q (vector-ref v j)))
(set! y q)
(vector-set! v j (next)) (/ y m)))
((eq? (car seed) 'get) (list a c m x y k v))
((eq? (car seed) 'set)
(let ((state (cadr seed)))
(set! a (list-ref state 0))
(set! c (list-ref state 1))
(set! m (list-ref state 2))
(set! x (list-ref state 3))
(set! y (list-ref state 4))
(set! k (list-ref state 5))
(set! v (list-ref state 6))))
(else (init (modulo (numerator
(inexact->exact (car seed))) m))
(rand))))))
(define (randint . args)
(cond ((null? (cdr args))
(floor (* (rand) (car args))))
((< (car args) (cadr args))
(+ (floor (* (rand) (- (cadr args) (car args)))) (car args)))
(else (+ (ceiling (* (rand) (- (cadr args) (car args)))) (car args)))))
(define (make-rand-vec n)
(let ((v (make-vector n)))
(do ((i 0 (+ i 1))) ((= i n) v)
(vector-set! v i (randint n)))))
(define (check-sort? v)
(let ((n (vector-length v)))
(let loop ((i 1))
(cond ((= i n) #t)
((< (vector-ref v i)
(vector-ref v (- i 1))) #f)
(else (loop (+ i 1)))))))
(define x (make-rand-vec 1024))
(vector-sort! x (lambda (a b) (- a b)))
(display (check-sort? x))