;;;; string-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Aug '10

(module string-utils

(;export
  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)
  ;-> (<prefix-length> <∈ others>)
  (define (prelength-tag item)
    (cons (string-longest-common-prefix-length cand item) item) )
  ;NOTE descending sort order!
  (define (prelength-tag> a b)
    (assume (
      (a (pair fixnum string))
      (b (pair fixnum string)) )
      (> (car a) (car a)) ) )
  ;NOTE descending sort order!
  (define (prelength-coalesced> a b)
    (assume (
      (a (pair fixnum list))
      (b (pair fixnum list)) )
      (if (= (car a) (car b))
        (> (length (cdr a)) (length (cdr b)))
        (> (car a) (car b))) ) )
  ;
  (let* (
    (cells
      (map prelength-tag others))
    (cells
      (sort cells prelength-tag>))
    (coalesced
      (foldl
        (lambda (coalesced cell)
          (assume (
            (cell (pair fixnum string)) )
            (let* (
              (len (car cell))
              (str (cdr cell))
              (strs `(,str)) )
              (if (null? coalesced)
                (cons (cons len strs) coalesced)
                (let (
                  (coalesced-cell (car coalesced)) )
                  (if (= len (car coalesced-cell))
                    ;share same
                    (begin
                      (set-cdr! coalesced-cell (append! strs (cdr coalesced-cell)))
                      coalesced)
                    ;changing of the guard
                    (cons (cons len strs) coalesced) ) ) ) ) ) )
        '()
        cells)) )
    ;longest
    (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 (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 (longest coalesced)
    (filter
      identity
      (append-map
        (lambda (cell)
          (let (
            (len (car cell))
            (strs (cdr cell)) )
            (if (zero? len) `(#f) (map (cut string-take <> len) strs) ) ) )
        coalesced)) )
  (*string-longest-common-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 ) ) ) ) )

) ;module string-utils