Changeset 39050 in project


Ignore:
Timestamp:
09/24/20 03:39:43 (5 weeks ago)
Author:
Kon Lovett
Message:

every vs any memoize, memoize is "pure", not predicates, rename conversion to follow convention, string-utils module needs utf8, fixed length is not memoized

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

Legend:

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

    r38937 r39050  
    99(;export
    1010  global-string
    11   make-string+
    12   string+)
     11  string+
     12  make-string+)
    1313
    1414(import scheme)
    1515(import (chicken base))
    1616(import (chicken type))
     17(import (only utf8 string make-string string-length string-ref))
     18(import (only utf8-srfi-13 string= string-hash))
    1719(import (only (srfi 1) every))
    18 (import (only (srfi 69)
    19   make-hash-table
    20   string-hash hash-table-ref/default
    21   hash-table-set!))
    22 (import (only unicode-utils
    23   ascii-codepoint? *unicode-string generic-make-string))
    24 (import (only type-checks
    25   check-list check-natural-fixnum check-char check-string))
     20(import (only (srfi 69) make-hash-table hash-table-ref/default hash-table-set!))
     21(import (only type-checks check-list check-natural-fixnum check-char check-string))
    2622
    2723;;
    2824
    29 (: global-string (string -> string))
    30 (: string+ (#!rest char -> string))
    31 (: make-string+ (number #!optional char -> string))
    32 (: *make-string+ (#!rest -> string))
     25(: global-string (string --> string))
     26(: string+ (#!rest char --> string))
     27(: make-string+ (fixnum #!optional char --> string))
    3328
    3429;;
     
    3833;;
    3934
    40 (define (global-string str)
    41   (*make-string+ (check-string 'global-string str)) )
     35(define (global-string str) (*string+ (check-string 'global-string str)))
    4236
    4337;;
     
    4640(define (string+ . chars)
    4741  (let ((len (length chars)))
    48     (if (zero? len) (*make-string+ 0 #f "")
     42    (if (zero? len) *empty-string*
    4943      (begin
    5044        #;(every (cut check-char 'string+ <>) chars)
    5145        (check-list 'string+ chars)
    52         (*make-string+ len (car chars) (delay (*unicode-string chars))) ) ) ) )
     46        (*string+ len (car chars) (delay (apply string chars))) ) ) ) )
    5347
    5448;; Memeoized `make-string'
     
    6155;;
    6256
     57(define (ensure-index-entry ht len ch dat)
     58  (let ((key `(,len . ,ch)))
     59    (or
     60      (hash-table-ref/default ht key #f)
     61      (let ((dat (force dat)))
     62        (hash-table-set! ht key dat)
     63        dat ) ) ) )
    6364
    64 (define *make-string+
    65   (let ((+global-strings+ (make-hash-table equal?)))
     65(define (ensure-string-entry ht len ch str)
     66  (let (
     67    (strtbl (ensure-index-entry ht len ch (delay (make-hash-table string= string-hash))) )
     68    (str (force str) ) )
     69    (or
     70      (hash-table-ref/default strtbl str #f)
     71      (begin
     72        (hash-table-set! strtbl str str)
     73        str ) ) ) )
    6674    ;
    67     (define (ensure-index-entry len ch dat)
    68       (let ((key `(,len . ,ch)))
    69         (or
    70           (hash-table-ref/default +global-strings+ key #f)
    71           (let ((dat (force dat)))
    72             (hash-table-set! +global-strings+ key dat)
    73             dat ) ) ) )
    74     ;
    75     (define (ensure-string-entry len ch str)
    76       (let (
    77         (strtbl (ensure-index-entry len ch (delay (make-hash-table string=? string-hash))) )
    78         (str (force str) ) )
    79         (or
    80           (hash-table-ref/default strtbl str #f)
    81           (begin
    82             (hash-table-set! strtbl str str)
    83             str ) ) ) )
    84     ;
     75
     76(define *string+
     77  (let ((+strings+ (make-hash-table equal?)))
    8578    (case-lambda
    8679      ((str)
    8780        (let* (
    88           (len (string-length str) )
    89           (ch (and (not (= 0 len)) (string-ref str 0)) ) )
    90           (*make-string+ len ch str) ) )
    91       ((len ch)
    92         (*make-string+ len ch (delay (generic-make-string len ch))) )
     81          (len (string-length str))
     82          (ch (and (not (= 0 len)) (string-ref str 0))) )
     83          (*string+ len ch str) ) )
    9384      ((len ch str)
    9485        (if (zero? len) *empty-string*
    95           (ensure-string-entry len ch str) ) ) ) ) )
     86          (ensure-string-entry +strings+ len ch str) ) ) ) ) )
     87
     88(define *make-string+
     89  (let ((+strings+ (make-hash-table equal?)))
     90    (case-lambda
     91      ((len ch)
     92        (*make-string+ len ch (delay (make-string len ch))) )
     93      ((len ch str)
     94        (if (zero? len) *empty-string*
     95          (ensure-index-entry +strings+ len ch str) ) ) ) ) )
    9696
    9797) ;module memoized-string
  • release/5/string-utils/trunk/string-utils.egg

    r38937 r39050  
    33
    44((synopsis "String Utilities")
    5  (version "2.3.1")
     5 (version "2.3.2")
    66 (category data)
    77 (author "[[kon lovett]]")
    88 (license "BSD")
    9  (dependencies
    10   (srfi-1 "0.1")
    11   (srfi-13 "0.1")
    12   (srfi-69 "0.1")
    13         (miscmacros "1.0")
    14         (utf8 "3.5.0")
    15         (check-errors "2.0.0"))
     9 (dependencies srfi-1 srfi-13 srfi-69 miscmacros check-errors utf8)
    1610 (test-dependencies test)
    1711 (components
  • release/5/string-utils/trunk/string-utils.scm

    r38937 r39050  
    1212(import scheme)
    1313(import (chicken base))
     14(import (only utf8 string-length make-string substring #;string-append))
    1415(import (chicken sort))
    1516(import (chicken type))
    1617(import (only (srfi 1) append! reverse! append-map filter))
    17 (import (only (srfi 13) string-null? string-take string-prefix-length))
    18 (import (only memoized-string make-string+))
     18(import (only utf8-srfi-13 string-null? string-take string-prefix-length))
    1919(import (only type-checks check-list check-char check-string check-fixnum))
    2020
     
    151151        (string-length (check-string 'string-fixed-length s)))) )
    152152    (if (positive? rem)
    153       (string-append s (make-string+ rem (check-char 'string-fixed-length pad-char)))
     153      (string-append s (make-string rem (check-char 'string-fixed-length pad-char)))
    154154      (let (
    155155        (lim (- n (string-length (check-string 'string-fixed-length trailing)))) )
  • release/5/string-utils/trunk/tests/string-utils-test.scm

    r38245 r39050  
    1414  (test-assert (ascii-codepoint? #\a))
    1515  (test "abc" (unicode-string #\a #\b #\c))
    16   (test "cebb" (string->hex (unicode-char->string #\U03BB)))
    17   (test "cebbcebbcebb" (string->hex (unicode-string #\U03BB #\U03BB #\U03BB)))
    18   (test "cebbcebb" (string->hex (unicode-make-string 2 #\U03BB)))
     16  (test "cebb" (string->hex (char->unicode-string #\u03BB)))
     17  (test "cebbcebbcebb" (string->hex (unicode-string #\u03BB #\u03BB #\u03BB)))
     18  (test "cebbcebb" (string->hex (unicode-make-string 2 #\u03BB)))
    1919)
    2020
     
    113113
    114114(test-group "string-utils"
     115  (import utf8)
    115116  (test "foo" (string-fixed-length "abcde" 1 #:trailing "foo"))
    116117  (test "a..." (string-fixed-length "abcde" 4))
    117118  (test "abc " (string-fixed-length "abc" 4))
     119  (test "👀..." (string-fixed-length "👀👩👚📷📺" 4))
     120  (test "👀👩🎑🎍" (string-fixed-length "👀👩👚📷📺" 4 #:trailing "🎑🎍"))
     121  #; ;FIXME char is not 24-bit
     122  (test "👀👩👚📷📺🎋" (string-fixed-length "👀👩👚📷📺" 6 #:pad-char #\U0001F38B))
    118123
    119124  (let ((strs '("foobaz" "foobar" "barbaz" "barfoo" "bazfoo")))
  • release/5/string-utils/trunk/unicode-utils.scm

    r38937 r39050  
    1919  ascii-codepoint?
    2020  unicode-surrogate?
    21   unicode-char->string
     21  char->unicode-string
    2222  unicode-string *unicode-string
    2323  generic-make-string
    2424  unicode-make-string *unicode-make-string
    25   unicode-surrogates->codepoint)
     25  unicode-surrogates->codepoint
     26  ;
     27  unicode-char->string)
    2628
    2729(import scheme)
     
    3436;;
    3537
    36 (: ascii-codepoint? (* -> boolean : char))
    37 (: unicode-surrogate? (* -> boolean : fixnum))
    38 (: unicode-char->string (char -> string))
     38(: ascii-codepoint? (* --> boolean))
     39(: unicode-surrogate? (* --> boolean))
     40(: char->unicode-string (char -> string))
     41(: unicode-char->string (deprecated char->unicode-string))
    3942(: *unicode-string ((list-of char) -> string))
    4043(: unicode-string (#!rest -> string))
     
    5659    (##sys#unicode-surrogate? n) ) )
    5760
    58 (define (unicode-char->string ch)
    59   (##sys#char->utf8-string (check-char 'unicode-char->string ch)) )
     61(define (char->unicode-string ch)
     62  (##sys#char->utf8-string (check-char 'char->unicode-string ch)) )
     63
     64(define unicode-char->string char->unicode-string)
    6065
    6166(define (*unicode-string chs)
     
    6671      (##sys#char->utf8-string (car chs)) )
    6772    (else
    68       (let (
    69         (chs (map ##sys#char->utf8-string chs)) )
    70         (##sys#fragments->string
    71           (foldl (lambda (l s) (+ l (the fixnum (##sys#size s)))) 0 chs)
    72           chs) ) ) ) )
     73      (let* (
     74        (sts (map ##sys#char->utf8-string chs))
     75        (cnt (foldl (lambda (l s) (+ l (the fixnum (##sys#size s)))) 0 sts)) )
     76        (##sys#fragments->string cnt sts) ) ) ) )
    7377
    7478;inefficient
Note: See TracChangeset for help on using the changeset viewer.