~ chicken-core (chicken-5) /data-structures.scm

  1;;; data-structures.scm - Optional data structures extensions
  2;
  3; Copyright (c) 2008-2022, 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
 31(module chicken.string
 32  (conc ->string string-chop string-chomp
 33   string-compare3 string-compare3-ci
 34   reverse-list->string reverse-string-append
 35   string-intersperse string-split
 36   string-translate string-translate*
 37   substring=? substring-ci=?
 38   substring-index substring-index-ci)
 39
 40(import scheme)
 41(import chicken.base)
 42(import chicken.condition)
 43(import chicken.fixnum)
 44(import chicken.foreign)
 45
 46; (reverse-string-append l) = (apply string-append (reverse l))
 47
 48(define (reverse-string-append l)
 49  (define (rev-string-append l i)
 50    (if (pair? l)
 51      (let* ((str (car l))
 52	     (len (string-length str))
 53	     (result (rev-string-append (cdr l) (fx+ i len))))
 54	(let loop ((j 0) (k (fx- (fx- (string-length result) i) len)))
 55	  (if (fx< j len)
 56	    (begin
 57	      (string-set! result k (string-ref str j))
 58	      (loop (fx+ j 1) (fx+ k 1)))
 59	    result)))
 60      (make-string i)))
 61  (rev-string-append l 0))
 62
 63(define (reverse-list->string l)
 64  (##sys#reverse-list->string l))
 65
 66;;; Anything->string conversion:
 67
 68(define ->string 
 69  (lambda (x)
 70    (cond [(string? x) x]
 71	  [(symbol? x) (symbol->string x)]
 72	  [(char? x) (string x)]
 73	  [(number? x) (##sys#number->string x)]
 74	  [else 
 75	   (let ([o (open-output-string)])
 76	     (display x o)
 77	     (get-output-string o) ) ] ) ) )
 78
 79(define conc
 80  (lambda args
 81    (apply string-append (map ->string args)) ) )
 82
 83
 84;;; Search one string inside another:
 85
 86(let ()
 87  (define (traverse which where start test loc)
 88    (##sys#check-string which loc)
 89    (##sys#check-string where loc)
 90    (let* ((wherelen (##sys#size where))
 91	   (whichlen (##sys#size which))
 92	   (end (fx- wherelen whichlen)))
 93      (##sys#check-fixnum start loc)
 94      (if (and (fx>= start 0)
 95	       (fx>= wherelen start))
 96	  (if (fx= whichlen 0)
 97	      start
 98	      (and (fx>= end 0)
 99		   (let loop ((istart start))
100		     (cond ((fx> istart end) #f)
101			   ((test istart whichlen) istart)
102			   (else (loop (fx+ istart 1)))))))
103	  (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
104			    loc
105			    start
106			    wherelen))))
107
108  (set! ##sys#substring-index 
109    (lambda (which where start)
110      (traverse 
111       which where start
112       (lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
113       'substring-index) ) )
114  (set! ##sys#substring-index-ci 
115    (lambda (which where start)
116      (traverse
117       which where start
118       (lambda (i l) (##core#inline "C_substring_compare_case_insensitive" which where 0 i l)) 
119       'substring-index-ci) ) ) )
120
121(define (substring-index which where #!optional (start 0))
122  (##sys#substring-index which where start) )
123
124(define (substring-index-ci which where #!optional (start 0))
125  (##sys#substring-index-ci which where start) )
126
127
128;;; 3-Way string comparison:
129
130(define (string-compare3 s1 s2)
131  (##sys#check-string s1 'string-compare3)
132  (##sys#check-string s2 'string-compare3)
133  (let ((len1 (##sys#size s1))
134	(len2 (##sys#size s2)) )
135    (let* ((len-diff (fx- len1 len2)) 
136	   (cmp (##core#inline "C_string_compare" s1 s2 (if (fx< len-diff 0) len1 len2))))
137      (if (fx= cmp 0) 
138	  len-diff 
139	  cmp))))
140
141(define (string-compare3-ci s1 s2)
142  (##sys#check-string s1 'string-compare3-ci)
143  (##sys#check-string s2 'string-compare3-ci)
144  (let ((len1 (##sys#size s1))
145	(len2 (##sys#size s2)) )
146    (let* ((len-diff (fx- len1 len2)) 
147	   (cmp (##core#inline "C_string_compare_case_insensitive" s1 s2 (if (fx< len-diff 0) len1 len2))))
148      (if (fx= cmp 0) 
149	  len-diff 
150	  cmp))))
151
152
153;;; Substring comparison:
154
155(define (##sys#substring=? s1 s2 start1 start2 n)
156  (##sys#check-string s1 'substring=?)
157  (##sys#check-string s2 'substring=?)
158  (##sys#check-range start1 0 (fx+ (##sys#size s1) 1) 'substring=?)
159  (##sys#check-range start2 0 (fx+ (##sys#size s2) 1) 'substring=?)
160  (let* ((maxlen (fxmin (fx- (##sys#size s1) start1)
161                        (fx- (##sys#size s2) start2)))
162         (len (if n
163                  (begin (##sys#check-range n 0 (fx+ maxlen 1) 'substring=?) n)
164                  maxlen)))
165    (##core#inline "C_substring_compare" s1 s2 start1 start2 len) ) )
166
167(define (substring=? s1 s2 #!optional (start1 0) (start2 0) len)
168  (##sys#substring=? s1 s2 start1 start2 len) )
169
170(define (##sys#substring-ci=? s1 s2 start1 start2 n)
171  (##sys#check-string s1 'substring-ci=?)
172  (##sys#check-string s2 'substring-ci=?)
173  (##sys#check-range start1 0 (fx+ (##sys#size s1) 1) 'substring-ci=?)
174  (##sys#check-range start2 0 (fx+ (##sys#size s2) 1) 'substring-ci=?)
175  (let* ((maxlen (fxmin (fx- (##sys#size s1) start1)
176                        (fx- (##sys#size s2) start2)))
177         (len (if n
178                  (begin (##sys#check-range n 0 (fx+ maxlen 1) 'substring-ci=?) n)
179                  maxlen)))
180    (##core#inline "C_substring_compare_case_insensitive"
181		   s1 s2 start1 start2 len) ) )
182
183(define (substring-ci=? s1 s2 #!optional (start1 0) (start2 0) len)
184  (##sys#substring-ci=? s1 s2 start1 start2 len) )
185
186
187;;; Split string into substrings:
188
189(define string-split
190  (lambda (str . delstr-and-flag)
191    (##sys#check-string str 'string-split)
192    (let* ([del (if (null? delstr-and-flag) "\t\n " (car delstr-and-flag))]
193	   [flag (if (fx= (length delstr-and-flag) 2) (cadr delstr-and-flag) #f)]
194	   [strlen (##sys#size str)] )
195      (##sys#check-string del 'string-split)
196      (let ([dellen (##sys#size del)] 
197	    [first #f] )
198	(define (add from to last)
199	  (let ([node (cons (##sys#substring str from to) '())])
200	    (if first
201		(##sys#setslot last 1 node)
202		(set! first node) ) 
203	    node) )
204	(let loop ([i 0] [last #f] [from 0])
205	  (cond [(fx>= i strlen)
206		 (when (or (fx> i from) flag) (add from i last))
207		 (or first '()) ]
208		[else
209		 (let ([c (##core#inline "C_subchar" str i)])
210		   (let scan ([j 0])
211		     (cond [(fx>= j dellen) (loop (fx+ i 1) last from)]
212			   [(eq? c (##core#inline "C_subchar" del j))
213			    (let ([i2 (fx+ i 1)])
214			      (if (or (fx> i from) flag)
215				  (loop i2 (add from i last) i2)
216				  (loop i2 last i2) ) ) ]
217			   [else (scan (fx+ j 1))] ) ) ) ] ) ) ) ) ) )
218
219
220;;; Concatenate list of strings:
221
222(define (string-intersperse strs #!optional (ds " "))
223  (##sys#check-list strs 'string-intersperse)
224  (##sys#check-string ds 'string-intersperse)
225  (let ((dslen (##sys#size ds)))
226    (let loop1 ((ss strs) (n 0))
227      (cond ((##core#inline "C_eqp" ss '())
228	     (if (##core#inline "C_eqp" strs '())
229		 ""
230		 (let ((str2 (##sys#allocate-vector (fx- n dslen) #t #\space #f)))
231		   (let loop2 ((ss2 strs) (n2 0))
232		     (let* ((stri (##sys#slot ss2 0))
233			    (next (##sys#slot ss2 1)) 
234			    (strilen (##sys#size stri)) )
235		       (##core#inline "C_substring_copy" stri str2 0 strilen n2)
236		       (let ((n3 (fx+ n2 strilen)))
237			 (if (##core#inline "C_eqp" next '())
238			     str2
239			     (begin
240			       (##core#inline "C_substring_copy" ds str2 0 dslen n3)
241			       (loop2 next (fx+ n3 dslen)) ) ) ) ) ) ) ) )
242	    ((and (##core#inline "C_blockp" ss) (##core#inline "C_pairp" ss))
243	     (let ((stri (##sys#slot ss 0)))
244	       (##sys#check-string stri 'string-intersperse)
245	       (loop1 (##sys#slot ss 1)
246		      (fx+ (##sys#size stri) (fx+ dslen n)) ) ) )
247	    (else (##sys#error-not-a-proper-list strs)) ) ) ) )
248
249
250;;; Translate elements of a string:
251
252(define string-translate 
253  (lambda (str from . to)
254
255    (define (instring s)
256      (let ([len (##sys#size s)])
257	(lambda (c)
258	  (let loop ([i 0])
259	    (cond [(fx>= i len) #f]
260		  [(eq? c (##core#inline "C_subchar" s i)) i]
261		  [else (loop (fx+ i 1))] ) ) ) ) )
262
263    (let* ([from
264	    (cond [(char? from) (lambda (c) (eq? c from))]
265		  [(pair? from) (instring (list->string from))]
266		  [else
267		   (##sys#check-string from 'string-translate)
268		   (instring from) ] ) ]
269	   [to
270	    (and (pair? to)
271		 (let ([tx (##sys#slot to 0)])
272		   (cond [(char? tx) tx]
273			 [(pair? tx) (list->string tx)]
274			 [else
275			  (##sys#check-string tx 'string-translate)
276			  tx] ) ) ) ] 
277	   [tlen (and (string? to) (##sys#size to))] )
278      (##sys#check-string str 'string-translate)
279      (let* ([slen (##sys#size str)]
280	     [str2 (make-string slen)] )
281	(let loop ([i 0] [j 0])
282	  (if (fx>= i slen)
283	      (if (fx< j i)
284		  (##sys#substring str2 0 j)
285		  str2)
286	      (let* ([ci (##core#inline "C_subchar" str i)]
287		     [found (from ci)] )
288		(cond [(not found)
289		       (##core#inline "C_setsubchar" str2 j ci)
290		       (loop (fx+ i 1) (fx+ j 1)) ]
291		      [(not to) (loop (fx+ i 1) j)]
292		      [(char? to)
293		       (##core#inline "C_setsubchar" str2 j to)
294		       (loop (fx+ i 1) (fx+ j 1)) ]
295		      [(fx>= found tlen)
296		       (##sys#error 'string-translate "invalid translation destination" i to) ]
297		      [else 
298		       (##core#inline "C_setsubchar" str2 j (##core#inline "C_subchar" to found))
299		       (loop (fx+ i 1) (fx+ j 1)) ] ) ) ) ) ) ) ) )
300
301(define (string-translate* str smap)
302  (##sys#check-string str 'string-translate*)
303  (##sys#check-list smap 'string-translate*)
304  (let ((len (##sys#size str)))
305    (define (collect i from total fs)
306      (if (fx>= i len)
307	  (##sys#fragments->string
308	   total
309	   (##sys#fast-reverse 
310	    (if (fx> i from) 
311		(cons (##sys#substring str from i) fs)
312		fs) ) )
313	  (let loop ((smap smap))
314	    (if (null? smap) 
315		(collect (fx+ i 1) from (fx+ total 1) fs)
316		(let* ((p (car smap))
317		       (sm (car p))
318		       (smlen (string-length sm))
319		       (st (cdr p)) )
320		  (if (and (fx<= (fx+ i smlen) len)
321			   (##core#inline "C_substring_compare" str sm i 0 smlen))
322		      (let ((i2 (fx+ i smlen)))
323			(when (fx> i from)
324			  (set! fs (cons (##sys#substring str from i) fs)) )
325			(collect 
326			 i2 i2
327			 (fx+ total (string-length st))
328			 (cons st fs) ) ) 
329		      (loop (cdr smap)) ) ) ) ) ) )
330    (collect 0 0 0 '()) ) )
331
332
333;;; Chop string into substrings:
334
335(define (string-chop str len)
336  (##sys#check-string str 'string-chop)
337  (##sys#check-fixnum len 'string-chop)
338  (let ([total (##sys#size str)])
339    (let loop ([total total] [pos 0])
340      (cond [(fx<= total 0) '()]
341	    [(fx<= total len) (list (##sys#substring str pos (fx+ pos total)))]
342	    [else (cons (##sys#substring str pos (fx+ pos len)) (loop (fx- total len) (fx+ pos len)))] ) ) ) )
343	   
344
345;;; Remove suffix
346
347(define (string-chomp str #!optional (suffix "\n"))
348  (##sys#check-string str 'string-chomp)
349  (##sys#check-string suffix 'string-chomp)
350  (let* ((len (##sys#size str))
351	 (slen (##sys#size suffix)) 
352	 (diff (fx- len slen)) )
353    (if (and (fx>= len slen)
354	     (##core#inline "C_substring_compare" str suffix diff 0 slen) )
355	(##sys#substring str 0 diff)
356	str) ) )
357
358) ; chicken.string
359
360
361(module chicken.sort
362    (merge merge! sort sort! sorted? topological-sort)
363
364(import scheme chicken.base chicken.condition chicken.fixnum)
365
366;;; Defines: sorted?, merge, merge!, sort, sort!
367;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
368;;;
369;;; This code is in the public domain.
370
371;;; Updated: 11 June 1991
372;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
373;;; Updated: 19 June 1995
374
375;;; (sorted? sequence less?)
376;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
377;;; such that for all 1 <= i <= m,
378;;;	(not (less? (list-ref list i) (list-ref list (- i 1)))).
379
380; Modified by flw for use with CHICKEN:
381;
382
383
384(define (sorted? seq less?)
385    (cond
386	((null? seq)
387	    #t)
388	((vector? seq)
389	    (let ((n (vector-length seq)))
390		(if (<= n 1)
391		    #t
392		    (do ((i 1 (+ i 1)))
393			((or (= i n)
394			     (less? (vector-ref seq i)
395				    (vector-ref seq (- i 1))))
396			    (= i n)) )) ))
397	(else
398	    (let loop ((last (car seq)) (next (cdr seq)))
399		(or (null? next)
400		    (and (not (less? (car next) last))
401			 (loop (car next) (cdr next)) )) )) ))
402
403
404;;; (merge a b less?)
405;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
406;;; and returns a new list in which the elements of a and b have been stably
407;;; interleaved so that (sorted? (merge a b less?) less?).
408;;; Note:  this does _not_ accept vectors.  See below.
409
410(define (merge a b less?)
411    (cond
412	((null? a) b)
413	((null? b) a)
414	(else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
415	    ;; The loop handles the merging of non-empty lists.	 It has
416	    ;; been written this way to save testing and car/cdring.
417	    (if (less? y x)
418		(if (null? b)
419		    (cons y (cons x a))
420		    (cons y (loop x a (car b) (cdr b)) ))
421		;; x <= y
422		(if (null? a)
423		    (cons x (cons y b))
424		    (cons x (loop (car a) (cdr a) y b)) )) )) ))
425
426
427;;; (merge! a b less?)
428;;; takes two sorted lists a and b and smashes their cdr fields to form a
429;;; single sorted list including the elements of both.
430;;; Note:  this does _not_ accept vectors.
431
432(define (merge! a b less?)
433    (define (loop r a b)
434	(if (less? (car b) (car a))
435	    (begin
436		(set-cdr! r b)
437		(if (null? (cdr b))
438		    (set-cdr! b a)
439		    (loop b a (cdr b)) ))
440	    ;; (car a) <= (car b)
441	    (begin
442		(set-cdr! r a)
443		(if (null? (cdr a))
444		    (set-cdr! a b)
445		    (loop a (cdr a) b)) )) )
446    (cond
447	((null? a) b)
448	((null? b) a)
449	((less? (car b) (car a))
450	    (if (null? (cdr b))
451		(set-cdr! b a)
452		(loop b a (cdr b)))
453	    b)
454	(else ; (car a) <= (car b)
455	    (if (null? (cdr a))
456		(set-cdr! a b)
457		(loop a (cdr a) b))
458	    a)))
459
460
461;;; (sort! sequence less?)
462;;; sorts the list or vector sequence destructively.  It uses a version
463;;; of merge-sort invented, to the best of my knowledge, by David H. D.
464;;; Warren, and first used in the DEC-10 Prolog system.	 R. A. O'Keefe
465;;; adapted it to work destructively in Scheme.
466
467(define (sort! seq less?)
468    (define (step n)
469	(cond
470	    ((> n 2)
471		(let* ((j (quotient n 2))
472		       (a (step j))
473		       (k (- n j))
474		       (b (step k)))
475		    (merge! a b less?)))
476	    ((= n 2)
477		(let ((x (car seq))
478		      (y (cadr seq))
479		      (p seq))
480		    (set! seq (cddr seq))
481		    (if (less? y x) (begin
482			(set-car! p y)
483			(set-car! (cdr p) x)))
484		    (set-cdr! (cdr p) '())
485		    p))
486	    ((= n 1)
487		(let ((p seq))
488		    (set! seq (cdr seq))
489		    (set-cdr! p '())
490		    p))
491	    (else
492		'()) ))
493    (if (vector? seq)
494	(let ((n (vector-length seq))
495	      (vec seq))
496	  (set! seq (vector->list seq))
497	  (do ((p (step n) (cdr p))
498	       (i 0 (+ i 1)))
499	      ((null? p) vec)
500	    (vector-set! vec i (car p)) ))
501	;; otherwise, assume it is a list
502	(step (length seq)) ))
503
504;;; (sort sequence less?)
505;;; sorts a vector or list non-destructively.  It does this by sorting a
506;;; copy of the sequence.  My understanding is that the Standard says
507;;; that the result of append is always "newly allocated" except for
508;;; sharing structure with "the last argument", so (append x '()) ought
509;;; to be a standard way of copying a list x.
510
511(define (sort seq less?)
512    (if (vector? seq)
513	(list->vector (sort! (vector->list seq) less?))
514	(sort! (append seq '()) less?)))
515
516
517;;; Topological sort with cycle detection:
518;;
519;; A functional implementation of the algorithm described in Cormen,
520;; et al. (2009), Introduction to Algorithms (3rd ed.), pp. 612-615.
521
522(define (topological-sort dag pred)
523  (define (visit dag node edges path state)
524    (case (alist-ref node (car state) pred)
525      ((grey)
526       (abort
527        (##sys#make-structure
528         'condition
529         '(exn runtime cycle)
530         `((exn . message) "cycle detected"
531           (exn . arguments) ,(list (cons node (reverse path)))
532           (exn . call-chain) ,(get-call-chain)
533           (exn . location) topological-sort))))
534      ((black)
535       state)
536      (else
537       (let walk ((edges (or edges (alist-ref node dag pred '())))
538                  (state (cons (cons (cons node 'grey) (car state))
539                               (cdr state))))
540         (if (null? edges)
541             (cons (alist-update! node 'black (car state) pred)
542                   (cons node (cdr state)))
543             (let ((edge (car edges)))
544               (walk (cdr edges)
545                     (visit dag
546                            edge
547                            #f
548                            (cons edge path)
549                            state))))))))
550  (define normalized-dag
551    (foldl (lambda (result node)
552             (alist-update! (car node)
553                            (append (cdr node)
554                                    (or (alist-ref (car node) dag pred) '()))
555                            result
556                            pred))
557           '()
558           dag))
559  (let loop ((dag normalized-dag)
560             (state (cons (list) (list))))
561    (if (null? dag)
562        (cdr state)
563        (loop (cdr dag)
564              (visit dag
565                     (caar dag)
566                     (cdar dag)
567                     '()
568                     state)))))
569) ; chicken.sort
570