mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
replacing quick sort in SRFI 95 with a stable merge sort
This commit is contained in:
Alex Shinn
parent
b93aa9cad9
commit
94067a1ffe
2 changed files with 102 additions and 70 deletions
|
|
@ -1,5 +1,5 @@
|
||||||
/* qsort.c -- quicksort implementation */
|
/* qsort.c -- object comparison & sort implementation */
|
||||||
/* Copyright (c) 2009-2011 Alex Shinn. All rights reserved. */
|
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
|
||||||
/* BSD-style license: http://synthcode.com/license.txt */
|
/* BSD-style license: http://synthcode.com/license.txt */
|
||||||
|
|
||||||
#include "chibi/eval.h"
|
#include "chibi/eval.h"
|
||||||
|
|
@ -174,83 +174,107 @@ 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 */
|
||||||
/* TODO: include another fast path when the key is a fixed offset */
|
/* TODO: include another fast path when the key is a fixed offset */
|
||||||
static void sexp_qsort (sexp ctx, sexp *vec, sexp_sint_t lo, sexp_sint_t hi) {
|
static void sexp_merge_sort (sexp ctx, sexp *vec, sexp *scratch, sexp_sint_t lo, sexp_sint_t hi) {
|
||||||
sexp_sint_t mid, i, j, diff;
|
sexp_sint_t mid, i, j, k;
|
||||||
sexp tmp, tmp2;
|
sexp tmp;
|
||||||
loop:
|
switch (hi - lo) {
|
||||||
if (lo < hi) {
|
case 0:
|
||||||
mid = lo + (hi-lo)/2;
|
scratch[lo] = vec[lo];
|
||||||
swap(tmp, vec[mid], vec[hi]);
|
break;
|
||||||
/* partition */
|
case 2:
|
||||||
for (i=j=lo; i < hi; i++) {
|
if (sexp_object_compare(ctx, vec[hi], vec[hi-1]) < 0)
|
||||||
diff = sexp_object_compare(ctx, vec[i], tmp);
|
swap(tmp, vec[hi], vec[hi-1]);
|
||||||
if (diff <= 0) {
|
/* ... FALLTHROUGH ... */
|
||||||
swap(tmp2, vec[i], vec[j]);
|
case 1:
|
||||||
j++;
|
if (sexp_object_compare(ctx, vec[lo+1], vec[lo]) < 0) {
|
||||||
|
swap(tmp, vec[lo+1], vec[lo]);
|
||||||
|
if (hi - lo > 1) {
|
||||||
|
if (sexp_object_compare(ctx, vec[lo+2], vec[lo+1]) < 0)
|
||||||
|
swap(tmp, vec[lo+2], vec[lo+1]);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
swap(tmp, vec[j], vec[hi]);
|
break;
|
||||||
/* recurse */
|
default: /* at least 4 elements */
|
||||||
sexp_qsort(ctx, vec, lo, j-1);
|
mid = (hi+lo)/2;
|
||||||
if (j < hi-1) {
|
sexp_merge_sort(ctx, vec, scratch, lo, mid);
|
||||||
lo = j;
|
sexp_merge_sort(ctx, vec, scratch, mid+1, hi);
|
||||||
goto loop; /* tail recurse on right side */
|
for (k=lo, i = lo, j = mid+1; k <= hi; ++k) {
|
||||||
|
if (i > mid) {
|
||||||
|
scratch[k] = vec[j++];
|
||||||
|
} else if (j > hi) {
|
||||||
|
scratch[k] = vec[i++];
|
||||||
|
} else {
|
||||||
|
if (sexp_object_compare(ctx, vec[j], vec[i]) < 0) {
|
||||||
|
scratch[k] = vec[j++];
|
||||||
|
} else {
|
||||||
|
scratch[k] = vec[i++];
|
||||||
|
}
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
memcpy(vec + lo, scratch + lo, (hi-lo+1) * sizeof(sexp));
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
static sexp sexp_qsort_less (sexp ctx, sexp *vec,
|
#define if_is_less(i, j) \
|
||||||
sexp_sint_t lo, sexp_sint_t hi,
|
a = (sexp_truep(key) ? (sexp_car(args1) = vec[i], sexp_apply(ctx, key, args1)) : vec[i]); \
|
||||||
sexp less, sexp key) {
|
if (sexp_exceptionp(a)) {res=a; goto done;} \
|
||||||
sexp_sint_t mid, i, j;
|
b = (sexp_truep(key) ? (sexp_car(args1) = vec[j], sexp_apply(ctx, key, args1)) : vec[j]); \
|
||||||
|
if (sexp_exceptionp(b)) {res=b; goto done;} \
|
||||||
|
sexp_car(args2) = a; \
|
||||||
|
sexp_car(args1) = b; \
|
||||||
|
res = sexp_apply(ctx, less, args2); \
|
||||||
|
if (sexp_exceptionp(res)) goto done; \
|
||||||
|
if (sexp_truep(res))
|
||||||
|
|
||||||
|
static sexp sexp_merge_sort_less (sexp ctx, sexp *vec, sexp *scratch,
|
||||||
|
sexp_sint_t lo, sexp_sint_t hi,
|
||||||
|
sexp less, sexp key) {
|
||||||
|
sexp_sint_t mid, i, j, k;
|
||||||
sexp args1;
|
sexp args1;
|
||||||
sexp_gc_var5(a, b, tmp, args2, res);
|
sexp_gc_var5(a, b, tmp, args2, res);
|
||||||
sexp_gc_preserve5(ctx, a, b, tmp, args2, res);
|
sexp_gc_preserve5(ctx, a, b, tmp, args2, res);
|
||||||
args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID);
|
args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID);
|
||||||
args1 = sexp_cdr(args2);
|
args1 = sexp_cdr(args2);
|
||||||
loop:
|
switch (hi - lo) {
|
||||||
if (lo >= hi) {
|
case 0:
|
||||||
res = SEXP_VOID;
|
res = SEXP_VOID;
|
||||||
} else {
|
scratch[lo] = vec[lo];
|
||||||
mid = lo + (hi-lo)/2;
|
break;
|
||||||
swap(tmp, vec[mid], vec[hi]);
|
case 2:
|
||||||
if (sexp_truep(key)) {
|
if_is_less (hi, hi-1)
|
||||||
sexp_car(args1) = tmp;
|
swap(tmp, vec[hi], vec[hi-1]);
|
||||||
b = sexp_apply(ctx, key, args1);
|
/* ... FALLTHROUGH ... */
|
||||||
} else {
|
case 1:
|
||||||
b = tmp;
|
if_is_less (lo+1, lo) {
|
||||||
}
|
swap(tmp, vec[lo+1], vec[lo]);
|
||||||
/* partition */
|
if (hi - lo > 1) {
|
||||||
for (i=j=lo; i < hi; i++) {
|
if_is_less (lo+2, lo+1)
|
||||||
if (sexp_truep(key)) {
|
swap(tmp, vec[lo+2], vec[lo+1]);
|
||||||
sexp_car(args1) = vec[i];
|
|
||||||
a = sexp_apply(ctx, key, args1);
|
|
||||||
} else {
|
|
||||||
a = vec[i];
|
|
||||||
}
|
|
||||||
sexp_car(args2) = b;
|
|
||||||
sexp_car(args1) = a;
|
|
||||||
res = sexp_apply(ctx, less, args2);
|
|
||||||
if (sexp_exceptionp(res)) {
|
|
||||||
goto done;
|
|
||||||
} else if (sexp_not(res)) {
|
|
||||||
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]);
|
break;
|
||||||
/* recurse */
|
default: /* at least 4 elements */
|
||||||
res = sexp_qsort_less(ctx, vec, lo, j-1, less, key);
|
mid = (hi+lo)/2;
|
||||||
|
res = sexp_merge_sort_less(ctx, vec, scratch, lo, mid, less, key);
|
||||||
if (sexp_exceptionp(res))
|
if (sexp_exceptionp(res))
|
||||||
goto done;
|
goto done;
|
||||||
if (j < hi-1) {
|
res = sexp_merge_sort_less(ctx, vec, scratch, mid+1, hi, less, key);
|
||||||
lo = j;
|
if (sexp_exceptionp(res))
|
||||||
goto loop; /* tail recurse on right side */
|
goto done;
|
||||||
|
for (k=lo, i = lo, j = mid+1; k <= hi; ++k) {
|
||||||
|
if (i > mid) {
|
||||||
|
scratch[k] = vec[j++];
|
||||||
|
} else if (j > hi) {
|
||||||
|
scratch[k] = vec[i++];
|
||||||
|
} else {
|
||||||
|
if_is_less (j, i) {
|
||||||
|
scratch[k] = vec[j++];
|
||||||
|
} else {
|
||||||
|
scratch[k] = vec[i++];
|
||||||
|
}
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
memcpy(vec + lo, scratch + lo, (hi-lo+1) * sizeof(sexp));
|
||||||
}
|
}
|
||||||
done:
|
done:
|
||||||
sexp_gc_release5(ctx);
|
sexp_gc_release5(ctx);
|
||||||
|
|
@ -260,22 +284,23 @@ static sexp sexp_qsort_less (sexp ctx, sexp *vec,
|
||||||
static sexp sexp_sort_x (sexp ctx, sexp self, sexp_sint_t n, sexp seq,
|
static sexp sexp_sort_x (sexp ctx, sexp self, sexp_sint_t n, sexp seq,
|
||||||
sexp less, sexp key) {
|
sexp less, sexp key) {
|
||||||
sexp_sint_t len;
|
sexp_sint_t len;
|
||||||
sexp res, *data;
|
sexp res;
|
||||||
sexp_gc_var1(vec);
|
sexp_gc_var2(vec, scratch);
|
||||||
|
|
||||||
if (sexp_nullp(seq)) return seq;
|
if (sexp_nullp(seq)) return seq;
|
||||||
|
|
||||||
sexp_gc_preserve1(ctx, vec);
|
sexp_gc_preserve2(ctx, vec, scratch);
|
||||||
|
|
||||||
vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq);
|
vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq);
|
||||||
|
|
||||||
if (! sexp_vectorp(vec)) {
|
if (! sexp_vectorp(vec)) {
|
||||||
res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec);
|
res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec);
|
||||||
} else {
|
} else {
|
||||||
data = sexp_vector_data(vec);
|
scratch = sexp_make_vector(ctx, sexp_make_fixnum(sexp_vector_length(vec)), SEXP_VOID);
|
||||||
len = sexp_vector_length(vec);
|
len = sexp_vector_length(vec);
|
||||||
if (sexp_not(key) && sexp_basic_comparator(less)) {
|
if (sexp_not(key) && sexp_basic_comparator(less)) {
|
||||||
sexp_qsort(ctx, data, 0, len-1);
|
sexp_merge_sort(ctx, sexp_vector_data(vec), sexp_vector_data(scratch),
|
||||||
|
0, len-1);
|
||||||
if (sexp_opcodep(less) && sexp_opcode_inverse(less))
|
if (sexp_opcodep(less) && sexp_opcode_inverse(less))
|
||||||
sexp_vector_nreverse(ctx, vec);
|
sexp_vector_nreverse(ctx, vec);
|
||||||
res = vec;
|
res = vec;
|
||||||
|
|
@ -284,15 +309,16 @@ static sexp sexp_sort_x (sexp ctx, sexp self, sexp_sint_t n, sexp seq,
|
||||||
} else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
|
} else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
|
||||||
res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key);
|
res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key);
|
||||||
} else {
|
} else {
|
||||||
res = sexp_qsort_less(ctx, data, 0, len-1, less, key);
|
res = sexp_merge_sort_less(ctx, sexp_vector_data(vec),
|
||||||
if (!sexp_exceptionp(res)) res = vec;
|
sexp_vector_data(scratch),
|
||||||
|
0, len-1, less, key);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
if (sexp_pairp(seq) && ! sexp_exceptionp(res))
|
if (sexp_pairp(seq) && ! sexp_exceptionp(res))
|
||||||
res = sexp_vector_copy_to_list(ctx, vec, seq);
|
res = sexp_vector_copy_to_list(ctx, vec, seq);
|
||||||
|
|
||||||
sexp_gc_release1(ctx);
|
sexp_gc_release2(ctx);
|
||||||
return res;
|
return res;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -125,4 +125,10 @@
|
||||||
(test "sort complex" '(3 3.14 355/113 22/7 3.14+0.0i 3.14+3.14i)
|
(test "sort complex" '(3 3.14 355/113 22/7 3.14+0.0i 3.14+3.14i)
|
||||||
(sort '(3.14+3.14i 355/113 3 22/7 3.14+0.0i 3.14)))
|
(sort '(3.14+3.14i 355/113 3 22/7 3.14+0.0i 3.14)))
|
||||||
|
|
||||||
|
(test "sort stable" '((0 2) (0 3) (0 4) (1 1) (1 2) (1 3) (2 1) (2 2))
|
||||||
|
(sort '((1 1) (0 2) (1 2) (2 1) (0 3) (2 2) (0 4) (1 3)) < car))
|
||||||
|
|
||||||
|
(test "sort stable complex" '(2i 3i 4i 1+i 1+2i 2+i 2+2i)
|
||||||
|
(sort '(1+i 2i 1+2i 2+i 3i 2+2i 4i) < real-part))
|
||||||
|
|
||||||
(test-end))))
|
(test-end))))
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue