;;;; memoized-string.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Oct '17
;;;; Kon Lovett, Aug '10

(module memoized-string

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

(import scheme utf8)
(import (chicken base))
(import (chicken type))
(import (chicken fixnum))
(import (only (srfi 1) member every))
(import (only (srfi 69)
  equal?-hash string-hash make-hash-table hash-table-ref/default hash-table-set!))
(import (only (check-errors sys)
  check-list check-fixnum check-char check-string check-exact-unsigned-integer))

(define-inline (check-natural-fixnum loc obj)
  (check-exact-unsigned-integer loc (check-fixnum loc obj)) )

;NOTE these are "pure" since 1:1 mapping arguments -> result

(: global-string (string -> string))
(: string+ (#!rest char -> string))

(: make-string+ (fixnum #!optional char -> string))

;;

;"intern" string
(define EMPTY-STRING "")

;;

(define index-key-hash equal?-hash)
(define (index-key=? a b) (and (= (car a) (car b)) (char=? (cdr a) (cdr b))))

(define (ensure-index-entry ht len ch dat)
  (let ((key `(,len . ,ch)))
    (or (hash-table-ref/default ht key #f)
        (let ((dat (force dat)))
          (hash-table-set! ht key dat)
          dat ) ) ) )

#; ;Unless >30 items too much
(define (ensure-string-entry ht len ch str)
  (let ((strtbl (ensure-index-entry ht len ch
                                    (delay (make-hash-table string=? string-hash))))
        (str (force str)) )
    (or (hash-table-ref/default strtbl str #f)
        (begin
          (hash-table-set! strtbl str str)
          str ) ) ) )
(define (ensure-string-entry ht len ch str)
  (let ((strs (ensure-index-entry ht len ch (delay `(_ . ())))) ;box
        (str (force str)) )
    (or (and-let* ((elm (member str (cdr strs) string=?))) (car elm))
        (begin
          (set-cdr! strs (cons str (cdr strs)))
          str ) ) ) )

;;

(define *string+
  (let ((+strings+ (make-hash-table index-key=? index-key-hash)))
    (case-lambda
      ;str not promise
      ((str)
        (let* ((len (string-length str))
               (ch (and (not (fx= 0 len)) (string-ref str 0))) )
          (*string+ len (or ch #\nul) str) ) )
      ;str maybe promise
      ((len ch str)
        (if (fx= 0 len) EMPTY-STRING
            (ensure-string-entry +strings+ len ch str) ) ) ) ) )

(define *make-string+
  (let ((+strings+ (make-hash-table index-key=? index-key-hash)))
    (case-lambda
      ((len ch)
        (*make-string+ len ch (delay (make-string len ch))) )
      ;str maybe promise
      ((len ch str)
        (if (fx= 0 len) EMPTY-STRING
            ;else there can be only one
            (ensure-index-entry +strings+ len ch str) ) ) ) ) )

;; Memeoized `string'

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

(define (string+ . chars)
  (let ((len (length chars)))
    (if (fx= 0 len) EMPTY-STRING
        (begin
          #; ;(cost N)
          (every (cut check-char 'string+ <>) chars)
          (check-list 'string+ chars)
          (*string+ len (car chars) (delay (apply string chars))) ) ) ) )

;; Memeoized `make-string'

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

) ;module memoized-string