source: project/release/5/string-utils/trunk/string-utils.scm @ 39544

Last change on this file since 39544 was 39544, checked in by Kon Lovett, 5 months ago

add 3 funcs, add suff/pre, add suff, fix name

File size: 6.6 KB
Line 
1;;;; string-utils.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Aug '10
4
5(module string-utils
6
7(;export
8  string-trim-whitespace-both
9  list-as-string
10  number->padded-string
11  string-fixed-length
12  string-longest-prefix
13  string-longest-suffix
14  string-longest-common-prefix
15  string-longest-common-suffix)
16
17(import scheme
18        (only utf8 string-length make-string substring) ;string-append
19        (chicken base)
20        (chicken type)
21        (chicken sort)
22        (only (chicken port) with-output-to-string)
23        (only (srfi 1) first any append! reverse! map! append-map filter)
24        (only utf8-srfi-13
25          string-null? string-take string-prefix-length string-trim-both string-pad string-reverse)
26        (only utf8-srfi-14
27          char-set:whitespace)
28        (only type-checks check-list check-char check-string check-fixnum))
29
30;;
31
32;(binary-predicate-reduce p? ls)
33;=> (and (p? (1st ls) (2nd ls)) (p? (2nd ls) (3rd ls)) ...)
34;
35(define (binary-predicate-reduce pred? ls)
36  (or (null? ls)
37      (let loop ((ls (cdr ls)) (prev (first ls)))
38        (or (null? ls)
39            (let ((curr (first ls)))
40              (and (pred? prev curr)
41                   (loop (cdr ls) curr) ) ) ) ) ) )
42
43;;
44
45(: string-trim-whitespace-both (string -> string))
46(: list-as-string (list -> string))
47(: number->padded-string (number fixnum #!optional char fixnum -> string))
48(: string-fixed-length (string fixnum #!rest -> string))
49
50(: *string-longest-common-prefix ((list-of (list-of char)) -> (list-of char)))
51(: string-longest-common-prefix ((list-of string) -> string))
52(: string-longest-common-suffix ((list-of string) -> string))
53
54(: *string-longest-prefix (string (list-of string) procedure -> *))
55(: string-longest-prefix (string (list-of string) -> (or boolean string)))
56(: string-longest-suffix (string (list-of string) -> (or boolean string)))
57
58;;
59
60(define (string-trim-whitespace-both str)
61  (string-trim-both str char-set:whitespace) )
62
63(define (list-as-string ls)
64  (with-output-to-string (cut write ls)) )
65
66(define (number->padded-string n wid #!optional (ch #\0) (base 10))
67  (string-pad (number->string n base) wid ch) )
68
69(define (string-fixed-length s n #!key (pad-char #\space) (trailing "..."))
70  (let (
71    (rem
72      (- (check-fixnum 'string-fixed-length n)
73         (string-length (check-string 'string-fixed-length s)))) )
74    (if (positive? rem)
75      (string-append s (make-string rem (check-char 'string-fixed-length pad-char)))
76      (let (
77        (lim (- n (string-length (check-string 'string-fixed-length trailing)))) )
78        (if (positive? lim)
79          (string-append (substring s 0 lim) trailing)
80          trailing ) ) ) ) )
81
82;;
83
84(define (*string-longest-common-prefix ls)
85  (let loop ((ls ls) (pre '()))
86    (if (any null? ls) pre
87      (let ((1st-chrs (map first ls)))
88        (if (not (binary-predicate-reduce char=? 1st-chrs)) pre
89          (loop (map cdr ls) (cons (first 1st-chrs) pre)) ) ) ) ) )
90
91(define (string-longest-common-prefix strs)
92  (let ((ls (map string->list strs)))
93    (list->string (reverse! (*string-longest-common-prefix ls))) ) )
94
95(define (string-longest-common-suffix strs)
96  (let ((ls (map! reverse! (map string->list strs))))
97    (list->string (*string-longest-common-prefix ls)) ) )
98
99;;
100
101(define (*string-longest-prefix cand others handler)
102  ;-> (<prefix-length> <∈ others>)
103  (define (prelength-tag item)
104    (cons (string-prefix-length cand item) item) )
105  ;NOTE descending sort order!
106  (define (prelength-tag> a b)
107    (assume (
108      (a (pair fixnum string))
109      (b (pair fixnum string)) )
110      (> (car a) (car a)) ) )
111  ;NOTE descending sort order!
112  (define (prelength-coalesced> a b)
113    (assume (
114      (a (pair fixnum list))
115      (b (pair fixnum list)) )
116      (if (= (car a) (car b))
117        (> (length (cdr a)) (length (cdr b)))
118        (> (car a) (car b))) ) )
119  ;
120  (let* (
121    (cells
122      (map prelength-tag others))
123    (cells
124      (sort cells prelength-tag>))
125    (coalesced
126      (foldl
127        (lambda (coalesced cell)
128          (assume (
129            (cell (pair fixnum string)) )
130            (let* (
131              (len (car cell))
132              (str (cdr cell))
133              (strs `(,str)) )
134              (if (null? coalesced)
135                (cons (cons len strs) coalesced)
136                (let (
137                  (coalesced-cell (car coalesced)) )
138                  (if (= len (car coalesced-cell))
139                    ;share same
140                    (begin
141                      (set-cdr! coalesced-cell (append! strs (cdr coalesced-cell)))
142                      coalesced)
143                    ;changing of the guard
144                    (cons (cons len strs) coalesced) ) ) ) ) ) )
145        '()
146        cells)) )
147    ;longest
148    (handler (sort coalesced prelength-coalesced>)) ) )
149
150(define (*1st-prefix als)
151  (and
152    (not (null? als))
153    (let* (
154      (cell (car als))
155      (len (car cell))
156      (strs (cdr cell)) )
157      (and (not (zero? len)) (string-take (car strs) len) ) ) ) )
158
159;;
160
161(define (string-longest-prefix cand others)
162  (*string-longest-prefix
163    (check-string 'string-longest-prefix cand)
164    (check-list 'string-longest-prefix others)
165    *1st-prefix) )
166
167(define (string-longest-suffix cand others)
168  (and-let* (
169    (pre
170      (*string-longest-prefix
171        (string-reverse (check-string 'string-longest-suffix cand))
172        (map string-reverse (check-list 'string-longest-suffix others))
173        *1st-prefix)) )
174    (string-reverse pre) ) )
175
176#| ;this just a complicated scratchpad dump!
177(: string-longest-prefix+ (string (list-of string) --> (list-of string)))
178;
179(define (string-longest-prefix+ cand others)
180  (define (longest coalesced)
181    (filter
182      identity
183      (append-map
184        (lambda (cell)
185          (let (
186            (len (car cell))
187            (strs (cdr cell)) )
188            (if (zero? len) `(#f) (map (cut string-take <> len) strs) ) ) )
189        coalesced)) )
190  (*string-longest-prefix cand others longest) )
191|#
192
193#| ;BUG '("ba" "bar" "fooba") should be '(bar" "fooba") !
194
195==== string-longest-prefixes
196
197<procedure>(string-longest-prefixes STRINGS) --> (list-of string)</procedure>
198
199Returns the longest comment prefixes amongst the {{STRINGS}}.
200
201; STRINGS : {{(list-of string)}}
202
203;;
204
205(: string-longest-prefixes ((list-of string) --> (list-of string)))
206;
207(define (string-longest-prefixes strs)
208  (let loop ((strs strs) (pres '()))
209    (if (null? strs)
210      pres
211      (let* (
212        (pre (string-longest-prefix (car strs) (cdr strs)))
213        (pres
214          (if (not pre)
215            pres
216            (cons pre pres))) )
217          (loop (cdr strs) pres) ) ) ) )
218
219  (let ((strs ))
220    #; ;BUG '("ba" "bar" "fooba") should be '(bar" "fooba") !
221    (test '("ba" "bar" "fooba") (string-longest-prefixes strs)) )
222|#
223
224) ;module string-utils
Note: See TracBrowser for help on using the repository browser.