root/src/compare.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. Scm_Compare
  2. shift_up
  3. sort_h
  4. sort_q
  5. cmp_scm
  6. cmp_int
  7. Scm_SortArray
  8. sort_list_int
  9. Scm_SortList
  10. Scm_SortListX

   1 /*
   2  * compare.c - comparison & sort
   3  *
   4  *   Copyright (c) 2000-2003 Shiro Kawai, All rights reserved.
   5  * 
   6  *   Redistribution and use in source and binary forms, with or without
   7  *   modification, are permitted provided that the following conditions
   8  *   are met:
   9  * 
  10  *   1. Redistributions of source code must retain the above copyright
  11  *      notice, this list of conditions and the following disclaimer.
  12  *
  13  *   2. Redistributions in binary form must reproduce the above copyright
  14  *      notice, this list of conditions and the following disclaimer in the
  15  *      documentation and/or other materials provided with the distribution.
  16  *
  17  *   3. Neither the name of the authors nor the names of its contributors
  18  *      may be used to endorse or promote products derived from this
  19  *      software without specific prior written permission.
  20  *
  21  *   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  22  *   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  23  *   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  24  *   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  25  *   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  26  *   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  27  *   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  28  *   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  29  *   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  30  *   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  31  *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32  *
  33  *  $Id: compare.c,v 1.12 2003/10/03 10:55:50 shirok Exp $
  34  */
  35 
  36 #include <stdlib.h>
  37 #define LIBGAUCHE_BODY
  38 #include "gauche.h"
  39 
  40 /*
  41  * Compare.
  42  */
  43 
  44 int Scm_Compare(ScmObj x, ScmObj y)
  45 {
  46     ScmClass *cx, *cy;
  47 
  48     /* Shortcut for typical case */
  49     if (SCM_NUMBERP(x) && SCM_NUMBERP(y))
  50         return Scm_NumCmp(x, y);
  51     if (SCM_STRINGP(x) && SCM_STRINGP(y))
  52         return Scm_StringCmp(SCM_STRING(x), SCM_STRING(y));
  53     if (SCM_CHARP(x) && SCM_CHARP(y))
  54         return SCM_CHAR_VALUE(x) == SCM_CHAR_VALUE(y)? 0 :
  55             SCM_CHAR_VALUE(x) < SCM_CHAR_VALUE(y)? -1 : 1;
  56 
  57     cx = Scm_ClassOf(x);
  58     cy = Scm_ClassOf(y);
  59     if (Scm_SubtypeP(cx, cy)) {
  60         if (cy->compare) return cy->compare(x, y, FALSE);
  61     } else {
  62         if (cx->compare) return cx->compare(x, y, FALSE);
  63     }
  64     Scm_Error("can't compare %S and %S", x, y);
  65     return 0; /* dummy */
  66 }
  67 
  68 /* NB: It turns out that calling back Scheme funtion from sort routine
  69    is very inefficient and runs much slower than Scheme version, if
  70    a Scheme comarison function is given.
  71    So, as of 0.7.2, the C function is only used when a comparison
  72    function is omitted. */
  73 
  74 /*
  75  * Basic function for sort family.  An array pointed by elts will be
  76  * destructively sorted.  Cmpfn can be either an applicable Scheme
  77  * object or #f.  If it's an applicable object, two arguments x and y
  78  * will be passed to it, and it must return an integer or a boolean
  79  * value, such that:
  80  *
  81  *  if (x < y), it may return a negative integer or #t.
  82  *  if (x == y), it may return 0 or #f.
  83  *  if (x > y), it may return a positive integer or #f.
  84  *
  85  * If cmpfn is #f, the first object's default compare method is used.
  86  *
  87  * Some notes:
  88  *  - We can't use libc's qsort, since it doesn't pass closure to cmpfn.
  89  *  - The naive Quicksort behaves too badly in the worst case.
  90  *  - The comparison operation is far more costly than exchange.
  91  *
  92  * The current implementation is hybrid of Quicksort and Heapsort.  First
  93  * the algorithm proceeds by Quicksort, but when it detects the recursion
  94  * is too deep, it switches to Heapsort.  See Knuth, The Art of Computer
  95  * Programming Second Edition, Section 5.2.2, p.122.
  96  */
  97 
  98 /* Heap sort */
  99 static inline void shift_up(ScmObj *elts, int root, int nelts,
 100                             int (*cmp)(ScmObj, ScmObj, ScmObj), ScmObj data)
 101 {
 102     int l = root+1, maxchild;
 103     while (l*2 <= nelts) {
 104         if (l*2 == nelts) {
 105             maxchild = nelts-1;
 106         } else if (cmp(elts[l*2-1], elts[l*2], data) < 0) {
 107             maxchild = l*2;
 108         } else {
 109             maxchild = l*2-1;
 110         }
 111         if (cmp(elts[l-1], elts[maxchild], data) < 0) {
 112             ScmObj tmp = elts[maxchild];
 113             elts[maxchild] = elts[l-1];
 114             elts[l-1] = tmp;
 115             l = maxchild+1;
 116         } else {
 117             break;
 118         }
 119     }
 120 }
 121 
 122 static void sort_h(ScmObj *elts, int nelts,
 123                    int (*cmp)(ScmObj, ScmObj, ScmObj), ScmObj data)
 124 {
 125     int l, r;
 126     for (l=nelts/2-1; l>=0; l--) {
 127         shift_up(elts, l, nelts, cmp, data);
 128     }
 129     for (r=nelts-1; r>=1; r--) {
 130         ScmObj tmp = elts[r];
 131         elts[r] = elts[0];
 132         elts[0] = tmp;
 133         shift_up(elts, 0, r, cmp, data);
 134     }
 135 }
 136 
 137 /* Quick sort */
 138 static void sort_q(ScmObj *elts, int lo, int hi, int depth, int limit,
 139                    int (*cmp)(ScmObj, ScmObj, ScmObj), ScmObj data)
 140 {
 141     while (lo < hi) {
 142         if (depth >= limit) {
 143             sort_h(elts+lo, (hi-lo+1), cmp, data);
 144             break;
 145         } else {
 146             int l = lo, r = hi;
 147             ScmObj pivot = elts[lo], tmp;
 148             while (l <= r) {
 149                 while (l <= r && cmp(elts[l], pivot, data) < 0) l++;
 150                 while (l <= r && cmp(pivot, elts[r], data) < 0) r--;
 151                 if (l > r) break;
 152                 tmp = elts[l]; elts[l] = elts[r]; elts[r] = tmp;
 153                 l++;
 154                 r--;
 155             }
 156             if (lo < r) sort_q(elts, lo, r, depth+1, limit, cmp, data);
 157             /* tail call to
 158                sort_q(elts, l, hi, depth+1, limit, cmp, data); */
 159             lo = l;
 160             depth++;
 161         }
 162     }
 163 }
 164 
 165 static int cmp_scm(ScmObj x, ScmObj y, ScmObj fn)
 166 {
 167     ScmObj r = Scm_Apply(fn, SCM_LIST2(x, y));
 168     if (SCM_TRUEP(r) || (SCM_INTP(r) && SCM_INT_VALUE(r) < 0))
 169         return -1;
 170     else
 171         return 1;
 172 }
 173 
 174 static int cmp_int(ScmObj x, ScmObj y, ScmObj dummy)
 175 {
 176     return Scm_Compare(x, y);
 177 }
 178 
 179 void Scm_SortArray(ScmObj *elts, int nelts, ScmObj cmpfn)
 180 {
 181     int limit, i;
 182     if (nelts <= 1) return;
 183     /* approximate 2*log2(nelts) */
 184     for (i=nelts,limit=1; i > 0; limit++) {i>>=1;}
 185     if (SCM_PROCEDUREP(cmpfn)) {
 186         sort_q(elts, 0, nelts-1, 0, limit, cmp_scm, cmpfn);
 187     } else {
 188         sort_q(elts, 0, nelts-1, 0, limit, cmp_int, NULL);
 189     }
 190 }
 191 
 192 /*
 193  * higher-level fns
 194  */
 195 
 196 #define STATIC_SIZE 32
 197 
 198 static ScmObj sort_list_int(ScmObj objs, ScmObj fn, int destructive)
 199 {
 200     ScmObj cp;
 201     ScmObj starray[STATIC_SIZE], *array;
 202     int len = STATIC_SIZE, i;
 203     array = Scm_ListToArray(objs, &len, starray, TRUE);
 204     Scm_SortArray(array, len, fn);
 205     if (destructive) {
 206         for (i=0, cp=objs; i<len; i++, cp = SCM_CDR(cp)) {
 207             SCM_SET_CAR(cp, array[i]);
 208         }
 209         return objs;
 210     } else {
 211         return Scm_ArrayToList(array, len);
 212     }
 213 }
 214 
 215 ScmObj Scm_SortList(ScmObj objs, ScmObj fn)
 216 {
 217     return sort_list_int(objs, fn, FALSE);
 218 }
 219 
 220 ScmObj Scm_SortListX(ScmObj objs, ScmObj fn)
 221 {
 222     return sort_list_int(objs, fn, TRUE);
 223 }

/* [<][>][^][v][top][bottom][index][help] */