;;; Copyright (c) 1997-2018 John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen, Frederik Fouvry
;;; see LICENSE for conditions

(in-package :lkb)

(define-lkb-frame chart-window 
  ((root :initform nil
	 :accessor chart-window-root)
   (nodes :initform nil
	  :accessor chart-window-nodes)
   (selected-words :initform nil
		   :accessor chart-window-selected-words)
   (selected-edge :initform nil
		  :accessor chart-window-selected-edge))	       
  :info-bar t
  :display-function 'draw-chart-window
  :text-style (lkb-parse-tree-font)
  :width :compute
  :height :compute)

(eval-when (:load-toplevel :compile-toplevel :execute)
  (clim:define-presentation-type word ())
  (clim:define-presentation-type edge ()))


;;; make sure that a chart window is not left open after
;;; a new sentence is parsed, since the interactions sometimes
;;; get confused if there's a window which corresponds to an 
;;; old parse
;;; also remove record of window if user closes it

(defun close-existing-chart-windows nil
  (invalidate-chart-commands)
  (when *main-chart-frame*
    (clim:execute-frame-command *main-chart-frame* '(com-close-frame)))
  (loop for frame in *sub-chart-window-frames*
       do
       (clim:execute-frame-command frame '(com-close-frame)))
  (setf *main-chart-frame* nil)
  (setf *sub-chart-window-frames* nil))

(defmethod clim:frame-exit :before ((frame chart-window)
                                    #+:allegro &rest #+:allegro keys)
  ;; !!! &rest keys is in Allegro CLIM but not in any CLIM specification or user guide
  #+:allegro (declare (ignore keys))
  (if (eq frame *main-chart-frame*)
    (setq *main-chart-frame* nil)
    (setq *sub-chart-window-frames* (remove frame *sub-chart-window-frames*))))


;;;

(defun draw-chart-lattice (node title &key (horizontalp t) (subframe-p nil))
  (declare (ignore horizontalp))
  (when (and *main-chart-frame* (not subframe-p))
    (clim:execute-frame-command *main-chart-frame* '(com-close-frame)))
  (mp:run-function
    title #'draw-chart-lattice-really node title subframe-p))
                           
(defun draw-chart-lattice-really (node title subframe-p)                    
  (let ((chart-window
          (clim:make-application-frame 'chart-window :pretty-name title)))
    (if subframe-p
        (push chart-window *sub-chart-window-frames*)
        (setf *main-chart-frame* chart-window))
    (setf (chart-window-root chart-window) node)
    (clim:run-frame-top-level chart-window)))


(defun draw-chart-window (window stream &key max-width max-height)
  (declare (ignore max-width max-height))
  (let ((root (chart-window-root window))
        (chart-nodes nil))
    ;; Don't bother if there's no chart
    (when (get root 'chart-edge-descendants)
      (clim:format-graph-from-roots
        (get root 'chart-edge-descendants)
        #'(lambda (node stream)
            (let ((s (get node 'chart-edge-name)))
              (if (member node (get root 'chart-edge-descendants) :test #'eq)
                  (with-text-style-bold-face (stream)
                    (clim:with-output-as-presentation (stream (symbol-name node) 'word)
                      (write-string s stream)))
                  (progn
                    (push node chart-nodes)
                    (clim:with-output-as-presentation (stream node 'edge)
                      (write-string s stream))))))
        #'(lambda (node) 
            (get node 'chart-edge-descendants))
        :stream stream 
        :graph-type :dag
        :merge-duplicates t
        :orientation :horizontal
        :maximize-generations t
        :generation-separation *tree-level-sep*
        :within-generation-separation *tree-node-sep*
        :center-nodes nil)
      (setf (chart-window-nodes window) chart-nodes)
      (finish-output stream) ; wait for graph drawing to finish
      ;; drawing finished flag below tested in wait-until-chart-ready
      #+:mcclim
      (setf (clim:frame-properties window 'finished) t)
      #-:mcclim
      (setf (getf (clim:frame-properties window) 'finished) t))))


;;; Update the yield pane when we are over an edge

(define-info-bar edge (node stream)
  (let ((yield (get node 'chart-edge-leaves)))
    (when yield
      (dolist (word yield)
        (write-string (string-downcase word) stream)
        (write-char #\space stream)))))

;;; Click on background to clear selection

(define-chart-window-command (com-background-menu)
    ((obj 'clim:blank-area :gesture (:select :menu nil))) 
  (declare (ignore obj))
  (clim:with-application-frame (frame)
    (setf (chart-window-selected-words frame) nil)
    (setf (chart-window-selected-edge frame) nil)
    (unhighlight-objects frame)))

;;; Click on a word to add to highlighted words

(define-chart-window-command (com-word-menu)
    ((str 'word :gesture (:select :menu nil))) 
  (clim:with-application-frame (frame)
    (with-slots (selected-words) frame
      (setf (chart-window-selected-edge frame) nil)
      (unhighlight-objects frame)
      (if (member str selected-words :test #'string=)
	  (setf selected-words (delete str selected-words :test #'string=))
	  (push str selected-words))
      (highlight-words frame))))

;;; Highlight selected words and all edges that cover selected words

(defun highlight-words (frame)
  (let* ((stream (clim:frame-standard-output frame))
         (words (chart-window-selected-words frame))
         (objects (nconc
                    (loop for node in (chart-window-nodes frame)
                        for edge-leaves = (get node 'chart-edge-leaves)
                        when (and
                               (= (length words) (length edge-leaves))
                               (subsetp edge-leaves words :test #'string=))
                        collect (find-object stream 
                                             #'(lambda (x) (eq x node))))
                    (loop for word in words
                        collect (find-object stream 
                                             #'(lambda (x) (string= x word)))))))
    (highlight-objects objects frame)))
		      
;;; Pop-up menu for chart edges

(define-chart-window-command (com-edge-menu)
    ((node 'edge :gesture (:select :menu nil))) 
  (clim:with-application-frame (frame)
    (let ((edge-rec
            (if (search "Generator Chart" (clim:frame-pretty-name frame))
                (find-gen-edge-given-id (get node 'chart-edge-id))
                (find-edge-given-id (get node 'chart-edge-id)))))
      (when edge-rec
        (pop-up-menu
          (append '(("Highlight nodes" :value highlight))
                  '(("Feature structure" :value fs))
                  '(("Unfilled feature structure" :value ufs))
                  (when (rule-p (edge-rule edge-rec))
                    `((,(format nil "Rule ~A" 
                                (rule-id (edge-rule edge-rec)))
                       :value rule)))
                  '(("New chart" :value new))
                  `((,(format nil "Tree ~A" (edge-id edge-rec))
                     :value edge))
                  `(("Compare" :value compare
                               :active ,(chart-window-selected-edge frame)))
                  `(("Unify" :value unify
                             :active ,*fs1*)))
          (fs (display-fs (edge-dag edge-rec)
                          (format nil "Edge ~A ~A - FS" 
                                  (edge-id edge-rec)
                                  (if (g-edge-p edge-rec) 
                                      "G" 
                                    "P"))))
          (ufs (display-fs (unfilled-tdfs (copy-tdfs-completely (edge-dag edge-rec)))
                           (format nil "Edge ~A ~A - Unfilled FS" 
                                   (edge-id edge-rec)
                                   (if (g-edge-p edge-rec) 
                                       "G" 
                                     "P"))))
          (edge (display-parse-tree edge-rec nil))
          (rule (let* ((item (edge-rule edge-rec))
                       (rule (and (rule-p item) item)))
                  (when rule
                    (display-fs (rule-full-fs rule)
                                (format nil "~A" (rule-id rule))))))
          (highlight (setf (chart-window-selected-edge frame) edge-rec)
                     (highlight-edge edge-rec frame))
          (new (display-edge-in-new-window frame edge-rec))
          (compare (compare (list (chart-window-selected-edge frame) edge-rec)))
          (unify (try-unify-fs-in-chart (edge-dag edge-rec))))))))

(defun try-unify-fs-in-chart (fs)
  ;; very similar to the function in activefs
  (let* ((fs1 *fs1*)
         (path1 *path1*)
         (result nil))
    (when (and fs1 (listp path1))
      (setq result
        (unify-paths-with-fail-messages 
          (create-path-from-feature-list path1)
            fs1
            (create-path-from-feature-list nil)
            (tdfs-indef fs)
            :selected1 path1 :selected2 nil))
      (terpri)
      (when result
        (display-fs result "Unification result")))
    (setq *fs1* nil)))            
             

;;; Highlight an edge in the chart - find topmost chart window on screen,
;;; locate the edge, ask for chart window to be scrolled so edge is visible in
;;; the center, and then highlight the edge

(defun display-edge-in-chart (edge)
  (let ((frame *main-chart-frame*))
    (when frame
      (highlight-edge edge frame :scroll-to t))))

(defun highlight-edge (edge frame &key (scroll-to nil))
  (let* ((stream (clim:frame-standard-output frame))
	 (record (find-object stream #'(lambda (x)
                                         (and (symbolp x)
                                              (eql (get x 'chart-edge-id)
                                                   (edge-id edge))))))
	 (on-path (append (collect-subs edge stream)
			  (collect-supers edge frame stream))))
    (setf (chart-window-selected-words frame) nil)
    (cond (record
	    (when scroll-to 
	      (scroll-to record stream))
	    (highlight-objects-mark on-path frame))
	  (t (highlight-objects on-path frame)))))

(defun collect-subs (edge stream)
  ;; .edge. and those displayed to its left in chart window
  (when edge
    (let ((record (find-object stream #'(lambda (x)
                                          (and (symbolp x)
                                               (eql (get x 'chart-edge-id)
                                                    (edge-id edge)))))))
      (append (when record (list record))
              (mapcan #'(lambda (e) (collect-subs e stream))
                      (edge-children edge))))))

(defun collect-supers (edge frame stream)
  ;; displayed to the right of .edge.
  (when edge
    (let ((node (loop
                    for n in (chart-window-nodes frame)
                    when (eql (get n 'chart-edge-id) (edge-id edge))
                    return n)))
      (when node
        (labels
          ((node-descendants (n)
             (cons n (mapcan #'node-descendants (get n 'chart-edge-descendants)))))
          (loop
              for desc in (delete-duplicates (cdr (node-descendants node))) ; inefficient
              collect
              (find-object stream #'(lambda (x) (eq x desc)))))))))


;;; Create a new chart window and display just the descendants and ancestors
;;; of the edge in it

(defun display-edge-in-new-window (parent-frame edge)
  (if edge
      (draw-chart-lattice
	(filtered-chart-lattice (chart-window-root parent-frame) edge nil)
	(symbol-name
          (gentemp (format nil "~A-" (clim:frame-pretty-name parent-frame))))
	:subframe-p t)
      (lkb-beep)))

(defun display-partial-chart (root edge subframe-p)
  ;; same as above, but called without drawing the full chart
  (if edge
      (draw-chart-lattice
	(filtered-chart-lattice root edge nil)
	"Partial Chart"
	:subframe-p subframe-p)
      (lkb-beep)))