add vector-sort to racket/vector (#1398)
* add vector interface to private/sort.rkt
This commit is contained in:
Andrew Kent
Sam Tobin-Hochstadt
parent
95e8ade091
commit
42f4784735
|
|
@ -528,7 +528,7 @@ which takes two elements of @racket[lst] and returns a true value if the
|
|||
first is less (i.e., should be sorted earlier) than the second.
|
||||
|
||||
The sort is stable; if two elements of @racket[lst] are ``equal''
|
||||
(i.e., @racket[proc] does not return a true value when given the pair in
|
||||
(i.e., @racket[less-than?] does not return a true value when given the pair in
|
||||
either order), then the elements preserve their relative order from
|
||||
@racket[lst] in the output list. To preserve this guarantee, use
|
||||
@racket[sort] with a strict comparison functions (e.g., @racket[<] or
|
||||
|
|
|
|||
|
|
@ -366,5 +366,56 @@ Like @racket[vector-member], but finds an element using @racket[eq?].
|
|||
(vector-memq 9 (vector 1 2 3 4))
|
||||
]}
|
||||
|
||||
@defproc[(vector-sort [vec vector?]
|
||||
[less-than? (any/c any/c . -> . any/c)]
|
||||
[start exact-nonnegative-integer? 0]
|
||||
[end exact-nonnegative-integer? (vector-length vec)]
|
||||
[#:key key (any/c . -> . any/c) (λ (x) x)]
|
||||
[#:cache-keys? cache-keys? boolean? #f])
|
||||
vector?]{
|
||||
|
||||
Like @racket[sort], but operates on vectors; a
|
||||
@emph{fresh} vector of length @racket[(- end start)] is
|
||||
returned containing the elements from indices
|
||||
@racket[start] (inclusive) through @racket[end] (exclusive)
|
||||
of @racket[vec], but in sorted order (i.e., @racket[vec] is
|
||||
not modified). This sort is stable (i.e., the order of ``equal''
|
||||
elements is preserved).
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(define v1 (vector 4 3 2 1))
|
||||
(vector-sort v1 <)
|
||||
v1
|
||||
(define v2 (vector '(4) '(3) '(2) '(1)))
|
||||
(vector-sort v2 < 1 3 #:key car)
|
||||
v2]
|
||||
|
||||
@history[#:added "6.6.0.5"]{}
|
||||
}
|
||||
|
||||
@defproc[(vector-sort! [vec (and/c vector? (not/c immutable?))]
|
||||
[less-than? (any/c any/c . -> . any/c)]
|
||||
[start exact-nonnegative-integer? 0]
|
||||
[end exact-nonnegative-integer? (vector-length vec)]
|
||||
[#:key key (any/c . -> . any/c) (λ (x) x)]
|
||||
[#:cache-keys? cache-keys? boolean? #f])
|
||||
void?]{
|
||||
|
||||
Like @racket[vector-sort], but @emph{updates} indices
|
||||
@racket[start] (inclusive) through @racket[end] (exclusive)
|
||||
of @racket[vec] by sorting them according to the @racket[less-than?]
|
||||
procedure.
|
||||
|
||||
@mz-examples[#:eval vec-eval
|
||||
(define v1 (vector 4 3 2 1))
|
||||
(vector-sort! v1 <)
|
||||
v1
|
||||
(define v2 (vector '(4) '(3) '(2) '(1)))
|
||||
(vector-sort! v2 < 1 3 #:key car)
|
||||
v2]
|
||||
|
||||
@history[#:added "6.6.0.5"]{}
|
||||
}
|
||||
|
||||
|
||||
@close-eval[vec-eval]
|
||||
|
|
|
|||
|
|
@ -229,4 +229,197 @@
|
|||
(err/rt-test (vector-map (lambda (x) x) #() #() #()) (check-regs #rx"vector-map" #rx"mismatch between procedure arity")))
|
||||
|
||||
|
||||
;; ---------- vector-sort basic ----------
|
||||
(test #("a" "b" "c" "c" "d" "e" "f")
|
||||
vector-sort
|
||||
#("d" "f" "e" "c" "a" "c" "b")
|
||||
string<?)
|
||||
(test #("a" "c" "e")
|
||||
vector-sort
|
||||
#("d" "f" "e" "c" "a" "c" "b")
|
||||
string<?
|
||||
2
|
||||
5)
|
||||
(test #(("a") ("c") ("e"))
|
||||
vector-sort
|
||||
#(("d") ("f") ("e") ("c") ("a") ("c") ("b"))
|
||||
string<?
|
||||
2
|
||||
5
|
||||
#:key car)
|
||||
(test #(("a") ("c") ("e"))
|
||||
vector-sort
|
||||
#(("d") ("f") ("e") ("c") ("a") ("c") ("b"))
|
||||
string<?
|
||||
2
|
||||
5
|
||||
#:key car
|
||||
#:cache-keys? #t)
|
||||
|
||||
(let ()
|
||||
(define (car< x y) (< (car x) (car y)))
|
||||
(define (random-vec n range)
|
||||
(build-vector n (λ _ (list (random range)))))
|
||||
;; sort a vector, then sort it with a #:key and with #:cache-keys?
|
||||
;; and make sure they're all doing the same thing
|
||||
(define (vector-sort* v [start 0] [end (vector-length v)])
|
||||
(let ([v1 (vector-sort v car< start end)]
|
||||
[v2 (vector-sort v < start end #:key car)]
|
||||
[v3 (vector-sort v < start end #:key car #:cache-keys? #t)])
|
||||
(test #t equal? v1 v2)
|
||||
(test #t equal? v1 v3)
|
||||
v1))
|
||||
(define (test-sort len times)
|
||||
(or (zero? times)
|
||||
;; build a random vector, sort it, check that it's sorted
|
||||
(and (let* ([rand (random-vec len (if (even? times) 1000000 10))]
|
||||
[sorted (vector-sort* rand)])
|
||||
(and (= len (vector-length sorted))
|
||||
(or (<= len 1)
|
||||
(let loop ([i 0] [i+1 1])
|
||||
(or (= i+1 len)
|
||||
(and (let ([ival (car (vector-ref sorted i))]
|
||||
[i+1val (car (vector-ref sorted i+1))])
|
||||
(<= ival i+1val))
|
||||
(loop (add1 i) (add1 i+1))))))))
|
||||
(test-sort len (sub1 times)))))
|
||||
(test #t test-sort 1 10)
|
||||
(test #t test-sort 2 20)
|
||||
(test #t test-sort 3 60)
|
||||
(test #t test-sort 4 100)
|
||||
(test #t test-sort 5 100)
|
||||
(test #t test-sort 10 100)
|
||||
(test #t test-sort 100 100)
|
||||
(test #t test-sort 1000 100)
|
||||
;; test stability for vector-sort
|
||||
(test #((1) (2) (3 a) (3 b) (3 c)) vector-sort* #((3 a) (1) (3 b) (2) (3 c)))
|
||||
;; test short lists (+ stable)
|
||||
(test #() vector-sort* #())
|
||||
(test #((1 1)) vector-sort* #((1 1)))
|
||||
(test #((1 2) (1 1)) vector-sort* #((1 2) (1 1)))
|
||||
(test #((1) (2)) vector-sort* #((2) (1)))
|
||||
(for-each (λ (v) (test #((0 3) (1 1) (1 2)) vector-sort* v))
|
||||
'(#((1 1) (1 2) (0 3))
|
||||
#((1 1) (0 3) (1 2))
|
||||
#((0 3) (1 1) (1 2))))
|
||||
(for-each (λ (v) (test #((0 2) (0 3) (1 1)) vector-sort* v))
|
||||
'(#((1 1) (0 2) (0 3))
|
||||
#((0 2) (1 1) (0 3))
|
||||
#((0 2) (0 3) (1 1))))
|
||||
;; exhaustive tests for 2 and 3 item lists
|
||||
(for-each (λ (v) (test #((1 x) (2 y)) vector-sort* v))
|
||||
'(#((1 x) (2 y))
|
||||
#((2 y) (1 x))))
|
||||
(for-each (λ (v) (test #((1 x) (2 y) (3 z)) vector-sort* v))
|
||||
'(#((1 x) (2 y) (3 z))
|
||||
#((2 y) (1 x) (3 z))
|
||||
#((2 y) (3 z) (1 x))
|
||||
#((3 z) (2 y) (1 x))
|
||||
#((3 z) (1 x) (2 y))
|
||||
#((1 x) (3 z) (2 y))))
|
||||
(test #((2)) vector-sort* #((4) (2) (1) (3)) 1 2)
|
||||
(test #((1) (2)) vector-sort* #((4) (2) (1) (3)) 1 3)
|
||||
(test #((1) (2) (3)) vector-sort* #((4) (2) (1) (3)) 1 4)
|
||||
(test #((1) (2) (4)) vector-sort* #((4) (2) (1) (3)) 0 3)
|
||||
(test #((1) (2) (3) (4) (5) (6) (7) (8)) vector-sort*
|
||||
#((4) (2) (1) (3) (6) (5) (8) (7) (10) (9))
|
||||
0 8)
|
||||
(test #((1) (3) (5) (6) (7) (8) (9) (10)) vector-sort*
|
||||
#((4) (2) (1) (3) (6) (5) (8) (7) (10) (9))
|
||||
2 10)
|
||||
|
||||
(define ((check-regs . regexps) exn)
|
||||
(and (exn:fail? exn)
|
||||
(andmap (λ (reg) (regexp-match reg (exn-message exn)))
|
||||
regexps)))
|
||||
|
||||
(err/rt-test (vector-sort! (list 1) <) (check-regs #rx"vector-sort!" #rx"vector" #rx"immutable"))
|
||||
(err/rt-test (vector-sort! #(1) <) (check-regs #rx"vector-sort!" #rx"vector" #rx"immutable"))
|
||||
(err/rt-test (vector-sort (list 1) <) (check-regs #rx"vector-sort" #rx"vector"))
|
||||
(err/rt-test (vector-sort! (vector 1) 1) (check-regs #rx"vector-sort!" #rx"any/c any/c . -> . any/c"))
|
||||
(err/rt-test (vector-sort (vector 1) 1) (check-regs #rx"vector-sort" #rx"any/c any/c . -> . any/c"))
|
||||
(err/rt-test (vector-sort! (vector 1) (λ (x) x)) (check-regs #rx"vector-sort!" #rx"any/c any/c . -> . any/c"))
|
||||
(err/rt-test (vector-sort (vector 1) (λ (x) x)) (check-regs #rx"vector-sort" #rx"any/c any/c . -> . any/c"))
|
||||
(err/rt-test (vector-sort! (vector 1) < #:key 42) (check-regs #rx"vector-sort!" #rx"any/c . -> . any/c"))
|
||||
(err/rt-test (vector-sort! (vector 1) < #:key <) (check-regs #rx"vector-sort!" #rx"any/c . -> . any/c"))
|
||||
(err/rt-test (vector-sort (vector 1) < #:key 42) (check-regs #rx"vector-sort" #rx"any/c . -> . any/c"))
|
||||
(err/rt-test (vector-sort (vector 1) < #:key <) (check-regs #rx"vector-sort" #rx"any/c . -> . any/c")))
|
||||
|
||||
;; ---------- vector-sort! actually mutates arg, and vector-sort does not ----------
|
||||
;; verify underlying vector is sorted
|
||||
(let ([v (vector 3 2 1)])
|
||||
(vector-sort! v <)
|
||||
(test #t
|
||||
equal?
|
||||
v
|
||||
(vector 1 2 3)))
|
||||
(let ([v (vector "d" "f" "e" "c" "a" "c" "b")])
|
||||
(vector-sort! v string<? 2 5)
|
||||
(test #t
|
||||
equal?
|
||||
v
|
||||
(vector "d" "f" "a" "c" "e" "c" "b")))
|
||||
;; verify underlying vector is unchanged
|
||||
(let ([v (vector 3 2 1)])
|
||||
(vector-sort v <)
|
||||
(test #t
|
||||
equal?
|
||||
v
|
||||
(vector 3 2 1)))
|
||||
(let ([v (vector "d" "f" "e" "c" "a" "c" "b")])
|
||||
(vector-sort v string<? 2 5)
|
||||
(test #t
|
||||
equal?
|
||||
v
|
||||
(vector "d" "f" "e" "c" "a" "c" "b")))
|
||||
|
||||
;; test #:key and #:cache-keys?
|
||||
(let ()
|
||||
(define v #((0) (9) (1) (8) (2) (7) (3) (6) (4) (5)))
|
||||
(define sorted #((0) (1) (2) (3) (4) (5) (6) (7) (8) (9)))
|
||||
(test sorted vector-sort v < #:key car)
|
||||
(let ([c1 0] [c2 0] [touched '()])
|
||||
(test sorted
|
||||
vector-sort v (λ (x y) (set! c1 (add1 c1)) (< x y))
|
||||
#:key (λ (x)
|
||||
(set! c2 (add1 c2))
|
||||
(set! touched (cons x touched))
|
||||
(car x)))
|
||||
;; test that the number of key uses is half the number of comparisons
|
||||
(test #t = (* 2 c1) c2)
|
||||
;; and that this is larger than the number of items in the list
|
||||
(test #t < (vector-length v) c2)
|
||||
;; and that every item was touched
|
||||
(test null remove* touched (vector->list v)))
|
||||
(let ([c 0] [touched '()])
|
||||
;; now cache the keys
|
||||
(test sorted
|
||||
vector-sort v <
|
||||
#:key (λ (x)
|
||||
(set! c (add1 c))
|
||||
(set! touched (cons x touched))
|
||||
(car x))
|
||||
#:cache-keys? #t)
|
||||
;; test that the number of key uses is the same as the list length
|
||||
(test #t = c (vector-length v))
|
||||
;; and that every item was touched
|
||||
(test null remove* touched (vector->list v)))
|
||||
(let* ([c 0] [getkey (λ (x) (set! c (add1 c)) x)])
|
||||
;; either way, we never use the key proc on no arguments
|
||||
(test #() vector-sort #() < #:key getkey #:cache-keys? #f)
|
||||
(test #() vector-sort #() < #:key getkey #:cache-keys? #t)
|
||||
(test #t = c 0)
|
||||
;; we also don't use it for 1-arg lists
|
||||
(test #(1) vector-sort #(1) < #:key getkey #:cache-keys? #f)
|
||||
(test #t = c 0)
|
||||
;; but we do use it once if caching happens (it's a consistent interface)
|
||||
(test #(1) vector-sort #(1) < #:key getkey #:cache-keys? #t)
|
||||
(test #t = c 1)
|
||||
;; check a few other short lists
|
||||
(test #(1 2) vector-sort #(2 1) < #:key getkey #:cache-keys? #t)
|
||||
(test #(1 2 3) vector-sort #(2 3 1) < #:key getkey #:cache-keys? #t)
|
||||
(test #(1 2 3 4) vector-sort #(4 2 3 1) < #:key getkey #:cache-keys? #t)
|
||||
(test #t = c 10)))
|
||||
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,11 @@
|
|||
|
||||
(#%require "small-scheme.rkt" "define.rkt" (for-syntax "stxcase-scheme.rkt"))
|
||||
|
||||
(#%provide sort)
|
||||
;; note, these are the raw interfaces --- user-facing definitions
|
||||
;; are exported from private/list.rkt and vector.rkt
|
||||
(#%provide sort
|
||||
vector-sort
|
||||
vector-sort!)
|
||||
|
||||
#|
|
||||
|
||||
|
|
@ -17,11 +21,6 @@ function, or precompiled versions with inlinable common comparison
|
|||
predicates) -- they are local macros so they're not left in the compiled
|
||||
code.
|
||||
|
||||
Note that there is no error checking on the arguments -- the `sort' function
|
||||
that this module provide is then wrapped up by a keyworded version in
|
||||
"racket/private/list.rkt", and that's what everybody sees. The wrapper is
|
||||
doing these checks.
|
||||
|
||||
|#
|
||||
|
||||
;; This code works with unsafe operations, if there are problems, the commented
|
||||
|
|
@ -31,192 +30,390 @@ doing these checks.
|
|||
(rename '#%unsafe i= unsafe-fx=)
|
||||
(rename '#%unsafe i< unsafe-fx<)
|
||||
(rename '#%unsafe i<= unsafe-fx<=)
|
||||
(rename '#%unsafe i> unsafe-fx>)
|
||||
(rename '#%unsafe i>= unsafe-fx>=)
|
||||
(rename '#%unsafe i>> unsafe-fxrshift)
|
||||
(rename '#%unsafe i<< unsafe-fxlshift)
|
||||
(rename '#%unsafe vref unsafe-vector-ref)
|
||||
(rename '#%unsafe vset! unsafe-vector-set!))
|
||||
(rename '#%unsafe vset! unsafe-vector-set!)
|
||||
(rename '#%unsafe ucar unsafe-car)
|
||||
(rename '#%unsafe ucdr unsafe-cdr)
|
||||
(rename '#%unsafe unsafe-fl< unsafe-fl<)
|
||||
(rename '#%unsafe unsafe-fl<= unsafe-fl<=)
|
||||
(rename '#%unsafe unsafe-fl> unsafe-fl>)
|
||||
(rename '#%unsafe unsafe-fl>= unsafe-fl>=))
|
||||
|
||||
(define sort (let ()
|
||||
(define-values (sort
|
||||
vector-sort
|
||||
vector-sort!)
|
||||
(let ()
|
||||
|
||||
(define-syntax define-syntax-rule
|
||||
(syntax-rules ()
|
||||
[(dr (foo . pattern) template)
|
||||
(define-syntax foo (syntax-rules () [(_ . pattern) template]))]))
|
||||
(define-syntax define-syntax-rule
|
||||
(syntax-rules ()
|
||||
[(dr (foo . pattern) template)
|
||||
(define-syntax foo (syntax-rules () [(_ . pattern) template]))]))
|
||||
|
||||
;; Use this to make it safe:
|
||||
;; (define-syntax-rule (i+ x y) (+ x y))
|
||||
;; (define-syntax-rule (i- x y) (- x y))
|
||||
;; (define-syntax-rule (i= x y) (= x y))
|
||||
;; (define-syntax-rule (i< x y) (< x y))
|
||||
;; (define-syntax-rule (i<= x y) (<= x y))
|
||||
;; (define-syntax-rule (i>> x y) (arithmetic-shift x (- y)))
|
||||
;; (define-syntax-rule (vref v i) (vector-ref v i))
|
||||
;; (define-syntax-rule (vset! v i x) (vector-set! v i x))
|
||||
;; Use this to make it safe:
|
||||
;;(define-syntax-rule (i+ x y) (+ x y))
|
||||
;;(define-syntax-rule (i- x y) (- x y))
|
||||
;;(define-syntax-rule (i= x y) (= x y))
|
||||
;;(define-syntax-rule (i< x y) (< x y))
|
||||
;;(define-syntax-rule (i<= x y) (<= x y))
|
||||
;;(define-syntax-rule (i>> x y) (arithmetic-shift x (- y)))
|
||||
;;(define-syntax-rule (i<< x y) (arithmetic-shift x y))
|
||||
;;(define-syntax-rule (vref v i) (vector-ref v i))
|
||||
;;(define-syntax-rule (vset! v i x) (vector-set! v i x))
|
||||
;;(define ucar car)
|
||||
;;(define ucdr cdr)
|
||||
|
||||
(define-syntax-rule (sort-internal-body v *<? n has-getkey? getkey)
|
||||
(let* ([n/2- (i>> n 1)] [n/2+ (i- n n/2-)])
|
||||
(define-syntax-rule (<? x y)
|
||||
(if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y)))
|
||||
(define-syntax-rule (ref n) (vref v n))
|
||||
(define-syntax-rule (set! n x) (vset! v n x))
|
||||
(define-syntax-rule (i/2 x) (i>> x 1))
|
||||
(define-syntax-rule (i*2 x) (i<< x 1))
|
||||
|
||||
(define-syntax-rule (merge lo? A1 A2 B1 B2 C1)
|
||||
(let ([b2 B2])
|
||||
(let loop ([a1 A1] [b1 B1] [c1 C1])
|
||||
(let ([x (ref a1)] [y (ref b1)])
|
||||
(if (if lo? (not (<? y x)) (<? x y))
|
||||
(begin (set! c1 x)
|
||||
(let ([a1 (i+ a1 1)] [c1 (i+ c1 1)])
|
||||
(when (i< c1 b1) (loop a1 b1 c1))))
|
||||
(begin (set! c1 y)
|
||||
(let ([b1 (i+ b1 1)] [c1 (i+ c1 1)])
|
||||
(if (i<= b2 b1)
|
||||
(let loop ([a1 a1] [c1 c1])
|
||||
(when (i< c1 b1)
|
||||
(set! c1 (ref a1))
|
||||
(loop (i+ a1 1) (i+ c1 1))))
|
||||
(loop a1 b1 c1)))))))))
|
||||
(define-syntax-rule (sort-internal-body A less-than? n key)
|
||||
(let ()
|
||||
;; comparison & vector access macros
|
||||
(define-syntax-rule (<? x y)
|
||||
(if key
|
||||
(less-than? (key x) (key y))
|
||||
(less-than? x y)))
|
||||
(define-syntax-rule (ref index) (vref A index))
|
||||
(define-syntax-rule (set! index val) (vset! A index val))
|
||||
;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
;; Stable Sort (Mergesort)
|
||||
;; (used by `sort', `vector-sort', and `vector-sort!')
|
||||
;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
;; Based on "Fast mergesort implementation based on half-copying merge algorithm",
|
||||
;; Cezary Juszczak, http://kicia.ift.uni.wroc.pl/algorytmy/mergesortpaper.pdf
|
||||
;; Written in Racket by Eli Barzilay. (Note: the reason for the seemingly
|
||||
;; redundant pointer arithmetic in that paper is dealing with cases of uneven
|
||||
;; number of elements.)
|
||||
(let* ([n/2- (i/2 n)]
|
||||
[n/2+ (i- n n/2-)])
|
||||
;; - - - - - - - - - - - - - - - - - - -
|
||||
;; Merge
|
||||
;; - - - - - - - - - - - - - - - - - - -
|
||||
(define-syntax-rule (merge lo? A1 A2 B1 B2 C1)
|
||||
(let ([b2 B2])
|
||||
(let loop ([a1 A1] [b1 B1] [c1 C1])
|
||||
(let ([x (ref a1)] [y (ref b1)])
|
||||
(if (if lo? (not (<? y x)) (<? x y))
|
||||
(begin (set! c1 x)
|
||||
(let ([a1 (i+ a1 1)] [c1 (i+ c1 1)])
|
||||
(when (i< c1 b1) (loop a1 b1 c1))))
|
||||
(begin (set! c1 y)
|
||||
(let ([b1 (i+ b1 1)] [c1 (i+ c1 1)])
|
||||
(if (i<= b2 b1)
|
||||
(let loop ([a1 a1] [c1 c1])
|
||||
(when (i< c1 b1)
|
||||
(set! c1 (ref a1))
|
||||
(loop (i+ a1 1) (i+ c1 1))))
|
||||
(loop a1 b1 c1)))))))))
|
||||
|
||||
(define-syntax-rule (copying-insertionsort Alo Blo n)
|
||||
;; n is never 0
|
||||
(begin (set! Blo (ref Alo))
|
||||
(let iloop ([i 1])
|
||||
(when (i< i n)
|
||||
(let ([ref-i (ref (i+ Alo i))])
|
||||
(let jloop ([j (i+ Blo i)])
|
||||
(let ([ref-j-1 (ref (i- j 1))])
|
||||
(if (and (i< Blo j) (<? ref-i ref-j-1))
|
||||
(begin (set! j ref-j-1) (jloop (i- j 1)))
|
||||
(begin (set! j ref-i) (iloop (i+ i 1)))))))))))
|
||||
;; - - - - - - - - - - - - - - - - - - -
|
||||
;; copying-insertionsort
|
||||
;; - - - - - - - - - - - - - - - - - - -
|
||||
(define-syntax-rule (copying-insertionsort Alo Blo n)
|
||||
;; n is never 0
|
||||
(begin (set! Blo (ref Alo))
|
||||
(let iloop ([i 1])
|
||||
(when (i< i n)
|
||||
(let ([ref-i (ref (i+ Alo i))])
|
||||
(let jloop ([j (i+ Blo i)])
|
||||
(let ([ref-j-1 (ref (i- j 1))])
|
||||
(if (and (i< Blo j) (<? ref-i ref-j-1))
|
||||
(begin (set! j ref-j-1) (jloop (i- j 1)))
|
||||
(begin (set! j ref-i) (iloop (i+ i 1)))))))))))
|
||||
|
||||
(define (copying-mergesort Alo Blo n)
|
||||
(cond
|
||||
;; n is never 0, smaller values are more frequent
|
||||
[(i= n 1) (set! Blo (ref Alo))]
|
||||
[(i= n 2) (let ([x (ref Alo)] [y (ref (i+ Alo 1))])
|
||||
(if (<? y x)
|
||||
(begin (set! Blo y) (set! (i+ Blo 1) x))
|
||||
(begin (set! Blo x) (set! (i+ Blo 1) y))))]
|
||||
;; insertion sort for small chunks (not much difference up to ~30)
|
||||
[(i< n 16) (copying-insertionsort Alo Blo n)]
|
||||
[else (let* ([n/2- (i>> n 1)] [n/2+ (i- n n/2-)])
|
||||
(let ([Amid1 (i+ Alo n/2-)]
|
||||
[Amid2 (i+ Alo n/2+)]
|
||||
[Bmid1 (i+ Blo n/2-)])
|
||||
(copying-mergesort Amid1 Bmid1 n/2+)
|
||||
(copying-mergesort Alo Amid2 n/2-)
|
||||
(merge #t Amid2 (i+ Alo n) Bmid1 (i+ Blo n) Blo)))]))
|
||||
;; - - - - - - - - - - - - - - - - - - -
|
||||
;; Mergesort
|
||||
;; - - - - - - - - - - - - - - - - - - -
|
||||
(define (copying-mergesort Alo Blo n)
|
||||
(cond
|
||||
;; n is never 0, smaller values are more frequent
|
||||
[(i= n 1) (set! Blo (ref Alo))]
|
||||
[(i= n 2) (let ([x (ref Alo)] [y (ref (i+ Alo 1))])
|
||||
(if (<? y x)
|
||||
(begin (set! Blo y) (set! (i+ Blo 1) x))
|
||||
(begin (set! Blo x) (set! (i+ Blo 1) y))))]
|
||||
;; insertion sort for small chunks (not much difference up to ~30)
|
||||
[(i< n 16) (copying-insertionsort Alo Blo n)]
|
||||
[else (let* ([n/2- (i/2 n)]
|
||||
[n/2+ (i- n n/2-)])
|
||||
(let ([Amid1 (i+ Alo n/2-)]
|
||||
[Amid2 (i+ Alo n/2+)]
|
||||
[Bmid1 (i+ Blo n/2-)])
|
||||
(copying-mergesort Amid1 Bmid1 n/2+)
|
||||
(copying-mergesort Alo Amid2 n/2-)
|
||||
(merge #t Amid2 (i+ Alo n) Bmid1 (i+ Blo n) Blo)))]))
|
||||
;; start the sorting!
|
||||
(let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n])
|
||||
(copying-mergesort Amid1 B1lo n/2+)
|
||||
(unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-))
|
||||
(merge #f B1lo (i+ B1lo n/2+) Amid2 Ahi Alo)))))
|
||||
|
||||
(let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n])
|
||||
(copying-mergesort Amid1 B1lo n/2+)
|
||||
(unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-))
|
||||
(merge #f B1lo (i+ B1lo n/2+) Amid2 Ahi Alo))))
|
||||
;; - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
;; Precompiling of standard comparison functions
|
||||
;; for standard data types
|
||||
;; - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
(define precompiled-sorts
|
||||
(let ([sorts (make-hasheq)])
|
||||
(define-syntax-rule (precomp less-than? more ...)
|
||||
(let ([sort-proc
|
||||
(λ (A n) (sort-internal-body A less-than? n #f))])
|
||||
(hash-set! sorts less-than? sort-proc)
|
||||
(hash-set! sorts more sort-proc) ...))
|
||||
;; for comparison ops provided by racket/base we build
|
||||
;; fast precompiled versions
|
||||
(precomp unsafe-fl< unsafe-fl<=)
|
||||
(precomp unsafe-fl> unsafe-fl>=)
|
||||
(precomp i< i<=)
|
||||
(precomp i> i>=)
|
||||
(precomp < <=)
|
||||
(precomp > >=)
|
||||
(precomp string<? string<=?)
|
||||
(precomp string>? string>=?)
|
||||
(precomp string-ci<? string-ci<=?)
|
||||
(precomp string-ci>? string-ci>=?)
|
||||
(precomp char<? char<=?)
|
||||
(precomp char>? char>=?)
|
||||
(precomp keyword<?)
|
||||
(make-immutable-hasheq (hash-map sorts cons))))
|
||||
|
||||
(define sort-internals (make-hasheq))
|
||||
(define _
|
||||
(let ()
|
||||
(define-syntax-rule (precomp <? more ...)
|
||||
(let ([proc (lambda (vec n) (sort-internal-body vec <? n #f #f))])
|
||||
(hash-set! sort-internals <? proc)
|
||||
(hash-set! sort-internals more proc) ...))
|
||||
(precomp < <=)
|
||||
(precomp > >=)
|
||||
(precomp string<? string<=?)
|
||||
(precomp string-ci<? string-ci<=?)
|
||||
(precomp keyword<?)))
|
||||
(define (generic-sort A less-than? n)
|
||||
(sort-internal-body A less-than? n #f))
|
||||
|
||||
(define-syntax sort-internal
|
||||
(syntax-rules ()
|
||||
[(_ <? vec n)
|
||||
(let ([si (hash-ref sort-internals <? #f)])
|
||||
(if si
|
||||
;; use a precompiled function if found
|
||||
(si vec n)
|
||||
;; otherwise, use the generic code
|
||||
(let () (sort-internal-body vec <? n #f #f))))]
|
||||
[(_ <? vec n getkey)
|
||||
(let () (sort-internal-body vec <? n #t getkey))]))
|
||||
(define (generic-sort/key A less-than? n key)
|
||||
(sort-internal-body A less-than? n key))
|
||||
|
||||
(define-syntax-rule (sort-body lst *<? has-getkey? getkey cache-keys?)
|
||||
(let ([n (length lst)])
|
||||
(define-syntax-rule (<? x y)
|
||||
(if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y)))
|
||||
(cond
|
||||
;; trivial case
|
||||
[(= n 0) lst]
|
||||
;; below we can assume a non-empty input list
|
||||
[cache-keys?
|
||||
;; decorate while converting to a vector, and undecorate when going
|
||||
;; back, always do this for consistency
|
||||
(let ([vec (make-vector (+ n (ceiling (/ n 2))))])
|
||||
;; list -> decorated-vector
|
||||
(let loop ([i 0] [lst lst])
|
||||
(when (pair? lst)
|
||||
(let ([x (car lst)])
|
||||
(vector-set! vec i (cons (getkey x) x))
|
||||
(loop (add1 i) (cdr lst)))))
|
||||
;; sort
|
||||
(sort-internal *<? vec n car)
|
||||
;; decorated-vector -> list
|
||||
(let loop ([i n] [r '()])
|
||||
(let ([i (sub1 i)])
|
||||
(if (< i 0) r (loop i (cons (cdr (vector-ref vec i)) r))))))]
|
||||
;; trivial cases
|
||||
[(< n 2) lst]
|
||||
;; check if the list is already sorted (which can be common, eg,
|
||||
;; directory lists)
|
||||
[(let loop ([last (car lst)] [next (cdr lst)])
|
||||
(or (null? next)
|
||||
(and (not (<? (car next) last))
|
||||
(loop (car next) (cdr next)))))
|
||||
lst]
|
||||
;; below we can assume an unsorted list
|
||||
;; inlined case, for optimization of short lists
|
||||
[(<= n 3)
|
||||
(if (= n 2)
|
||||
;; (because of the above test, we can assume that the input is
|
||||
;; unsorted)
|
||||
(list (cadr lst) (car lst))
|
||||
(let ([a (car lst)] [b (cadr lst)] [c (caddr lst)])
|
||||
;; General note: we need a stable sort, so we should always compare
|
||||
;; (<? later-item earlier-item) since it gives more information. A
|
||||
;; good way to see that we have good code is to check that each
|
||||
;; permutation appears exactly once. This means that n=4 will have
|
||||
;; 23 cases, so don't bother. (Homework: write a macro to generate
|
||||
;; code for a specific N. Bonus: prove correctness. Extra bonus:
|
||||
;; prove optimal solution. Extra extra bonus: prove optimal
|
||||
;; solution exists, extract macro from proof.)
|
||||
(let ([a (car lst)] [b (cadr lst)] [c (caddr lst)])
|
||||
(if (<? b a)
|
||||
;; b<a
|
||||
(if (<? c b)
|
||||
(list c b a)
|
||||
;; b<a, b<=c
|
||||
(if (<? c a) (list b c a) (list b a c)))
|
||||
;; a<=b, so c<b (b<=c is impossible due to above test)
|
||||
(if (<? c a) (list c a b) (list a c b))))))]
|
||||
[else (let ([vec (make-vector (+ n (ceiling (/ n 2))))])
|
||||
;; list -> vector
|
||||
(let loop ([i 0] [lst lst])
|
||||
(when (pair? lst)
|
||||
(vector-set! vec i (car lst))
|
||||
(loop (add1 i) (cdr lst))))
|
||||
(define-syntax (sort-internal stx)
|
||||
(syntax-case stx ()
|
||||
[(_ vec less-than? n #:key #f)
|
||||
#'(let ([precomp (hash-ref precompiled-sorts less-than? #f)])
|
||||
(if precomp
|
||||
;; use a precompiled function if found
|
||||
(precomp vec n)
|
||||
;; otherwise, use the generic code
|
||||
(generic-sort vec less-than? n)))]
|
||||
[(_ vec less-than? n #:key key)
|
||||
#'(generic-sort/key vec less-than? n key)]))
|
||||
|
||||
;; - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
;; List Sorting Definition Body
|
||||
;; - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
||||
(define-syntax (list-sort-body stx)
|
||||
(syntax-case stx ()
|
||||
[(_ lst less-than? #:key key #:cache-keys? cache-keys?)
|
||||
#'(let ([n (length lst)])
|
||||
(define-syntax-rule (<? x y)
|
||||
(if key
|
||||
(less-than? (key x) (key y))
|
||||
(less-than? x y)))
|
||||
(cond
|
||||
;; trivial cases (where we know there is no caching to be done)
|
||||
[(i= n 0) lst]
|
||||
;; below we can assume a non-empty input list
|
||||
;; if we know statically this is not a cache-keys? use
|
||||
;; case, don't include this case in the cond
|
||||
[cache-keys?
|
||||
;; decorate while converting to a vector, and undecorate when going
|
||||
;; back, always do this for consistency
|
||||
(let ([vec (make-vector (+ n (ceiling (/ n 2))))])
|
||||
;; list -> decorated-vector
|
||||
(let loop ([i 0] [lst lst])
|
||||
(when (pair? lst)
|
||||
(let ([x (car lst)])
|
||||
(vset! vec i (cons (key x) x))
|
||||
(loop (i+ i 1) (cdr lst)))))
|
||||
;; sort
|
||||
(sort-internal vec less-than? n #:key ucar)
|
||||
;; decorated-vector -> list
|
||||
(let loop ([i n] [r '()])
|
||||
(let ([i (i- i 1)])
|
||||
(if (i< i 0)
|
||||
r
|
||||
(loop i (cons (ucdr (vref vec i)) r))))))]
|
||||
;; check if the list is already sorted (which can be common, eg,
|
||||
;; directory lists)
|
||||
[(let loop ([last (car lst)] [next (cdr lst)])
|
||||
(or (null? next)
|
||||
(and (not (<? (ucar next) last))
|
||||
(loop (ucar next) (ucdr next)))))
|
||||
lst]
|
||||
;; below we can assume an unsorted list
|
||||
;; inlined case, for optimization of short lists
|
||||
[(i<= n 3)
|
||||
(cond
|
||||
[(i= n 1) lst]
|
||||
[(i= n 2)
|
||||
;; (because of the above test, we know lst is unsorted)
|
||||
(list (cadr lst) (car lst))]
|
||||
[else
|
||||
(let ([a (car lst)] [b (cadr lst)] [c (caddr lst)])
|
||||
;; General note: we need a stable sort, so we should always compare
|
||||
;; (<? later-item earlier-item) since it gives more information.
|
||||
;; Good code should have each permutation appears exactly once.
|
||||
;; This means that n=4 will have 23 cases, so don't bother.
|
||||
(if (<? b a)
|
||||
;; b<a
|
||||
(if (<? c b)
|
||||
(list c b a)
|
||||
;; b<a, b<=c
|
||||
(if (<? c a) (list b c a) (list b a c)))
|
||||
;; a<=b, so c<b (b<=c is impossible due to above test)
|
||||
(if (<? c a) (list c a b) (list a c b))))])]
|
||||
[else (let ([vec (make-vector (+ n (ceiling (/ n 2))))])
|
||||
;; list -> vector
|
||||
(let loop ([i 0] [lst lst])
|
||||
(when (pair? lst)
|
||||
(vector-set! vec i (car lst))
|
||||
(loop (add1 i) (cdr lst))))
|
||||
;; sort
|
||||
(sort-internal vec less-than? n #:key key)
|
||||
;; vector -> list
|
||||
(let loop ([i n] [r '()])
|
||||
(let ([i (sub1 i)])
|
||||
(if (< i 0) r (loop i (cons (vector-ref vec i) r))))))]))]))
|
||||
|
||||
|
||||
;; - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
;; Vector Sorting Definition Body
|
||||
;; - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
||||
(define-syntax (vector-sort-body stx)
|
||||
(syntax-case stx ()
|
||||
[(_ src-vec less-than? start end
|
||||
#:key key
|
||||
#:cache-keys? cache-keys?
|
||||
#:constructive? constructive?)
|
||||
#'(let ([n (- end start)])
|
||||
(define-syntax-rule (<? x y)
|
||||
(if key
|
||||
(less-than? (key x) (key y))
|
||||
(less-than? x y)))
|
||||
(define-syntax-rule (swap! A i j)
|
||||
(let ([tmp (vref A i)])
|
||||
(vset! A i (vref A j))
|
||||
(vset! A j tmp)))
|
||||
(define dst-vec (if constructive? (make-vector n) src-vec))
|
||||
(define dst-start (if constructive? 0 start))
|
||||
(cond
|
||||
;; trivial case (where we know we don't even need to cache a key)
|
||||
[(i= n 0) (void)]
|
||||
;; below we can assume a non-empty input vector
|
||||
;; if we statically know we're not caching keys, don't
|
||||
;; include this case in the cond
|
||||
[cache-keys?
|
||||
;; decorate while converting to a vector for sorting,
|
||||
;; and undecorate when going back, always do this for
|
||||
;; consistency
|
||||
(define work-vec (make-vector (+ n (ceiling (/ n 2))) #t))
|
||||
;; vector -> decorated-vector
|
||||
(let loop ([i 0])
|
||||
(when (i< i n)
|
||||
(let ([x (vref src-vec (i+ i start))])
|
||||
(vset! work-vec i (cons (key x) x)))
|
||||
(loop (i+ i 1))))
|
||||
;; sort
|
||||
(if getkey
|
||||
(sort-internal *<? vec n getkey)
|
||||
(sort-internal *<? vec n))
|
||||
;; vector -> list
|
||||
(let loop ([i n] [r '()])
|
||||
(let ([i (sub1 i)])
|
||||
(if (< i 0) r (loop i (cons (vector-ref vec i) r))))))])))
|
||||
(sort-internal work-vec less-than? n #:key ucar)
|
||||
;; decorated-vector -> vector
|
||||
(let loop ([i 0])
|
||||
(when (i< i n)
|
||||
(vset! dst-vec (i+ i dst-start) (ucdr (vref work-vec i)))
|
||||
(loop (i+ i 1))))]
|
||||
;; check if the vector is already sorted
|
||||
[(let loop ([prev-val (vref src-vec start)]
|
||||
[next-index (i+ start 1)])
|
||||
(or (i= next-index end)
|
||||
(let ([next-val (vref src-vec next-index)])
|
||||
(and (not (<? next-val prev-val))
|
||||
(loop next-val (i+ next-index 1))))))
|
||||
(when constructive?
|
||||
(vector-copy! dst-vec dst-start src-vec start end))]
|
||||
;; other easy/small cases
|
||||
;; below we can assume an unsorted list
|
||||
;; inlined case, for optimization of short lists
|
||||
[(i<= n 3)
|
||||
(when constructive?
|
||||
(vector-copy! dst-vec dst-start src-vec start end))
|
||||
(cond
|
||||
[(i= n 1) (void)]
|
||||
[(i= n 2)
|
||||
;; (because of the above test, we know lst is unsorted)
|
||||
(swap! dst-vec
|
||||
(i+ dst-start 0)
|
||||
(i+ dst-start 1))]
|
||||
[else
|
||||
(let ([a (vref dst-vec (i+ dst-start 0))]
|
||||
[b (vref dst-vec (i+ dst-start 1))]
|
||||
[c (vref dst-vec (i+ dst-start 2))])
|
||||
(cond
|
||||
[(<? b a)
|
||||
(cond
|
||||
[(<? c b)
|
||||
(vset! dst-vec (i+ dst-start 0) c)
|
||||
(vset! dst-vec (i+ dst-start 2) a)]
|
||||
[(<? c a)
|
||||
(vset! dst-vec (i+ dst-start 0) b)
|
||||
(vset! dst-vec (i+ dst-start 1) c)
|
||||
(vset! dst-vec (i+ dst-start 2) a)]
|
||||
[else (vset! dst-vec (i+ dst-start 0) b)
|
||||
(vset! dst-vec (i+ dst-start 1) a)])]
|
||||
[(<? c a) (vset! dst-vec (i+ dst-start 0) c)
|
||||
(vset! dst-vec (i+ dst-start 1) a)
|
||||
(vset! dst-vec (i+ dst-start 2) b)]
|
||||
[else (vset! dst-vec (i+ dst-start 1) c)
|
||||
(vset! dst-vec (i+ dst-start 2) b)]))])]
|
||||
[else
|
||||
(let ([work-vec (make-vector (+ n (ceiling (/ n 2))) #f)])
|
||||
;; src vector -> work-vector (to do merge sort in)
|
||||
(vector-copy! work-vec 0 src-vec start end)
|
||||
;; sort!
|
||||
(sort-internal work-vec less-than? n #:key key)
|
||||
;; work-vector -> dst vector
|
||||
(vector-copy! dst-vec dst-start work-vec 0 n))])
|
||||
(if constructive?
|
||||
dst-vec
|
||||
(void)))]))
|
||||
|
||||
;; Finally, this is the provided `sort' value
|
||||
(case-lambda
|
||||
[(lst <?) (sort-body lst <? #f #f #f)]
|
||||
[(lst <? getkey)
|
||||
(if (and getkey (not (eq? values getkey)))
|
||||
(sort lst <? getkey #f) (sort lst <?))]
|
||||
[(lst <? getkey cache-keys?)
|
||||
(if (and getkey (not (eq? values getkey)))
|
||||
(sort-body lst <? #t getkey cache-keys?) (sort lst <?))])
|
||||
|
||||
)))
|
||||
;; macro for defining the various vector-sort case-lambdas
|
||||
(define-syntax-rule (vector-sort-case-lambda sort-name #:constructive? constructive?)
|
||||
(case-lambda
|
||||
[(vec less-than? start end)
|
||||
(vector-sort-body vec less-than? start end
|
||||
#:key #f
|
||||
#:cache-keys? #f
|
||||
#:constructive? constructive?)]
|
||||
[(vec less-than? start end getkey cache-keys?)
|
||||
(if (and getkey (not (eq? values getkey)))
|
||||
(vector-sort-body vec less-than? start end
|
||||
#:key getkey
|
||||
#:cache-keys? cache-keys?
|
||||
#:constructive? constructive?)
|
||||
(sort-name vec less-than? start end))]))
|
||||
|
||||
;; - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
;; Actual Sorting Function Definitions
|
||||
;; - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
||||
;; Finally, these are the provided `sort' values
|
||||
(values
|
||||
;; sort
|
||||
(case-lambda
|
||||
[(lst less-than?)
|
||||
(list-sort-body lst less-than? #:key #f #:cache-keys? #f)]
|
||||
[(lst less-than? getkey)
|
||||
(if (and getkey (not (eq? values getkey)))
|
||||
(sort lst less-than? getkey #f)
|
||||
(sort lst less-than?))]
|
||||
[(lst less-than? getkey cache-keys?)
|
||||
(if (and getkey (not (eq? values getkey)))
|
||||
(list-sort-body lst less-than? #:key getkey #:cache-keys? cache-keys?)
|
||||
(sort lst less-than?))])
|
||||
;; vector-sort
|
||||
(vector-sort-case-lambda vector-sort #:constructive? #t)
|
||||
;; vector-sort!
|
||||
(vector-sort-case-lambda vector-sort! #:constructive? #f))
|
||||
|
||||
))) ;; end of module
|
||||
|
|
|
|||
|
|
@ -5,8 +5,13 @@
|
|||
vector-take-right vector-drop-right vector-split-at-right
|
||||
vector-filter vector-filter-not
|
||||
vector-count vector-argmin vector-argmax
|
||||
vector-member vector-memq vector-memv)
|
||||
(require racket/unsafe/ops)
|
||||
vector-member vector-memq vector-memv
|
||||
vector-sort vector-sort!)
|
||||
(require racket/unsafe/ops
|
||||
(for-syntax racket/base)
|
||||
(rename-in (except-in "private/sort.rkt" sort)
|
||||
[vector-sort! raw-vector-sort!]
|
||||
[vector-sort raw-vector-sort]))
|
||||
|
||||
(define (vector-set*! v . pairs)
|
||||
(unless (even? (length pairs))
|
||||
|
|
@ -23,11 +28,14 @@
|
|||
(vector-copy! new-v 0 v start end)
|
||||
new-v)
|
||||
|
||||
|
||||
(define (vector-copy v [start 0] [end (and (vector? v) (vector-length v))])
|
||||
(unless (vector? v)
|
||||
(raise-argument-error 'vector-copy "vector?" v))
|
||||
(unless (exact-nonnegative-integer? start)
|
||||
(raise-argument-error 'vector-copy "exact-nonnegative-integer?" start))
|
||||
(unless (exact-nonnegative-integer? end)
|
||||
(raise-argument-error 'vector-copy "exact-nonnegative-integer?" end))
|
||||
(let ([len (vector-length v)])
|
||||
(cond
|
||||
[(= len 0)
|
||||
|
|
@ -231,3 +239,54 @@
|
|||
(vm-mk vector-member equal?)
|
||||
(vm-mk vector-memq eq?)
|
||||
(vm-mk vector-memv eqv?)
|
||||
|
||||
(define-syntax-rule (perform-common-sort-arg-checks name vec less? start end getkey)
|
||||
(let ()
|
||||
;; check other args are valid
|
||||
(unless (exact-nonnegative-integer? start)
|
||||
(raise-argument-error 'name "exact-nonnegative-integer?" start))
|
||||
(unless (exact-nonnegative-integer? end)
|
||||
(raise-argument-error 'name "exact-nonnegative-integer?" end))
|
||||
(unless (and (procedure? less?) (procedure-arity-includes? less? 2))
|
||||
(raise-argument-error 'name "(any/c any/c . -> . any/c)" less?))
|
||||
(when (and getkey (not (and (procedure? getkey)
|
||||
(procedure-arity-includes? getkey 1))))
|
||||
(raise-argument-error 'name "(any/c . -> . any/c)" getkey))
|
||||
(let ([len (vector-length vec)])
|
||||
(unless (and (<= 0 start len))
|
||||
(raise-range-error 'name "vector" "starting " start vec 0 len))
|
||||
(unless (and (<= start end len))
|
||||
(raise-range-error 'name "vector" "ending " end vec start len 0)))))
|
||||
|
||||
|
||||
|
||||
;; vector sort
|
||||
(define (vector-sort vec less? [start 0] [end #f]
|
||||
#:key [getkey #f] #:cache-keys? [cache-keys? #f])
|
||||
;; is the input vector the right kind? (mutable vs immutable allowed?)
|
||||
(unless (vector? vec)
|
||||
(raise-argument-error 'vector-sort "vector?" vec))
|
||||
|
||||
;; calulate end if not provided
|
||||
(let ([end (or end (vector-length vec))])
|
||||
(perform-common-sort-arg-checks vector-sort vec less? start end getkey)
|
||||
(if getkey
|
||||
(raw-vector-sort vec less? start end getkey cache-keys?)
|
||||
(raw-vector-sort vec less? start end))))
|
||||
|
||||
;; vector sort
|
||||
(define (vector-sort! vec less? [start 0] [end #f]
|
||||
#:key [getkey #f]
|
||||
#:cache-keys? [cache-keys? #f])
|
||||
;; is the input vector the right kind? (mutable vs immutable allowed?)
|
||||
(unless (and (vector? vec) (not (immutable? vec)))
|
||||
(raise-argument-error 'vector-sort!
|
||||
"(and/c vector? (not/c immutable?))"
|
||||
vec))
|
||||
|
||||
;; calulate end if not provided
|
||||
(let ([end (or end (vector-length vec))])
|
||||
(perform-common-sort-arg-checks vector-sort! vec less? start end getkey)
|
||||
(if getkey
|
||||
(raw-vector-sort! vec less? start end getkey cache-keys?)
|
||||
(raw-vector-sort! vec less? start end))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user