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

Last change on this file since 35184 was 35184, checked in by kon, 10 months ago

add string-utils-extensions

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