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

;;; CLIM version

(in-package :lkb)

;;; Appearance parameters

(defparameter *parse-window-width* 400
  "Initial width of parse summary window")

(defparameter *parse-window-height* 400
  "Initial height of parse summary window")

(def-lkb-parameter *ptree-node-sep* #+:mcclim 14 #-:mcclim 6
  "Spacing between nodes at the same level in parse tree")

(def-lkb-parameter *ptree-level-sep* #+:mcclim 14 #-:mcclim 12
  "Spacing between levels in parse tree")                    

(defparameter *parsum-node-sep* 5)

(defparameter *parsum-level-sep* 6)                    

(defun lkb-parse-tree-font ()
  (clim:make-text-style :sans-serif :roman (or *parse-tree-font-size* 12)))

(defun lkb-summary-tree-font ()
  (clim:make-text-style :sans-serif :roman (or *summary-tree-font-size* 8)))

(declaim (notinline lkb-parse-tree-font lkb-summary-tree-font))


;;; Globals used to keep track of parse chart - set in chartout which is therefore read in
;;; after this file

(defvar *main-chart-frame* nil)
(defvar *sub-chart-window-frames* nil)


;;; Window showing a single parse tree

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

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

(define-info-bar node (node stream)
  (let ((edge (get node 'edge-record)))
    (when (edge-p edge)
      (if (g-edge-p edge)
          (write-string (string-downcase (string (g-edge-index edge))) stream)
          (format stream "~A-~A" (edge-from edge) (edge-to edge)))
      (format stream " [~A] ~A " (edge-id edge)
        (if (rule-p (edge-rule edge)) (rule-id (edge-rule edge)) (edge-rule edge)))
      (format stream "~{~(~A~)~^ ~}" (edge-lex-ids edge))))) ; JAC 8-Dec-2018: was edge-leaves


(defun draw-new-parse-tree (topnode title horizontalp &optional counter)
  (declare (ignore horizontalp))
  (mp:run-function
    title #'draw-new-parse-tree-really topnode counter title))

(defun draw-new-parse-tree-really (topnode counter &optional title)
  (let ((pframe
          (clim:make-application-frame 'parse-tree :pretty-name (or title "Parse Tree"))))
    (setf (parse-tree-nodes pframe) topnode)
    (setf (parse-tree-current-chart pframe) 
      (or counter
          *chart-generation-counter*))
    (clim:run-frame-top-level pframe)))


(defun draw-parse-tree (ptree-frame stream)
  (clim:stream-set-cursor-position stream 6 4)
  (clim:format-graph-from-root
    (parse-tree-nodes ptree-frame)
    #'(lambda (node stream)
        (multiple-value-bind (s lex-p) 
            (get-string-for-edge node)
          (if lex-p
            (with-text-style-bold-face (stream) (write-string s stream))
            (clim:with-output-as-presentation (stream node 'node) (write-string s stream)))))
    #'find-children
    :graph-type :parse-tree ; new CLIM graph type, defined in graph.lsp
    :stream stream 
    :orientation :vertical
    :generation-separation *ptree-level-sep*
    :within-generation-separation *ptree-node-sep*
    :move-cursor nil))


;;; Menus on active parse tree nodes

(define-parse-tree-command (com-parse-tree-menu)
    ((edge-symbol 'node :gesture (:select :menu nil)))
  (let* ((edge-record (get edge-symbol 'edge-record))
         (full-fs (get edge-symbol 'full-fs))
         (item (edge-rule edge-record)))
    (pop-up-menu
     `(
       ("Feature structure"
        :value fs)
       ("Unfilled feature structure"
        :value ufs)
       (,(format nil "Feature structure - Chart edge ~A" (edge-id edge-record))
        :value edge-fs)
       (,(format nil "Unfilled feature structure - Chart edge ~A" (edge-id edge-record))
        :value edge-ufs)
       ("Show edge in chart" 
        :value edge
        :active ,(and (not (g-edge-p edge-record))
                      (or
                       (not (parse-tree-current-chart clim:*application-frame*))
                       (eql (parse-tree-current-chart clim:*application-frame*)
                            *chart-generation-counter*))))
       (,(if (rule-p item)
             (format nil "Rule ~A" (rule-id item))
             "Entry") ; omit the item since it might not be displayable in the menu font
        :value rule
        :active ,(or (rule-p item) (get-tdfs-given-id item)))
       ("Sement"
        :value sement
        :active ,(mrs::algebra-available-p))
       ("Rule sement"
        :value rule-sement
        :active ,(mrs::algebra-available-p))
       ("Check algebra"
        :value check-algebra
        :active ,(mrs::algebra-available-p)) 
       ("Generate from edge" :value generate
                             :active ,(and *mrs-loaded*
                                       (not (g-edge-p edge-record))))
       #+:ignore ; lex ids information moved to info bar
       (,(format nil "Lex ids ~A" (edge-lex-ids edge-record))
        :value nil
        :active nil))
     (fs (display-fs full-fs
                     (format nil "Edge ~A ~A - Tree FS" 
                             (edge-id edge-record)
                             (if (g-edge-p edge-record) "G" "P"))))
     (ufs (display-fs (unfilled-tdfs
                        (copy-tdfs-completely full-fs))
                      (format nil "Edge ~A ~A - Tree Unfilled FS" 
                              (edge-id edge-record)
                              (if (g-edge-p edge-record) "G" "P"))))
     (edge-fs
      (let ((tdfs (and (edge-p edge-record) (edge-dag edge-record))))
        (when (tdfs-p tdfs)
          (display-fs tdfs
                      (format nil "Edge ~A ~A - Edge FS" 
                              (edge-id edge-record)
                              (if (g-edge-p edge-record) "G" "P"))))))
     (edge-ufs
      (let ((tdfs (and (edge-p edge-record) (edge-dag edge-record))))
        (when (tdfs-p tdfs)
          (display-fs (unfilled-tdfs (copy-tdfs-completely tdfs))
                      (format nil "Edge ~A ~A - Edge Unfilled FS" 
                              (edge-id edge-record)
                              (if (g-edge-p edge-record) "G" "P"))))))
     (edge
          (progn
            (cond ((and *main-chart-frame* 
                        (eql (clim:frame-state *main-chart-frame*) 
                             :enabled))
                   nil)
                  ((and *main-chart-frame* 
                        (eql (clim:frame-state *main-chart-frame*) 
                             :shrunk))
                   (clim:raise-frame *main-chart-frame*))
                  (t (show-chart)
                     (wait-until-chart-ready)))
            (highlight-edge edge-record *main-chart-frame* :scroll-to t)))
     (rule 
      (let ((rule (if (rule-p item) item nil)))
        (if rule
            (display-fs (rule-full-fs rule)
                        (format nil "~A" (rule-id rule))
                        (rule-id rule))
          (let ((alternative (get-tdfs-given-id item)))
            (when alternative
              (display-fs alternative 
                          (format nil "~A" item)
                          item))))))
     (sement       
      ;;; we have to use the tdfs as used by the parser here, because
      ;;; otherwise we have things on the rels list that shouldn't be 
      ;;; there because of the diff list
      (let ((parse-tdfs (and (edge-p edge-record) (edge-dag edge-record))))
        (when (tdfs-p parse-tdfs)
          (show-mrs-sement-window parse-tdfs
                                  full-fs edge-record
                                  (format nil "Edge ~A ~A - Sement" 
                                          (edge-id edge-record)
                                          (if (g-edge-p edge-record) "G" "P"))))))
     (rule-sement       
      ;;; this is to get the contribution of the rule - for cases where
      ;;; it has a c-cont
      (let ((rule-tdfs (and (edge-p edge-record) 
                            (rule-p (edge-rule edge-record))
                            (rule-full-fs (edge-rule edge-record)))))
        (when (tdfs-p rule-tdfs)
          (show-mrs-rule-sement-window rule-tdfs
                                  (format nil "Edge ~A ~A - Rule sement" 
                                          (edge-id edge-record)
                                          (if (g-edge-p edge-record) "G" "P"))))))
     (check-algebra       
      (let ((parse-tdfs (if (edge-p edge-record) (edge-dag edge-record))))
        (when (tdfs-p parse-tdfs)
          (show-mrs-sement-check-window parse-tdfs
                                  full-fs edge-record
                                  (format nil "Edge ~A ~A - algebra check" 
                                          (edge-id edge-record)
                                          (if (g-edge-p edge-record) "G" "P")))))) 
     (generate (funcall 'really-generate-from-edge edge-record)))))


;;; ***** Display window showing multiple parses ********
;;; because it's very annoying to get zillions of windows when there's
;;; a highly ambiguous sentence, the following code displays a
;;; single window with lots of little parse trees.  It is
;;; based on Rob's compare code (see compare.lsp)

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defstruct parsum 
    top ; top node of a single parse tree
    output-record ; its output record
    edge))

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

(define-lkb-frame parse-summary
  ((trees :initform nil
          :accessor parse-summary-trees)
   (current-chart :initform nil
                  :accessor parse-summary-current-chart)
   (last-margin :initform nil
                :accessor parse-summary-last-margin)
   (last-ncolumns :initform 0
                  :accessor parse-summary-last-ncolumns)
   (max-tree-width :initform nil
                   :accessor parse-summary-max-tree-width))
  :info-bar t
  :display-function 'draw-parse-summary-window
  :text-style (lkb-summary-tree-font)
  ;; JAC 5-Dec-2018: width and height were previously :compute, but now there is no
  ;; well-defined default width/height since trees are formatted to fit window width
  :width *parse-window-width*
  :height *parse-window-height*)

(define-info-bar parsum (parsum stream)
  (let ((edge (when parsum (parsum-edge parsum))))
    (when edge
      (format stream "~A-~A [~A] ~A "
        (edge-from edge) (edge-to edge) (edge-id edge)
        (if (rule-p (edge-rule edge)) (rule-id (edge-rule edge)) (edge-rule edge))))))

(defmethod clim:run-frame-top-level :before ((frame parse-summary) &key &allow-other-keys)
  ;; Set up the doc-pane - this is based on the style in the summary tree pane but with
  ;; the size of the full-size parse tree font
  (let ((lkb-pane
          (clim:find-pane-named frame 'lkb-pane))
        (doc-pane 
          (clim:find-pane-named frame 'doc-pane)))
    (when (and lkb-pane doc-pane)
      (let ((new-style
              (text-style-new-size
                (clim:pane-text-style lkb-pane)
                (clim:text-style-size (lkb-parse-tree-font)))))
        (setf (clim:medium-text-style doc-pane) new-style)))))


;;; Detect resizing of the window by an :after method on allocate-space. If there is a
;;; significant change in the window width then redisplay, which might reflow the columns

(define-parse-summary-command com-resize-window ((frame 'parse-summary))
  (draw-parse-summary-window
    frame (clim:find-pane-named frame 'lkb-pane)))

(defmethod clim:allocate-space :after ((pane lkb-pane) width height)
  (declare (ignore height))
  (clim:with-application-frame (frame)
    (when (slot-exists-p frame 'last-margin) ; does frame reformat lkb-pane on resize?
      ;; in McCLIM, a horizontal resize of a scrolling pane does not always update the
      ;; text margin of its child pane
      #+:mcclim
      (setf (clim:stream-text-margin pane)
        (clim:bounding-rectangle-width (clim:pane-viewport-region pane)))
      (let ((margin (clim:stream-text-margin pane)))
        (with-slots (last-margin) frame
          (cond
            ((null last-margin) ; a brand new frame, not a resize?
              (setf last-margin margin))
            ((> (abs (- margin last-margin)) 10) ; significant change since last redisplay attempt?
              (setf last-margin margin)
              (clim:execute-frame-command frame `(com-resize-window ,frame)))))))))


(defun invalidate-chart-commands nil
  ;;; this function should be redundant now because of *chart-generation-counter*
  nil)
#|
  (clim:map-over-frames 
   #'(lambda (frame) 
       (when (and (eql (clim:frame-name frame) 'parse-summary)
                  (member (clim:frame-state frame) '(:enabled :shrunk)))
         (setf (clim:command-enabled 'com-multiple-tree-menu frame) nil) 
         (setf (clim:command-enabled 'com-show-chart-from-tree frame) nil)))))
|#

(defun show-parse-summary (parses &optional title)
  #+:lui
  (if (lui-status-p :tree)
      (let ((input (format nil "~{~a~^ ~}" (edge-leaves (first parses)))))
        (lui-show-parses parses input))
      (mp:run-function
        title #'show-parse-summary-really parses title))
  #-:lui
  (mp:run-function
     title #'show-parse-summary-really parses title))

(defun show-parse-summary-really (parses &optional title)
  (let ((frame
          (clim:make-application-frame 'parse-summary
            :pretty-name
            (or title
              (format nil "Parse Trees (~A) for \"~A\""
                (length parses)
                ;; can't use *sentence* since can be called from an arbitrary Compare frame
                (shortened-sentence-string (edge-leaves (first parses))))))))
    (setf (parse-summary-trees frame)
      (mapcar
        #'(lambda (p) (make-parsum :top (make-new-parse-tree p) :edge p))
        parses))
    (setf (parse-summary-current-chart frame) *chart-generation-counter*)
    (clim:run-frame-top-level frame)))


(defun draw-parse-summary-window (frame stream &key max-width max-height)
  (declare (ignore max-width max-height))
  (let* ((trees (parse-summary-trees frame))
         (max-tree-width
           (or (parse-summary-max-tree-width frame)
             (loop
                 for tree in trees
                 repeat 10 ; a sample just for first time through
                 maximize (compute-parse-tree-width (parsum-top tree) stream))))
         (window-width (clim:stream-text-margin stream))
         (ncolumns
           (max 1 (floor window-width (+ max-tree-width 15)))))
    (unless (= ncolumns (parse-summary-last-ncolumns frame))
      (setf (parse-summary-last-ncolumns frame) ncolumns)
      (clim:window-clear stream)
      (loop with v = 4 ; not using formatting-table since want immediate start to output
          with maxw = 0
          while trees
          do
          (loop with u = 6 ; start a new row
              with linev = v
              repeat ncolumns
              while trees
              do
                (clim:stream-set-cursor-position stream u v)
                (draw-single-res-tree (pop trees) stream)
                (multiple-value-bind (u1 v1)
                    (clim:stream-cursor-position stream)
                  (setq linev (max linev v1))
                  (setq maxw (max maxw (- u1 u)))
                  (setq u (+ u1 15)))
              finally
              (setq v (+ linev 5)))
          finally
          (setf (parse-summary-max-tree-width frame) maxw))
      ;; update pane contents size to ensure scroll bar extents are correct
      #+mcclim
      (multiple-value-bind (x1 y1 x2 y2)
          (clim:bounding-rectangle* (clim:stream-output-history stream))
        (declare (ignore x1 y1))
        (clim:change-space-requirements stream :width (1+ x2) :height (+ y2 4))))))

(defun compute-parse-tree-width (node stream)
  (labels
    ((node/daughters-max-width (node)
      (multiple-value-bind (s lex-p) 
          (get-string-for-edge node)
        (max 
          (+
            (if lex-p
              (with-text-style-bold-face (stream) (clim:stream-string-width stream s))
              (clim:stream-string-width stream s))
            *parsum-node-sep*)
          (loop
            for d in (find-children node)
            sum (node/daughters-max-width d))))))
    (node/daughters-max-width node)))

(defun draw-single-res-tree (tree stream)
  (let
    ((record
       (or (parsum-output-record tree)
         (setf (parsum-output-record tree)
           (clim:with-output-to-output-record (stream)
             (clim:with-output-as-presentation (stream tree 'parsum :single-box t)
               (clim:format-graph-from-root
                 (parsum-top tree)
                 #'(lambda (node stream)
                     (multiple-value-bind (s lex-p) 
                         (get-string-for-edge node)
                       (if lex-p
                         (with-text-style-bold-face (stream) (write-string s stream))
                         (write-string s stream))))
                 #'find-children
                 :graph-type :parse-tree
                 :stream stream 
                 :orientation :vertical
                 :generation-separation *parsum-level-sep*
                 :within-generation-separation *parsum-node-sep*
                 :move-cursor nil)))))))
    (setf (clim:output-record-position record) (clim:stream-cursor-position stream))
    (unless (clim:output-record-parent record)
      (clim:stream-add-output-record stream record))
    (clim:replay record stream)
    (clim:stream-increment-cursor-position stream
      (clim:bounding-rectangle-width record) (clim:bounding-rectangle-height record))))


(define-parse-summary-command (com-multiple-tree-menu)
    ((tree 'parsum :gesture (:select :menu nil)))
    (pop-up-menu
        `(("Show enlarged tree" :value show)
          ("Highlight chart nodes" :value chart) 
          ("Partial chart" :value partial-chart)
          ("Generate" :value generate :active ,*mrs-loaded*)
          ("MRS" :value mrs :active ,*mrs-loaded*)
          ("Prolog MRS" :value prolog :active ,*mrs-loaded*)
          ("RMRS" :value rmrs :active ,*mrs-loaded*)
          ("DMRS" :value dmrs :active ,*mrs-loaded*)
          ("Indexed MRS" :value indexed :active ,*mrs-loaded*)
          ("Scoped MRS" :value scoped :active ,*mrs-loaded*)
          #+:logon
          ("UTool MRS" :value utool :active ,*mrs-loaded*)
          ("Dependencies" :value dependencies :active ,*mrs-loaded*)
          ("FOL approximation" :value fol :active ,*mrs-loaded*)
          ("Rephrase" :value rephrase :active ,*mrs-loaded*))
        (show (draw-new-parse-tree
                (parsum-top tree)
                (format nil "Parse Tree for \"~A\""
                  (shortened-sentence-string (edge-leaves (parsum-edge tree))))
                nil 
                (parse-summary-current-chart clim:*application-frame*)))
        (chart
             (if (or (not (parse-summary-current-chart clim:*application-frame*))
                     (eql (parse-summary-current-chart clim:*application-frame*)
                          *chart-generation-counter*))
                 (progn
                   (cond ((and *main-chart-frame* 
                               (eq (clim:frame-state *main-chart-frame*) 
                                   :enabled)))
                         ((and *main-chart-frame* 
                               (eq (clim:frame-state *main-chart-frame*) 
                                   :shrunk))
                           (clim:raise-frame *main-chart-frame*))
                         (t
                           (show-chart) 
                           (wait-until-chart-ready)))
                   (display-edge-in-chart (parsum-edge tree)))
                 (lkb-beep)))
        (partial-chart
             (if (or (not (parse-summary-current-chart clim:*application-frame*))
                     (eql (parse-summary-current-chart clim:*application-frame*)
                          *chart-generation-counter*))
                 (multiple-value-bind (root subframe-p)
                   (cond ((and *main-chart-frame* 
                               (eq (clim:frame-state *main-chart-frame*) 
                                   :enabled))
                           (values (chart-window-root *main-chart-frame*) t))
                         ((and *main-chart-frame* 
                               (eq (clim:frame-state *main-chart-frame*) 
                                   :shrunk))
                           (values (chart-window-root *main-chart-frame*) t))
                         (t
                           (values (construct-chart-no-display) nil)))
                   (display-partial-chart root (parsum-edge tree) subframe-p))
                 (lkb-beep)))
        ;; funcall avoids undefined function warnings
        (generate (funcall 'really-generate-from-edge (parsum-edge tree)))
        (mrs (funcall 'show-mrs-window (parsum-edge tree)))
        (indexed (funcall 'show-mrs-indexed-window (parsum-edge tree)))
        (prolog (funcall 'show-mrs-prolog-window (parsum-edge tree)))
        (scoped (funcall 'show-mrs-scoped-window (parsum-edge tree)))
        #+:logon
        (utool (funcall 'show-mrs-utool-window (parsum-edge tree)))
        (rmrs (funcall 'show-mrs-rmrs-window (parsum-edge tree)))
        (dmrs (funcall 'show-mrs-dmrs-window (parsum-edge tree)))
        (dependencies 
             (funcall 'show-mrs-dependencies-window (parsum-edge tree)))
        (fol 
             (funcall 'show-mrs-fol-window (parsum-edge tree)))
        (rephrase
             (let ((symbol (when (find-package :mt)
                             (find-symbol "REPHRASE" :mt))))
               (when (and symbol (fboundp symbol))
                 (funcall symbol (parsum-edge tree)))))))


(defun wait-until-chart-ready nil
  (mp:process-wait-with-timeout "Waiting" 5
    #'(lambda ()
        (and *main-chart-frame*
             (eql (clim:frame-state *main-chart-frame*) :enabled)
             #+:mcclim
             (clim:frame-properties *main-chart-frame* 'finished)
             #-:mcclim
             (getf (clim:frame-properties *main-chart-frame*) 'finished))))
  (sleep 1)) ; for some reason need to wait a little longer


(define-parse-summary-command (com-show-chart-from-tree :menu "Show chart")
    ()   
  (if (or (not (parse-summary-current-chart clim:*application-frame*))
          (eql (parse-summary-current-chart clim:*application-frame*)
               *chart-generation-counter*))
      (show-chart)
    (lkb-beep)))

(define-parse-summary-command 
    (com-compare-from-tree :name "Compare" :menu t)
    ()
  (clim:with-application-frame (frame)
    (let ((edges (loop
                     for tree in (parse-summary-trees frame)
                     collect (parsum-edge tree))))
      (compare-parses edges))))