1: /*
    2:  * compare.c - comparison & sort
    3:  *
    4:  *   Copyright (c) 2000-2007  Shiro Kawai  <shiro@acm.org>
    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.14 2007/03/02 07:39:13 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_ApplyRec(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: }