source: project/release/4/string-utils/trunk/string-utils-extensions.scm @ 35788

Last change on this file since 35788 was 35788, checked in by kon, 3 months ago

fix imports

File size: 2.6 KB
Line 
1;;;; string-utils-extensions.scm
2;;;; Kon Lovett, Feb '18
3
4(module string-utils-extensions
5
6(;export
7  string-copy-over!
8  string-copy*
9  string-count*
10  string-any* string-every*)
11
12(import scheme chicken)
13(use
14  (only data-structures o)
15  (only srfi-1 reduce)
16  (only utf8 substring make-string string-length string-ref string-set!)
17  (only utf8-srfi-13 string-count string-any string-every))
18
19;;
20
21(define-type char*-predicate (#!rest char --> boolean))
22
23;;
24
25(define (min-string-length strs)
26  (reduce fxmin 0 (map string-length strs)) )
27
28(define (strings-ref strs idx)
29  (map (cut string-ref <> idx) strs) )
30
31;;
32
33(: string-copy-over! (string string #!optional fixnum fixnum -> string))
34;
35(define (string-copy-over! from to #!optional (start 0) (end (string-length from)))
36  (unless (fx<= end (string-length to))
37    (error 'string-copy-over "destination string is too short") )
38  (do ((idx start (fx+ 1 idx)))
39      ((fx>= idx end) to)
40    (string-set! to idx (string-ref from idx)) ) )
41
42(: string-copy* (string #!optional fixnum fixnum char -> string))
43;
44(define (string-copy* str #!optional (start 0) (end (string-length str)) (fill #\space))
45  (unless (fx<= start end)
46    (error 'string-copy* "start > end" start end) )
47  (let* (
48    (tot (fx- end start))
49    (end (fxmin end (string-length str)))
50    (len (fx- end start))
51    (str (substring str start end)) )
52    (string-append str (make-string (fx- tot len) fill)) ) )
53
54(: string-count* (char*-predicate #!rest string -> fixnum))
55;
56(define (string-count* pred? . strs)
57  (if (null? (cdr strs))
58    (string-count (car strs) pred?)
59    (let (
60      (start 0)
61      (end (min-string-length strs))
62      (cnt 0) )
63      (do ((idx start (fx+ 1 idx)))
64           ((fx>= idx end) cnt)
65        (when (apply pred? (strings-ref strs idx))
66          (set! cnt (fx+ 1 cnt))) ) ) ) )
67
68(: string-any* (char*-predicate #!rest string -> (or boolean char)))
69;
70(define (string-any* pred? . strs)
71  (if (null? (cdr strs))
72    (string-any (car strs) pred?)
73    (let (
74      (start 0)
75      (end (min-string-length strs)) )
76      (let loop ((idx start))
77        (and
78          (fx> end idx)
79          (or
80            (apply pred? (strings-ref strs idx))
81            (loop (fx+ 1 idx))) ) ) ) ) )
82
83(: string-every* (char*-predicate #!rest string -> (or boolean char)))
84;
85(define (string-every* pred? . strs)
86  (if (null? (cdr strs))
87    (string-every (car strs) pred?)
88    (let (
89      (start 0)
90      (end (min-string-length strs)) )
91      (let loop ((idx start) (prev #t))
92        (if (fx<= end idx)
93          prev
94          (let ((ret (apply pred? (strings-ref strs idx))))
95            (and ret (loop (fx+ 1 idx) ret)) ) ) ) ) ) )
96
97) ;module string-utils-extensions
Note: See TracBrowser for help on using the repository browser.