guile18/libguile/sort.c

   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.
   6  *
   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.
  11  *
  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
  15  */
  16
  17
  18
  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
  32  * quicksort code.
  33  */
  34
  35 #ifdef HAVE_CONFIG_H
  36 # include <config.h>
  37 #endif
  38
  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"
  48
  49 #include "libguile/validate.h"
  50 #include "libguile/sort.h"
  51
  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.
  55 */
  56
  57 #define NAME        quicksort1
  58 #define INC_PARAM   /* empty */
  59 #define INC         1
  60 #include "libguile/quicksort.i.c"
  61
  62 #define NAME        quicksort
  63 #define INC_PARAM   ssize_t inc,
  64 #define INC         inc
  65 #include "libguile/quicksort.i.c"
  66
  67 static scm_t_trampoline_2
  68 compare_function (SCM less, unsigned int arg_nr, const char* fname)
  69 {
  70   const scm_t_trampoline_2 cmp = scm_trampoline_2 (less);
  71   SCM_ASSERT_TYPE (cmp != NULL, less, arg_nr, fname, "less predicate");
  72   return cmp;
  73 }
  74
  75
  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"
  82             "is not specified.")
  83 #define FUNC_NAME s_scm_restricted_vector_sort_x
  84 {
  85   const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
  86   size_t vlen, spos, len;
  87   ssize_t vinc;
  88   scm_t_array_handle handle;
  89   SCM *velts;
  90
  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;
  94
  95   if (vinc == 1)
  96     quicksort1 (velts + spos*vinc, len, cmp, less);
  97   else
  98     quicksort (velts + spos*vinc, len, vinc, cmp, less);
  99
 100   scm_array_handle_release (&handle);
 101
 102   return SCM_UNSPECIFIED;
 103 }
 104 #undef FUNC_NAME
 105
 106
 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
 117 {
 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 */
 121
 122   if (SCM_NULL_OR_NIL_P (items))
 123     return SCM_BOOL_T;
 124
 125   if (scm_is_pair (items))
 126     {
 127       len = scm_ilength (items); /* also checks that it's a pure list */
 128       SCM_ASSERT_RANGE (1, items, len >= 0);
 129       if (len <= 1)
 130         return SCM_BOOL_T;
 131
 132       item = SCM_CAR (items);
 133       rest = SCM_CDR (items);
 134       j = len - 1;
 135       while (j > 0)
 136         {
 137           if (scm_is_true ((*cmp) (less, SCM_CAR (rest), item)))
 138             return SCM_BOOL_F;
 139           else
 140             {
 141               item = SCM_CAR (rest);
 142               rest = SCM_CDR (rest);
 143               j--;
 144             }
 145         }
 146       return SCM_BOOL_T;
 147     }
 148   else
 149     {
 150       scm_t_array_handle handle;
 151       size_t i, len;
 152       ssize_t inc;
 153       const SCM *elts;
 154       SCM result = SCM_BOOL_T;
 155
 156       elts = scm_vector_elements (items, &handle, &len, &inc);
 157
 158       for (i = 1; i < len; i++, elts += inc)
 159         {
 160           if (scm_is_true ((*cmp) (less, elts[inc], elts[0])))
 161             {
 162               result = SCM_BOOL_F;
 163               break;
 164             }
 165         }
 166
 167       scm_array_handle_release (&handle);
 168
 169       return result;
 170     }
 171
 172   return SCM_BOOL_F;
 173 }
 174 #undef FUNC_NAME
 175
 176
 177 /* (merge a b less?)
 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
 192 {
 193   SCM build;
 194
 195   if (SCM_NULL_OR_NIL_P (alist))
 196     return blist;
 197   else if (SCM_NULL_OR_NIL_P (blist))
 198     return alist;
 199   else
 200     {
 201       const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
 202       long alen, blen;          /* list lengths */
 203       SCM last;
 204
 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))))
 208         {
 209           build = scm_cons (SCM_CAR (blist), SCM_EOL);
 210           blist = SCM_CDR (blist);
 211           blen--;
 212         }
 213       else
 214         {
 215           build = scm_cons (SCM_CAR (alist), SCM_EOL);
 216           alist = SCM_CDR (alist);
 217           alen--;
 218         }
 219       last = build;
 220       while ((alen > 0) && (blen > 0))
 221         {
 222           SCM_TICK;
 223           if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 224             {
 225               SCM_SETCDR (last, scm_cons (SCM_CAR (blist), SCM_EOL));
 226               blist = SCM_CDR (blist);
 227               blen--;
 228             }
 229           else
 230             {
 231               SCM_SETCDR (last, scm_cons (SCM_CAR (alist), SCM_EOL));
 232               alist = SCM_CDR (alist);
 233               alen--;
 234             }
 235           last = SCM_CDR (last);
 236         }
 237       if ((alen > 0) && (blen == 0))
 238         SCM_SETCDR (last, alist);
 239       else if ((alen == 0) && (blen > 0))
 240         SCM_SETCDR (last, blist);
 241     }
 242   return build;
 243 }
 244 #undef FUNC_NAME
 245
 246
 247 static SCM
 248 scm_merge_list_x (SCM alist, SCM blist,
 249                   long alen, long blen,
 250                   scm_t_trampoline_2 cmp, SCM less)
 251 {
 252   SCM build, last;
 253
 254   if (SCM_NULL_OR_NIL_P (alist))
 255     return blist;
 256   else if (SCM_NULL_OR_NIL_P (blist))
 257     return alist;
 258   else
 259     {
 260       if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 261         {
 262           build = blist;
 263           blist = SCM_CDR (blist);
 264           blen--;
 265         }
 266       else
 267         {
 268           build = alist;
 269           alist = SCM_CDR (alist);
 270           alen--;
 271         }
 272       last = build;
 273       while ((alen > 0) && (blen > 0))
 274         {
 275           SCM_TICK;
 276           if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 277             {
 278               SCM_SETCDR (last, blist);
 279               blist = SCM_CDR (blist);
 280               blen--;
 281             }
 282           else
 283             {
 284               SCM_SETCDR (last, alist);
 285               alist = SCM_CDR (alist);
 286               alen--;
 287             }
 288           last = SCM_CDR (last);
 289         }
 290       if ((alen > 0) && (blen == 0))
 291         SCM_SETCDR (last, alist);
 292       else if ((alen == 0) && (blen > 0))
 293         SCM_SETCDR (last, blist);
 294     }
 295   return build;
 296 }                               /* scm_merge_list_x */
 297
 298
 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
 309 {
 310   if (SCM_NULL_OR_NIL_P (alist))
 311     return blist;
 312   else if (SCM_NULL_OR_NIL_P (blist))
 313     return alist;
 314   else
 315     {
 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);
 321     }
 322 }
 323 #undef FUNC_NAME
 324
 325
 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.
 330 */
 331 static SCM
 332 scm_merge_list_step (SCM * seq, scm_t_trampoline_2 cmp, SCM less, long n)
 333 {
 334   SCM a, b;
 335
 336   if (n > 2)
 337     {
 338       long mid = n / 2;
 339       SCM_TICK;
 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);
 343     }
 344   else if (n == 2)
 345     {
 346       SCM p = *seq;
 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)))
 353         {
 354           SCM_SETCAR (p, y);
 355           SCM_SETCAR (rest, x);
 356         }
 357       return p;
 358     }
 359   else if (n == 1)
 360     {
 361       SCM p = *seq;
 362       *seq = SCM_CDR (p);
 363       SCM_SETCDR (p, SCM_EOL);
 364       return p;
 365     }
 366   else
 367     return SCM_EOL;
 368 }                               /* scm_merge_list_step */
 369
 370
 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
 379 {
 380   long len;                     /* list/vector length */
 381   if (SCM_NULL_OR_NIL_P (items))
 382     return items;
 383
 384   if (scm_is_pair (items))
 385     {
 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);
 389     }
 390   else if (scm_is_vector (items))
 391     {
 392       scm_restricted_vector_sort_x (items,
 393                                     less,
 394                                     scm_from_int (0),
 395                                     scm_vector_length (items));
 396       return items;
 397     }
 398   else
 399     SCM_WRONG_TYPE_ARG (1, items);
 400 }
 401 #undef FUNC_NAME
 402
 403
 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
 410 {
 411   if (SCM_NULL_OR_NIL_P (items))
 412     return items;
 413
 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);
 418   else
 419     SCM_WRONG_TYPE_ARG (1, items);
 420 }
 421 #undef FUNC_NAME
 422
 423
 424 static void
 425 scm_merge_vector_x (SCM *vec,
 426                     SCM *temp,
 427                     scm_t_trampoline_2 cmp,
 428                     SCM less,
 429                     size_t low,
 430                     size_t mid,
 431                     size_t high,
 432                     ssize_t inc)
 433 {
 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 */
 437
 438 #define VEC(i) vec[(i)*inc]
 439
 440   /* Copy while both segments contain more characters */
 441   for (it = low; (i1 <= mid) && (i2 <= high); ++it)
 442     {
 443       if (scm_is_true ((*cmp) (less, VEC(i2), VEC(i1))))
 444         temp[it] = VEC(i2++);
 445       else
 446         temp[it] = VEC(i1++);
 447     }
 448
 449   {
 450     /* Copy while first segment contains more characters */
 451     while (i1 <= mid)
 452       temp[it++] = VEC(i1++);
 453
 454     /* Copy while second segment contains more characters */
 455     while (i2 <= high)
 456       temp[it++] = VEC(i2++);
 457
 458     /* Copy back from temp to vp */
 459     for (it = low; it <= high; it++)
 460       VEC(it) = temp[it];
 461   }
 462 }                               /* scm_merge_vector_x */
 463
 464
 465 static void
 466 scm_merge_vector_step (SCM *vec,
 467                        SCM *temp,
 468                        scm_t_trampoline_2 cmp,
 469                        SCM less,
 470                        size_t low,
 471                        size_t high,
 472                        ssize_t inc)
 473 {
 474   if (high > low)
 475     {
 476       size_t mid = (low + high) / 2;
 477       SCM_TICK;
 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);
 481     }
 482 }                               /* scm_merge_vector_step */
 483
 484
 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
 493 {
 494   const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 495   long len;                     /* list/vector length */
 496
 497   if (SCM_NULL_OR_NIL_P (items))
 498     return items;
 499
 500   if (scm_is_pair (items))
 501     {
 502       SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 503       return scm_merge_list_step (&items, cmp, less, len);
 504     }
 505   else if (scm_is_vector (items))
 506     {
 507       scm_t_array_handle temp_handle, vec_handle;
 508       SCM temp, *temp_elts, *vec_elts;
 509       size_t len;
 510       ssize_t inc;
 511
 512       vec_elts = scm_vector_writable_elements (items, &vec_handle,
 513                                                &len, &inc);
 514       temp = scm_c_make_vector (len, SCM_UNDEFINED);
 515       temp_elts = scm_vector_writable_elements (temp, &temp_handle,
 516                                                 NULL, NULL);
 517
 518       scm_merge_vector_step (vec_elts, temp_elts, cmp, less, 0, len-1, inc);
 519
 520       scm_array_handle_release (&temp_handle);
 521       scm_array_handle_release (&vec_handle);
 522
 523       return items;
 524     }
 525   else
 526     SCM_WRONG_TYPE_ARG (1, items);
 527 }
 528 #undef FUNC_NAME
 529
 530
 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
 537 {
 538   if (SCM_NULL_OR_NIL_P (items))
 539     return SCM_EOL;
 540
 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);
 545   else
 546     SCM_WRONG_TYPE_ARG (1, items);
 547 }
 548 #undef FUNC_NAME
 549
 550
 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
 558 {
 559   const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 560   long len;
 561
 562   SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 563   return scm_merge_list_step (&items, cmp, less, len);
 564 }
 565 #undef FUNC_NAME
 566
 567
 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
 573 {
 574   const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 575   long len;
 576
 577   SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 578   items = scm_list_copy (items);
 579   return scm_merge_list_step (&items, cmp, less, len);
 580 }
 581 #undef FUNC_NAME
 582
 583
 584 void
 585 scm_init_sort ()
 586 {
 587 #include "libguile/sort.x"
 588
 589   scm_add_feature ("sort");
 590 }
 591
 592 /*
 593   Local Variables:
 594   c-file-style: "gnu"
 595   End:
 596 */