minl.scm

(define (shortest-one S)
  (define (zip ls1 ls2)
    (if (or (null? ls1) (null? ls2)) '()
      (cons (cons (car ls1) (car ls2)) (zip (cdr ls1) (cdr ls2)))))
  (define (kons e1 e2)
    (if (< (cdr e1) (cdr e2)) e1 e2))
  (let* ((lens (map string-length S))
         (ls (zip S lens)))
    (car (fold kons (car ls) (cdr ls)))))

(define (sublist ls begin-idx end-idx)
  (let ((n (length ls)))
    (cond ((= begin-idx end-idx) '())
          ((and (<= 0 begin-idx) (<= end-idx n))
           (drop (take ls end-idx) begin-idx))
          (else '()))))

(use srfi-13)
(define (language-include S sigma)

  (define (string-include s sigma)
    (let loop ((idx 0) (ls sigma))
      (if (null? ls) #t
        (let* ((t (car ls))
               (rest (cdr ls))
               (idx* (string-contains s t idx)))
          (if idx*
            (loop (+ idx* (string-length t)) rest)
            #f)))))

  (every (cut string-include <> sigma) S))

(define (minl S)
  ; input S: non-empty finite set of strings
  ; Output p: a pattern containing S
  (let* ((s (shortest-one S))
         (sigma '())
         (n (string-length s))
         (m 0))
    (while (positive? n)
      (let for-i ((i 0))
        (let for-j ((j 0))
          (let ((sigma*
                 (append (sublist sigma 0 j)
                         (list (substring s i (+ i n)))
                         (sublist sigma j m))))
            (when (language-include S sigma*)
              (set! sigma sigma*)
              (set! m (length sigma*))
              (for-i i)))
          (when (< j m) (for-j (+ j 1))))
        (when (< i (- (string-length s) n))
          (for-i (+ i 1))))
      (set! n (min (- (string-length s) (length sigma)) (- n 1))))

    sigma))

(let ((S
        (list "This is a cat"
              "That is the cat"
              "This is not a dog")))
  (write (minl S))
  (newline))