source: project/chicken/trunk/data-structures.scm @ 13140

Last change on this file since 13140 was 13140, checked in by Kon Lovett, 12 years ago

Renamed not proper list error per ##sys#error- for all error type procs, deprecated '##sys#not-a-proper-list-error'.

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