1 /* Copyright (C) 1999, 2000, 2001, 2002, 2004, 2006, 2007, 2008, 2009,
2 * 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22 /* Written in December 1998 by Roland Orre <orre@nada.kth.se>
23 * This implements the same sort interface as slib/sort.scm
24 * for lists and vectors where slib defines:
25 * sorted?, merge, merge!, sort, sort!
26 * For scsh compatibility sort-list and sort-list! are also defined.
27 * In cases where a stable-sort is required use stable-sort or
28 * stable-sort!. An additional feature is
29 * (restricted-vector-sort! vector less? startpos endpos)
30 * which allows you to sort part of a vector.
31 * Thanks to Aubrey Jaffer for the slib/sort.scm library.
32 * Thanks to Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
33 * for the merge sort inspiration.
34 * Thanks to Douglas C. Schmidt (schmidt@ics.uci.edu) for the
42 #include "libguile/_scm.h"
43 #include "libguile/eval.h"
44 #include "libguile/arrays.h"
45 #include "libguile/array-map.h"
46 #include "libguile/feature.h"
47 #include "libguile/vectors.h"
48 #include "libguile/async.h"
49 #include "libguile/dynwind.h"
51 #include "libguile/validate.h"
52 #include "libguile/sort.h"
54 /* We have two quicksort variants: one for contigous vectors and one
55 for vectors with arbitrary increments between elements. Note that
56 increments can be negative.
59 #define NAME quicksort1
60 #define INC_PARAM /* empty */
62 #include "libguile/quicksort.i.c"
64 #define NAME quicksort
65 #define INC_PARAM ssize_t inc,
67 #include "libguile/quicksort.i.c"
70 SCM_DEFINE (scm_restricted_vector_sort_x
, "restricted-vector-sort!", 4, 0, 0,
71 (SCM vec
, SCM less
, SCM startpos
, SCM endpos
),
72 "Sort the vector @var{vec}, using @var{less} for comparing\n"
73 "the vector elements. @var{startpos} (inclusively) and\n"
74 "@var{endpos} (exclusively) delimit\n"
75 "the range of the vector which gets sorted. The return value\n"
77 #define FUNC_NAME s_scm_restricted_vector_sort_x
79 size_t vlen
, spos
, len
;
81 scm_t_array_handle handle
;
84 velts
= scm_vector_writable_elements (vec
, &handle
, &vlen
, &vinc
);
85 spos
= scm_to_unsigned_integer (startpos
, 0, vlen
);
86 len
= scm_to_unsigned_integer (endpos
, spos
, vlen
) - spos
;
89 quicksort1 (velts
+ spos
*vinc
, len
, less
);
91 quicksort (velts
+ spos
*vinc
, len
, vinc
, less
);
93 scm_array_handle_release (&handle
);
95 return SCM_UNSPECIFIED
;
100 /* (sorted? sequence less?)
101 * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
102 * such that for all 1 <= i <= m,
103 * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
104 SCM_DEFINE (scm_sorted_p
, "sorted?", 2, 0, 0,
105 (SCM items
, SCM less
),
106 "Return @code{#t} iff @var{items} is a list or vector such that, "
107 "for each element @var{x} and the next element @var{y} of "
108 "@var{items}, @code{(@var{less} @var{y} @var{x})} returns "
110 #define FUNC_NAME s_scm_sorted_p
112 long len
, j
; /* list/vector length, temp j */
113 SCM item
, rest
; /* rest of items loop variable */
115 if (SCM_NULL_OR_NIL_P (items
))
118 if (scm_is_pair (items
))
120 len
= scm_ilength (items
); /* also checks that it's a pure list */
121 SCM_ASSERT_RANGE (1, items
, len
>= 0);
125 item
= SCM_CAR (items
);
126 rest
= SCM_CDR (items
);
130 if (scm_is_true (scm_call_2 (less
, SCM_CAR (rest
), item
)))
134 item
= SCM_CAR (rest
);
135 rest
= SCM_CDR (rest
);
143 scm_t_array_handle handle
;
147 SCM result
= SCM_BOOL_T
;
149 elts
= scm_vector_elements (items
, &handle
, &len
, &inc
);
151 for (i
= 1; i
< len
; i
++, elts
+= inc
)
153 if (scm_is_true (scm_call_2 (less
, elts
[inc
], elts
[0])))
160 scm_array_handle_release (&handle
);
171 takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
172 and returns a new list in which the elements of a and b have been stably
173 interleaved so that (sorted? (merge a b less?) less?).
174 Note: this does _not_ accept vectors. */
175 SCM_DEFINE (scm_merge
, "merge", 3, 0, 0,
176 (SCM alist
, SCM blist
, SCM less
),
177 "Merge two already sorted lists into one.\n"
178 "Given two lists @var{alist} and @var{blist}, such that\n"
179 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
180 "return a new list in which the elements of @var{alist} and\n"
181 "@var{blist} have been stably interleaved so that\n"
182 "@code{(sorted? (merge alist blist less?) less?)}.\n"
183 "Note: this does _not_ accept vectors.")
184 #define FUNC_NAME s_scm_merge
188 if (SCM_NULL_OR_NIL_P (alist
))
190 else if (SCM_NULL_OR_NIL_P (blist
))
194 long alen
, blen
; /* list lengths */
197 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist
, alen
);
198 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist
, blen
);
199 if (scm_is_true (scm_call_2 (less
, SCM_CAR (blist
), SCM_CAR (alist
))))
201 build
= scm_cons (SCM_CAR (blist
), SCM_EOL
);
202 blist
= SCM_CDR (blist
);
207 build
= scm_cons (SCM_CAR (alist
), SCM_EOL
);
208 alist
= SCM_CDR (alist
);
212 while ((alen
> 0) && (blen
> 0))
215 if (scm_is_true (scm_call_2 (less
, SCM_CAR (blist
), SCM_CAR (alist
))))
217 SCM_SETCDR (last
, scm_cons (SCM_CAR (blist
), SCM_EOL
));
218 blist
= SCM_CDR (blist
);
223 SCM_SETCDR (last
, scm_cons (SCM_CAR (alist
), SCM_EOL
));
224 alist
= SCM_CDR (alist
);
227 last
= SCM_CDR (last
);
229 if ((alen
> 0) && (blen
== 0))
230 SCM_SETCDR (last
, alist
);
231 else if ((alen
== 0) && (blen
> 0))
232 SCM_SETCDR (last
, blist
);
240 scm_merge_list_x (SCM alist
, SCM blist
,
241 long alen
, long blen
,
246 if (SCM_NULL_OR_NIL_P (alist
))
248 else if (SCM_NULL_OR_NIL_P (blist
))
252 if (scm_is_true (scm_call_2 (less
, SCM_CAR (blist
), SCM_CAR (alist
))))
255 blist
= SCM_CDR (blist
);
261 alist
= SCM_CDR (alist
);
265 while ((alen
> 0) && (blen
> 0))
268 if (scm_is_true (scm_call_2 (less
, SCM_CAR (blist
), SCM_CAR (alist
))))
270 SCM_SETCDR (last
, blist
);
271 blist
= SCM_CDR (blist
);
276 SCM_SETCDR (last
, alist
);
277 alist
= SCM_CDR (alist
);
280 last
= SCM_CDR (last
);
282 if ((alen
> 0) && (blen
== 0))
283 SCM_SETCDR (last
, alist
);
284 else if ((alen
== 0) && (blen
> 0))
285 SCM_SETCDR (last
, blist
);
288 } /* scm_merge_list_x */
291 SCM_DEFINE (scm_merge_x
, "merge!", 3, 0, 0,
292 (SCM alist
, SCM blist
, SCM less
),
293 "Takes two lists @var{alist} and @var{blist} such that\n"
294 "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
295 "returns a new list in which the elements of @var{alist} and\n"
296 "@var{blist} have been stably interleaved so that\n"
297 " @code{(sorted? (merge alist blist less?) less?)}.\n"
298 "This is the destructive variant of @code{merge}\n"
299 "Note: this does _not_ accept vectors.")
300 #define FUNC_NAME s_scm_merge_x
302 if (SCM_NULL_OR_NIL_P (alist
))
304 else if (SCM_NULL_OR_NIL_P (blist
))
308 long alen
, blen
; /* list lengths */
309 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist
, alen
);
310 SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist
, blen
);
311 return scm_merge_list_x (alist
, blist
, alen
, blen
, less
);
317 /* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
318 The algorithm is stable. We also tried to use the algorithm used by
319 scsh's merge-sort but that algorithm showed to not be stable, even
320 though it claimed to be.
323 scm_merge_list_step (SCM
* seq
, SCM less
, long n
)
331 a
= scm_merge_list_step (seq
, less
, mid
);
332 b
= scm_merge_list_step (seq
, less
, n
- mid
);
333 return scm_merge_list_x (a
, b
, mid
, n
- mid
, less
);
338 SCM rest
= SCM_CDR (*seq
);
339 SCM x
= SCM_CAR (*seq
);
340 SCM y
= SCM_CAR (SCM_CDR (*seq
));
341 *seq
= SCM_CDR (rest
);
342 SCM_SETCDR (rest
, SCM_EOL
);
343 if (scm_is_true (scm_call_2 (less
, y
, x
)))
346 SCM_SETCAR (rest
, x
);
354 SCM_SETCDR (p
, SCM_EOL
);
359 } /* scm_merge_list_step */
362 SCM_DEFINE (scm_sort_x
, "sort!", 2, 0, 0,
363 (SCM items
, SCM less
),
364 "Sort the sequence @var{items}, which may be a list or a\n"
365 "vector. @var{less} is used for comparing the sequence\n"
366 "elements. The sorting is destructive, that means that the\n"
367 "input sequence is modified to produce the sorted result.\n"
368 "This is not a stable sort.")
369 #define FUNC_NAME s_scm_sort_x
371 long len
; /* list/vector length */
372 if (SCM_NULL_OR_NIL_P (items
))
375 if (scm_is_pair (items
))
377 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
378 return scm_merge_list_step (&items
, less
, len
);
380 else if (scm_is_array (items
) && scm_c_array_rank (items
) == 1)
382 scm_restricted_vector_sort_x (items
,
385 scm_array_length (items
));
389 SCM_WRONG_TYPE_ARG (1, items
);
394 SCM_DEFINE (scm_sort
, "sort", 2, 0, 0,
395 (SCM items
, SCM less
),
396 "Sort the sequence @var{items}, which may be a list or a\n"
397 "vector. @var{less} is used for comparing the sequence\n"
398 "elements. This is not a stable sort.")
399 #define FUNC_NAME s_scm_sort
401 if (SCM_NULL_OR_NIL_P (items
))
404 if (scm_is_pair (items
))
405 return scm_sort_x (scm_list_copy (items
), less
);
406 else if (scm_is_array (items
) && scm_c_array_rank (items
) == 1)
407 return scm_sort_x (scm_vector_copy (items
), less
);
409 SCM_WRONG_TYPE_ARG (1, items
);
415 scm_merge_vector_x (SCM
*vec
,
423 size_t it
; /* Index for temp vector */
424 size_t i1
= low
; /* Index for lower vector segment */
425 size_t i2
= mid
+ 1; /* Index for upper vector segment */
427 #define VEC(i) vec[(i)*inc]
429 /* Copy while both segments contain more characters */
430 for (it
= low
; (i1
<= mid
) && (i2
<= high
); ++it
)
432 if (scm_is_true (scm_call_2 (less
, VEC(i2
), VEC(i1
))))
433 temp
[it
] = VEC(i2
++);
435 temp
[it
] = VEC(i1
++);
439 /* Copy while first segment contains more characters */
441 temp
[it
++] = VEC(i1
++);
443 /* Copy while second segment contains more characters */
445 temp
[it
++] = VEC(i2
++);
447 /* Copy back from temp to vp */
448 for (it
= low
; it
<= high
; it
++)
451 } /* scm_merge_vector_x */
455 scm_merge_vector_step (SCM
*vec
,
464 size_t mid
= (low
+ high
) / 2;
466 scm_merge_vector_step (vec
, temp
, less
, low
, mid
, inc
);
467 scm_merge_vector_step (vec
, temp
, less
, mid
+1, high
, inc
);
468 scm_merge_vector_x (vec
, temp
, less
, low
, mid
, high
, inc
);
470 } /* scm_merge_vector_step */
473 SCM_DEFINE (scm_stable_sort_x
, "stable-sort!", 2, 0, 0,
474 (SCM items
, SCM less
),
475 "Sort the sequence @var{items}, which may be a list or a\n"
476 "vector. @var{less} is used for comparing the sequence elements.\n"
477 "The sorting is destructive, that means that the input sequence\n"
478 "is modified to produce the sorted result.\n"
479 "This is a stable sort.")
480 #define FUNC_NAME s_scm_stable_sort_x
482 long len
; /* list/vector length */
484 if (SCM_NULL_OR_NIL_P (items
))
487 if (scm_is_pair (items
))
489 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
490 return scm_merge_list_step (&items
, less
, len
);
492 else if (scm_is_array (items
) && 1 == scm_c_array_rank (items
))
494 scm_t_array_handle temp_handle
, vec_handle
;
495 SCM temp
, *temp_elts
, *vec_elts
;
499 vec_elts
= scm_vector_writable_elements (items
, &vec_handle
,
502 scm_array_handle_release (&vec_handle
);
506 temp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
507 temp_elts
= scm_vector_writable_elements (temp
, &temp_handle
,
510 scm_merge_vector_step (vec_elts
, temp_elts
, less
, 0, len
-1, inc
);
512 scm_array_handle_release (&temp_handle
);
513 scm_array_handle_release (&vec_handle
);
518 SCM_WRONG_TYPE_ARG (1, items
);
523 SCM_DEFINE (scm_stable_sort
, "stable-sort", 2, 0, 0,
524 (SCM items
, SCM less
),
525 "Sort the sequence @var{items}, which may be a list or a\n"
526 "vector. @var{less} is used for comparing the sequence elements.\n"
527 "This is a stable sort.")
528 #define FUNC_NAME s_scm_stable_sort
530 if (SCM_NULL_OR_NIL_P (items
))
533 if (scm_is_pair (items
))
534 return scm_stable_sort_x (scm_list_copy (items
), less
);
536 return scm_stable_sort_x (scm_vector_copy (items
), less
);
541 SCM_DEFINE (scm_sort_list_x
, "sort-list!", 2, 0, 0,
542 (SCM items
, SCM less
),
543 "Sort the list @var{items}, using @var{less} for comparing the\n"
544 "list elements. The sorting is destructive, that means that the\n"
545 "input list is modified to produce the sorted result.\n"
546 "This is a stable sort.")
547 #define FUNC_NAME s_scm_sort_list_x
551 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
552 return scm_merge_list_step (&items
, less
, len
);
557 SCM_DEFINE (scm_sort_list
, "sort-list", 2, 0, 0,
558 (SCM items
, SCM less
),
559 "Sort the list @var{items}, using @var{less} for comparing the\n"
560 "list elements. This is a stable sort.")
561 #define FUNC_NAME s_scm_sort_list
565 SCM_VALIDATE_LIST_COPYLEN (1, items
, len
);
566 items
= scm_list_copy (items
);
567 return scm_merge_list_step (&items
, less
, len
);
575 #include "libguile/sort.x"
577 scm_add_feature ("sort");