source: project/chicken/branches/prerelease/data-structures.scm @ 15920

Last change on this file since 15920 was 15920, checked in by Ivan Raikov, 10 years ago

including topological-sort in the prerelease branch

File size: 28.2 KB
Line 
1;;; data-structures.scm - Optional data structures extensions
2;
3; Copyright (c) 2008-2009, The Chicken Team
4; 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;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29 (unit data-structures)
30 (usual-integrations)
31 (disable-warning redef)
32 (foreign-declare #<<EOF
33#define C_mem_compare(to, from, n)   C_fix(C_memcmp(C_c_string(to), C_c_string(from), C_unfix(n)))
34EOF
35) )
36
37(cond-expand
38 [paranoia]
39 [else
40  (declare
41    (no-bound-checks)
42    (no-procedure-checks-for-usual-bindings)
43    (bound-to-procedure
44      ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string
45      ##sys#substring ##sys#for-each ##sys#map ##sys#setslot
46      ##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
47      ##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
48      ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
49      ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
50      ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
51      ##sys#print ##sys#check-structure ##sys#make-structure make-parameter
52      ##sys#flush-output ##sys#write-char-0 ##sys#number->string
53      ##sys#fragments->string ##sys#symbol->qualified-string
54      ##extras#reverse-string-append ##sys#number? ##sys#procedure->string
55      ##sys#pointer->string ##sys#user-print-hook ##sys#peek-char-0
56      ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
57      ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
58      input-port? make-vector list->vector sort! merge! open-output-string floor
59      get-output-string current-output-port display write port? list->string
60      make-string string pretty-print-width newline char-name read random
61      open-input-string make-string call-with-input-file read-line reverse ) ) ] )
62
63(private data-structures
64  reverse-string-append
65  fprintf0 generic-write )
66
67(declare
68  (hide
69    fprintf0 generic-write ) )
70
71(include "unsafe-declarations.scm")
72
73(register-feature! 'data-structures)
74
75
76
77;;; Combinators:
78
79(define (identity x) x)
80
81(define (project n)
82  (lambda args (list-ref args n)) )
83
84(define (conjoin . preds)
85  (lambda (x)
86    (let loop ([preds preds])
87      (or (null? preds)
88          (and ((##sys#slot preds 0) x)
89               (loop (##sys#slot preds 1)) ) ) ) ) )
90
91(define (disjoin . preds)
92  (lambda (x)
93    (let loop ([preds preds])
94      (and (not (null? preds))
95           (or ((##sys#slot preds 0) x)
96               (loop (##sys#slot preds 1)) ) ) ) ) )
97
98(define (constantly . xs)
99  (if (eq? 1 (length xs))
100      (let ([x (car xs)])
101        (lambda _ x) )
102      (lambda _ (apply values xs)) ) )
103
104(define (flip proc) (lambda (x y) (proc y x)))
105
106(define complement
107  (lambda (p)
108    (lambda args (not (apply p args))) ) )
109
110(define (compose . fns)
111  (define (rec f0 . fns)
112    (if (null? fns)
113        f0
114        (lambda args
115          (call-with-values
116              (lambda () (apply (apply rec fns) args))
117            f0) ) ) )
118  (if (null? fns)
119      values
120      (apply rec fns) ) )
121
122(define (o . fns)
123  (if (null? fns)
124      identity
125      (let loop ((fns fns))
126        (let ((h (##sys#slot fns 0))
127              (t (##sys#slot fns 1)) )
128          (if (null? t)
129              h
130              (lambda (x) (h ((loop t) x))))))))
131
132(define (list-of? pred)
133  (lambda (lst)
134    (let loop ([lst lst])
135      (cond [(null? lst) #t]
136            [(not-pair? lst) #f]
137            [(pred (##sys#slot lst 0)) (loop (##sys#slot lst 1))]
138            [else #f] ) ) ) )
139
140(define list-of list-of?)               ; DEPRECATED
141
142(define (noop . _) (void))
143
144(define (each . procs)
145  (cond ((null? procs) (lambda _ (void)))
146        ((null? (##sys#slot procs 1)) (##sys#slot procs 0))
147        (else
148         (lambda args
149           (let loop ((procs procs))
150             (let ((h (##sys#slot procs 0))
151                   (t (##sys#slot procs 1)) )
152               (if (null? t)
153                   (apply h args)
154                   (begin
155                     (apply h args)
156                     (loop t) ) ) ) ) ) ) ) )
157
158(define (any? x) #t)
159
160(define (none? x) #f)
161
162(define (always? . _) #t)
163
164(define (never? . _) #f)
165
166(define (left-section proc . args)
167  (##sys#check-closure proc 'left-section)
168  (lambda xs
169    (##sys#apply proc (##sys#append args xs)) ) )
170
171(define right-section
172  (let ([##sys#reverse reverse])
173    (lambda (proc . args)
174      (##sys#check-closure proc 'right-section)
175      (let ([revdargs (##sys#reverse args)])
176        (lambda xs
177          (##sys#apply proc (##sys#reverse (##sys#append revdargs (##sys#reverse xs)))) ) ) ) ) )
178
179
180;;; List operators:
181
182(define (atom? x) (##core#inline "C_i_not_pair_p" x))
183
184(define (tail? x y)
185  (##sys#check-list y 'tail?)
186  (or (##core#inline "C_eqp" x '())
187      (let loop ((y y))
188        (cond ((##core#inline "C_eqp" y '()) #f)
189              ((##core#inline "C_eqp" x y) #t)
190              (else (loop (##sys#slot y 1))) ) ) ) )
191
192(define intersperse 
193  (lambda (lst x)
194    (let loop ((ns lst))
195      (if (##core#inline "C_eqp" ns '())
196          ns
197          (let ((tail (cdr ns)))
198            (if (##core#inline "C_eqp" tail '())
199                ns
200                (cons (##sys#slot ns 0) (cons x (loop tail))) ) ) ) ) ) )
201
202(define (butlast lst)
203  (##sys#check-pair lst 'butlast)
204  (let loop ((lst lst))
205    (let ((next (##sys#slot lst 1)))
206      (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))
207          (cons (##sys#slot lst 0) (loop next))
208          '() ) ) ) )
209
210(define (flatten . lists0)
211  (let loop ([lists lists0] [rest '()])
212    (cond [(null? lists) rest]
213          [else
214           (let ([head (##sys#slot lists 0)]
215                 [tail (##sys#slot lists 1)] )
216             (if (list? head)
217                 (loop head (loop tail rest))
218                 (cons head (loop tail rest)) ) ) ] ) ) )
219
220(define chop
221  (let ([reverse reverse])
222    (lambda (lst n)
223      (##sys#check-exact n 'chop)
224      (cond-expand
225       [(not unsafe) (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))]
226       [else] )
227      (let ([len (length lst)])
228        (let loop ([lst lst] [i len])
229          (cond [(null? lst) '()]
230                [(fx< i n) (list lst)]
231                [else
232                 (do ([hd '() (cons (##sys#slot tl 0) hd)]
233                      [tl lst (##sys#slot tl 1)] 
234                      [c n (fx- c 1)] )
235                     ((fx= c 0)
236                      (cons (reverse hd) (loop tl (fx- i n))) ) ) ] ) ) ) ) ) )
237
238(define (join lsts . lst)
239  (let ([lst (if (pair? lst) (car lst) '())])
240    (##sys#check-list lst 'join)
241    (let loop ([lsts lsts])
242      (cond [(null? lsts) '()]
243            [(cond-expand [unsafe #f] [else (not (pair? lsts))])
244             (##sys#error-not-a-proper-list lsts) ]
245            [else
246             (let ([l (##sys#slot lsts 0)]
247                   [r (##sys#slot lsts 1)] )
248               (if (null? r)
249                   l
250                   (##sys#append l lst (loop r)) ) ) ] ) ) ) )
251
252(define compress
253  (lambda (blst lst)
254    (let ([msg "bad argument type - not a proper list"])
255      (##sys#check-list lst 'compress)
256      (let loop ([blst blst] [lst lst])
257        (cond [(null? blst) '()]
258              [(cond-expand [unsafe #f] [else (not (pair? blst))])
259               (##sys#signal-hook #:type-error 'compress msg blst) ]
260              [(cond-expand [unsafe #f] [else (not (pair? lst))])
261               (##sys#signal-hook #:type-error 'compress msg lst) ]
262              [(##sys#slot blst 0) (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1)))]
263              [else (loop (##sys#slot blst 1) (##sys#slot lst 1))] ) ) ) ) )
264
265(define shuffle
266  ;; this should really shadow SORT! and RANDOM...
267  (lambda (l random)
268    (let ((len (length l)))
269      (map cdr
270           (sort! (map (lambda (x) (cons (random len) x)) l)
271                  (lambda (x y) (< (car x) (car y)))) ) ) ) )
272
273
274;;; Alists:
275
276(define (alist-update! x y lst . cmp)
277  (let* ([cmp (if (pair? cmp) (car cmp) eqv?)]
278         [aq (cond [(eq? eq? cmp) assq]
279                   [(eq? eqv? cmp) assv]
280                   [(eq? equal? cmp) assoc]
281                   [else
282                    (lambda (x lst)
283                      (let loop ([lst lst])
284                        (and (pair? lst)
285                             (let ([a (##sys#slot lst 0)])
286                               (if (and (pair? a) (cmp (##sys#slot a 0) x))
287                                   a
288                                   (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ] 
289         [item (aq x lst)] )
290    (if item
291        (begin
292          (##sys#setslot item 1 y)
293          lst)
294        (cons (cons x y) lst) ) ) )
295
296(define (alist-ref x lst #!optional (cmp eqv?) (default #f))
297  (let* ([aq (cond [(eq? eq? cmp) assq]
298                   [(eq? eqv? cmp) assv]
299                   [(eq? equal? cmp) assoc]
300                   [else
301                    (lambda (x lst)
302                      (let loop ([lst lst])
303                        (and (pair? lst)
304                             (let ([a (##sys#slot lst 0)])
305                               (if (and (pair? a) (cmp (##sys#slot a 0) x))
306                                   a
307                                   (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ] 
308         [item (aq x lst)] )
309    (if item
310        (##sys#slot item 1)
311        default) ) )
312
313(define (rassoc x lst . tst)
314  (cond-expand [(not unsafe) (##sys#check-list lst 'rassoc)][else])
315  (let ([tst (if (pair? tst) (car tst) eqv?)])
316    (let loop ([l lst])
317      (and (pair? l)
318           (let ([a (##sys#slot l 0)])
319             (cond-expand [(not unsafe) (##sys#check-pair a 'rassoc)][else])
320             (if (tst x (##sys#slot a 1))
321                 a
322                 (loop (##sys#slot l 1)) ) ) ) ) ) )
323
324
325
326; (reverse-string-append l) = (apply string-append (reverse l))
327
328(define (reverse-string-append l)
329
330  (define (rev-string-append l i)
331    (if (pair? l)
332      (let* ((str (car l))
333             (len (string-length str))
334             (result (rev-string-append (cdr l) (+ i len))))
335        (let loop ((j 0) (k (- (- (string-length result) i) len)))
336          (if (< j len)
337            (begin
338              (string-set! result k (string-ref str j))
339              (loop (+ j 1) (+ k 1)))
340            result)))
341      (make-string i)))
342
343  (rev-string-append l 0))
344
345;;; Anything->string conversion:
346
347(define ->string 
348  (let ([open-output-string open-output-string]
349        [display display]
350        [string string]
351        [get-output-string get-output-string] )
352    (lambda (x)
353      (cond [(string? x) x]
354            [(symbol? x) (symbol->string x)]
355            [(char? x) (string x)]
356            [(number? x) (##sys#number->string x)]
357            [else
358             (let ([o (open-output-string)])
359               (display x o)
360               (get-output-string o) ) ] ) ) ) )
361
362(define conc
363  (let ([string-append string-append])
364    (lambda args
365      (apply string-append (map ->string args)) ) ) )
366
367
368;;; Search one string inside another:
369
370(let ()
371  (define (traverse which where start test loc)
372    (##sys#check-string which loc)
373    (##sys#check-string where loc)
374    (let ([wherelen (##sys#size where)]
375          [whichlen (##sys#size which)] )
376      (##sys#check-exact start loc)
377      (let loop ([istart start] [iend whichlen])
378        (cond [(fx> iend wherelen) #f]
379              [(test istart whichlen) istart]
380              [else
381               (loop (fx+ istart 1)
382                     (fx+ iend 1) ) ] ) ) ) )
383  (set! ##sys#substring-index 
384    (lambda (which where start)
385      (traverse 
386       which where start
387       (lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
388       'substring-index) ) )
389  (set! ##sys#substring-index-ci 
390    (lambda (which where start)
391      (traverse
392       which where start
393       (lambda (i l) (##core#inline "C_substring_compare_case_insensitive" which where 0 i l)) 
394       'substring-index-ci) ) ) )
395
396(define (substring-index which where #!optional (start 0))
397  (##sys#substring-index which where start) )
398
399(define (substring-index-ci which where #!optional (start 0))
400  (##sys#substring-index-ci which where start) )
401
402
403;;; 3-Way string comparison:
404
405(define (string-compare3 s1 s2)
406  (##sys#check-string s1 'string-compare3)
407  (##sys#check-string s2 'string-compare3)
408  (let ((len1 (##sys#size s1))
409        (len2 (##sys#size s2)) )
410    (let* ((len-diff (fx- len1 len2)) 
411           (cmp (##core#inline "C_mem_compare" s1 s2 (if (fx< len-diff 0) len1 len2))))
412      (if (fx= cmp 0) 
413          len-diff 
414          cmp))))
415
416(define (string-compare3-ci s1 s2)
417  (##sys#check-string s1 'string-compare3-ci)
418  (##sys#check-string s2 'string-compare3-ci)
419  (let ((len1 (##sys#size s1))
420        (len2 (##sys#size s2)) )
421    (let* ((len-diff (fx- len1 len2)) 
422           (cmp (##core#inline "C_string_compare_case_insensitive" s1 s2 (if (fx< len-diff 0) len1 len2))))
423      (if (fx= cmp 0) 
424          len-diff 
425          cmp))))
426
427
428;;; Substring comparison:
429
430(define (##sys#substring=? s1 s2 start1 start2 n)
431  (##sys#check-string s1 'substring=?)
432  (##sys#check-string s2 'substring=?)
433  (let ((len (or n
434                 (fxmin (fx- (##sys#size s1) start1)
435                        (fx- (##sys#size s2) start2) ) ) ) )
436    (##sys#check-exact start1 'substring=?)
437    (##sys#check-exact start2 'substring=?)
438    (##core#inline "C_substring_compare" s1 s2 start1 start2 len) ) )
439
440(define (substring=? s1 s2 #!optional (start1 0) (start2 0) len)
441  (##sys#substring=? s1 s2 start1 start2 len) )
442
443(define (##sys#substring-ci=? s1 s2 start1 start2 n)
444  (##sys#check-string s1 'substring-ci=?)
445  (##sys#check-string s2 'substring-ci=?)
446  (let ((len (or n
447                 (fxmin (fx- (##sys#size s1) start1)
448                        (fx- (##sys#size s2) start2) ) ) ) )
449    (##sys#check-exact start1 'substring-ci=?)
450    (##sys#check-exact start2 'substring-ci=?)
451    (##core#inline "C_substring_compare_case_insensitive"
452                   s1 s2 start1 start2 len) ) )
453
454(define (substring-ci=? s1 s2 #!optional (start1 0) (start2 0) len)
455  (##sys#substring-ci=? s1 s2 start1 start2 len) )
456
457
458;;; Split string into substrings:
459
460(define string-split
461  (lambda (str . delstr-and-flag)
462    (##sys#check-string str 'string-split)
463    (let* ([del (if (null? delstr-and-flag) "\t\n " (car delstr-and-flag))]
464           [flag (if (fx= (length delstr-and-flag) 2) (cadr delstr-and-flag) #f)]
465           [strlen (##sys#size str)] )
466      (##sys#check-string del 'string-split)
467      (let ([dellen (##sys#size del)] 
468            [first #f] )
469        (define (add from to last)
470          (let ([node (cons (##sys#substring str from to) '())])
471            (if first
472                (##sys#setslot last 1 node)
473                (set! first node) ) 
474            node) )
475        (let loop ([i 0] [last #f] [from 0])
476          (cond [(fx>= i strlen)
477                 (when (or (fx> i from) flag) (add from i last))
478                 (or first '()) ]
479                [else
480                 (let ([c (##core#inline "C_subchar" str i)])
481                   (let scan ([j 0])
482                     (cond [(fx>= j dellen) (loop (fx+ i 1) last from)]
483                           [(eq? c (##core#inline "C_subchar" del j))
484                            (let ([i2 (fx+ i 1)])
485                              (if (or (fx> i from) flag)
486                                  (loop i2 (add from i last) i2)
487                                  (loop i2 last i2) ) ) ]
488                           [else (scan (fx+ j 1))] ) ) ) ] ) ) ) ) ) )
489
490
491;;; Concatenate list of strings:
492
493(define (string-intersperse strs #!optional (ds " "))
494  (##sys#check-list strs 'string-intersperse)
495  (##sys#check-string ds 'string-intersperse)
496  (let ((dslen (##sys#size ds)))
497    (let loop1 ((ss strs) (n 0))
498      (cond ((##core#inline "C_eqp" ss '())
499             (if (##core#inline "C_eqp" strs '())
500                 ""
501                 (let ((str2 (##sys#allocate-vector (fx- n dslen) #t #\space #f)))
502                   (let loop2 ((ss2 strs) (n2 0))
503                     (let* ((stri (##sys#slot ss2 0))
504                            (next (##sys#slot ss2 1)) 
505                            (strilen (##sys#size stri)) )
506                       (##core#inline "C_substring_copy" stri str2 0 strilen n2)
507                       (let ((n3 (fx+ n2 strilen)))
508                         (if (##core#inline "C_eqp" next '())
509                             str2
510                             (begin
511                               (##core#inline "C_substring_copy" ds str2 0 dslen n3)
512                               (loop2 next (fx+ n3 dslen)) ) ) ) ) ) ) ) )
513            ((and (##core#inline "C_blockp" ss) (##core#inline "C_pairp" ss))
514             (let ((stri (##sys#slot ss 0)))
515               (##sys#check-string stri 'string-intersperse)
516               (loop1 (##sys#slot ss 1)
517                      (fx+ (##sys#size stri) (fx+ dslen n)) ) ) )
518            (else (##sys#error-not-a-proper-list strs)) ) ) ) )
519
520
521;;; Translate elements of a string:
522
523(define string-translate 
524  (let ([make-string make-string]
525        [list->string list->string] )
526    (lambda (str from . to)
527
528      (define (instring s)
529        (let ([len (##sys#size s)])
530          (lambda (c)
531            (let loop ([i 0])
532              (cond [(fx>= i len) #f]
533                    [(eq? c (##core#inline "C_subchar" s i)) i]
534                    [else (loop (fx+ i 1))] ) ) ) ) )
535
536      (let* ([from
537              (cond [(char? from) (lambda (c) (eq? c from))]
538                    [(pair? from) (instring (list->string from))]
539                    [else
540                     (##sys#check-string from 'string-translate)
541                     (instring from) ] ) ]
542             [to
543              (and (pair? to)
544                   (let ([tx (##sys#slot to 0)])
545                     (cond [(char? tx) tx]
546                           [(pair? tx) (list->string tx)]
547                           [else
548                            (##sys#check-string tx 'string-translate)
549                            tx] ) ) ) ] 
550             [tlen (and (string? to) (##sys#size to))] )
551        (##sys#check-string str 'string-translate)
552        (let* ([slen (##sys#size str)]
553               [str2 (make-string slen)] )
554          (let loop ([i 0] [j 0])
555            (if (fx>= i slen)
556                (if (fx< j i)
557                    (##sys#substring str2 0 j)
558                    str2)
559                (let* ([ci (##core#inline "C_subchar" str i)]
560                       [found (from ci)] )
561                  (cond [(not found)
562                         (##core#inline "C_setsubchar" str2 j ci)
563                         (loop (fx+ i 1) (fx+ j 1)) ]
564                        [(not to) (loop (fx+ i 1) j)]
565                        [(char? to)
566                         (##core#inline "C_setsubchar" str2 j to)
567                         (loop (fx+ i 1) (fx+ j 1)) ]
568                        [(cond-expand [unsafe #f] [else (fx>= found tlen)])
569                         (##sys#error 'string-translate "invalid translation destination" i to) ]
570                        [else
571                         (##core#inline "C_setsubchar" str2 j (##core#inline "C_subchar" to found))
572                         (loop (fx+ i 1) (fx+ j 1)) ] ) ) ) ) ) ) ) ) )
573
574(define (string-translate* str smap)
575  (##sys#check-string str 'string-translate*)
576  (##sys#check-list smap 'string-translate*)
577  (let ([len (##sys#size str)])
578    (define (collect i from total fs)
579      (if (fx>= i len)
580          (##sys#fragments->string
581           total
582           (reverse
583            (if (fx> i from) 
584                (cons (##sys#substring str from i) fs)
585                fs) ) )
586          (let loop ([smap smap])
587            (if (null? smap) 
588                (collect (fx+ i 1) from (fx+ total 1) fs)
589                (let* ([p (car smap)]
590                       [sm (car p)]
591                       [smlen (string-length sm)]
592                       [st (cdr p)] )
593                  (if (##core#inline "C_substring_compare" str sm i 0 smlen)
594                      (let ([i2 (fx+ i smlen)])
595                        (when (fx> i from)
596                          (set! fs (cons (##sys#substring str from i) fs)) )
597                        (collect 
598                         i2 i2
599                         (fx+ total (string-length st))
600                         (cons st fs) ) ) 
601                      (loop (cdr smap)) ) ) ) ) ) )
602    (collect 0 0 0 '()) ) )
603
604
605;;; Chop string into substrings:
606
607(define (string-chop str len)
608  (##sys#check-string str 'string-chop)
609  (##sys#check-exact len 'string-chop)
610  (let ([total (##sys#size str)])
611    (let loop ([total total] [pos 0])
612      (cond [(fx<= total 0) '()]
613            [(fx<= total len) (list (##sys#substring str pos (fx+ pos total)))]
614            [else (cons (##sys#substring str pos (fx+ pos len)) (loop (fx- total len) (fx+ pos len)))] ) ) ) )
615           
616
617;;; Remove suffix
618
619(define (string-chomp str #!optional (suffix "\n"))
620  (##sys#check-string str 'string-chomp)
621  (##sys#check-string suffix 'string-chomp)
622  (let* ((len (##sys#size str))
623         (slen (##sys#size suffix)) 
624         (diff (fx- len slen)) )
625    (if (and (fx>= len slen)
626             (##core#inline "C_substring_compare" str suffix diff 0 slen) )
627        (##sys#substring str 0 diff)
628        str) ) )
629
630
631
632;;; Defines: sorted?, merge, merge!, sort, sort!
633;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
634;;;
635;;; This code is in the public domain.
636
637;;; Updated: 11 June 1991
638;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
639;;; Updated: 19 June 1995
640
641;;; (sorted? sequence less?)
642;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
643;;; such that for all 1 <= i <= m,
644;;;     (not (less? (list-ref list i) (list-ref list (- i 1)))).
645
646; Modified by flw for use with CHICKEN:
647;
648
649
650(define (sorted? seq less?)
651    (cond
652        ((null? seq)
653            #t)
654        ((vector? seq)
655            (let ((n (vector-length seq)))
656                (if (<= n 1)
657                    #t
658                    (do ((i 1 (+ i 1)))
659                        ((or (= i n)
660                             (less? (vector-ref seq i)
661                                    (vector-ref seq (- i 1))))
662                            (= i n)) )) ))
663        (else
664            (let loop ((last (car seq)) (next (cdr seq)))
665                (or (null? next)
666                    (and (not (less? (car next) last))
667                         (loop (car next) (cdr next)) )) )) ))
668
669
670;;; (merge a b less?)
671;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
672;;; and returns a new list in which the elements of a and b have been stably
673;;; interleaved so that (sorted? (merge a b less?) less?).
674;;; Note:  this does _not_ accept vectors.  See below.
675
676(define (merge a b less?)
677    (cond
678        ((null? a) b)
679        ((null? b) a)
680        (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
681            ;; The loop handles the merging of non-empty lists.  It has
682            ;; been written this way to save testing and car/cdring.
683            (if (less? y x)
684                (if (null? b)
685                    (cons y (cons x a))
686                    (cons y (loop x a (car b) (cdr b)) ))
687                ;; x <= y
688                (if (null? a)
689                    (cons x (cons y b))
690                    (cons x (loop (car a) (cdr a) y b)) )) )) ))
691
692
693;;; (merge! a b less?)
694;;; takes two sorted lists a and b and smashes their cdr fields to form a
695;;; single sorted list including the elements of both.
696;;; Note:  this does _not_ accept vectors.
697
698(define (merge! a b less?)
699    (define (loop r a b)
700        (if (less? (car b) (car a))
701            (begin
702                (set-cdr! r b)
703                (if (null? (cdr b))
704                    (set-cdr! b a)
705                    (loop b a (cdr b)) ))
706            ;; (car a) <= (car b)
707            (begin
708                (set-cdr! r a)
709                (if (null? (cdr a))
710                    (set-cdr! a b)
711                    (loop a (cdr a) b)) )) )
712    (cond
713        ((null? a) b)
714        ((null? b) a)
715        ((less? (car b) (car a))
716            (if (null? (cdr b))
717                (set-cdr! b a)
718                (loop b a (cdr b)))
719            b)
720        (else ; (car a) <= (car b)
721            (if (null? (cdr a))
722                (set-cdr! a b)
723                (loop a (cdr a) b))
724            a)))
725
726
727;;; (sort! sequence less?)
728;;; sorts the list or vector sequence destructively.  It uses a version
729;;; of merge-sort invented, to the best of my knowledge, by David H. D.
730;;; Warren, and first used in the DEC-10 Prolog system.  R. A. O'Keefe
731;;; adapted it to work destructively in Scheme.
732
733(define (sort! seq less?)
734    (define (step n)
735        (cond
736            ((> n 2)
737                (let* ((j (quotient n 2))
738                       (a (step j))
739                       (k (- n j))
740                       (b (step k)))
741                    (merge! a b less?)))
742            ((= n 2)
743                (let ((x (car seq))
744                      (y (cadr seq))
745                      (p seq))
746                    (set! seq (cddr seq))
747                    (if (less? y x) (begin
748                        (set-car! p y)
749                        (set-car! (cdr p) x)))
750                    (set-cdr! (cdr p) '())
751                    p))
752            ((= n 1)
753                (let ((p seq))
754                    (set! seq (cdr seq))
755                    (set-cdr! p '())
756                    p))
757            (else
758                '()) ))
759    (if (vector? seq)
760        (let ((n (vector-length seq))
761              (vec seq))
762          (set! seq (vector->list seq))
763          (do ((p (step n) (cdr p))
764               (i 0 (+ i 1)))
765              ((null? p) vec)
766            (vector-set! vec i (car p)) ))
767        ;; otherwise, assume it is a list
768        (step (length seq)) ))
769
770;;; (sort sequence less?)
771;;; sorts a vector or list non-destructively.  It does this by sorting a
772;;; copy of the sequence.  My understanding is that the Standard says
773;;; that the result of append is always "newly allocated" except for
774;;; sharing structure with "the last argument", so (append x '()) ought
775;;; to be a standard way of copying a list x.
776
777(define (sort seq less?)
778    (if (vector? seq)
779        (list->vector (sort! (vector->list seq) less?))
780        (sort! (append seq '()) less?)))
781
782
783;;;  Simple topological sort:
784;
785; Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt
786
787(define (topological-sort dag pred)
788  (if (null? dag)
789      '()
790      (let* ((adj-table '())
791             (sorted '()))
792
793        (define (insert x y)
794          (let loop ([at adj-table])
795            (cond [(null? at) (set! adj-table (cons (cons x y) adj-table))]
796                  [(pred x (caar at)) (set-cdr! (car at) y)]
797                  [else (loop (cdr at))] ) ) )
798       
799        (define (lookup x)
800          (let loop ([at adj-table])
801            (cond [(null? at) #f]
802                  [(pred x (caar at)) (cdar at)]
803                  [else (loop (cdr at))] ) ) )
804       
805        (define (visit u adj-list)
806          ;; Color vertex u
807          (insert u 'colored)
808          ;; Visit uncolored vertices which u connects to
809          (for-each (lambda (v)
810                      (let ((val (lookup v)))
811                        (if (not (eq? val 'colored))
812                            (visit v (or val '())))))
813                    adj-list)
814          ;; Since all vertices downstream u are visited
815          ;; by now, we can safely put u on the output list
816          (set! sorted (cons u sorted)) )
817       
818        ;; Hash adjacency lists
819        (for-each (lambda (def) (insert (car def) (cdr def)))
820                  (cdr dag))
821        ;; Visit vertices
822        (visit (caar dag) (cdar dag))
823        (for-each (lambda (def)
824                    (let ((val (lookup (car def))))
825                      (if (not (eq? val 'colored))
826                          (visit (car def) (cdr def)))))
827                  (cdr dag)) 
828        sorted) ) )
829
830
831;;; Binary search:
832
833(define binary-search
834  (let ([list->vector list->vector])
835    (lambda (vec proc)
836      (if (pair? vec)
837          (set! vec (list->vector vec))
838          (##sys#check-vector vec 'binary-search) )
839      (let ([len (##sys#size vec)])
840        (and (fx> len 0)
841             (let loop ([ps 0]
842                        [pe len] )
843               (let ([p (fx+ ps (##core#inline "C_fixnum_divide" (fx- pe ps) 2))])
844                 (let* ([x (##sys#slot vec p)]
845                        [r (proc x)] )
846                   (cond [(fx= r 0) p]
847                         [(fx< r 0) (and (not (fx= pe p)) (loop ps p))]
848                         [else (and (not (fx= ps p)) (loop p pe))] ) ) ) ) ) ) ) ) )
849
850
851
852; Support for queues
853;
854; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
855;
856; This code is in the public domain.
857;
858; (heavily adapated for use with CHICKEN by felix)
859;
860
861
862; Elements in a queue are stored in a list.  The last pair in the list
863; is stored in the queue type so that datums can be added in constant
864; time.
865
866(define (make-queue) (##sys#make-structure 'queue '() '()))
867(define (queue? x) (##sys#structure? x 'queue))
868
869(define (queue-empty? q)
870  (##sys#check-structure q 'queue 'queue-empty?)
871  (eq? '() (##sys#slot q 1)) )
872
873(define queue-first
874  (lambda (q)
875    (##sys#check-structure q 'queue 'queue-first)
876    (let ((first-pair (##sys#slot q 1)))
877      (cond-expand 
878       [(not unsafe)
879        (when (eq? '() first-pair)
880          (##sys#error 'queue-first "queue is empty" q)) ]
881       [else] )
882      (##sys#slot first-pair 0) ) ) )
883
884(define queue-last
885  (lambda (q)
886    (##sys#check-structure q 'queue 'queue-last)
887    (let ((last-pair (##sys#slot q 2)))
888      (cond-expand
889       [(not unsafe)
890        (when (eq? '() last-pair)
891          (##sys#error 'queue-last "queue is empty" q)) ]
892       [else] )
893      (##sys#slot last-pair 0) ) ) )
894
895(define (queue-add! q datum)
896  (##sys#check-structure q 'queue 'queue-add!)
897  (let ((new-pair (cons datum '())))
898    (cond ((eq? '() (##sys#slot q 1)) (##sys#setslot q 1 new-pair))
899          (else (##sys#setslot (##sys#slot q 2) 1 new-pair)) )
900    (##sys#setslot q 2 new-pair) 
901    (##core#undefined) ) )
902
903(define queue-remove!
904  (lambda (q)
905    (##sys#check-structure q 'queue 'queue-remove!)
906    (let ((first-pair (##sys#slot q 1)))
907      (cond-expand
908       [(not unsafe)
909        (when (eq? '() first-pair)
910          (##sys#error 'queue-remove! "queue is empty" q) ) ]
911       [else] )
912      (let ((first-cdr (##sys#slot first-pair 1)))
913        (##sys#setslot q 1 first-cdr)
914        (if (eq? '() first-cdr)
915            (##sys#setslot q 2 '()) )
916        (##sys#slot first-pair 0) ) ) ) )
917
918(define (queue->list q)
919  (##sys#check-structure q 'queue 'queue->list)
920  (##sys#slot q 1) )
921
922(define (list->queue lst0)
923  (##sys#check-list lst0 'list->queue)
924  (##sys#make-structure 
925   'queue lst0
926   (if (eq? lst0 '())
927       '()
928       (do ((lst lst0 (##sys#slot lst 1)))
929           ((eq? (##sys#slot lst 1) '()) lst)
930         (if (or (not (##core#inline "C_blockp" lst))
931                 (not (##core#inline "C_pairp" lst)) )
932             (##sys#error-not-a-proper-list lst0 'list->queue) ) ) ) ) )
933
934
935; (queue-push-back! queue item)
936; Pushes an item into the first position of a queue.
937
938(define (queue-push-back! q item)
939  (##sys#check-structure q 'queue 'queue-push-back!)
940  (let ((newlist (cons item (##sys#slot q 1))))
941    (##sys#setslot q 1 newlist)
942    (if (eq? '() (##sys#slot q 2))
943        (##sys#setslot q 2 newlist))))
944
945; (queue-push-back-list! queue item-list)
946; Pushes the items in item-list back onto the queue,
947; so that (car item-list) becomes the next removable item.
948
949(define-inline (last-pair lst0)
950  (do ((lst lst0 (##sys#slot lst 1)))
951      ((eq? (##sys#slot lst 1) '()) lst)))
952
953(define (queue-push-back-list! q itemlist)
954  (##sys#check-structure q 'queue 'queue-push-back-list!)
955  (##sys#check-list itemlist 'queue-push-back-list!)
956  (let* ((newlist (append itemlist (##sys#slot q 1)))
957         (newtail (if (eq? newlist '())
958                       '()
959                       (last-pair newlist))))
960    (##sys#setslot q 1 newlist)
961    (##sys#setslot q 2 newtail)))
Note: See TracBrowser for help on using the repository browser.