libguile/sort.c

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