Changeset 39544 in project


Ignore:
Timestamp:
01/29/21 03:04:13 (4 weeks ago)
Author:
Kon Lovett
Message:

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

Location:
release/5/string-utils/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/string-utils/trunk/string-utils.egg

    r39050 r39544  
    33
    44((synopsis "String Utilities")
    5  (version "2.3.2")
     5 (version "2.4.0")
    66 (category data)
    7  (author "[[kon lovett]]")
     7 (author "Kon Lovett")
    88 (license "BSD")
    99 (dependencies srfi-1 srfi-13 srfi-69 miscmacros check-errors utf8)
  • release/5/string-utils/trunk/string-utils.scm

    r39050 r39544  
    66
    77(;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
    814  string-longest-common-prefix
    9   #;string-longest-common-prefixes
    10   string-fixed-length)
    11 
    12 (import scheme)
    13 (import (chicken base))
    14 (import (only utf8 string-length make-string substring #;string-append))
    15 (import (chicken sort))
    16 (import (chicken type))
    17 (import (only (srfi 1) append! reverse! append-map filter))
    18 (import (only utf8-srfi-13 string-null? string-take string-prefix-length))
    19 (import (only type-checks check-list check-char check-string check-fixnum))
    20 
    21 ;;
    22 
    23 (: *string-longest-common-prefix (string (list-of string) procedure --> *))
    24 (: string-longest-common-prefix (string (list-of string) --> (or boolean string)))
    25 (: string-fixed-length (string fixnum #!rest --> string))
    26 
    27 ;;
    28 
    29 (define string-longest-common-prefix-length string-prefix-length)
    30 
    31 ;;
    32 
    33 (define (*string-longest-common-prefix cand others handler)
     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)
    34102  ;-> (<prefix-length> <∈ others>)
    35103  (define (prelength-tag item)
    36     (cons (string-longest-common-prefix-length cand item) item) )
     104    (cons (string-prefix-length cand item) item) )
    37105  ;NOTE descending sort order!
    38106  (define (prelength-tag> a b)
     
    80148    (handler (sort coalesced prelength-coalesced>)) ) )
    81149
    82 ;;
    83 
    84 (define (string-longest-common-prefix cand others)
    85   (define (longest coalesced)
    86     (and
    87       (not (null? coalesced))
    88       (let* (
    89         (cell (car coalesced))
    90         (len (car cell))
    91         (strs (cdr cell)) )
    92         (and (not (zero? len)) (string-take (car strs) len) ) ) ) )
    93   (*string-longest-common-prefix
    94     (check-string 'string-longest-common-prefix cand)
    95     (check-list 'string-longest-common-prefix others)
    96     longest) )
    97 
    98 #| ;BUG '("ba" "bar" "fooba") should be '(bar" "fooba") !
    99 
    100 ==== string-longest-common-prefixes
    101 
    102 <procedure>(string-longest-common-prefixes STRINGS) --> (list-of string)</procedure>
    103 
    104 Returns the longest comment prefixes amongst the {{STRINGS}}.
    105 
    106 ; STRINGS : {{(list-of string)}}
    107 
    108 ;;
    109 
    110 (: string-longest-common-prefixes ((list-of string) --> (list-of string)))
     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)))
    111178;
    112 (define (string-longest-common-prefixes strs)
    113   (let loop ((strs strs) (pres '()))
    114     (if (null? strs)
    115       pres
    116       (let* (
    117         (pre (string-longest-common-prefix (car strs) (cdr strs)))
    118         (pres
    119           (if (not pre)
    120             pres
    121             (cons pre pres))) )
    122           (loop (cdr strs) pres) ) ) ) )
    123 |#
    124 
    125 #| ;this just a complicated scratchpad dump!
    126 ;;
    127 
    128 (: string-longest-common-prefix+ (string (list-of string) --> (list-of string)))
    129 ;
    130 (define (string-longest-common-prefix+ cand others)
     179(define (string-longest-prefix+ cand others)
    131180  (define (longest coalesced)
    132181    (filter
     
    139188            (if (zero? len) `(#f) (map (cut string-take <> len) strs) ) ) )
    140189        coalesced)) )
    141   (*string-longest-common-prefix cand others longest) )
     190  (*string-longest-prefix cand others longest) )
    142191|#
    143192
    144 ;;
    145 
    146 (define (string-fixed-length s n #!key (pad-char #\space) (trailing "..."))
    147   (let (
    148     (rem
    149       (-
    150         (check-fixnum 'string-fixed-length n)
    151         (string-length (check-string 'string-fixed-length s)))) )
    152     (if (positive? rem)
    153       (string-append s (make-string rem (check-char 'string-fixed-length pad-char)))
    154       (let (
    155         (lim (- n (string-length (check-string 'string-fixed-length trailing)))) )
    156         (if (positive? lim)
    157           (string-append (substring s 0 lim) trailing)
    158           trailing ) ) ) ) )
     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|#
    159223
    160224) ;module string-utils
  • release/5/string-utils/trunk/tests/string-utils-test.scm

    r39050 r39544  
    114114(test-group "string-utils"
    115115  (import utf8)
     116
    116117  (test "foo" (string-fixed-length "abcde" 1 #:trailing "foo"))
    117118  (test "a..." (string-fixed-length "abcde" 4))
     
    122123  (test "👀👩👚📷📺🎋" (string-fixed-length "👀👩👚📷📺" 6 #:pad-char #\U0001F38B))
    123124
    124   (let ((strs '("foobaz" "foobar" "barbaz" "barfoo" "bazfoo")))
    125     (test "foobar" (string-longest-common-prefix "foobarbaz" strs))
    126     #; ;BUG '("ba" "bar" "fooba") should be '(bar" "fooba") !
    127     (test '("ba" "bar" "fooba") (string-longest-common-prefixes strs)) )
     125  (test "foo" (string-trim-whitespace-both "  foo \t \n  \r "))
     126  (test "(a b)" (list-as-string '(a b)))
     127  (test "...27" (number->padded-string 23 5 #\. 8))
     128
     129  (test "foobar" (string-longest-prefix "foobarbaz" '("foobaz" "foobar" "barbaz" "barfoo" "bazfoo")))
     130  (test "barbaz" (string-longest-suffix "foobarbaz" '("foobaz" "foobar" "barbaz" "barfoo" "bazfoo")))
     131
     132  (test "fooba" (string-longest-common-prefix '("foobaz" "foobar")))
     133  (test "foo" (string-longest-common-suffix '("bazfoo" "barfoo")))
    128134)
    129135
Note: See TracChangeset for help on using the changeset viewer.