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

Last change on this file since 39830 was 39830, checked in by Kon Lovett, 4 months ago

add semantic-version & support

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