suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added `copying-insertionsort' for small blocks, some fixes.

Browse Source 
svn: r17006
This commit is contained in:
Eli Barzilay 2009-11-23 18:50:12 +00:00
parent ab832a3b4d
commit ea94f5dea5
1 changed files with 28 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/scheme/private/sort.ss
View File

@ -33,7 +33,7 @@ doing these checks.
(define-syntax foo (syntax-rules () [(_ . pattern) template]))])) (define-syntax foo (syntax-rules () [(_ . pattern) template]))]))
(define-syntax-rule (sort-internal-body v *<? n has-getkey? getkey) (define-syntax-rule (sort-internal-body v *<? n has-getkey? getkey)
(let* ([n/2+ (ceiling (/ n 2))] [n/2- (- n n/2+)]) (let* ([n/2- (arithmetic-shift n -1)] [n/2+ (- n n/2-)])
(define-syntax-rule (<? x y) (define-syntax-rule (<? x y)
(if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y))) (if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y)))
(define-syntax-rule (ref n) (vector-ref v n)) (define-syntax-rule (ref n) (vector-ref v n))
@ -56,20 +56,37 @@ doing these checks.
(loop (add1 a1) (add1 c1)))) (loop (add1 a1) (add1 c1))))
(loop a1 b1 c1))))))))) (loop a1 b1 c1)))))))))
(define-syntax-rule (copying-insertionsort Alo Blo n)
(let iloop ([i 0] [A Alo])
(when (< i n)
(let ([ref-i (ref A)])
(let jloop ([j (+ Blo i)])
(let ([ref-j-1 (ref (sub1 j))])
(if (and (> j Blo) (<? ref-i ref-j-1))
(begin (set! j ref-j-1) (jloop (sub1 j)))
(begin (set! j ref-i) (iloop (add1 i) (add1 A))))))))))
(define (copying-mergesort Alo Blo n) (define (copying-mergesort Alo Blo n)
(cond [(n . > . 1) ;; n is never 0, smaller values are more frequent
(let* ([n/2+ (ceiling (/ n 2))] [n/2- (- n n/2+)]) (cond
(let ([Amid1 (+ Alo n/2-)] [(= n 1) (set! Blo (ref Alo))]
[Amid2 (+ Alo n/2+)] [(= n 2) (let ([x (ref Alo)] [y (ref (add1 Alo))])
[Bmid1 (+ Blo n/2-)]) (if (<? y x)
(copying-mergesort Amid1 Bmid1 n/2+) (begin (set! Blo y) (set! (add1 Blo) x))
(copying-mergesort Alo Amid2 n/2-) (begin (set! Blo x) (set! (add1 Blo) y))))]
(merge #t Amid2 (+ Alo n) Bmid1 (+ Blo n) Blo)))] [(n . < . 16) ; not much difference up to ~30
[(= 1 n) (set! Blo (ref Alo))])) (copying-insertionsort Alo Blo n)]
[else (let* ([n/2- (arithmetic-shift n -1)] [n/2+ (- n n/2-)])
(let ([Amid1 (+ Alo n/2-)]
[Amid2 (+ Alo n/2+)]
[Bmid1 (+ Blo n/2-)])
(copying-mergesort Amid1 Bmid1 n/2+)
(copying-mergesort Alo Amid2 n/2-)
(merge #t Amid2 (+ Alo n) Bmid1 (+ Blo n) Blo)))]))
(let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n]) (let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n])
(copying-mergesort Amid1 B1lo n/2+) (copying-mergesort Amid1 B1lo n/2+)
(copying-mergesort Alo Amid2 n/2-) (unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-))
(merge #f B1lo (+ B1lo n/2+) Amid2 Ahi Alo)))) (merge #f B1lo (+ B1lo n/2+) Amid2 Ahi Alo))))
(define sort-internals (make-hasheq)) (define sort-internals (make-hasheq))