Changeset 39544 in project

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:

• string-utils.egg (modified) (1 diff)
• string-utils.scm (modified) (3 diffs)
• tests/string-utils-test.scm (modified) (2 diffs)

release/5/string-utils/trunk/string-utils.egg

@@ -3 +3 @@
 
 ((synopsis "String Utilities")
- (version "2.3.2")
+ (version "2.4.0")
  (category data)
- (author "[[kon lovett]]")
+ (author "Kon Lovett")
  (license "BSD")
  (dependencies srfi-1 srfi-13 srfi-69 miscmacros check-errors utf8)

release/5/string-utils/trunk/string-utils.scm

@@ -6 +6 @@
 
 (;export
+  string-trim-whitespace-both
+  list-as-string
+  number->padded-string
+  string-fixed-length
+  string-longest-prefix
+  string-longest-suffix
   string-longest-common-prefix
-  #;string-longest-common-prefixes
-  string-fixed-length)
-
-(import scheme)
-(import (chicken base))
-(import (only utf8 string-length make-string substring #;string-append))
-(import (chicken sort))
-(import (chicken type))
-(import (only (srfi 1) append! reverse! append-map filter))
-(import (only utf8-srfi-13 string-null? string-take string-prefix-length))
-(import (only type-checks check-list check-char check-string check-fixnum))
-
-;;
-
-(: *string-longest-common-prefix (string (list-of string) procedure --> *))
-(: string-longest-common-prefix (string (list-of string) --> (or boolean string)))
-(: string-fixed-length (string fixnum #!rest --> string))
-
-;;
-
-(define string-longest-common-prefix-length string-prefix-length)
-
-;;
-
-(define (*string-longest-common-prefix cand others handler)
+  string-longest-common-suffix)
+
+(import scheme
+        (only utf8 string-length make-string substring) ;string-append
+        (chicken base)
+        (chicken type)
+        (chicken sort)
+        (only (chicken port) with-output-to-string)
+        (only (srfi 1) first any append! reverse! map! append-map filter)
+        (only utf8-srfi-13
+          string-null? string-take string-prefix-length string-trim-both string-pad string-reverse)
+        (only utf8-srfi-14
+          char-set:whitespace)
+        (only type-checks check-list check-char check-string check-fixnum))
+
+;;
+
+;(binary-predicate-reduce p? ls)
+;=> (and (p? (1st ls) (2nd ls)) (p? (2nd ls) (3rd ls)) ...)
+;
+(define (binary-predicate-reduce pred? ls)
+  (or (null? ls)
+      (let loop ((ls (cdr ls)) (prev (first ls)))
+        (or (null? ls)
+            (let ((curr (first ls)))
+              (and (pred? prev curr)
+                   (loop (cdr ls) curr) ) ) ) ) ) )
+
+;;
+
+(: string-trim-whitespace-both (string -> string))
+(: list-as-string (list -> string))
+(: number->padded-string (number fixnum #!optional char fixnum -> string))
+(: string-fixed-length (string fixnum #!rest -> string))
+
+(: *string-longest-common-prefix ((list-of (list-of char)) -> (list-of char)))
+(: string-longest-common-prefix ((list-of string) -> string))
+(: string-longest-common-suffix ((list-of string) -> string))
+
+(: *string-longest-prefix (string (list-of string) procedure -> *))
+(: string-longest-prefix (string (list-of string) -> (or boolean string)))
+(: string-longest-suffix (string (list-of string) -> (or boolean string)))
+
+;;
+
+(define (string-trim-whitespace-both str)
+  (string-trim-both str char-set:whitespace) )
+
+(define (list-as-string ls)
+  (with-output-to-string (cut write ls)) )
+
+(define (number->padded-string n wid #!optional (ch #\0) (base 10))
+  (string-pad (number->string n base) wid ch) )
+
+(define (string-fixed-length s n #!key (pad-char #\space) (trailing "..."))
+  (let (
+    (rem
+      (- (check-fixnum 'string-fixed-length n)
+         (string-length (check-string 'string-fixed-length s)))) )
+    (if (positive? rem)
+      (string-append s (make-string rem (check-char 'string-fixed-length pad-char)))
+      (let (
+        (lim (- n (string-length (check-string 'string-fixed-length trailing)))) )
+        (if (positive? lim)
+          (string-append (substring s 0 lim) trailing)
+          trailing ) ) ) ) )
+
+;;
+
+(define (*string-longest-common-prefix ls)
+  (let loop ((ls ls) (pre '()))
+    (if (any null? ls) pre
+      (let ((1st-chrs (map first ls)))
+        (if (not (binary-predicate-reduce char=? 1st-chrs)) pre
+          (loop (map cdr ls) (cons (first 1st-chrs) pre)) ) ) ) ) )
+
+(define (string-longest-common-prefix strs)
+  (let ((ls (map string->list strs)))
+    (list->string (reverse! (*string-longest-common-prefix ls))) ) )
+
+(define (string-longest-common-suffix strs)
+  (let ((ls (map! reverse! (map string->list strs))))
+    (list->string (*string-longest-common-prefix ls)) ) )
+
+;;
+
+(define (*string-longest-prefix cand others handler)
   ;-> (<prefix-length> <∈ others>)
   (define (prelength-tag item)
-    (cons (string-longest-common-prefix-length cand item) item) )
+    (cons (string-prefix-length cand item) item) )
   ;NOTE descending sort order!
   (define (prelength-tag> a b)
@@ -80 +148 @@
     (handler (sort coalesced prelength-coalesced>)) ) )
 
-;;
-
-(define (string-longest-common-prefix cand others)
-  (define (longest coalesced)
-    (and
-      (not (null? coalesced))
-      (let* (
-        (cell (car coalesced))
-        (len (car cell))
-        (strs (cdr cell)) )
-        (and (not (zero? len)) (string-take (car strs) len) ) ) ) )
-  (*string-longest-common-prefix
-    (check-string 'string-longest-common-prefix cand)
-    (check-list 'string-longest-common-prefix others)
-    longest) )
-
-#| ;BUG '("ba" "bar" "fooba") should be '(bar" "fooba") !
-
-==== string-longest-common-prefixes
-
-<procedure>(string-longest-common-prefixes STRINGS) --> (list-of string)</procedure>
-
-Returns the longest comment prefixes amongst the {{STRINGS}}.
-
-; STRINGS : {{(list-of string)}}
-
-;;
-
-(: string-longest-common-prefixes ((list-of string) --> (list-of string)))
+(define (*1st-prefix als)
+  (and
+    (not (null? als))
+    (let* (
+      (cell (car als))
+      (len (car cell))
+      (strs (cdr cell)) )
+      (and (not (zero? len)) (string-take (car strs) len) ) ) ) )
+
+;;
+
+(define (string-longest-prefix cand others)
+  (*string-longest-prefix
+    (check-string 'string-longest-prefix cand)
+    (check-list 'string-longest-prefix others)
+    *1st-prefix) )
+
+(define (string-longest-suffix cand others)
+  (and-let* (
+    (pre
+      (*string-longest-prefix
+        (string-reverse (check-string 'string-longest-suffix cand))
+        (map string-reverse (check-list 'string-longest-suffix others))
+        *1st-prefix)) )
+    (string-reverse pre) ) )
+
+#| ;this just a complicated scratchpad dump!
+(: string-longest-prefix+ (string (list-of string) --> (list-of string)))
 ;
-(define (string-longest-common-prefixes strs)
-  (let loop ((strs strs) (pres '()))
-    (if (null? strs)
-      pres
-      (let* (
-        (pre (string-longest-common-prefix (car strs) (cdr strs)))
-        (pres
-          (if (not pre)
-            pres
-            (cons pre pres))) )
-          (loop (cdr strs) pres) ) ) ) )
-|#
-
-#| ;this just a complicated scratchpad dump!
-;;
-
-(: string-longest-common-prefix+ (string (list-of string) --> (list-of string)))
-;
-(define (string-longest-common-prefix+ cand others)
+(define (string-longest-prefix+ cand others)
   (define (longest coalesced)
     (filter
@@ -139 +188 @@
             (if (zero? len) `(#f) (map (cut string-take <> len) strs) ) ) )
         coalesced)) )
-  (*string-longest-common-prefix cand others longest) )
+  (*string-longest-prefix cand others longest) )
 |#
 
-;;
-
-(define (string-fixed-length s n #!key (pad-char #\space) (trailing "..."))
-  (let (
-    (rem
-      (-
-        (check-fixnum 'string-fixed-length n)
-        (string-length (check-string 'string-fixed-length s)))) )
-    (if (positive? rem)
-      (string-append s (make-string rem (check-char 'string-fixed-length pad-char)))
-      (let (
-        (lim (- n (string-length (check-string 'string-fixed-length trailing)))) )
-        (if (positive? lim)
-          (string-append (substring s 0 lim) trailing)
-          trailing ) ) ) ) )
+#| ;BUG '("ba" "bar" "fooba") should be '(bar" "fooba") !
+
+==== string-longest-prefixes
+
+<procedure>(string-longest-prefixes STRINGS) --> (list-of string)</procedure>
+
+Returns the longest comment prefixes amongst the {{STRINGS}}.
+
+; STRINGS : {{(list-of string)}}
+
+;;
+
+(: string-longest-prefixes ((list-of string) --> (list-of string)))
+;
+(define (string-longest-prefixes strs)
+  (let loop ((strs strs) (pres '()))
+    (if (null? strs)
+      pres
+      (let* (
+        (pre (string-longest-prefix (car strs) (cdr strs)))
+        (pres
+          (if (not pre)
+            pres
+            (cons pre pres))) )
+          (loop (cdr strs) pres) ) ) ) )
+
+  (let ((strs ))
+    #; ;BUG '("ba" "bar" "fooba") should be '(bar" "fooba") !
+    (test '("ba" "bar" "fooba") (string-longest-prefixes strs)) )
+|#
 
 ) ;module string-utils

release/5/string-utils/trunk/tests/string-utils-test.scm

@@ -114 +114 @@
 (test-group "string-utils"
   (import utf8)
+
   (test "foo" (string-fixed-length "abcde" 1 #:trailing "foo"))
   (test "a..." (string-fixed-length "abcde" 4))
@@ -122 +123 @@
   (test "👀👩👚📷📺🎋" (string-fixed-length "👀👩👚📷📺" 6 #:pad-char #\U0001F38B))
 
-  (let ((strs '("foobaz" "foobar" "barbaz" "barfoo" "bazfoo")))
-    (test "foobar" (string-longest-common-prefix "foobarbaz" strs))
-    #; ;BUG '("ba" "bar" "fooba") should be '(bar" "fooba") !
-    (test '("ba" "bar" "fooba") (string-longest-common-prefixes strs)) )
+  (test "foo" (string-trim-whitespace-both "  foo \t \n  \r "))
+  (test "(a b)" (list-as-string '(a b)))
+  (test "...27" (number->padded-string 23 5 #\. 8))
+
+  (test "foobar" (string-longest-prefix "foobarbaz" '("foobaz" "foobar" "barbaz" "barfoo" "bazfoo")))
+  (test "barbaz" (string-longest-suffix "foobarbaz" '("foobaz" "foobar" "barbaz" "barfoo" "bazfoo")))
+
+  (test "fooba" (string-longest-common-prefix '("foobaz" "foobar")))
+  (test "foo" (string-longest-common-suffix '("bazfoo" "barfoo")))
 )