mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
adding (srfi 132)
This commit is contained in:
Alex Shinn
parent
6e2013153a
commit
67712e5624
4 changed files with 881 additions and 1 deletions
19
lib/srfi/132.sld
Normal file
19
lib/srfi/132.sld
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
(define-library (srfi 132)
|
||||
(import (scheme base) (srfi 95))
|
||||
(export
|
||||
list-sorted? vector-sorted?
|
||||
list-sort list-stable-sort
|
||||
list-sort! list-stable-sort!
|
||||
vector-sort vector-stable-sort
|
||||
vector-sort! vector-stable-sort!
|
||||
list-merge list-merge!
|
||||
vector-merge vector-merge!
|
||||
list-delete-neighbor-dups
|
||||
list-delete-neighbor-dups!
|
||||
vector-delete-neighbor-dups
|
||||
vector-delete-neighbor-dups!
|
||||
vector-find-median
|
||||
vector-find-median!
|
||||
vector-select!
|
||||
vector-separate!)
|
||||
(include "132/sort.scm"))
|
||||
172
lib/srfi/132/sort.scm
Normal file
172
lib/srfi/132/sort.scm
Normal file
|
|
@ -0,0 +1,172 @@
|
|||
|
||||
(define (list-sorted? < ls) (sorted? ls <))
|
||||
(define (vector-sorted? < vec) (sorted? vec <))
|
||||
|
||||
(define (list-sort < ls) (sort ls <))
|
||||
(define (list-stable-sort < ls) (sort ls <))
|
||||
|
||||
(define (vector-sort < vec . o)
|
||||
(if (pair? o) (sort (apply vector-copy vec o) <) (sort vec <)))
|
||||
(define vector-stable-sort vector-sort)
|
||||
|
||||
(define (list-sort! < ls) (sort! ls <))
|
||||
(define (list-stable-sort! < ls) (sort! ls <))
|
||||
|
||||
(define (vector-sort! < vec . o)
|
||||
(if (pair? o)
|
||||
(let ((v (vector-sort! < (apply vector-copy vec o))))
|
||||
(vector-copy! vec (car o) v)
|
||||
vec)
|
||||
(sort! vec <)))
|
||||
(define vector-stable-sort! vector-sort!)
|
||||
|
||||
(define (list-merge < ls1 ls2) (merge ls1 ls2 <))
|
||||
(define (list-merge! < ls1 ls2) (merge! ls1 ls2 <))
|
||||
|
||||
(define (vector-merge less vec1 vec2 . o)
|
||||
(if (pair? o)
|
||||
(if (pair? (cdr o))
|
||||
(vector-merge less
|
||||
(vector-copy vec1 (car o) (cadr o))
|
||||
(apply vector-copy vec2 (cddr o)))
|
||||
(vector-merge less (vector-copy vec1 (car o)) vec2))
|
||||
(let* ((e1 (vector-length vec1))
|
||||
(e2 (vector-length vec2))
|
||||
(res (make-vector (+ e1 e2))))
|
||||
(let lp ((i 0) (i1 0) (i2 0))
|
||||
(cond
|
||||
((and (>= i1 e1) (>= i2 e2)) res)
|
||||
((or (>= i1 e1)
|
||||
(and (< i2 e2)
|
||||
(less (vector-ref vec2 i2) (vector-ref vec1 i1))))
|
||||
(vector-set! res i (vector-ref vec2 i2))
|
||||
(lp (+ i 1) i1 (+ i2 1)))
|
||||
(else
|
||||
(vector-set! res i (vector-ref vec1 i1))
|
||||
(lp (+ i 1) (+ i1 1) i2)))))))
|
||||
|
||||
(define (vector-merge! < to vec1 vec2 . o)
|
||||
(let ((start (if (pair? o) (car o) 0))
|
||||
(o (if (pair? o) (cdr o) '())))
|
||||
(let ((res (apply vector-merge < vec1 vec2 o)))
|
||||
(vector-copy! to start res))))
|
||||
|
||||
(define (list-delete-neighbor-dups eq ls)
|
||||
(let lp ((ls ls) (res '()))
|
||||
(cond ((null? ls) (reverse res))
|
||||
((and (pair? res) (eq (car res) (car ls))) (lp (cdr ls) res))
|
||||
(else (lp (cdr ls) (cons (car ls) res))))))
|
||||
|
||||
(define (list-delete-neighbor-dups! eq ls)
|
||||
(if (pair? ls)
|
||||
(let lp ((ls (cdr ls)) (start ls))
|
||||
(cond ((null? ls) (set-cdr! start '()))
|
||||
((eq (car start) (car ls)) (lp (cdr ls) start))
|
||||
(else (set-cdr! start ls) (lp (cdr ls) ls)))))
|
||||
ls)
|
||||
|
||||
(define (vector-delete-neighbor-dups eq vec . o)
|
||||
(if (zero? (vector-length vec))
|
||||
vec
|
||||
(let ((ls (if (and (pair? o) (pair? (cdr o)))
|
||||
(vector->list vec (car o) (cadr o))
|
||||
(apply vector->list vec o))))
|
||||
(list->vector (list-delete-neighbor-dups eq ls)))))
|
||||
|
||||
(define (vector-delete-neighbor-dups! eq vec . o)
|
||||
(let ((start (if (pair? o) (car o) 0))
|
||||
(end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length vec))))
|
||||
(cond
|
||||
((<= end start) start)
|
||||
(else
|
||||
(let lp ((i (+ start 1))
|
||||
(fill (+ start 1)))
|
||||
(cond
|
||||
((>= i end) fill)
|
||||
((eq (vector-ref vec (- i 1)) (vector-ref vec i)) (lp (+ i 1) fill))
|
||||
(else
|
||||
(if (> i fill)
|
||||
(vector-set! vec fill (vector-ref vec i)))
|
||||
(lp (+ i 1) (+ fill 1)))))))))
|
||||
|
||||
;; Median of 3 (good in practice, use median-of-medians for guaranteed
|
||||
;; linear time).
|
||||
(define (choose-pivot < vec left right)
|
||||
(let* ((mid (quotient (+ left right) 2))
|
||||
(a (vector-ref vec left))
|
||||
(b (vector-ref vec mid))
|
||||
(c (vector-ref vec right)))
|
||||
(if (< a b)
|
||||
(if (< b c) mid (if (< a c) right left))
|
||||
(if (< a c) left (if (< b c) right mid)))))
|
||||
|
||||
;; Partitions around elt and returns the resulting median index.
|
||||
(define (vector-partition! < vec left right pivot)
|
||||
(define (swap! i j)
|
||||
(let ((tmp (vector-ref vec i)))
|
||||
(vector-set! vec i (vector-ref vec j))
|
||||
(vector-set! vec j tmp)))
|
||||
(let ((elt (vector-ref vec pivot)))
|
||||
(swap! pivot right)
|
||||
(let lp ((i left)
|
||||
(j left))
|
||||
(cond
|
||||
((= i right)
|
||||
(swap! i j)
|
||||
j)
|
||||
((< (vector-ref vec i) elt)
|
||||
(swap! i j)
|
||||
(lp (+ i 1) (+ j 1)))
|
||||
(else
|
||||
(lp (+ i 1) j))))))
|
||||
|
||||
;; Permutes vec in-place to move the k smallest elements as ordered by
|
||||
;; < to the beginning of the vector (unsorted). Returns the nth smallest.
|
||||
(define (vector-select! < vec k . o)
|
||||
(let* ((left (if (pair? o) (car o) 0))
|
||||
(k (+ k left)))
|
||||
(if (not (<= 0 k (vector-length vec)))
|
||||
(error "k out of range" vec k))
|
||||
(let select ((left left)
|
||||
(right (- (if (and (pair? o) (pair? (cdr o)))
|
||||
(cadr o)
|
||||
(vector-length vec))
|
||||
1)))
|
||||
(if (>= left right)
|
||||
(vector-ref vec left)
|
||||
(let* ((pivot (choose-pivot < vec left right))
|
||||
(pivot-index (vector-partition! < vec left right pivot)))
|
||||
(cond
|
||||
((= k pivot-index)
|
||||
(vector-ref vec k))
|
||||
((< k pivot-index)
|
||||
(select left (- pivot-index 1)))
|
||||
(else
|
||||
(select (+ pivot-index 1) right))))))))
|
||||
|
||||
(define (vector-separate! < vec k . o)
|
||||
(apply vector-select! < vec k o)
|
||||
(if #f #f))
|
||||
|
||||
(define (vector-find-median! < vec knil . o)
|
||||
(vector-sort! < vec) ; required by SRFI 132
|
||||
(let* ((len (vector-length vec))
|
||||
(mid (quotient len 2))
|
||||
(mean (if (pair? o) (car o) (lambda (a b) (/ (+ a b) 2)))))
|
||||
(cond
|
||||
((zero? len) knil)
|
||||
((odd? len) (vector-ref vec mid))
|
||||
(else (mean (vector-ref vec (- mid 1)) (vector-ref vec mid))))))
|
||||
|
||||
(define (vector-find-median < vec knil . o)
|
||||
(let* ((vec (vector-copy vec))
|
||||
(len (vector-length vec))
|
||||
(mid (quotient len 2))
|
||||
(mean (if (pair? o) (car o) (lambda (a b) (/ (+ a b) 2)))))
|
||||
(cond
|
||||
((zero? len) knil)
|
||||
(else
|
||||
(vector-separate! < vec mid)
|
||||
(cond
|
||||
((odd? len) (vector-ref vec mid))
|
||||
(else (mean (vector-ref vec (- mid 1)) (vector-ref vec mid))))))))
|
||||
686
lib/srfi/132/test.sld
Normal file
686
lib/srfi/132/test.sld
Normal file
|
|
@ -0,0 +1,686 @@
|
|||
(define-library (srfi 132 test)
|
||||
(import (scheme base) (srfi 132) (chibi test))
|
||||
(export run-tests)
|
||||
(begin
|
||||
(define (run-tests)
|
||||
(test-begin "sorting")
|
||||
(test '()
|
||||
(list-sort > (list)))
|
||||
(test '(987)
|
||||
(list-sort > (list 987)))
|
||||
(test '(987 654)
|
||||
(list-sort > (list 987 654)))
|
||||
(test '(9 8 7 6 5 4 3 2 1 0)
|
||||
(list-sort > (list 9 8 6 3 0 4 2 5 7 1)))
|
||||
(test '()
|
||||
(list-stable-sort > (list)))
|
||||
(test '(987)
|
||||
(list-stable-sort > (list 987)))
|
||||
(test '(987 654)
|
||||
(list-stable-sort > (list 987 654)))
|
||||
(test '(9 8 7 6 5 4 3 2 1 0)
|
||||
(list-stable-sort > (list 9 8 6 3 0 4 2 5 7 1)))
|
||||
(test '(9 8 6 7 4 5 3 2 0 1)
|
||||
(list-stable-sort (lambda (x y)
|
||||
(> (quotient x 2)
|
||||
(quotient y 2)))
|
||||
(list 9 8 6 3 0 4 2 5 7 1)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-sort > v)))
|
||||
(test '#(987)
|
||||
(let ((v (vector 987)))
|
||||
(vector-sort > (vector 987))))
|
||||
(test '#(987 654)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-sort > v)))
|
||||
(test '#(9 8 7 6 5 4 3 2 1 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-sort > v)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-stable-sort > v)))
|
||||
(test '#(987)
|
||||
(let ((v (vector 987)))
|
||||
(vector-stable-sort > (vector 987))))
|
||||
(test '#(987 654)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-stable-sort > v)))
|
||||
(test '#(9 8 7 6 5 4 3 2 1 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort > v)))
|
||||
(test '#(9 8 6 7 4 5 3 2 0 1)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort (lambda (x y)
|
||||
(> (quotient x 2)
|
||||
(quotient y 2)))
|
||||
v)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-sort > v 0)))
|
||||
(test '#()
|
||||
(let ((v (vector 987)))
|
||||
(vector-sort > (vector 987) 1)))
|
||||
(test '#(654)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-sort > v 1)))
|
||||
(test '#(7 5 4 3 2 1 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-sort > v 3)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-stable-sort > v 0)))
|
||||
(test '#()
|
||||
(let ((v (vector 987)))
|
||||
(vector-stable-sort > (vector 987) 1)))
|
||||
(test '#(654 987)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-stable-sort < v 0 2)))
|
||||
(test '#(7 5 4 3 2 1 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort > v 3)))
|
||||
(test '#(7 4 5 3 2 0 1)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort (lambda (x y)
|
||||
(> (quotient x 2)
|
||||
(quotient y 2)))
|
||||
v
|
||||
3)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-sort > v 0 0)))
|
||||
(test '#()
|
||||
(let ((v (vector 987)))
|
||||
(vector-sort > (vector 987) 1 1)))
|
||||
(test '#(654)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-sort > v 1 2)))
|
||||
(test '#(5 4 2 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-sort > v 4 8)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-stable-sort > v 0 0)))
|
||||
(test '#()
|
||||
(let ((v (vector 987)))
|
||||
(vector-stable-sort > (vector 987) 1 1)))
|
||||
(test '#(654)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-stable-sort > v 1 2)))
|
||||
(test '#(6 4 3 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort > v 2 6)))
|
||||
(test '#(8 6 4 5 3 2 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort (lambda (x y)
|
||||
(> (quotient x 2)
|
||||
(quotient y 2)))
|
||||
v
|
||||
1
|
||||
8)))
|
||||
(test '()
|
||||
(list-sort! > (list)))
|
||||
(test '(987)
|
||||
(list-sort! > (list 987)))
|
||||
(test '(987 654)
|
||||
(list-sort! > (list 987 654)))
|
||||
(test '(9 8 7 6 5 4 3 2 1 0)
|
||||
(list-sort! > (list 9 8 6 3 0 4 2 5 7 1)))
|
||||
(test '()
|
||||
(list-stable-sort! > (list)))
|
||||
(test '(987)
|
||||
(list-stable-sort! > (list 987)))
|
||||
(test '(987 654)
|
||||
(list-stable-sort! > (list 987 654)))
|
||||
(test '(9 8 7 6 5 4 3 2 1 0)
|
||||
(list-stable-sort! > (list 9 8 6 3 0 4 2 5 7 1)))
|
||||
(test '(9 8 6 7 4 5 3 2 0 1)
|
||||
(list-stable-sort! (lambda (x y)
|
||||
(> (quotient x 2)
|
||||
(quotient y 2)))
|
||||
(list 9 8 6 3 0 4 2 5 7 1)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-sort! > v)
|
||||
v))
|
||||
(test '#(987)
|
||||
(let ((v (vector 987)))
|
||||
(vector-sort! > (vector 987))
|
||||
v))
|
||||
(test '#(987 654)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-sort! > v)
|
||||
v))
|
||||
(test '#(9 8 7 6 5 4 3 2 1 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-sort! > v)
|
||||
v))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-stable-sort! > v)
|
||||
v))
|
||||
(test '#(987)
|
||||
(let ((v (vector 987)))
|
||||
(vector-stable-sort! > (vector 987))
|
||||
v))
|
||||
(test '#(987 654)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-stable-sort! > v)
|
||||
v))
|
||||
(test '#(9 8 7 6 5 4 3 2 1 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort! > v)
|
||||
v))
|
||||
(test '#(9 8 6 7 4 5 3 2 0 1)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort! (lambda (x y)
|
||||
(> (quotient x 2)
|
||||
(quotient y 2)))
|
||||
v)
|
||||
v))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-sort! > v 0)
|
||||
v))
|
||||
(test '#(987)
|
||||
(let ((v (vector 987)))
|
||||
(vector-sort! > (vector 987) 1)
|
||||
v))
|
||||
(test '#(987 654)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-sort! > v 1)
|
||||
v))
|
||||
(test '#(9 8 6 7 5 4 3 2 1 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-sort! > v 3)
|
||||
v))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-stable-sort! > v 0)
|
||||
v))
|
||||
(test '#(987)
|
||||
(let ((v (vector 987)))
|
||||
(vector-stable-sort! > (vector 987) 1)
|
||||
v))
|
||||
(test '#(654 987)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-stable-sort! < v 0 2)
|
||||
v))
|
||||
(test '#(9 8 6 7 5 4 3 2 1 0)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort! > v 3)
|
||||
v))
|
||||
(test '#(9 8 6 7 4 5 3 2 0 1)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort! (lambda (x y)
|
||||
(> (quotient x 2)
|
||||
(quotient y 2)))
|
||||
v
|
||||
3)
|
||||
v))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-sort! > v 0 0)
|
||||
v))
|
||||
(test '#(987)
|
||||
(let ((v (vector 987)))
|
||||
(vector-sort! > (vector 987) 1 1)
|
||||
v))
|
||||
(test '#(987 654)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-sort! > v 1 2)
|
||||
v))
|
||||
(test '#(9 8 6 3 5 4 2 0 7 1)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-sort! > v 4 8)
|
||||
v))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-stable-sort! > v 0 0)
|
||||
v))
|
||||
(test '#(987)
|
||||
(let ((v (vector 987)))
|
||||
(vector-stable-sort! > (vector 987) 1 1)
|
||||
v))
|
||||
(test '#(987 654)
|
||||
(let ((v (vector 987 654)))
|
||||
(vector-stable-sort! > v 1 2)
|
||||
v))
|
||||
(test '#(9 8 6 4 3 0 2 5 7 1)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort! > v 2 6)
|
||||
v))
|
||||
(test '#(9 8 6 4 5 3 2 0 7 1)
|
||||
(let ((v (vector 9 8 6 3 0 4 2 5 7 1)))
|
||||
(vector-stable-sort! (lambda (x y)
|
||||
(> (quotient x 2)
|
||||
(quotient y 2)))
|
||||
v
|
||||
1
|
||||
8)
|
||||
v))
|
||||
(test (list-merge > (list) (list))
|
||||
'())
|
||||
(test '(9 6 3 0)
|
||||
(list-merge > (list) (list 9 6 3 0)))
|
||||
(test '(9 7 5 3 1)
|
||||
(list-merge > (list 9 7 5 3 1) (list)))
|
||||
(test '(9 9 7 6 5 3 3 1 0)
|
||||
(list-merge > (list 9 7 5 3 1) (list 9 6 3 0)))
|
||||
(test '()
|
||||
(list-merge! > (list) (list)))
|
||||
(test '(9 6 3 0)
|
||||
(list-merge! > (list) (list 9 6 3 0)))
|
||||
(test '(9 7 5 3 1)
|
||||
(list-merge! > (list 9 7 5 3 1) (list)))
|
||||
(test '(9 9 7 6 5 3 3 1 0)
|
||||
(list-merge! > (list 9 7 5 3 1) (list 9 6 3 0)))
|
||||
(test '#()
|
||||
(vector-merge > (vector) (vector)))
|
||||
(test '#(9 6 3 0)
|
||||
(vector-merge > (vector) (vector 9 6 3 0)))
|
||||
(test '#(9 7 5 3 1)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector)))
|
||||
(test '#(9 9 7 6 5 3 3 1 0)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector 9 6 3 0)))
|
||||
(test '#(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector))
|
||||
v))
|
||||
(test '#( 9 6 3 0 #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector 9 6 3 0))
|
||||
v))
|
||||
(test '#( 9 7 5 3 1 #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector))
|
||||
v))
|
||||
(test '#( 9 9 7 6 5 3 3 1 0 #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector 9 6 3 0))
|
||||
v))
|
||||
(test '#(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector) 0)
|
||||
v))
|
||||
(test '#( 9 6 3 0 #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector 9 6 3 0) 0)
|
||||
v))
|
||||
(test '#( 9 7 5 3 1 #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector) 0)
|
||||
v))
|
||||
(test '#( 9 9 7 6 5 3 3 1 0 #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector 9 6 3 0) 0)
|
||||
v))
|
||||
(test '#(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector) 2)
|
||||
v))
|
||||
(test '#(#f #f 9 6 3 0 #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector 9 6 3 0) 2)
|
||||
v))
|
||||
(test '#(#f #f 9 7 5 3 1 #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector) 2)
|
||||
v))
|
||||
(test '#(#f #f 9 9 7 6 5 3 3 1 0 #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector 9 6 3 0) 2)
|
||||
v))
|
||||
(test '#()
|
||||
(vector-merge > (vector) (vector) 0))
|
||||
(test '#(9 6 3 0)
|
||||
(vector-merge > (vector) (vector 9 6 3 0) 0))
|
||||
(test '#(5 3 1)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector) 2))
|
||||
(test '#(9 6 5 3 3 1 0)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector 9 6 3 0) 2))
|
||||
(test '#(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector) 2 0)
|
||||
v))
|
||||
(test '#(#f #f 9 6 3 0 #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector 9 6 3 0) 2 0)
|
||||
v))
|
||||
(test '#(#f #f 5 3 1 #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector) 2 2)
|
||||
v))
|
||||
(test '#(#f #f 9 6 5 3 3 1 0 #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector 9 6 3 0) 2 2)
|
||||
v))
|
||||
(test '#()
|
||||
(vector-merge > (vector) (vector) 0 0))
|
||||
(test '#(9 6 3 0)
|
||||
(vector-merge > (vector) (vector 9 6 3 0) 0 0))
|
||||
(test '#(5 3 1)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector) 2 5))
|
||||
(test '#(9 6 5 3 3 1 0)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector 9 6 3 0) 2 5))
|
||||
(test '#(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector) 2 0 0)
|
||||
v))
|
||||
(test '#(#f #f 9 6 3 0 #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector 9 6 3 0) 2 0 0)
|
||||
v))
|
||||
(test '#(#f #f 5 3 1 #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector) 2 2 5)
|
||||
v))
|
||||
(test '#(#f #f 9 6 5 3 3 1 0 #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector 9 6 3 0) 2 2 5)
|
||||
v))
|
||||
(test '#()
|
||||
(vector-merge > (vector) (vector) 0 0))
|
||||
(test '#(9 6 3 0)
|
||||
(vector-merge > (vector) (vector 9 6 3 0) 0 0))
|
||||
(test '#(5 3)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector) 2 4))
|
||||
(test '#(9 6 5 3 3 0)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector 9 6 3 0) 2 4))
|
||||
(test '#(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector) 2 0 0)
|
||||
v))
|
||||
(test '#(#f #f 9 6 3 0 #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector 9 6 3 0) 2 0 0)
|
||||
v))
|
||||
(test '#(#f #f 5 3 #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector) 2 2 4)
|
||||
v))
|
||||
(test '#(#f #f 9 6 5 3 3 0 #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector 9 6 3 0) 2 2 4)
|
||||
v))
|
||||
(test '#()
|
||||
(vector-merge > (vector) (vector) 0 0 0))
|
||||
(test '#(9 6 3 0)
|
||||
(vector-merge > (vector) (vector 9 6 3 0) 0 0 0))
|
||||
(test '#(5 3)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector) 2 4 0))
|
||||
(test '#(9 6 5 3 3 0)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector 9 6 3 0) 2 4 0))
|
||||
(test '#(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector) 2 0 0 0)
|
||||
v))
|
||||
(test '#(#f #f 9 6 3 0 #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector 9 6 3 0) 2 0 0 0)
|
||||
v))
|
||||
(test '#(#f #f 5 3 #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector) 2 2 4 0)
|
||||
v))
|
||||
(test '#(#f #f 9 6 5 3 3 0 #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector 9 6 3 0) 2 2 4 0)
|
||||
v))
|
||||
(test '#()
|
||||
(vector-merge > (vector) (vector) 0 0 0))
|
||||
(test '#(6 3 0)
|
||||
(vector-merge > (vector) (vector 9 6 3 0) 0 0 1))
|
||||
(test '#(5 3)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector) 2 4 0))
|
||||
(test '#(6 5 3 3 0)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector 9 6 3 0) 2 4 1))
|
||||
(test '#(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector) 2 0 0 0)
|
||||
v))
|
||||
(test '#(#f #f 6 3 0 #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector 9 6 3 0) 2 0 0 1)
|
||||
v))
|
||||
(test '#(#f #f 5 3 #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector) 2 2 4 0)
|
||||
v))
|
||||
(test '#(#f #f 6 5 3 3 0 #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector 9 6 3 0) 2 2 4 1)
|
||||
v))
|
||||
(test '#()
|
||||
(vector-merge > (vector) (vector) 0 0 0 0))
|
||||
(test '#(6 3 0)
|
||||
(vector-merge > (vector) (vector 9 6 3 0) 0 0 1 4))
|
||||
(test '#(5 3)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector) 2 4 0 0))
|
||||
(test '#(6 5 3 3 0)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector 9 6 3 0) 2 4 1 4))
|
||||
(test '#(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector) 2 0 0 0 0)
|
||||
v))
|
||||
(test '#(#f #f 6 3 0 #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector 9 6 3 0) 2 0 0 1 4)
|
||||
v))
|
||||
(test '#(#f #f 5 3 #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector) 2 2 4 0 0)
|
||||
v))
|
||||
(test '#(#f #f 6 5 3 3 0 #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector 9 6 3 0) 2 2 4 1 4)
|
||||
v))
|
||||
(test '#()
|
||||
(vector-merge > (vector) (vector) 0 0 0 0))
|
||||
(test '#(6)
|
||||
(vector-merge > (vector) (vector 9 6 3 0) 0 0 1 2))
|
||||
(test '#(5 3)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector) 2 4 0 0))
|
||||
(test '#(6 5 3)
|
||||
(vector-merge > (vector 9 7 5 3 1) (vector 9 6 3 0) 2 4 1 2))
|
||||
(test '#(#f #f #f #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector) 2 0 0 0 0)
|
||||
v))
|
||||
(test '#(#f #f 6 #f #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector) (vector 9 6 3 0) 2 0 0 1 2)
|
||||
v))
|
||||
(test '#(#f #f 5 3 #f #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector) 2 2 4 0 0)
|
||||
v))
|
||||
(test '#(#f #f 6 5 3 #f #f #f #f #f #f #f)
|
||||
(let ((v (make-vector 12 #f)))
|
||||
(vector-merge! > v (vector 9 7 5 3 1) (vector 9 6 3 0) 2 2 4 1 2)
|
||||
v))
|
||||
(test '()
|
||||
(list-delete-neighbor-dups char=? (list)))
|
||||
(test '(#\a)
|
||||
(list-delete-neighbor-dups char=? (list #\a)))
|
||||
(test '(#\a #\b #\a)
|
||||
(list-delete-neighbor-dups char=? (list #\a #\a #\a #\b #\b #\a)))
|
||||
(test '()
|
||||
(list-delete-neighbor-dups! char=? (list)))
|
||||
(test '(#\a)
|
||||
(list-delete-neighbor-dups! char=? (list #\a)))
|
||||
(test '(#\a #\b #\a)
|
||||
(list-delete-neighbor-dups! char=? (list #\a #\a #\a #\b #\b #\a)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-delete-neighbor-dups char=? v)))
|
||||
(test '#(#\a)
|
||||
(let ((v (vector #\a)))
|
||||
(vector-delete-neighbor-dups char=? v)))
|
||||
(test '#(#\a #\b #\a)
|
||||
(let ((v (vector #\a #\a #\a #\b #\b #\a)))
|
||||
(vector-delete-neighbor-dups char=? v)))
|
||||
(test '(0 #())
|
||||
(let ((v (vector)))
|
||||
(list (vector-delete-neighbor-dups! char=? v) v)))
|
||||
(test '(1 #(#\a))
|
||||
(let ((v (vector #\a)))
|
||||
(list (vector-delete-neighbor-dups! char=? v) v)))
|
||||
(test '(3 #(#\a #\b #\a #\b #\b #\a))
|
||||
(let ((v (vector #\a #\a #\a #\b #\b #\a)))
|
||||
(list (vector-delete-neighbor-dups! char=? v) v)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-delete-neighbor-dups char=? v 0)))
|
||||
(test '#(#\a)
|
||||
(let ((v (vector #\a)))
|
||||
(vector-delete-neighbor-dups char=? v 0)))
|
||||
(test '#(#\a #\b #\a)
|
||||
(let ((v (vector #\a #\a #\a #\b #\b #\a)))
|
||||
(vector-delete-neighbor-dups char=? v 0)))
|
||||
(test '(0 #())
|
||||
(let ((v (vector)))
|
||||
(list (vector-delete-neighbor-dups! char=? v 0) v)))
|
||||
(test '(1 #(#\a))
|
||||
(let ((v (vector #\a)))
|
||||
(list (vector-delete-neighbor-dups! char=? v 0) v)))
|
||||
(test '(3 #(#\a #\b #\a #\b #\b #\a))
|
||||
(let ((v (vector #\a #\a #\a #\b #\b #\a)))
|
||||
(list (vector-delete-neighbor-dups! char=? v 0) v)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-delete-neighbor-dups char=? v 0)))
|
||||
(test '#()
|
||||
(let ((v (vector #\a)))
|
||||
(vector-delete-neighbor-dups char=? v 1)))
|
||||
(test '#(#\b #\a)
|
||||
(let ((v (vector #\a #\a #\a #\b #\b #\a)))
|
||||
(vector-delete-neighbor-dups char=? v 3)))
|
||||
(test '(0 #())
|
||||
(let ((v (vector)))
|
||||
(list (vector-delete-neighbor-dups! char=? v 0) v)))
|
||||
(test '(1 #(#\a))
|
||||
(let ((v (vector #\a)))
|
||||
(list (vector-delete-neighbor-dups! char=? v 1) v)))
|
||||
(test '(5 #(#\a #\a #\a #\b #\a #\a))
|
||||
(let ((v (vector #\a #\a #\a #\b #\b #\a)))
|
||||
(list (vector-delete-neighbor-dups! char=? v 3) v)))
|
||||
(test '#()
|
||||
(let ((v (vector)))
|
||||
(vector-delete-neighbor-dups char=? v 0 0)))
|
||||
(test '#()
|
||||
(let ((v (vector #\a)))
|
||||
(vector-delete-neighbor-dups char=? v 1 1)))
|
||||
(test '#(#\b)
|
||||
(let ((v (vector #\a #\a #\a #\b #\b #\a)))
|
||||
(vector-delete-neighbor-dups char=? v 3 5)))
|
||||
(test '(0 #())
|
||||
(let ((v (vector)))
|
||||
(list (vector-delete-neighbor-dups! char=? v 0 0) v)))
|
||||
(test '(1 #(#\a))
|
||||
(let ((v (vector #\a)))
|
||||
(list (vector-delete-neighbor-dups! char=? v 0 1) v)))
|
||||
(test '(1 #(#\a))
|
||||
(let ((v (vector #\a)))
|
||||
(list (vector-delete-neighbor-dups! char=? v 1 1) v)))
|
||||
(test '(4 #(#\a #\a #\a #\b #\b #\a))
|
||||
(let ((v (vector #\a #\a #\a #\b #\b #\a)))
|
||||
(list (vector-delete-neighbor-dups! char=? v 3 5) v)))
|
||||
(let ((v (vector 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6)))
|
||||
(test '(9 . #(0 0 0 1 2 3 4 5 6 4 4 5 5 6 6))
|
||||
(cons (vector-delete-neighbor-dups! = v 3) v)))
|
||||
(test "knil" (vector-find-median < (vector) "knil"))
|
||||
(test 17 (vector-find-median < (vector 17) "knil"))
|
||||
(test 12 (vector-find-median < (vector 18 1 12 14 12 5 18 2) "knil"))
|
||||
(test 23/2 (vector-find-median < (vector 18 1 11 14 12 5 18 2) "knil"))
|
||||
(test (list 12 12)
|
||||
(vector-find-median < (vector 18 1 12 14 12 5 18 2) "knil" list))
|
||||
(test (list 11 12)
|
||||
(vector-find-median < (vector 18 1 11 14 12 5 18 2) "knil" list))
|
||||
(test 7 (vector-find-median < (vector 7 6 9 3 1 18 15 7 8) "knil"))
|
||||
(test 7 (vector-find-median < (vector 7 6 9 3 1 18 15 7 8) "knil" list))
|
||||
(test 19
|
||||
(let ((v (vector 19)))
|
||||
(vector-select! < v 0)))
|
||||
(test 3
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 0)))
|
||||
(test 9
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 2)))
|
||||
(test 22
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 8)))
|
||||
(test 23
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 9)))
|
||||
(test 19
|
||||
(let ((v (vector 19)))
|
||||
(vector-select! < v 0 0)))
|
||||
(test 3
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 0 0)))
|
||||
(test 9
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 2 0)))
|
||||
(test 22
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 8 0)))
|
||||
(test 23
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 9 0)))
|
||||
(test 19
|
||||
(let ((v (vector 19)))
|
||||
(vector-select! < v 0 0 1)))
|
||||
(test 3
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 0 0 10)))
|
||||
(test 9
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 2 0 10)))
|
||||
(test 22
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 8 0 10)))
|
||||
(test 23
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 9 0 10)))
|
||||
(test 3
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 0 4 10)))
|
||||
(test 13
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 2 4 10)))
|
||||
(test 21
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 4 4 10)))
|
||||
(test 23
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 5 4 10)))
|
||||
(test 3
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 0 4 10)))
|
||||
(test 13
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 2 4 10)))
|
||||
(test 13
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 3 4 10)))
|
||||
(test 21
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 4 4 10)))
|
||||
(test 23
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 5 4 10)))
|
||||
(test 9
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 0 4 8)))
|
||||
(test 13
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 1 4 8)))
|
||||
(test 13
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 2 4 8)))
|
||||
(test 21
|
||||
(let ((v (vector 8 22 19 19 13 9 21 13 3 23)))
|
||||
(vector-select! < v 3 4 8)))
|
||||
(test-end))))
|
||||
|
|
@ -287,7 +287,8 @@ sexp sexp_sort_x (sexp ctx, sexp self, sexp_sint_t n, sexp seq,
|
|||
sexp res;
|
||||
sexp_gc_var2(vec, scratch);
|
||||
|
||||
if (sexp_nullp(seq)) return seq;
|
||||
if (sexp_nullp(seq) || seq == sexp_global(ctx, SEXP_G_EMPTY_VECTOR))
|
||||
return seq;
|
||||
|
||||
sexp_gc_preserve2(ctx, vec, scratch);
|
||||
|
||||
|
|
@ -312,6 +313,8 @@ sexp sexp_sort_x (sexp ctx, sexp self, sexp_sint_t n, sexp seq,
|
|||
res = sexp_merge_sort_less(ctx, sexp_vector_data(vec),
|
||||
sexp_vector_data(scratch),
|
||||
0, len-1, less, key);
|
||||
if (!sexp_exceptionp(res))
|
||||
res = scratch;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue