1 /* Copyright (C) 1999,2000,2001,2002, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
2 * This library is free software; you can redistribute it and/or
3 * modify it under the terms of the GNU Lesser General Public
4 * License as published by the Free Software Foundation; either
5 * version 2.1 of the License, or (at your option) any later version.
7 * This library is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
10 * Lesser General Public License for more details.
12 * You should have received a copy of the GNU Lesser General Public
13 * License along with this library; if not, write to the Free Software
14 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 /* Written in December 1998 by Roland Orre <orre@nada.kth.se>
20 * This implements the same sort interface as slib/sort.scm
21 * for lists and vectors where slib defines:
22 * sorted?, merge, merge!, sort, sort!
23 * For scsh compatibility sort-list and sort-list! are also defined.
24 * In cases where a stable-sort is required use stable-sort or
25 * stable-sort!. An additional feature is
26 * (restricted-vector-sort! vector less? startpos endpos)
27 * which allows you to sort part of a vector.
28 * Thanks to Aubrey Jaffer for the slib/sort.scm library.
29 * Thanks to Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
30 * for the merge sort inspiration.
31 * Thanks to Douglas C. Schmidt (schmidt@ics.uci.edu) for the
39 #include "libguile/_scm.h"
40 #include "libguile/eval.h"
41 #include "libguile/unif.h"
42 #include "libguile/ramap.h"
43 #include "libguile/feature.h"
44 #include "libguile/vectors.h"
45 #include "libguile/lang.h"
46 #include "libguile/async.h"
47 #include "libguile/dynwind.h"
49 #include "libguile/validate.h"
50 #include "libguile/sort.h"
52 /* We have two quicksort variants: one for contigous vectors and one
53 for vectors with arbitrary increments between elements. Note that
54 increments can be negative.
57 #define NAME quicksort1
58 #define INC_PARAM /* empty */
60 #include "libguile/quicksort.i.c"
62 #define NAME quicksort
63 #define INC_PARAM ssize_t inc,
65 #include "libguile/quicksort.i.c"
67 static scm_t_trampoline_2
68 compare_function (SCM less
, unsigned int arg_nr
, const char* fname
)
70 const scm_t_trampoline_2 cmp
= scm_trampoline_2 (less
);
71 SCM_ASSERT_TYPE (cmp
!= NULL
, less
, arg_nr
, fname
, "less predicate");
76 SCM_DEFINE (scm_restricted_vector_sort_x
, "restricted-vector-sort!", 4, 0, 0,
77 (SCM vec
, SCM less
, SCM startpos
, SCM endpos
),
78 "Sort the vector @var{vec}, using @var{less} for comparing\n"
79 "the vector elements. @var{startpos} (inclusively) and\n"
80 "@var{endpos} (exclusively) delimit\n"
81 "the range of the vector which gets sorted. The return value\n"
83 #define FUNC_NAME s_scm_restricted_vector_sort_x
85 const scm_t_trampoline_2 cmp
= compare_function (less
, 2, FUNC_NAME
);
86 size_t vlen
, spos
, len
;
88 scm_t_array_handle handle
;
91 velts
= scm_vector_writable_elements (vec
, &handle
, &vlen
, &vinc
);
92 spos
= scm_to_unsigned_integer (startpos
, 0, vlen
);
93 len
= scm_to_unsigned_integer (endpos
, spos
, vlen
) - spos
;
96 quicksort1 (velts
+ spos
*vinc
, len
, cmp
, less
);
98 quicksort (velts
+ spos
*vinc
, len
, vinc
, cmp
, less
);
100 scm_array_handle_release (&handle
);
102 return SCM_UNSPECIFIED
;
107 /* (sorted? sequence less?)
108 * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
109 * such that for all 1 <= i <= m,
110 * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
111 SCM_DEFINE (scm_sorted_p
, "sorted?", 2, 0, 0,
112 (SCM items
, SCM less
),
113 "Return @code{#t} iff @var{items} is a list or a vector such that\n"
114 "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
115 "applied to all elements i - 1 and i")
116 #define FUNC_NAME s_scm_sorted_p
118 const scm_t_trampoline_2 cmp
= compare_function (less
, 2, FUNC_NAME
);
119 long len
, j
; /* list/vector length, temp j */
120 SCM item
, rest
; /* rest of items loop variable */
122 if (SCM_NULL_OR_NIL_P (items
))
125 if (scm_is_pair (items
))
127 len
= scm_ilength (items
); /* also checks that it's a pure list */
128 SCM_ASSERT_RANGE (1, items
, len
>= 0);
132 item
= SCM_CAR (items
);
133 rest
= SCM_CDR (items
);
137 if (scm_is_true ((*cmp
) (less
, SCM_CAR (rest
), item
)))
141 item
= SCM_CAR (rest
);
142 rest
= SCM_CDR (rest
);
150 scm_t_array_handle handle
;
154 SCM result
= SCM_BOOL_T
;
156 elts
= scm_vector_elements (items
, &handle
, &len
, &inc
);
158 for (i
= 1; i
< len
; i
++, elts
+= inc
)
160 if (scm_is_true ((*cmp
) (less
, elts
[inc
], elts
[0])))
167 scm_array_handle_release (&handle
);
178 takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
179 and returns a new list in which the elements of a and b have been stably
180 interleaved so that (sorted? (merge a b less?) less?).
181 Note: this does _not_ accept vectors. */
182 SCM_DEFINE (scm_merge
, "merge", 3, 0, 0,
183 (SCM alist
, SCM blist
, SCM less
),
184 "Merge two already sorted lists into one.\n"
185 "Given two lists @var{alist} and @var{blist}, such that\n"
186 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
187 "return a new list in which the elements of @var{alist} and\n"
188 "@var{blist} have been stably interleaved so that\n"
189 "@code{(sorted? (merge alist blist less?) less?)}.\n"
190 "Note: this does _not_ accept vectors.")
191 #define FUNC_NAME s_scm_merge
195 if (SCM_NULL_OR_NIL_P (alist
))
197 else if (SCM_NULL_OR_NIL_P (blist
))
201 const scm_t_trampoline_2 cmp
= compare_function (less
, 3, FUNC_NAME
);
202 long alen
, blen
; /* list lengths */
205 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist
, alen
);
206 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist
, blen
);
207 if (scm_is_true ((*cmp
) (less
, SCM_CAR (blist
), SCM_CAR (alist
))))
209 build
= scm_cons (SCM_CAR (blist
), SCM_EOL
);
210 blist
= SCM_CDR (blist
);
215 build
= scm_cons (SCM_CAR (alist
), SCM_EOL
);
216 alist
= SCM_CDR (alist
);
220 while ((alen
> 0) && (blen
> 0))
223 if (scm_is_true ((*cmp
) (less
, SCM_CAR (blist
), SCM_CAR (alist
))))
225 SCM_SETCDR (last
, scm_cons (SCM_CAR (blist
), SCM_EOL
));
226 blist
= SCM_CDR (blist
);
231 SCM_SETCDR (last
, scm_cons (SCM_CAR (alist
), SCM_EOL
));
232 alist
= SCM_CDR (alist
);
235 last
= SCM_CDR (last
);
237 if ((alen
> 0) && (blen
== 0))
238 SCM_SETCDR (last
, alist
);
239 else if ((alen
== 0) && (blen
> 0))
240 SCM_SETCDR (last
, blist
);
248 scm_merge_list_x (SCM alist
, SCM blist
,
249 long alen
, long blen
,
250 scm_t_trampoline_2 cmp
, SCM less
)
254 if (SCM_NULL_OR_NIL_P (alist
))
256 else if (SCM_NULL_OR_NIL_P (blist
))
260 if (scm_is_true ((*cmp
) (less
, SCM_CAR (blist
), SCM_CAR (alist
))))
263 blist
= SCM_CDR (blist
);
269 alist
= SCM_CDR (alist
);
273 while ((alen
> 0) && (blen
> 0))
276 if (scm_is_true ((*cmp
) (less
, SCM_CAR (blist
), SCM_CAR (alist
))))
278 SCM_SETCDR (last
, blist
);
279 blist
= SCM_CDR (blist
);
284 SCM_SETCDR (last
, alist
);
285 alist
= SCM_CDR (alist
);
288 last
= SCM_CDR (last
);
290 if ((alen
> 0) && (blen
== 0))
291 SCM_SETCDR (last
, alist
);
292 else if ((alen
== 0) && (blen
> 0))
293 SCM_SETCDR (last
, blist
);
296 } /* scm_merge_list_x */
299 SCM_DEFINE (scm_merge_x
, "merge!", 3, 0, 0,
300 (SCM alist
, SCM blist
, SCM less
),
301 "Takes two lists @var{alist} and @var{blist} such that\n"
302 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
303 "returns a new list in which the elements of @var{alist} and\n"
304 "@var{blist} have been stably interleaved so that\n"
305 " @code{(sorted? (merge alist blist less?) less?)}.\n"
306 "This is the destructive variant of @code{merge}\n"
307 "Note: this does _not_ accept vectors.")
308 #define FUNC_NAME s_scm_merge_x
310 if (SCM_NULL_OR_NIL_P (alist
))
312 else if (SCM_NULL_OR_NIL_P (blist
))
316 const scm_t_trampoline_2 cmp
= compare_function (less
, 3, FUNC_NAME
);
317 long alen
, blen
; /* list lengths */
318 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist
, alen
);
319 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist
, blen
);
320 return scm_merge_list_x (alist
, blist
, alen
, blen
, cmp
, less
);
326 /* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
327 The algorithm is stable. We also tried to use the algorithm used by
328 scsh's merge-sort but that algorithm showed to not be stable, even
329 though it claimed to be.
332 scm_merge_list_step (SCM
* seq
, scm_t_trampoline_2 cmp
, SCM less
, long n
)
340 a
= scm_merge_list_step (seq
, cmp
, less
, mid
);
341 b
= scm_merge_list_step (seq
, cmp
, less
, n
- mid
);
342 return scm_merge_list_x (a
, b
, mid
, n
- mid
, cmp
, less
);
347 SCM rest
= SCM_CDR (*seq
);
348 SCM x
= SCM_CAR (*seq
);
349 SCM y
= SCM_CAR (SCM_CDR (*seq
));
350 *seq
= SCM_CDR (rest
);
351 SCM_SETCDR (rest
, SCM_EOL
);
352 if (scm_is_true ((*cmp
) (less
, y
, x
)))
355 SCM_SETCAR (rest
, x
);
363 SCM_SETCDR (p
, SCM_EOL
);
368 } /* scm_merge_list_step */
371 SCM_DEFINE (scm_sort_x
, "sort!", 2, 0, 0,
372 (SCM items
, SCM less
),
373 "Sort the sequence @var{items}, which may be a list or a\n"
374 "vector. @var{less} is used for comparing the sequence\n"
375 "elements. The sorting is destructive, that means that the\n"
376 "input sequence is modified to produce the sorted result.\n"
377 "This is not a stable sort.")
378 #define FUNC_NAME s_scm_sort_x
380 long len
; /* list/vector length */
381 if (SCM_NULL_OR_NIL_P (items
))
384 if (scm_is_pair (items
))
386 const scm_t_trampoline_2 cmp
= compare_function (less
, 2, FUNC_NAME
);
387 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
388 return scm_merge_list_step (&items
, cmp
, less
, len
);
390 else if (scm_is_vector (items
))
392 scm_restricted_vector_sort_x (items
,
395 scm_vector_length (items
));
399 SCM_WRONG_TYPE_ARG (1, items
);
404 SCM_DEFINE (scm_sort
, "sort", 2, 0, 0,
405 (SCM items
, SCM less
),
406 "Sort the sequence @var{items}, which may be a list or a\n"
407 "vector. @var{less} is used for comparing the sequence\n"
408 "elements. This is not a stable sort.")
409 #define FUNC_NAME s_scm_sort
411 if (SCM_NULL_OR_NIL_P (items
))
414 if (scm_is_pair (items
))
415 return scm_sort_x (scm_list_copy (items
), less
);
416 else if (scm_is_vector (items
))
417 return scm_sort_x (scm_vector_copy (items
), less
);
419 SCM_WRONG_TYPE_ARG (1, items
);
425 scm_merge_vector_x (SCM
*vec
,
427 scm_t_trampoline_2 cmp
,
434 size_t it
; /* Index for temp vector */
435 size_t i1
= low
; /* Index for lower vector segment */
436 size_t i2
= mid
+ 1; /* Index for upper vector segment */
438 #define VEC(i) vec[(i)*inc]
440 /* Copy while both segments contain more characters */
441 for (it
= low
; (i1
<= mid
) && (i2
<= high
); ++it
)
443 if (scm_is_true ((*cmp
) (less
, VEC(i2
), VEC(i1
))))
444 temp
[it
] = VEC(i2
++);
446 temp
[it
] = VEC(i1
++);
450 /* Copy while first segment contains more characters */
452 temp
[it
++] = VEC(i1
++);
454 /* Copy while second segment contains more characters */
456 temp
[it
++] = VEC(i2
++);
458 /* Copy back from temp to vp */
459 for (it
= low
; it
<= high
; it
++)
462 } /* scm_merge_vector_x */
466 scm_merge_vector_step (SCM
*vec
,
468 scm_t_trampoline_2 cmp
,
476 size_t mid
= (low
+ high
) / 2;
478 scm_merge_vector_step (vec
, temp
, cmp
, less
, low
, mid
, inc
);
479 scm_merge_vector_step (vec
, temp
, cmp
, less
, mid
+1, high
, inc
);
480 scm_merge_vector_x (vec
, temp
, cmp
, less
, low
, mid
, high
, inc
);
482 } /* scm_merge_vector_step */
485 SCM_DEFINE (scm_stable_sort_x
, "stable-sort!", 2, 0, 0,
486 (SCM items
, SCM less
),
487 "Sort the sequence @var{items}, which may be a list or a\n"
488 "vector. @var{less} is used for comparing the sequence elements.\n"
489 "The sorting is destructive, that means that the input sequence\n"
490 "is modified to produce the sorted result.\n"
491 "This is a stable sort.")
492 #define FUNC_NAME s_scm_stable_sort_x
494 const scm_t_trampoline_2 cmp
= compare_function (less
, 2, FUNC_NAME
);
495 long len
; /* list/vector length */
497 if (SCM_NULL_OR_NIL_P (items
))
500 if (scm_is_pair (items
))
502 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
503 return scm_merge_list_step (&items
, cmp
, less
, len
);
505 else if (scm_is_vector (items
))
507 scm_t_array_handle temp_handle
, vec_handle
;
508 SCM temp
, *temp_elts
, *vec_elts
;
512 vec_elts
= scm_vector_writable_elements (items
, &vec_handle
,
514 temp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
515 temp_elts
= scm_vector_writable_elements (temp
, &temp_handle
,
518 scm_merge_vector_step (vec_elts
, temp_elts
, cmp
, less
, 0, len
-1, inc
);
520 scm_array_handle_release (&temp_handle
);
521 scm_array_handle_release (&vec_handle
);
526 SCM_WRONG_TYPE_ARG (1, items
);
531 SCM_DEFINE (scm_stable_sort
, "stable-sort", 2, 0, 0,
532 (SCM items
, SCM less
),
533 "Sort the sequence @var{items}, which may be a list or a\n"
534 "vector. @var{less} is used for comparing the sequence elements.\n"
535 "This is a stable sort.")
536 #define FUNC_NAME s_scm_stable_sort
538 if (SCM_NULL_OR_NIL_P (items
))
541 if (scm_is_pair (items
))
542 return scm_stable_sort_x (scm_list_copy (items
), less
);
543 else if (scm_is_vector (items
))
544 return scm_stable_sort_x (scm_vector_copy (items
), less
);
546 SCM_WRONG_TYPE_ARG (1, items
);
551 SCM_DEFINE (scm_sort_list_x
, "sort-list!", 2, 0, 0,
552 (SCM items
, SCM less
),
553 "Sort the list @var{items}, using @var{less} for comparing the\n"
554 "list elements. The sorting is destructive, that means that the\n"
555 "input list is modified to produce the sorted result.\n"
556 "This is a stable sort.")
557 #define FUNC_NAME s_scm_sort_list_x
559 const scm_t_trampoline_2 cmp
= compare_function (less
, 2, FUNC_NAME
);
562 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
563 return scm_merge_list_step (&items
, cmp
, less
, len
);
568 SCM_DEFINE (scm_sort_list
, "sort-list", 2, 0, 0,
569 (SCM items
, SCM less
),
570 "Sort the list @var{items}, using @var{less} for comparing the\n"
571 "list elements. This is a stable sort.")
572 #define FUNC_NAME s_scm_sort_list
574 const scm_t_trampoline_2 cmp
= compare_function (less
, 2, FUNC_NAME
);
577 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
578 items
= scm_list_copy (items
);
579 return scm_merge_list_step (&items
, cmp
, less
, len
);
587 #include "libguile/sort.x"
589 scm_add_feature ("sort");