libguile/sort.c

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