libguile/sort.c

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