(in-package "USER")

;;;
;;; ?? original code by Stephan Oepen
;;; 

;;;
;;; `haha' + `hihi' --- konkatenive verknuepfung von automaten
;;;

;;;
;;; automatenbeschreibung als uebergangstabelle; spalte 0 zeigt endzustaende
;;;

(defparameter *haha* 
    (make-array (list 3 4)
                :initial-contents '((nil (1) nil nil)
                                    (nil nil (0 2) nil)
                                    (:ha nil nil nil))))

(defparameter *hihi* 
    (make-array (list 3 4)
                :initial-contents '((nil (1) nil nil)
                                    (nil nil nil (2))
                                    (:hi (1) nil nil))))

;;;
;;; abbildung zwischen eingabesymbolen und spalten 1 .. n der tabelle
;;;

(defun token2code (token)
  (case token
    (#\h 1)
    (#\a 2)
    (#\i 3)))

;;;
;;; konkatenation von .prefix. und .suffix.  erzeugt neue uebergangstabelle, in
;;; die (i) alle uebergange von .prefix. einkopiert werden, (ii) alle
;;; uebergange aus .suffix. um die laenge von .prefix. (zahl der zustaende) - 1
;;; nach hinten geschoben (umbenannt) sind und (iii) alle endzustaende von
;;; .prefix. nicht mehr als endzustand gelten, sondern mit dem eingangszustand
;;; von .suffix. verknuepft sind (vereinigung der uebergaenge).  ergebnis ist
;;; moeglicherweise nicht deterministisch, auch wenn .prefix. und .suffix.
;;; deterministisch sind. 
;;;

(defun concatenate-automata (prefix suffix)

  (let* ((width (array-dimension prefix 1))
         (offset (- (array-dimension prefix 0) 1))
         (sstates (array-dimension suffix 0))
         (new (make-array (list (+ offset sstates) width))))

    (loop
        for i from 0 to offset by 1
        for finalp = (aref prefix i 0)
        do 
          (loop
              for j from 1 by 1
              while (< j width)
              unless finalp do
                ;;
                ;; copy all information from .prefix. into .new. transition 
                ;; table ...
                ;;
                (setf (aref new i j) 
                   ;;
                   ;; copy explicitly to make .new. fully self-contained
                   ;;
                   (copy-list (aref prefix i j)))
              else do 
                ;;
                ;; ... and connect .suffix. transitions from initial state to
                ;; .prefix. final states, where appropriate
                ;;
                (setf (aref new i j)
                   ;;
                   ;; append() copies all but its last argument; luckily, the
                   ;; `collect' yields fresh cons()es anyway
                   ;;
                   (append (aref prefix i j)
                           (loop
                               for next in (aref suffix 0 j)
                               collect (+ next offset))))))
    ;;
    ;; append .suffix. transition table to .new. starting from .offset.
    ;;
    (loop
        for i from 1 by 1
        while (< i sstates)
        do
          ;;
          ;; assume that values associated with final states are symbols ---
          ;; thus, no explicit copy is required
          ;;
          (setf (aref new (+ offset i) 0) (aref suffix i 0))
          (loop
              for j from 1 by 1
              while (< j width)
              do
                (setf (aref new (+ offset i) j)
                  (loop
                      for next in (aref suffix i j)
                      collect (+ next offset)))))
    new))

;;;
;;; _beispiele_
;;;
;;;   (traverse (concatenate-automata *haha* *hihi*) "hahahihi") --> :hi
;;;   (traverse (concatenate-automata *haha* *hihi*) "haha") --> nil
;;;   (traverse (concatenate-automata *haha* *hihi*) "hihi") --> nil
;;;