libguile/sort.c

   1 /* Copyright (C) 1999,2000,2001,2002, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 #include "libguile/_scm.h"
  36 #include "libguile/eval.h"
  37 #include "libguile/unif.h"
  38 #include "libguile/ramap.h"
  39 #include "libguile/feature.h"
  40 #include "libguile/vectors.h"
  41 #include "libguile/lang.h"
  42 #include "libguile/async.h"
  43 #include "libguile/dynwind.h"
  44
  45 #include "libguile/validate.h"
  46 #include "libguile/sort.h"
  47
  48 /* We have two quicksort variants: one for contigous vectors and one
  49    for vectors with arbitrary increments between elements.  Note that
  50    increments can be negative.
  51 */
  52
  53 #define NAME        quicksort1
  54 #define INC_PARAM   /* empty */
  55 #define INC         1
  56 #include "libguile/quicksort.i.c"
  57
  58 #define NAME        quicksort
  59 #define INC_PARAM   ssize_t inc,
  60 #define INC         inc
  61 #include "libguile/quicksort.i.c"
  62
  63 static scm_t_trampoline_2
  64 compare_function (SCM less, unsigned int arg_nr, const char* fname)
  65 {
  66   const scm_t_trampoline_2 cmp = scm_trampoline_2 (less);
  67   SCM_ASSERT_TYPE (cmp != NULL, less, arg_nr, fname, "less predicate");
  68   return cmp;
  69 }
  70
  71
  72 SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
  73             (SCM vec, SCM less, SCM startpos, SCM endpos),
  74             "Sort the vector @var{vec}, using @var{less} for comparing\n"
  75             "the vector elements.  @var{startpos} (inclusively) and\n"
  76             "@var{endpos} (exclusively) delimit\n"
  77             "the range of the vector which gets sorted.  The return value\n"
  78             "is not specified.")
  79 #define FUNC_NAME s_scm_restricted_vector_sort_x
  80 {
  81   const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
  82   size_t vlen, spos, len;
  83   ssize_t vinc;
  84   scm_t_array_handle handle;
  85   SCM *velts;
  86
  87   velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
  88   spos = scm_to_unsigned_integer (startpos, 0, vlen);
  89   len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
  90
  91   if (vinc == 1)
  92     quicksort1 (velts + spos*vinc, len, cmp, less);
  93   else
  94     quicksort (velts + spos*vinc, len, vinc, cmp, less);
  95
  96   return SCM_UNSPECIFIED;
  97 }
  98 #undef FUNC_NAME
  99
 100
 101 /* (sorted? sequence less?)
 102  * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
 103  * such that for all 1 <= i <= m,
 104  * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
 105 SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
 106             (SCM items, SCM less),
 107             "Return @code{#t} iff @var{items} is a list or a vector such that\n"
 108             "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
 109             "applied to all elements i - 1 and i")
 110 #define FUNC_NAME s_scm_sorted_p
 111 {
 112   const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 113   long len, j;                  /* list/vector length, temp j */
 114   SCM item, rest;               /* rest of items loop variable */
 115
 116   if (SCM_NULL_OR_NIL_P (items))
 117     return SCM_BOOL_T;
 118
 119   if (scm_is_pair (items))
 120     {
 121       len = scm_ilength (items); /* also checks that it's a pure list */
 122       SCM_ASSERT_RANGE (1, items, len >= 0);
 123       if (len <= 1)
 124         return SCM_BOOL_T;
 125
 126       item = SCM_CAR (items);
 127       rest = SCM_CDR (items);
 128       j = len - 1;
 129       while (j > 0)
 130         {
 131           if (scm_is_true ((*cmp) (less, SCM_CAR (rest), item)))
 132             return SCM_BOOL_F;
 133           else
 134             {
 135               item = SCM_CAR (rest);
 136               rest = SCM_CDR (rest);
 137               j--;
 138             }
 139         }
 140       return SCM_BOOL_T;
 141     }
 142   else
 143     {
 144       scm_t_array_handle handle;
 145       size_t i, len;
 146       ssize_t inc;
 147       const SCM *elts;
 148       SCM result = SCM_BOOL_T;
 149
 150       elts = scm_vector_elements (items, &handle, &len, &inc);
 151
 152       for (i = 1; i < len; i++, elts += inc)
 153         {
 154           if (scm_is_true ((*cmp) (less, elts[inc], elts[0])))
 155             {
 156               result = SCM_BOOL_F;
 157               break;
 158             }
 159         }
 160
 161       return result;
 162     }
 163
 164   return SCM_BOOL_F;
 165 }
 166 #undef FUNC_NAME
 167
 168
 169 /* (merge a b less?)
 170    takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
 171    and returns a new list in which the elements of a and b have been stably
 172    interleaved so that (sorted? (merge a b less?) less?).
 173    Note:  this does _not_ accept vectors. */
 174 SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
 175             (SCM alist, SCM blist, SCM less),
 176             "Merge two already sorted lists into one.\n"
 177             "Given two lists @var{alist} and @var{blist}, such that\n"
 178             "@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
 179             "return a new list in which the elements of @var{alist} and\n"
 180             "@var{blist} have been stably interleaved so that\n"
 181             "@code{(sorted? (merge alist blist less?) less?)}.\n"
 182             "Note:  this does _not_ accept vectors.")
 183 #define FUNC_NAME s_scm_merge
 184 {
 185   SCM build;
 186
 187   if (SCM_NULL_OR_NIL_P (alist))
 188     return blist;
 189   else if (SCM_NULL_OR_NIL_P (blist))
 190     return alist;
 191   else
 192     {
 193       const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
 194       long alen, blen;          /* list lengths */
 195       SCM last;
 196
 197       SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
 198       SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
 199       if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 200         {
 201           build = scm_cons (SCM_CAR (blist), SCM_EOL);
 202           blist = SCM_CDR (blist);
 203           blen--;
 204         }
 205       else
 206         {
 207           build = scm_cons (SCM_CAR (alist), SCM_EOL);
 208           alist = SCM_CDR (alist);
 209           alen--;
 210         }
 211       last = build;
 212       while ((alen > 0) && (blen > 0))
 213         {
 214           SCM_TICK;
 215           if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 216             {
 217               SCM_SETCDR (last, scm_cons (SCM_CAR (blist), SCM_EOL));
 218               blist = SCM_CDR (blist);
 219               blen--;
 220             }
 221           else
 222             {
 223               SCM_SETCDR (last, scm_cons (SCM_CAR (alist), SCM_EOL));
 224               alist = SCM_CDR (alist);
 225               alen--;
 226             }
 227           last = SCM_CDR (last);
 228         }
 229       if ((alen > 0) && (blen == 0))
 230         SCM_SETCDR (last, alist);
 231       else if ((alen == 0) && (blen > 0))
 232         SCM_SETCDR (last, blist);
 233     }
 234   return build;
 235 }
 236 #undef FUNC_NAME
 237
 238
 239 static SCM
 240 scm_merge_list_x (SCM alist, SCM blist,
 241                   long alen, long blen,
 242                   scm_t_trampoline_2 cmp, SCM less)
 243 {
 244   SCM build, last;
 245
 246   if (SCM_NULL_OR_NIL_P (alist))
 247     return blist;
 248   else if (SCM_NULL_OR_NIL_P (blist))
 249     return alist;
 250   else
 251     {
 252       if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 253         {
 254           build = blist;
 255           blist = SCM_CDR (blist);
 256           blen--;
 257         }
 258       else
 259         {
 260           build = alist;
 261           alist = SCM_CDR (alist);
 262           alen--;
 263         }
 264       last = build;
 265       while ((alen > 0) && (blen > 0))
 266         {
 267           SCM_TICK;
 268           if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
 269             {
 270               SCM_SETCDR (last, blist);
 271               blist = SCM_CDR (blist);
 272               blen--;
 273             }
 274           else
 275             {
 276               SCM_SETCDR (last, alist);
 277               alist = SCM_CDR (alist);
 278               alen--;
 279             }
 280           last = SCM_CDR (last);
 281         }
 282       if ((alen > 0) && (blen == 0))
 283         SCM_SETCDR (last, alist);
 284       else if ((alen == 0) && (blen > 0))
 285         SCM_SETCDR (last, blist);
 286     }
 287   return build;
 288 }                               /* scm_merge_list_x */
 289
 290
 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
 301 {
 302   if (SCM_NULL_OR_NIL_P (alist))
 303     return blist;
 304   else if (SCM_NULL_OR_NIL_P (blist))
 305     return alist;
 306   else
 307     {
 308       const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
 309       long alen, blen;          /* list lengths */
 310       SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
 311       SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
 312       return scm_merge_list_x (alist, blist, alen, blen, cmp, less);
 313     }
 314 }
 315 #undef FUNC_NAME
 316
 317
 318 /* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
 319    The algorithm is stable. We also tried to use the algorithm used by
 320    scsh's merge-sort but that algorithm showed to not be stable, even
 321    though it claimed to be.
 322 */
 323 static SCM
 324 scm_merge_list_step (SCM * seq, scm_t_trampoline_2 cmp, SCM less, long n)
 325 {
 326   SCM a, b;
 327
 328   if (n > 2)
 329     {
 330       long mid = n / 2;
 331       SCM_TICK;
 332       a = scm_merge_list_step (seq, cmp, less, mid);
 333       b = scm_merge_list_step (seq, cmp, less, n - mid);
 334       return scm_merge_list_x (a, b, mid, n - mid, cmp, less);
 335     }
 336   else if (n == 2)
 337     {
 338       SCM p = *seq;
 339       SCM rest = SCM_CDR (*seq);
 340       SCM x = SCM_CAR (*seq);
 341       SCM y = SCM_CAR (SCM_CDR (*seq));
 342       *seq = SCM_CDR (rest);
 343       SCM_SETCDR (rest, SCM_EOL);
 344       if (scm_is_true ((*cmp) (less, y, x)))
 345         {
 346           SCM_SETCAR (p, y);
 347           SCM_SETCAR (rest, x);
 348         }
 349       return p;
 350     }
 351   else if (n == 1)
 352     {
 353       SCM p = *seq;
 354       *seq = SCM_CDR (p);
 355       SCM_SETCDR (p, SCM_EOL);
 356       return p;
 357     }
 358   else
 359     return SCM_EOL;
 360 }                               /* scm_merge_list_step */
 361
 362
 363 SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
 364             (SCM items, SCM less),
 365             "Sort the sequence @var{items}, which may be a list or a\n"
 366             "vector.  @var{less} is used for comparing the sequence\n"
 367             "elements.  The sorting is destructive, that means that the\n"
 368             "input sequence is modified to produce the sorted result.\n"
 369             "This is not a stable sort.")
 370 #define FUNC_NAME s_scm_sort_x
 371 {
 372   long len;                     /* list/vector length */
 373   if (SCM_NULL_OR_NIL_P (items))
 374     return items;
 375
 376   if (scm_is_pair (items))
 377     {
 378       const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 379       SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 380       return scm_merge_list_step (&items, cmp, less, len);
 381     }
 382   else if (scm_is_vector (items))
 383     {
 384       scm_restricted_vector_sort_x (items,
 385                                     less,
 386                                     scm_from_int (0),
 387                                     scm_vector_length (items));
 388       return items;
 389     }
 390   else
 391     SCM_WRONG_TYPE_ARG (1, items);
 392 }
 393 #undef FUNC_NAME
 394
 395
 396 SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
 397             (SCM items, SCM less),
 398             "Sort the sequence @var{items}, which may be a list or a\n"
 399             "vector.  @var{less} is used for comparing the sequence\n"
 400             "elements.  This is not a stable sort.")
 401 #define FUNC_NAME s_scm_sort
 402 {
 403   if (SCM_NULL_OR_NIL_P (items))
 404     return items;
 405
 406   if (scm_is_pair (items))
 407     return scm_sort_x (scm_list_copy (items), less);
 408   else if (scm_is_vector (items))
 409     return scm_sort_x (scm_vector_copy (items), less);
 410   else
 411     SCM_WRONG_TYPE_ARG (1, items);
 412 }
 413 #undef FUNC_NAME
 414
 415
 416 static void
 417 scm_merge_vector_x (SCM *vec,
 418                     SCM *temp,
 419                     scm_t_trampoline_2 cmp,
 420                     SCM less,
 421                     size_t low,
 422                     size_t mid,
 423                     size_t high,
 424                     ssize_t inc)
 425 {
 426   size_t it;            /* Index for temp vector */
 427   size_t i1 = low;      /* Index for lower vector segment */
 428   size_t i2 = mid + 1;  /* Index for upper vector segment */
 429
 430 #define VEC(i) vec[(i)*inc]
 431
 432   /* Copy while both segments contain more characters */
 433   for (it = low; (i1 <= mid) && (i2 <= high); ++it)
 434     {
 435       if (scm_is_true ((*cmp) (less, VEC(i2), VEC(i1))))
 436         temp[it] = VEC(i2++);
 437       else
 438         temp[it] = VEC(i1++);
 439     }
 440
 441   {
 442     /* Copy while first segment contains more characters */
 443     while (i1 <= mid)
 444       temp[it++] = VEC(i1++);
 445
 446     /* Copy while second segment contains more characters */
 447     while (i2 <= high)
 448       temp[it++] = VEC(i2++);
 449
 450     /* Copy back from temp to vp */
 451     for (it = low; it <= high; it++)
 452       VEC(it) = temp[it];
 453   }
 454 }                               /* scm_merge_vector_x */
 455
 456
 457 static void
 458 scm_merge_vector_step (SCM *vec,
 459                        SCM *temp,
 460                        scm_t_trampoline_2 cmp,
 461                        SCM less,
 462                        size_t low,
 463                        size_t high,
 464                        ssize_t inc)
 465 {
 466   if (high > low)
 467     {
 468       size_t mid = (low + high) / 2;
 469       SCM_TICK;
 470       scm_merge_vector_step (vec, temp, cmp, less, low, mid, inc);
 471       scm_merge_vector_step (vec, temp, cmp, less, mid+1, high, inc);
 472       scm_merge_vector_x (vec, temp, cmp, less, low, mid, high, inc);
 473     }
 474 }                               /* scm_merge_vector_step */
 475
 476
 477 SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
 478             (SCM items, SCM less),
 479             "Sort the sequence @var{items}, which may be a list or a\n"
 480             "vector. @var{less} is used for comparing the sequence elements.\n"
 481             "The sorting is destructive, that means that the input sequence\n"
 482             "is modified to produce the sorted result.\n"
 483             "This is a stable sort.")
 484 #define FUNC_NAME s_scm_stable_sort_x
 485 {
 486   const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 487   long len;                     /* list/vector length */
 488
 489   if (SCM_NULL_OR_NIL_P (items))
 490     return items;
 491
 492   if (scm_is_pair (items))
 493     {
 494       SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 495       return scm_merge_list_step (&items, cmp, less, len);
 496     }
 497   else if (scm_is_vector (items))
 498     {
 499       scm_t_array_handle temp_handle, vec_handle;
 500       SCM temp, *temp_elts, *vec_elts;
 501       size_t len;
 502       ssize_t inc;
 503
 504       vec_elts = scm_vector_writable_elements (items, &vec_handle,
 505                                                &len, &inc);
 506       temp = scm_c_make_vector (len, SCM_UNDEFINED);
 507       temp_elts = scm_vector_writable_elements (temp, &temp_handle,
 508                                                 NULL, NULL);
 509
 510       scm_merge_vector_step (vec_elts, temp_elts, cmp, less, 0, len-1, inc);
 511
 512       return items;
 513     }
 514   else
 515     SCM_WRONG_TYPE_ARG (1, items);
 516 }
 517 #undef FUNC_NAME
 518
 519
 520 SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
 521             (SCM items, SCM less),
 522             "Sort the sequence @var{items}, which may be a list or a\n"
 523             "vector. @var{less} is used for comparing the sequence elements.\n"
 524             "This is a stable sort.")
 525 #define FUNC_NAME s_scm_stable_sort
 526 {
 527   if (scm_is_pair (items))
 528     return scm_stable_sort_x (scm_list_copy (items), less);
 529   else if (scm_is_vector (items))
 530     return scm_stable_sort_x (scm_vector_copy (items), less);
 531   else
 532     SCM_WRONG_TYPE_ARG (1, items);
 533 }
 534 #undef FUNC_NAME
 535
 536
 537 SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
 538             (SCM items, SCM less),
 539             "Sort the list @var{items}, using @var{less} for comparing the\n"
 540             "list elements. The sorting is destructive, that means that the\n"
 541             "input list is modified to produce the sorted result.\n"
 542             "This is a stable sort.")
 543 #define FUNC_NAME s_scm_sort_list_x
 544 {
 545   const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 546   long len;
 547
 548   SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 549   return scm_merge_list_step (&items, cmp, less, len);
 550 }
 551 #undef FUNC_NAME
 552
 553
 554 SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
 555             (SCM items, SCM less),
 556             "Sort the list @var{items}, using @var{less} for comparing the\n"
 557             "list elements. This is a stable sort.")
 558 #define FUNC_NAME s_scm_sort_list
 559 {
 560   const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
 561   long len;
 562
 563   SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 564   items = scm_list_copy (items);
 565   return scm_merge_list_step (&items, cmp, less, len);
 566 }
 567 #undef FUNC_NAME
 568
 569
 570 void
 571 scm_init_sort ()
 572 {
 573 #include "libguile/sort.x"
 574
 575   scm_add_feature ("sort");
 576 }
 577
 578 /*
 579   Local Variables:
 580   c-file-style: "gnu"
 581   End:
 582 */