;;;; memoized-string.scm  -*- Hen -*-
;;;; Kon Lovett, Oct '17
;;;; Kon Lovett, Aug '10

(module memoized-string

;FIXME should export 'global-string', 'string' & 'make-string'
(;export
  memorize-string
  make-string+
  string+
  ;DEPRECATED
  make-string*)

(import scheme)

(import chicken)

(import
  (only srfi-1 every)
  (only srfi-69
    make-hash-table
    string-hash
    hash-table-ref/default hash-table-set!)
  (only unicode-utils
    ascii-codepoint?
    *unicode-string
    generic-make-string)
  (only type-checks
    check-natural-fixnum check-char check-string))
(require-library srfi-1 srfi-69 unicode-utils type-checks)

;;

(define *empty-string* "")

;;

(define (memorize-string str)
  (*string+ (check-string 'memorize-string str)) )

;;

(define (string+ . chars)
  (every (cut check-char 'string+ <>) chars)
  (*string+ (*unicode-string chars)) )

;; Memeoized `make-string'

;len - length of string in chars
(define (make-string+ len #!optional (fill #\space))
  (*make-string+
    (check-natural-fixnum 'make-string+ len)
    (check-char 'make-string+ fill)) )

;;

(define *string+
  (let ((+diff-strings+ (make-hash-table string=? string-hash)))
    (lambda (str)
      (if (fx= 0 (string-length str))
        *empty-string*
        (or
          (hash-table-ref/default +diff-strings+ str #f)
          (begin
            (hash-table-set! +diff-strings+ str str)
            str ) ) ) ) ) )

(define *make-string+
  (let ((+same-strings+ (make-hash-table equal?)))
    (case-lambda
      ((len ch)
        (*make-string+ len ch (delay (generic-make-string len ch))) )
      ((len ch str)
        (if (fx= 0 len)
          *empty-string*
          (let ((key `(,ch . ,len)))
            (or
              (hash-table-ref/default +same-strings+ key #f)
              (let ((str (force str)))
                (hash-table-set! +same-strings+ key str)
                str ) ) ) ) ) ) ) )

;DEPRECATED
(define make-string* make-string+)

) ;module memoized-string