/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- Scm_Compare
- shift_up
- sort_h
- sort_q
- cmp_scm
- cmp_int
- Scm_SortArray
- sort_list_int
- Scm_SortList
- 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 }