codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; 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))
Private
[
?
]
Run code
Submit