(defpackage :expressm
  (:export :m :m-all :fathom-init :make-stream-and-talk)
  (:use :common-lisp :theoretica :english :radiplex :fathomr :db :util))
(in-package :expressm)

;;;; Input and output to the fathomr.

(defparameter *ind* 0 "Used to index words of a sentence passed in.")

(defparameter *word-index* (make-hash-table) "Position of word in sentence.")

(defparameter *last-phrase* nil "When we need to know what was said last.")


(defstruct parse
  "Used to hold morphological info returned from server." 
  constituents relations)


(defun m (phrase &optional clear-context)
  ;; what do we need?
  ;; - what is the parse tree and semantic info from the parser?
  ;; - what is the result of their semantic interpretation?
  ;; - return the phrase that the result is the tree of
  ;;   * therefore, we are assuming that the fathomr has instantiated a parse tree
  ;;     from previous examples -- or is that done here? fathomr only semantics?
  ;;   * how can we arrange a parse tree so that semantics lead to it?
  ;;     componentization and selection of structure based on semantics?
  ;;     how to componentize? source -function-> target instances, piecemeal formed
  ;;     (each of which can be composed of an sft)
  ;;     how the semantics of a parsed phrase fits within a context affects the
  ;;     semantics of previous and subsequent phrases, and therefore the how the
  ;;     semantics form (forming how to form)
  (unless (get-one (hashid *void*))
    (init))
  (if clear-context
      (fathom nil)
    (let ((parse (first (get-parses phrase))))
      (multiple-value-bind (tree elements parts)
          (parse-tree (second (parse-constituents parse)))
        (let ((new (make-instance 'immediate
                                  :tree tree ; first is ROOT
                                  :semantics (append parts
                                                     (define-relations
                                                      (parse-relations parse))))))
          (fathom new))))))


(defun clr ()
  (clear-parent-cache)
  (clear-caches))


(defun m-all (filename &optional clear-context)
  (when clear-context
    (m "" T))
  (mapcar #'m (load-from-file filename)))


(defun init ()
  (flet ((basic-add (nod ctx)
           (let ((added (add-one nod)))
             (setf (gethash (hashid nod) (proper ctx)) added))))
    (mapcar #'(lambda (nod)
                (basic-add nod (inputs))
                (basic-add nod (current-session)))
            *common-list*)
    (mapcar #'(lambda (nod)
                (basic-add nod (inputs))
                (when (closurep nod)
                  (set-all-parents ))
                (when (qnodep nod)
                  (add-qnode nod)))
            *init-list*)))




(defun parse-tree (tree)
  "Returns a parsed closure in non-cached form and syntactic elements."
  (let ((operator (first tree))
        (remainder (rest tree))
        (parsed (make-instance 'closure)))
    (if (stringp (car remainder))
        (let* ((pos (cache-of (case-pos operator))) ; either a punctuation or a word
               (word (cache-of (car remainder)))
               (out (cache-of (make-instance 'connection
                                             :hashid nil
                                             :prev (hashid word)
                                             :curr (hashid *form*)
                                             :subs (hashid pos)))))
          (setf (root parsed) word)
          (setf (outs parsed) (list out))
          (let ((wrapped (wrap out *POS*)))
            (set-all-parents wrapped)
            (values parsed '() (list wrapped))))
      (let ((elements '())
            (fwd nil)
            (constituent (case-constituent operator))
            (speech '())) 
        (dolist (one remainder)
          (multiple-value-bind (clo elem parts)
              (parse-tree one)
            (let ((out (make-instance 'connection
                                      :prev constituent
                                      :curr *bind*
                                      :subs clo))
                  (el (make-instance 'connection
                                     :prev constituent
                                     :curr *bind*
                                     :subs (root clo))))
              (if (null fwd)
                  (setf fwd (make-instance 'connection
                                           :prev clo))
                (let ((el (make-instance 'connection
                                         :prev (root (prev fwd))
                                         :curr *bind* ; correct?
                                         :subs (root clo))))
                  (setf (curr fwd) *bind*)
                  (setf (subs fwd) clo)
                  (push fwd (forwards parsed))
                  (setf fwd nil)
                  (push el elements)))
              (setf speech (remove-duplicates (append speech parts)))
              (push out (outs parsed))
              (push el elements)
              (setf elements (remove-duplicates (append elem elements))))))
        (setf (root parsed) constituent)
        (setf (outs parsed) (reverse (outs parsed)))
        (setf (forwards parsed) (reverse (forwards parsed)))
        (values parsed elements speech)))))





(defun parse-relation-word (str)
  (let ((parts (split str 9999 '(#\-))))
    (if (> (list-length parts) 2)
        (let ((word (subseq str 0 (position #\- str :from-end T))))
          (values word word (car (last parts)))) ; don't process hyphenated
      (let ((word (first parts)))
        (values word (get-word-root word) (second parts))))))




(defun define-relations (relations)
  (when relations
    (let* ((relation (first relations))
           (dep (case-dependencies (first relation)
                                   (parse-relation-word (second relation))
                                   (parse-relation-word (third relation)))))
      (if (connectionp dep)
          (let ((wrapped (wrap dep)))
            (set-all-parents wrapped)
            (cons wrapped
                  (define-relations (rest relations))))
        (define-relations (rest relations))))))


(defun wrap (out2 &optional targ)
  (let ((out1 (cache-of (make-instance 'connection
                                       :hashid nil
                                       :prev (prev out2)
                                       :curr (hashid *bind*)
                                       :subs (hashid (if targ targ *form*)))))
        (fwd (cache-of (make-instance 'connection
                                      :hashid nil
                                      :prev (hashid (if targ targ *form*))
                                      :curr (hashid *free*)
                                      :subs (subs out2)))))
    (cache-of (make-closure nil
                            (get-one (prev out2))
                            (list out1 out2)
                            (list fwd)))))
; do we need to add-parents here? looks like they're added nowhere...



(defun get-word-root (w)
  "Get root form of word from server."
  (let ((word-root (get-kb (concatenate 'string "=" w))))
    (when word-root
      (setf word-root (caar word-root))
      ;; filter out single letters
      (when (> (length word-root) 1)
        word-root))))




(defun get-parses (phrase)
  "Calls to external morphological server to get parses of the phrase."
  (let ((all-parses-in (get-kb (concatenate 'string "'" phrase "'")))
        (all-parses-out '())
        (current-parse nil))
    (dolist (p all-parses-in)
      (cond ((string-equal (first p) "parse") 
             (push current-parse all-parses-out)
             (setf current-parse nil))
            (current-parse
             (push p (parse-relations current-parse)))
            ((null current-parse)
             (setf current-parse (make-parse))
             (setf (parse-constituents current-parse) p))
            (T nil)))
    (reverse all-parses-out)))





(defun make-stream-and-talk (handle)
  (let ((stream (make-instance 'comm:socket-stream
                               :socket handle
                               :direction :io
                               :element-type 'base-char)))
  (mp:process-run-function (format nil "talk ~D"
                                   handle)
                           '()
                           'talk-on-stream stream)))

(defun talk-on-stream (stream)
  (unwind-protect
      (loop for line = (read-line stream nil nil)
            while line
            do
            (format stream "'~A'~%" (fathom line))
            (force-output stream))
      (close stream)))

;(comm:start-up-server :function 'expressm:make-stream-and-talk :service 21212)


(defun load-from-file (p)
  (let ((lines '()))
    (with-open-file (s p)
      (do ((l (read-line s) (read-line s nil 'eof)))
          ((eq l 'eof) "Reached end of file.")
        (unless (equal "" l)
          (push l lines))))
    (reverse lines)))