libguile/sort.c

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