;;;; 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
  (chicken base)
  (chicken fixnum)
  (chicken sort)
  (chicken type)
  (only (srfi 1) append! reverse!)
  (only (srfi 13) string-null? string-take string-prefix-length)
  (only memoized-string make-string+)
  (only type-checks check-char check-string check-fixnum ))

;;

(define string-longest-common-prefix-length string-prefix-length)

;;

(: string-longest-common-prefix (string (list-of string) -> (or boolean string)))
;
(define (string-longest-common-prefix cand others)
  ;
  (define (prelen item)
    (string-longest-common-prefix-length cand item) )
  ;
  (let* (
    (cells
      (map (lambda (item) (cons (prelen item) item)) others))
    (cells
      (sort cells (lambda (a b) (fx> (car a) (car b)))))
    (coalesced
      (foldl
        (lambda (coalesced cell)
          (let* (
            (len (car cell))
            (str (cdr cell))
            (strs `(,str)) )
            (if (null? coalesced)
              (cons (cons len strs) coalesced)
              (let (
                (coalesced-cell (car coalesced)) )
                (if (fx= 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))
    (coalesced
      (sort
        coalesced
        (lambda (a b)
          (if (fx= (car a) (car b))
            (fx> (length (cdr a)) (length (cdr b)))
            (fx> (car a) (car b)))))) )
    ;longest
    (if (null? coalesced)
      #f
      (let* (
        (cell (car coalesced))
        (strs (cdr cell)) )
        (string-take (car strs) (car cell)) ) ) ) )

;;

(: 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))))
        (let (
          (pres
            (if (or (not pre) (string-null? pre))
              pres
              (cons pre pres))) )
          (loop (cdr strs) pres) ) ) ) ) )

;;

(: string-fixed-length (string fixnum #!rest --> string))
;
(define (string-fixed-length s n #!key (pad-char #\space) (trailing "..."))
  (let (
    (rem
      (fx-
        (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 (fx- n (string-length (check-string 'string-fixed-length trailing)))) )
        (if (positive? lim)
          (string-append (substring s 0 lim) trailing)
          trailing ) ) ) ) )

) ;module string-utils