;; Musterloesung fuer das 3. Uebungsblatt


(in-package "USER")

;;------------------------------------------------------------
;; Aufgabe 1. Automatenoperationen 
;;
;; Aufgabe 1.a)

;; Zuerst definieren wir mal Hilfsfunktionen, um die Hoehe und Breite 
;; einer Uebergangstabelle zu bestimmen.

(defun table-width (transition-table)
  (array-dimension transition-table 1))

(defun table-height (transition-table)
  (array-dimension transition-table 0))

;; verschiebe-automat uebertraegt eine kleine Uebergangstabelle in 
;; eine groessere Uebergangstabelle. Der Offset bestimmt die Position
;; innerhalb der grossen Tabelle. 

(defun verschiebe-automat (small big offset)
  
  (let ((small-width (table-width small))
	(big-width (table-width big))
	(small-height (table-height small))
	(big-height (table-height big)))
    
    ;; Wir ueberpruefen wichtige Randbedingungen fuer die Operation
    ;; und geben qualifizierte Fehlermeldungen aus, falls diese nicht
    ;; eingehalten werden.
    (unless (= big-width small-width)
      (error "Die Breiten von SMALL (~A) und BIG (~A) sind ungleich!"
             small-width big-width))
    (unless (>= big-height (+ small-height offset))
      (error "Die Hoehe von BIG (~A) reicht nicht aus,
um SMALL (~A) mit einem Offset von (~A) aufzunehmen"
             big-height small-height offset))
    
    (loop for source-line from 0 below small-height
	for target-line = (+ source-line offset)
	do (setf (aref big target-line 0) ;; copy final-state
             (aref small source-line 0))
	do (loop for column from 1 below small-width ;; copy next-states
               do (setf (aref big target-line column) 
                    (mapcar #'(lambda (num) (+ num offset))
                            (aref small source-line column)))))
    big))

;; Und jetzt testen wir mal.

(defvar *container* nil)
(setf *container* (make-array '(10 5)))

(defvar *a* )
(setf *a*
  (make-array '(2 5)
              :initial-contents '((NIL NIL (1) NIL NIL)
                                  (AA NIL NIL NIL NIL))))
(defvar *b*)
(setf *b* (make-array '(2 5)
		      :initial-contents '((NIL NIL NIL (1) NIL)
					  (bb NIL NIL NIL NIL))))

;;;USER(7): (verschiebe-automat *a* *container* 2)
;;;#2A((NIL NIL NIL NIL NIL)
;;;    (NIL NIL NIL NIL NIL)
;;;    (NIL NIL (3) NIL NIL)
;;;    (AA NIL NIL NIL NIL)
;;;    (NIL NIL NIL NIL NIL)
;;;    (NIL NIL NIL NIL NIL)
;;;    (NIL NIL NIL NIL NIL)
;;;    (NIL NIL NIL NIL NIL)
;;;    (NIL NIL NIL NIL NIL)
;;;    (NIL NIL NIL NIL NIL))

;;;USER(10): (verschiebe-automat *a* *b* 2)
;;;Error: Die Hoehe von BIG (2) reicht nicht aus,
;;;um SMALL (2) mit einem Offset von (2) aufzunehmen


