libguile/sort.c

   1 /* Copyright (C) 1999, 2000, 2001, 2002, 2004, 2006, 2007, 2008, 2009,
   2  *   2010, 2011, 2012, 2014 Free Software Foundation, Inc.
   3  *
   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.
   8  *
   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.
  13  *
  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
  17  * 02110-1301 USA
  18  */
  19
  20
  21
  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
  35  * quicksort code.
  36  */
  37
  38 #ifdef HAVE_CONFIG_H
  39 # include <config.h>
  40 #endif
  41
  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"
  50
  51 #include "libguile/validate.h"
  52 #include "libguile/sort.h"
  53
  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.
  57 */
  58
  59 #define NAME        quicksort1
  60 #define INC_PARAM   /* empty */
  61 #define INC         1
  62 #include "libguile/quicksort.i.c"
  63
  64 #define NAME        quicksort
  65 #define INC_PARAM   ssize_t inc,
  66 #define INC         inc
  67 #include "libguile/quicksort.i.c"
  68
  69
  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"
  76             "is not specified.")
  77 #define FUNC_NAME s_scm_restricted_vector_sort_x
  78 {
  79   size_t vlen, spos, len;
  80   ssize_t vinc;
  81   scm_t_array_handle handle;
  82   SCM *velts;
  83
  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;
  87
  88   if (vinc == 1)
  89     quicksort1 (velts + spos*vinc, len, less);
  90   else
  91     quicksort (velts + spos*vinc, len, vinc, less);
  92
  93   scm_array_handle_release (&handle);
  94
  95   return SCM_UNSPECIFIED;
  96 }
  97 #undef FUNC_NAME
  98
  99
 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 "
 109             "@code{#f}.")
 110 #define FUNC_NAME s_scm_sorted_p
 111 {
 112   long len, j;                  /* list/vector length, temp j */
 113   SCM item, rest;               /* rest of items loop variable */
 114
 115   if (SCM_NULL_OR_NIL_P (items))
 116     return SCM_BOOL_T;
 117
 118   if (scm_is_pair (items))
 119     {
 120       len = scm_ilength (items); /* also checks that it's a pure list */
 121       SCM_ASSERT_RANGE (1, items, len >= 0);
 122       if (len <= 1)
 123         return SCM_BOOL_T;
 124
 125       item = SCM_CAR (items);
 126       rest = SCM_CDR (items);
 127       j = len - 1;
 128       while (j > 0)
 129         {
 130           if (scm_is_true (scm_call_2 (less, SCM_CAR (rest), item)))
 131             return SCM_BOOL_F;
 132           else
 133             {
 134               item = SCM_CAR (rest);
 135               rest = SCM_CDR (rest);
 136               j--;
 137             }
 138         }
 139       return SCM_BOOL_T;
 140     }
 141   else
 142     {
 143       scm_t_array_handle handle;
 144       size_t i, len;
 145       ssize_t inc;
 146       const SCM *elts;
 147       SCM result = SCM_BOOL_T;
 148
 149       elts = scm_vector_elements (items, &handle, &len, &inc);
 150
 151       for (i = 1; i < len; i++, elts += inc)
 152         {
 153           if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
 154             {
 155               result = SCM_BOOL_F;
 156               break;
 157             }
 158         }
 159
 160       scm_array_handle_release (&handle);
 161
 162       return result;
 163     }
 164
 165   return SCM_BOOL_F;
 166 }
 167 #undef FUNC_NAME
 168
 169
 170 /* (merge a b less?)
 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
 185 {
 186   SCM build;
 187
 188   if (SCM_NULL_OR_NIL_P (alist))
 189     return blist;
 190   else if (SCM_NULL_OR_NIL_P (blist))
 191     return alist;
 192   else
 193     {
 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 (scm_call_2 (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 (scm_call_2 (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 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 (scm_call_2 (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 (scm_call_2 (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       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);
 312     }
 313 }
 314 #undef FUNC_NAME
 315
 316
 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.
 321 */
 322 static SCM
 323 scm_merge_list_step (SCM * seq, SCM less, long n)
 324 {
 325   SCM a, b;
 326
 327   if (n > 2)
 328     {
 329       long mid = n / 2;
 330       SCM_TICK;
 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);
 334     }
 335   else if (n == 2)
 336     {
 337       SCM p = *seq;
 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)))
 344         {
 345           SCM_SETCAR (p, y);
 346           SCM_SETCAR (rest, x);
 347         }
 348       return p;
 349     }
 350   else if (n == 1)
 351     {
 352       SCM p = *seq;
 353       *seq = SCM_CDR (p);
 354       SCM_SETCDR (p, SCM_EOL);
 355       return p;
 356     }
 357   else
 358     return SCM_EOL;
 359 }                               /* scm_merge_list_step */
 360
 361
 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
 370 {
 371   long len;                     /* list/vector length */
 372   if (SCM_NULL_OR_NIL_P (items))
 373     return items;
 374
 375   if (scm_is_pair (items))
 376     {
 377       SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 378       return scm_merge_list_step (&items, less, len);
 379     }
 380   else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
 381     {
 382       scm_restricted_vector_sort_x (items,
 383                                     less,
 384                                     scm_from_int (0),
 385                                     scm_array_length (items));
 386       return items;
 387     }
 388   else
 389     SCM_WRONG_TYPE_ARG (1, items);
 390 }
 391 #undef FUNC_NAME
 392
 393
 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
 400 {
 401   if (SCM_NULL_OR_NIL_P (items))
 402     return items;
 403
 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);
 408   else
 409     SCM_WRONG_TYPE_ARG (1, items);
 410 }
 411 #undef FUNC_NAME
 412
 413
 414 static void
 415 scm_merge_vector_x (SCM *vec,
 416                     SCM *temp,
 417                     SCM less,
 418                     size_t low,
 419                     size_t mid,
 420                     size_t high,
 421                     ssize_t inc)
 422 {
 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 */
 426
 427 #define VEC(i) vec[(i)*inc]
 428
 429   /* Copy while both segments contain more characters */
 430   for (it = low; (i1 <= mid) && (i2 <= high); ++it)
 431     {
 432       if (scm_is_true (scm_call_2 (less, VEC(i2), VEC(i1))))
 433         temp[it] = VEC(i2++);
 434       else
 435         temp[it] = VEC(i1++);
 436     }
 437
 438   {
 439     /* Copy while first segment contains more characters */
 440     while (i1 <= mid)
 441       temp[it++] = VEC(i1++);
 442
 443     /* Copy while second segment contains more characters */
 444     while (i2 <= high)
 445       temp[it++] = VEC(i2++);
 446
 447     /* Copy back from temp to vp */
 448     for (it = low; it <= high; it++)
 449       VEC(it) = temp[it];
 450   }
 451 }                               /* scm_merge_vector_x */
 452
 453
 454 static void
 455 scm_merge_vector_step (SCM *vec,
 456                        SCM *temp,
 457                        SCM less,
 458                        size_t low,
 459                        size_t high,
 460                        ssize_t inc)
 461 {
 462   if (high > low)
 463     {
 464       size_t mid = (low + high) / 2;
 465       SCM_TICK;
 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);
 469     }
 470 }                               /* scm_merge_vector_step */
 471
 472
 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
 481 {
 482   long len;                     /* list/vector length */
 483
 484   if (SCM_NULL_OR_NIL_P (items))
 485     return items;
 486
 487   if (scm_is_pair (items))
 488     {
 489       SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 490       return scm_merge_list_step (&items, less, len);
 491     }
 492   else if (scm_is_array (items) && 1 == scm_c_array_rank (items))
 493     {
 494       scm_t_array_handle temp_handle, vec_handle;
 495       SCM temp, *temp_elts, *vec_elts;
 496       size_t len;
 497       ssize_t inc;
 498
 499       vec_elts = scm_vector_writable_elements (items, &vec_handle,
 500                                                &len, &inc);
 501       if (len == 0) {
 502         scm_array_handle_release (&vec_handle);
 503         return items;
 504       }
 505
 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, less, 0, len-1, inc);
 511
 512       scm_array_handle_release (&temp_handle);
 513       scm_array_handle_release (&vec_handle);
 514
 515       return items;
 516     }
 517   else
 518     SCM_WRONG_TYPE_ARG (1, items);
 519 }
 520 #undef FUNC_NAME
 521
 522
 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
 529 {
 530   if (SCM_NULL_OR_NIL_P (items))
 531     return SCM_EOL;
 532
 533   if (scm_is_pair (items))
 534     return scm_stable_sort_x (scm_list_copy (items), less);
 535   else
 536     return scm_stable_sort_x (scm_vector_copy (items), less);
 537 }
 538 #undef FUNC_NAME
 539
 540
 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
 548 {
 549   long len;
 550
 551   SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 552   return scm_merge_list_step (&items, less, len);
 553 }
 554 #undef FUNC_NAME
 555
 556
 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
 562 {
 563   long len;
 564
 565   SCM_VALIDATE_LIST_COPYLEN (1, items, len);
 566   items = scm_list_copy (items);
 567   return scm_merge_list_step (&items, less, len);
 568 }
 569 #undef FUNC_NAME
 570
 571
 572 void
 573 scm_init_sort ()
 574 {
 575 #include "libguile/sort.x"
 576
 577   scm_add_feature ("sort");
 578 }
 579
 580 /*
 581   Local Variables:
 582   c-file-style: "gnu"
 583   End:
 584 */