;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;    CKY-PARSER FOR PCFG
;;  
;;    RETURNERER DET MEST SANNSYNLIGE
;;    PARSETREET MED INPUTSTRENGEN SOM "YIELD"
;;    
;;    BRUKER N X N -tabell der N er inputlengde (+ 1) og 
;;    hver celle er en hashtabell indeksert p? ikketerminalene
;;    og med sannsynligheter som verdier.


(defun makeemptycell ()
  ;;
  ;; Lager hastabell med 0 for hver ikketerminal
  ;;
  (let ((newcell (make-hash-table)))
    (loop for cat in *nonterminals*
        do (setf (get cat newcell) 0))
    newcell))

(defun skriv (table i j key value)
  (let ((cell (aref table i j))) 
    (setf (get key cell) value)))


(defun les (table i j key)
  (get key (aref table i j)))

(defun build_tree (input back i j A)
  (if (eq (+ i 1) j)
      (list A (nth i input)) ; basistilfelle/leksikonoppslag
    (let* ((trippel (les back i j A))
           (k (first trippel))
           (B (first (rest trippel)))
           (C (first (rest (rest trippel)))))
      (list A
            (build_tree input back i k B)
            (build_tree input back k j C)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Rule and lexeme data types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct rule mother child1 child2 prob)

(defstruct lexeme pos form prob)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Recognizer.  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun parse (input)

  (let* ((n (length input))
         (table (make-array (list (+ n 1) (+ n 1))))
         (back  (make-array (list (+ n 1) (+ n 1)))))
    ;;                    
    ;; first, initialize table to all zero probabilities:
    ;;   
    (loop for i from 0 to n do
         (loop for j from 0 to n do
               (setf (aref table i j) (makeemptycell))
               (setf (aref back  i j) (makeemptycell))))
    ;;
    (loop for j from 1 to n do
          ;; fill in probabilities from lexicon:
          (loop for lexeme in *lexicon* do
                (if (eq (nth (- j 1) input) (lexeme-form lexeme))
                    (skriv table (- j 1) j (lexeme-pos lexeme) (lexeme-prob lexeme))))
          (loop for i from (- j 2) downto 0 do
                (loop for k from (+ i 1) to (- j 1) do
                      (loop for rule in *rules* do
                            (let ((new (* (rule-prob rule)
                                          (les table i k (rule-child1 rule))
                                          (les table k j (rule-child2 rule)))))
                              (if (> new (les table i j (rule-mother rule)))
                                  (progn 
                                    (skriv table i j (rule-mother rule) new)
                                    (skriv back i j (rule-mother rule) (list k 
                                                                            (rule-child1 rule)
                                                                            (rule-child2 rule))))))))))
    (build_tree input back 0 n *start-symbol*)))