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