Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-11 06:57:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

fixing sorting with duplicates

Browse source
This commit is contained in:
Alex Shinn 2012-05-06 14:27:25 +09:00
parent 14e1cd482f
commit 8869320e63
2 changed files with 24 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
lib/srfi/95/qsort.c
View file

@ -122,16 +122,24 @@ static sexp sexp_object_compare_op (sexp ctx, sexp self, sexp_sint_t n, sexp a,
/* fast path when using general object-cmp comparator with no key */ /* fast path when using general object-cmp comparator with no key */
static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) { static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) {
sexp_sint_t mid, i, j; sexp_sint_t mid, i, j, diff;
sexp tmp, tmp2; sexp tmp, tmp2;
loop: loop:
if (lo < hi) { if (lo < hi) {
mid = lo + (hi-lo)/2; mid = lo + (hi-lo)/2;
swap(tmp, vec[mid], vec[hi]); swap(tmp, vec[mid], vec[hi]);
for (i=j=lo; i < hi; i++) /* partition */
if (sexp_object_compare(ctx, vec[i], tmp) < 0) for (i=j=lo; i < hi; i++) {
swap(tmp2, vec[i], vec[j]), j++; diff = sexp_object_compare(ctx, vec[i], tmp);
if (diff < 0) {
swap(tmp2, vec[i], vec[j]);
j++;
} else if (diff == 0) {
j++;
}
}
swap(tmp, vec[j], vec[hi]); swap(tmp, vec[j], vec[hi]);
/* recurse */
sexp_qsort(ctx, vec, lo, j-1); sexp_qsort(ctx, vec, lo, j-1);
if (j < hi-1) { if (j < hi-1) {
lo = j; lo = j;
@ -171,10 +179,16 @@ static sexp sexp_qsort_less (sexp ctx, sexp *vec,
sexp_car(args2) = a; sexp_car(args2) = a;
sexp_car(args1) = b; sexp_car(args1) = b;
res = sexp_apply(ctx, less, args2); res = sexp_apply(ctx, less, args2);
if (sexp_exceptionp(res)) if (sexp_exceptionp(res)) {
goto done; goto done;
else if (sexp_truep(res)) } else if (sexp_truep(res)) {
swap(res, vec[i], vec[j]), j++; swap(res, vec[i], vec[j]), j++;
} else {
sexp_car(args2) = b;
sexp_car(args1) = a;
res = sexp_apply(ctx, less, args2);
if (sexp_not(res)) j++; /* equal */
}
} }
swap(tmp, vec[j], vec[hi]); swap(tmp, vec[j], vec[hi]);
res = sexp_qsort_less(ctx, vec, lo, j-1, less, key); res = sexp_qsort_less(ctx, vec, lo, j-1, less, key);

4
tests/sort-tests.scm
View file

@ -8,11 +8,15 @@
(test "sort null" '() (sort '())) (test "sort null" '() (sort '()))
(test "sort null <" '() (sort '() <)) (test "sort null <" '() (sort '() <))
(test "sort null < car" '() (sort '() < car)) (test "sort null < car" '() (sort '() < car))
(test "sort equal list" '(0 0 0 0 0 0 0 0 0) (sort '(0 0 0 0 0 0 0 0 0)))
(test "sort equal list cmp" '(0 0 0 0 0 0 0 0 0)
(sort '(0 0 0 0 0 0 0 0 0) (lambda (a b) (< a b))))
(test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9))) (test "sort ordered list" '(1 2 3 4 5 6 7 8 9) (sort '(1 2 3 4 5 6 7 8 9)))
(test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1))) (test "sort reversed list" '(1 2 3 4 5 6 7 8 9) (sort '(9 8 7 6 5 4 3 2 1)))
(test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3))) (test "sort random list 1" '(1 2 3 4 5 6 7 8 9) (sort '(7 5 2 8 1 6 4 9 3)))
(test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2))) (test "sort random list 2" '(1 2 3 4 5 6 7 8) (sort '(5 3 4 1 7 6 8 2)))
(test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2))) (test "sort random list 3" '(1 2 3 4 5 6 7 8 9) (sort '(5 3 4 1 7 9 6 8 2)))
(test "sort short equal list" '(0 0 0) (sort '(0 0 0)))
(test "sort short random list" '(1 2 3) (sort '(2 1 3))) (test "sort short random list" '(1 2 3) (sort '(2 1 3)))
(test "sort short random list cmp" '(1 2 3) (sort '(2 1 3) (lambda (a b) (< a b)))) (test "sort short random list cmp" '(1 2 3) (sort '(2 1 3) (lambda (a b) (< a b))))
(test "sort numeric list <" '(1 2 3 4 5 6 7 8 9) (test "sort numeric list <" '(1 2 3 4 5 6 7 8 9)