;; Zum Testen definiere ich mir eine kleine, sehr harmlose token2code Funktion,
;; die nur ueber dem Alphabet {a, b, c} definiert ist. Diese Funktion evaluiere
;; ich nur im Listener.
#| 
(defun token2code (token)
  (case token
    (#\a 2)
    (#\b 3)
    (#\c 4)))
|#

(defun traverse-string (table input &optional 
				    (state 0) (position 0) (n (length input)))
  (append
   ;; Folge zunaechst allen Epsilon-Uebergaengen und sammle die Endzustaende
   (loop for next-eps-state in (aref table state 1)
       append (traverse-string table input next-eps-state position n))
   ;; Arbeite das naechste Eingabezeichen ab
   ;; oder
   ;; falls die Eingabe abgearbeitet ist 
   (if (= n position)
       ;; ist es ein Endzustand ? Dann bestimme seinen "Wert".
       (when (aref table state 0) (list (aref table state 0)))
     ;; sonst arbeite das naechste Eingabezeichen ab.
     (loop for next-state in
	   (aref table state (token2code (schar input position)))
	 append (traverse-string table input next-state (1+ position) n)))))

;; Aufgabe 1.b)

(defun concat-automata (r-table s-table)
  ;; bestimme neue Gr"osse
  ;; erzeuge neue Tabelle
  ;; verschiebe R-TABELLE mit OFFSET 0
  ;; verschiebe S-TABELLE mit OFFSET Gr"osse-von-r
  ;; f"uge den/die epsilon-"Uberg"ange hinzu
  ;; l"osche Endzust"ande von R-TABELLE
  (let* ((offset (table-height r-table))
	 (new-height (+ offset
			(table-height s-table)))
	 (new-table (make-array (list new-height (table-width r-table)))))
    (verschiebe-automat r-table new-table 0)
    (verschiebe-automat s-table new-table offset)
    (loop for state from 0 below offset
        when (aref new-table state 0) ;; es ist ein Endzustand
        do (setf (aref new-table state 1)
             (list offset)
             (aref new-table state 0)
             nil))
    new-table))

(defun join-automata (r-table s-table)
  ;; bestimme neue Gr"osse
  ;; erzeuge neue Tabelle
  ;; neuer Startzustand
  ;; verschiebe R-TABELLE mit OFFSET 1
  ;; verschiebe S-TABELLE mit OFFSET Gr"osse-von-r
  ;; neuer Endzustand
  ;; f"uge den/die epsilon-"Uberg"ange hinzu
  ;; l"osche Endzust"ande von S/R-TABELLE
  (let* ((offset (1+ (table-height r-table)))
	 (new-height (+ offset
			(table-height s-table)
			1))  ;; neuer Endzustand
	 (new-table (make-array (list new-height (table-width r-table)))))
    (setf (aref new-table 0 1) (list 1 offset))
    (verschiebe-automat r-table new-table 1)
    (verschiebe-automat s-table new-table offset)
    (setf (aref new-table (1- new-height) 0) 'final-state) ;; neuer Endzustand
    (loop for state from 1 below (1- new-height)
        when (aref new-table state 0) ;; es ist ein Endzustand
        do (setf (aref new-table state 1) ;; espilon-"Ubergang zum 
             (list (1- new-height))   ;; neuen Endzustand
             (aref new-table state 0)
             nil))
    new-table))

;; Variante von join-automata, die keine neuen Endzustände erzeugt (ein
;; bisschen anders als in der schematischen Darstellung der Vorlesung).
;; Die brauchen wir so auch fuer Aufgabe 2!

(defun join-automata (r-table s-table)

  (let* ((offset (1+ (table-height r-table)))
	 (new-height (+ offset
			(table-height s-table)))
	 (new-table (make-array (list new-height (table-width r-table)))))
    (setf (aref new-table 0 1) (list 1 offset))
    (verschiebe-automat r-table new-table 1)
    (verschiebe-automat s-table new-table offset)
    new-table))

(defun kleene-star (r-table)
  ;; bestimme neue Gr"osse
  ;; erzeuge neue Tabelle
  ;; neuer Startzustand
  ;; verschiebe R-TABELLE mit OFFSET 1
  ;; f"uge den/die epsilon-"Uberg"ange hinzu
  ;; l"osche Endzust"ande von R-TABELLE
  ;; mache alten Startzustand zum neuen Endzustand
  (let* ((new-height (1+ (table-height r-table)))
	 (new-table (make-array (list new-height
				      (table-width r-table)))))
    (setf (aref new-table 0 1)  ;; neuer Startzustand m. epsilon-uebergang
      (list 1))
    (verschiebe-automat r-table new-table 1)
    (loop for state from 1 below new-height
        when (aref new-table state 0) ;; es ist ein Endzustand
        do (setf (aref new-table state 1) ;; epsilon-"Ubergang zum 
             (list 1)   ;; neuen Endzustand
             (aref new-table state 0)
             nil))
    (setf (aref new-table 1 0) ;; alter Startzustand zum neuen Endzustand
      'final-state) 
    new-table))


;;;USER(4): (setf *conc* (concat-automata *a* *b*))
;;;#2A((NIL NIL (1) NIL NIL)
;;;    (NIL (2) NIL NIL NIL)
;;;    (NIL NIL NIL (3) NIL)
;;;    (BB NIL NIL NIL NIL))
;;;USER(5): (setf *join* (join-automata *a* *b*))
;;;#2A((NIL (1 3) NIL NIL NIL)
;;;    (NIL NIL (2) NIL NIL)
;;;    (AA NIL NIL NIL NIL)
;;;    (NIL NIL NIL (4) NIL)
;;;    (BB NIL NIL NIL NIL))
;;;USER(6): (setf *kleene* (kleene-star *a*))
;;;#2A((NIL (1) NIL NIL NIL)
;;;    (FINAL-STATE NIL (2) NIL NIL)
;;;    (NIL (1) NIL NIL NIL))
;;;USER(7): (traverse-string *conc* "ab")
;;;(BB)
;;;USER(8): (traverse-string *conc* "ba")
;;;NIL
;;;USER(9): (traverse-string *join* "a")
;;;(AA)
;;;USER(10): (traverse-string *join* "c")
;;;NIL
;;;USER(11): (traverse-string *kleene* "")
;;;(FINAL-STATE)
;;;USER(12): (traverse-string *kleene* "aaaaa")
;;;(FINAL-STATE)
;;;USER(13): (traverse-string *kleene* "aabaaa")
;;;NIL


;;------------------------------------------------------------
;; Aufgabe 2. Wortautomaten
;;
;; Aufgabe 2.a)


(defparameter *tokens2codes* (make-array 256))

(defparameter *code-maximum*
  (loop
      with j = 1
      for i from 0 to 255 by 1
      when (alphanumericp (code-char i))
      do
        (setf (aref *tokens2codes* i) (incf j))
      finally (return j)))

(defun token2code (token)
  (aref *tokens2codes* (char-code token)))

(defun string2table (string)
  (loop with length = (length string)
      with table = (make-array (list (1+ length) (1+ *code-maximum*)))
      for i from 0 below length
      do (setf (aref table i (token2code (schar string i))) (list (+ i 1)))
      finally
	(setf (aref table length 0) string)
        (return table)))

(defun stringlist2table (stringlist)
  (when (null stringlist)
    (error "STRINGLIST2TABLE Es muss wenigstens ein String gegeben sein."))
  (let ((initial-automaton (string2table (first stringlist))))
    (if (> (length stringlist) 1)
	(join-automata initial-automaton
		       (stringlist2table (rest stringlist)))
      initial-automaton)))

;;; Elegante Lösung von Tanja Scheffler:
(defun reduce-stringlist2table (stringlist)
  (reduce #'join-automata (mapcar #'string2table stringlist)))

;;; Dabei ist der Aufbau des Automaten sehr langsam, selbst mit
;;; kompilierten Funktionen:

; (time (setq *table100* (reduce-stringlist2table *wortliste100*)))
; cpu time (non-gc) 2,150 msec user, 0 msec system
; cpu time (gc)     60 msec user, 0 msec system
; cpu time (total)  2,210 msec user, 0 msec system
; real time  2,282 msec
; space allocation:
;  30,011 cons cells, 0 symbols, 7,562,384 other bytes

; (time (traverse-string *table100* "zwischen"))
; cpu time (non-gc) 0 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  0 msec user, 0 msec system
; real time  0 msec
; space allocation:
;  426 cons cells, 0 symbols, 32 other bytes
; ("zwischen")

;  ...und über 5 Minuten für 1000 Worte!

; (time (setq *table1000* (reduce-stringlist2table *wortliste1000*)))
; cpu time (non-gc) 315,330 msec (00:05:15.330) user, 30 msec system
; cpu time (gc)     22,350 msec user, 40 msec system
; cpu time (total)  337,680 msec (00:05:37.680) user, 70 msec system
; real time  349,250 msec (00:05:49.250)
; space allocation:
;  4,053,686 cons cells, 0 symbols, 1,036,557,584 other bytes

; (time (traverse-string *table1000* "zwischen"))
; cpu time (non-gc) 0 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  0 msec user, 0 msec system
; real time  6 msec
; space allocation:
;  4,066 cons cells, 0 symbols, 32 other bytes
; ("zwischen")

; Bessere Lösung (s. auch Übung 4, Aufgabe 1a)

; ---------------------- Aufgabe 2b ----------------------

; neue Version als Ersatz für string2table

(defun cons2table (cons-zelle)
  (loop with string = (first cons-zelle)
	with final-value = (rest cons-zelle)	
	with length = (length string)
	with table = (make-array (list (1+ length) (1+ *code-maximum*)))
	for i from 0 below length
	do (setf (aref table i (token2code (schar string i))) (list (+ i 1)))
	finally
	(setf (aref table length 0) final-value)
        (return table)))

(defun reduce-conslist2table (conslist)
  (reduce #'join-automata (mapcar #'cons2table conslist)))

; Wieder nicht effizient, hier Daten für ein verkürztes Lexikon:

; (length *lexicon-small*)
; 78

; (time (setq *table-lex-small* (reduce-conslist2table *lexicon-small*)))
; cpu time (non-gc) 2,160 msec user, 20 msec system
; cpu time (gc)     170 msec user, 10 msec system
; cpu time (total)  2,330 msec user, 30 msec system
; real time  2,419 msec
; space allocation:
;  30,067 cons cells, 0 symbols, 7,605,040 other bytes

; (time (traverse-string *table-lex-small* "Anerkennung"))
; cpu time (non-gc) 0 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  0 msec user, 0 msec system
; real time  0 msec
; space allocation:
;  404 cons cells, 0 symbols, 32 other bytes
; (NN)



;;------------------------------------------------------------
;; Aufgabe 3. Erkennen von Patterns
;;
;; B)

(defparameter *category2code-max* 0)
(defparameter *category2code-table* NIL)

;; die sollte nach Aufgabe category2code heissen, was nicht konsequent ist.
(defun construct-cat2code (patterns)
  (setf *category2code-max* 2)
  (setf *category2code-table* (make-hash-table))
  (loop for pat in patterns
      do (loop for tag in (rest pat)
             unless (gethash tag *category2code-table*)
             do (setf (gethash tag *category2code-table*)
                  (incf *category2code-max*)))))

(defun category2code (category)
  (gethash category *category2code-table*))

;;; A) 

(defun pattern2table (pattern)
  (loop with categories = (rest pattern)
      with length = (length categories)
      with table = (make-array (list (1+ length)
                                     (1+ *code-maximum*)))
      for category in categories
      for i from 0
      do (setf (aref table i (category2code category))
           (list (+ i 1)))
      finally
	(setf (aref table length 0) 
          (first pattern))
        (return table)))

(defun patterns2table (patterns)
  (reduce #'join-automata (mapcar #'pattern2table patterns)))


;;;USER(56): (construct-cat2code *patterns*)
;;;NIL
;;;USER(57): (setf *np-pp-fst* (patterns2table *patterns*))
;;;#2A((NIL (1 49) NIL NIL NIL NIL NIL NIL NIL NIL ...)
;;;    (NIL (2 44) NIL NIL NIL NIL NIL NIL NIL NIL ...)
;;;    (NIL (3 39) NIL NIL NIL NIL NIL NIL NIL NIL ...)
;;;    (NIL (4 35) NIL NIL NIL NIL NIL NIL NIL NIL ...)
;;;    (NIL (5 32) NIL NIL NIL NIL NIL NIL NIL NIL ...)
;;;    (NIL (6 28) NIL NIL NIL NIL NIL NIL NIL NIL ...)
;;;    (NIL (7 25) NIL NIL NIL NIL NIL NIL NIL NIL ...)
;;;    (NIL (8 21) NIL NIL NIL NIL NIL NIL NIL NIL ...)
;;;    (NIL (9 16) NIL NIL NIL NIL NIL NIL NIL NIL ...)
;;;    (NIL (10 13) NIL NIL NIL NIL NIL NIL NIL NIL ...)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Schmoekaufgabe 4
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun traverse-list (table input &key (state 0) (code-fn #'category2code))
  (nconc
   ;; Folge zunaechst allen Epsilon-Uebergaengen und sammele die Endzustaende
   (loop for next-eps-state in (aref table state 1)
       nconc (traverse-list table input :state next-eps-state))
   ;; Arbeite das naechste Eingabezeichen ab
   ;; oder
   ;; falls die Eingabe abgearbeitet ist
   (if (endp input)
       ;; ist es ein Endzustand ? Dann bestimme seinen "Wert".
       (when (aref table state 0) (list (aref table state 0)))
     ;; sonst arbeite das naechste Eingabezeichen ab.
     (loop for next-state in (aref table state
                                   (funcall code-fn (first input)))
         nconc (traverse-list table (rest input) :state next-state)))))


;;;USER(58): (traverse-list *np-pp-fst* '(ADV ART ADJA NN))
;;;(NP)