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


(in-package :lkb)

;;; Support for parse tree and chart output which is generic across GUI toolkits

#-:tty
(defun show-parse (&optional edges title)
  #-:clim (declare (ignore title))
  (let ((edges (or edges *parse-record*)))
    (if edges
      (with-parser-lock ()
        (if #+:lui (lui-status-p :tree) #-:lui nil
          #+:lui (lui-show-parses edges *sentence*) #-:lui nil
          #+:clim
          (if
            (or (< (length edges) 1000)
              (y-or-n-p-general
                (format nil "There are ~A trees, which might take some time to display.
Do you want to view them?"
                  (length edges))))
            (show-parse-summary edges title))
          #-:clim
          (dolist (edge edges) (display-parse-tree edge nil)))
        (let ((hook (when (and (find-package :mrs) 
                               (find-symbol "OUTPUT-MRS-AFTER-PARSE" :mrs)
                               (fboundp (find-symbol "OUTPUT-MRS-AFTER-PARSE" :mrs)))
                      (symbol-function (find-symbol "OUTPUT-MRS-AFTER-PARSE" :mrs)))))
          (when hook (funcall hook edges))))
      (progn
        (lkb-beep)
        (format t "~%No parses found")))))


#-:tty
(defun show-parse-edge nil
  (let ((possible-edge-name
          (ask-for-lisp-movable "Current Interaction" 
            `(("Specify an edge number" . ,*edge-id*)) nil)))
      (when possible-edge-name
         (let* ((edge-id (car possible-edge-name))
               (edge-record (find-edge-given-id edge-id)))
            (if edge-record 
               (display-parse-tree edge-record t)
               (show-message-window (format nil "No parser edge ~A" edge-id)))))))


(defun find-edge-given-id (edge-id)
  ;; we might not find the target edge in the parse chart if packing is on,
  ;; since unpacking creates further edges - so also look in the parse results
  (labels
    ((find-edge-in-chart (chart)
       (dotimes (i (array-total-size chart))
         (dolist (e (row-major-aref chart i))
	   (when (eql (edge-id e) edge-id) (return-from find-edge-in-chart e))
           (dolist (p (edge-packed e))
             (when (eql (edge-id p) edge-id) (return-from find-edge-in-chart p)))
           (dolist (p (edge-equivalent e))
             (when (eql (edge-id p) edge-id) (return-from find-edge-in-chart p))))))
     (find-edge-in-parse (e)
       (if (eql (edge-id e) edge-id)
           e
           (dolist (c (edge-children e))
             (let ((found (find-edge-in-parse c)))
               (when found (return found)))))))
    (or (find-edge-in-chart *chart*)
        (find-edge-in-chart *achart*)
        (loop for p in *parse-record* thereis (find-edge-in-parse p)))))


;;; labelling parse tree nodes --- code for handling the
;;; templates

;;; templates are stored in *category-display-templates*
;;; which is an association list

(defparameter *category-display-templates* nil
  "used in parseout.lsp")

(defun get-display-template-entry (id)
  (cdr (assoc id *category-display-templates*)))

(defun clear-category-display-templates nil
  (setf *category-display-templates* nil))

(defun add-category-display-template (id non-def defs)
  (push (cons id
	      (make-non-lex-psort-entry id non-def defs))
	*category-display-templates*))

(defun find-category-abb (fs)
   ;; Two versions of this, controlled by *simple-tree-display* - one as in
   ;; the original LKB and another which emulates PAGE.
   ;;
   ;; The original LKB version is simple - it checks to see whether fs is
   ;; subsumed by any of the special templates in *category-display-templates*
   ;; and returns as label the template name (as a symbol) if it does
   ;;
   ;; The PAGE emulation version relies on unification:
   ;; a - the template's type is ignored
   ;; b - the unification is checked on a portion of the FS
   ;;     reached by the *label-fs-path*
   ;; c - there are two types of templates - label and meta
   ;;     The label templates provide the first half of the node label
   ;;     then the meta template is checked - if this is satisfied,
   ;;     the path *recursive-path* is followed into the fs
   ;;     and this is checked against the *local-path*
   ;;     of the label nodes, and so on recursively. This gives
   ;;     node labels like S/NP
   ;;
   ;; JAC 15-Jan-2021: this function used to cache the fs->label computation in
   ;; a hash table *cached-category-abbs*; removed this cache since some
   ;; patterns of user interaction resulted in a memory leak, and anyway labels
   ;; are already cached on tree node symbols.
   ;;
   (if *simple-tree-display*
       (dolist (tmpl-pair *category-display-templates*)
         (let* ((tmpl (car tmpl-pair))
                (tmpl-entry (cdr tmpl-pair))
                (tmpl-fs
                   (if tmpl-entry (tdfs-indef (psort-full-fs tmpl-entry)))))
           (when (and tmpl-fs (dag-subsumes-p tmpl-fs (tdfs-indef fs)))
             (return tmpl))))
       (calculate-tdl-label fs)))


;;; Computing PAGE-style node labels

(defvar *label-display-templates* nil)
(defvar *meta-display-templates* nil)

(defstruct (label-template)
  label
  fs)

(defstruct (meta-template)
  prefix
  suffix
  fs)

(defun split-up-templates nil
  ;; templates in *category-display-templates* were accumulated in reverse order
  (if *simple-tree-display*
      (setq *category-display-templates*
        (nreverse *category-display-templates*))
      (progn
        (setq *label-display-templates* nil)
        (setq *meta-display-templates* nil)
        (loop for tmpl-pair in *category-display-templates*
            do
            (let* ((tmpl (car tmpl-pair))
                   (tmpl-entry (cdr tmpl-pair))
                   (tmpl-fs (if tmpl-entry
                                (tdfs-indef
                                  (psort-full-fs tmpl-entry)))))
              (if tmpl-fs
                  (if (label-template-fs-p tmpl-fs)
                      (push (make-label-template
                              :fs tmpl-fs
                              :label (get-string-path-value tmpl-fs *label-path*
                                                            tmpl))
                            *label-display-templates*)
                      (push (make-meta-template
                              :fs tmpl-fs
                              :prefix (get-string-path-value tmpl-fs *prefix-path*
                                                             tmpl)
                              :suffix (get-string-path-value tmpl-fs *suffix-path*
                                                             tmpl))
                            *meta-display-templates*))
                  (format t "~%Warning: no valid fs for ~A" tmpl)))))))


(defun label-template-fs-p (fs)
  (let ((type (type-of-fs fs)))
    (subtype-or-equal type *label-template-type*)))

(defun get-string-path-value (tmpl-fs path tmpl)
  ;; it is an error for the structure not to have the
  ;; feature which has been declared to provide the label name
  ;; and for this not to be a string
  ;; If this occurs, a warning message is printed
  ;; and the template name is used instead
  (if path
      (let* ((dag-found (existing-dag-at-end-of tmpl-fs path))
             (dag-value (if dag-found (type-of-fs dag-found)))
             (label (if (stringp dag-value)
                        dag-value)))
        (or label
            (progn
              (format t "~%Warning: no ~A in ~A, template name used instead"
                      path tmpl)
              (string tmpl))))
      ""))


;;; Calculate a tree node label for a fs. The original approach was to check
;;; unifiability of the dags below each 'real' top-level feature separately. This
;;; was incorrect since it ignored any re-entrancies between them.

(defun calculate-tdl-label (fs)
  (let ((fsl (existing-dag-at-end-of (tdfs-indef fs) *label-fs-path*)))
    (if fsl
        (let ((fsr (create-dag)))
          ;; instead of removing label etc features from templates, we equivalently
          ;; make sure they're not in the node fs - and at the same time remove the
          ;; args etc features since we're only allowing a match on the node itself,
          ;; not the whole subtree it dominates
          (setf (dag-arcs fsr)
            (remove-if #'excluded-labelling-feature-p
              (dag-arcs fsl) :key #'(lambda (a) (dag-arc-attribute a))))
          (let ((label (match-label fsr))
                (meta (check-meta fsr)))
            (when meta
              (setq label (concatenate 'string label meta)))
            (when (some #'lower-case-p label)
              (setq label (string-upcase label)))
            label))
        "UNK")))

(defun excluded-labelling-feature-p (feat)
  (or (eq feat (car *label-path*))
      (eq feat (car *prefix-path*))
      (eq feat (car *suffix-path*))
      (member feat *deleted-daughter-features* :test #'eq)))


;;; Check to find a match for the initial, label part.

(defun match-label (fs)
  (or
    (dolist (tmpl *label-display-templates*)
      (when (template-match-p (label-template-fs tmpl) fs)
        (return (label-template-label tmpl))))
    "?"))

(defun template-match-p (tmpl-fs fs)
  (unifiable-wffs-p fs tmpl-fs))


;;; Check to find a match for the final, meta part.

(defun check-meta (fs)
  (when (and *meta-display-templates*
          (not (empty-diff-list-at-end-of-path-p fs *recursive-path*)))
    (let ((meta-fs 
            (existing-dag-at-end-of fs *recursive-path*)))
      (when meta-fs
        (dolist (meta-tmpl *meta-display-templates*)
          (when (template-match-p (meta-template-fs meta-tmpl) fs)
            (return (concatenate 'string 
                                 (meta-template-prefix meta-tmpl) 
                                 (match-meta-label meta-fs)
                                 (meta-template-suffix meta-tmpl)))))))))

(defun empty-diff-list-at-end-of-path-p (fs path)
  (let ((diff-list-pos (position *diff-list-list* path :test #'eq)))
    (when diff-list-pos
      (let ((diff-list-fs 
             (existing-dag-at-end-of fs (subseq path 0 diff-list-pos))))
        (and diff-list-fs
             (empty-diff-list-p diff-list-fs))))))

(defun empty-diff-list-p (fs)
  (let ((list-val (get-dag-value fs *diff-list-list*))
        (last-val (get-dag-value fs *diff-list-last*)))
    (eq list-val last-val)))


(defun match-meta-label (fs)
  (or
    (dolist (tmpl *label-display-templates*)
      (when (meta-template-match-p (label-template-fs tmpl) fs)
        (return (label-template-label tmpl))))
    "?"))

(defun meta-template-match-p (tmpl-fs fs)
  ;; does the part of the template after the *local-path* unify with the node,
  ;; or, if *local-path* is null, does the whole template unify?
  (if *local-path*
      (let ((real-templ-fs (existing-dag-at-end-of tmpl-fs *local-path*)))
        (if real-templ-fs
            (unifiable-wffs-p real-templ-fs fs)))
      (template-match-p tmpl-fs fs)))


;;; Generic support for graphical display of parse chart

#-tty
(defun show-chart nil 
  (if (> *chart-max* 0) ; anything in chart?
    (if #+:lui (lui-status-p :chart) #-:lui nil
      #+:lui (lui-show-chart) #-:lui nil
      (let ((root (make-symbol "")))
        ;; make sure root's descendants are in input order, with each position being
        ;; a set to allow for multi-word lexical entries 
        (setf (get root 'chart-edge-descendants)
          (make-array (1+ *chart-max*) :initial-element nil))
	(create-chart-pointers root)
        (setf (get root 'chart-edge-descendants)
          (reduce #'append (get root 'chart-edge-descendants) :from-end t))
        (adjust-chart-pointers root)
        (draw-chart-lattice 
          root
          (format nil "Parse Chart for \"~A\"" *sentence*))
        root))
    (lkb-beep)))


(defun create-chart-pointers (root)
  ;; create a global mapping from edge-ids to symbols, and then also a
  ;; local one (per-string position) from lexical items to symbols, neither
  ;; set of symbols interned - so we don't end up hanging on to old edges
  ;;
  (setf (get root 'chart-edge-span) "")
  (let ((edge-symbols nil))
    (dotimes (left-vertex *chart-max*)
      (dotimes (r *chart-max*)
        (dolist (e (aref *chart* left-vertex (1+ r)))
          (let ((edge-symbol (make-edge-symbol (edge-id e))))
            (push (cons (edge-id e) edge-symbol) edge-symbols)))))
    (dotimes (left-vertex *chart-max*)
      (create-chart-pointers1 left-vertex root edge-symbols))))

(defun create-chart-pointers1 (left-vertex root edge-symbols)
  (let ((lex-pairs nil))
    (dotimes (r *chart-max*)
      (dolist (e (aref *chart* left-vertex (1+ r)))
        (let ((edge-symbol (cdr (assoc (edge-id e) edge-symbols))))
          (setf (get edge-symbol 'chart-edge-name)
            (chart-edge-text-string e
              (format nil "~A-~A" left-vertex (edge-to e)) nil))
          (setf (get edge-symbol 'chart-edge-leaves) (edge-leaves e))
          (setf (get edge-symbol 'chart-edge-id) (edge-id e))
          (setf (get edge-symbol 'chart-edge-rule) (edge-rule e))
          (setf (get edge-symbol 'chart-edge-partial-tree-p) (and (edge-partial-tree e) t))
          (if (edge-children e)
              (dolist (c (edge-children e))
                (when c
                  (push edge-symbol
                    (get (cdr (assoc (edge-id c) edge-symbols)) 'chart-edge-descendants))))
              (let* ((lex (car (edge-leaves e)))
                     (lex-symbol (cdr (assoc lex lex-pairs :test #'equal))))
                (unless lex-symbol
                  (push (cons lex (setq lex-symbol (make-symbol lex))) lex-pairs))
                (setf (get lex-symbol 'chart-edge-name)
                  (chart-edge-text-string e nil lex-symbol))
                (push edge-symbol
                  (get lex-symbol 'chart-edge-descendants))
                (pushnew lex-symbol
                  (svref (get root 'chart-edge-descendants) left-vertex)))))))))

(defun adjust-chart-pointers (node)
  ;; Update chart pointers to respect *show-lex-rules*, *show-morphology*, and
  ;; *show-incomplete-lex-rule-chains*
  (setf (get node 'chart-edge-descendants)
    (loop
        for desc in (get node 'chart-edge-descendants)
        append (adjust-chart-pointers desc)))
  (let ((rule (get node 'chart-edge-rule)))
    (cond
      ((and (not *show-incomplete-lex-rule-chains*)
            (get node 'chart-edge-partial-tree-p)
            (null (get node 'chart-edge-descendants)))
        nil)
      ((or (not rule)
           (and (rule-p rule)
                (or *show-lex-rules* (not (lexical-rule-p rule))))
           (and *show-lex-rules* *show-morphology*))
        (list node))
      (t
        (get node 'chart-edge-descendants)))))
  

;;; Create appropriate textual representations for edges, tree nodes, window titles etc

(defun chart-edge-text-string (edge span lex)
  (if lex
      ;; used to include vertex span on lexical nodes when *characterize-p* true; removed
      ;; as superfluous and inconsistent
      (format nil "~A" (tree-node-text-string lex))
      (let ((rule (edge-rule edge)))
        (format nil "~A [~A] ~A"
                span
                (edge-id edge)
                (tree-node-text-string (cond ((rule-p rule) (rule-id rule))
                                             ((symbolp rule) rule)
                                             ((g-edge-p edge) rule)
                                             (t (edge-category edge))))))))

(defun shortened-sentence-string (word-list &optional (len 24))
  ;; return word-list as a string in len or fewer characters, but always including
  ;; at least the first word. If X11/Lisp can't reliably display non-Latin-1
  ;; characters in a window title bar then replace them with middle dot
  (labels
    ((sanitize-string (s)
      #+:mcclim s
      #-:mcclim
      (concatenate 'string
	(loop for c across s collect (if (> (char-code c) 255) #\middle_dot c))))
     (shorten-sentence (words prev-len)
      (if words
        (let* ((w (sanitize-string (string (car words))))
               (cur-len (length w)))
          (if
            (or (zerop prev-len)
                (and (null (cdr words)) (<= (+ prev-len cur-len) len)) ; final word fits?
                (<= (+ prev-len cur-len 4) len)) ; +4 for space char and elipsis
            (cons w
              (shorten-sentence (cdr words) (+ prev-len cur-len 1))) ; +1 for space char
            (list "...")))
        nil)))
    (format nil "~{~A~^ ~}" (shorten-sentence word-list 0))))

(defun tree-node-text-string (x)
   (let ((full-string
           (typecase x
              (symbol (symbol-name x))
              (string x)
              (t (princ-to-string x)))))
      (if (> (length full-string) 30)
         (subseq full-string 0 30)
         full-string)))


;;; Make a copy of an existing root and descendant chart lattice, filtered
;;; such that only edges which are ancestors or descendants of given edge are
;;; present

(defun filtered-chart-lattice (node edge found)
  ;; .found. is a plist keeping track of nodes that have already been processed,
  ;; and recording their new names
  (labels
      ((super-chart-edge-path-p (e)
         ;; path from e recursively through children to edge?
         (and e                                ; don't blow up on active edges
              (or (eq e edge)
                  (some #'super-chart-edge-path-p (edge-children e)))))
       (sub-chart-edge-path-p (e edge)
         ;; path from edge recursively through children to e?
         (and edge
              (or (eq e edge)
                  (some #'(lambda (c) (sub-chart-edge-path-p e c)) 
                        (edge-children edge))))))
    (let* ((id (get node 'chart-edge-id))
           (e (if (g-edge-p edge) (find-gen-edge-given-id id) (find-edge-given-id id))))
      (cond
        ((not (or (null e)
                  (super-chart-edge-path-p e)
                  (sub-chart-edge-path-p e edge)))
          (values nil found))
        ((getf found node)
          (values (getf found node) found))
        (t
          (let ((new (make-symbol (symbol-name node))))
            (setq found (list* node new found))
            (let ((new-ds nil))
              (dolist (d (get node 'chart-edge-descendants))
                (multiple-value-bind (new-d new-found)
                    (filtered-chart-lattice d edge found)
                  (setq found new-found)
                  (when new-d
                    (setf (get new-d 'chart-edge-name) (get d 'chart-edge-name))
                    (setf (get new-d 'chart-edge-leaves) (get d 'chart-edge-leaves))
                    (setf (get new-d 'chart-edge-id) (get d 'chart-edge-id))
                    (push new-d new-ds))))
              (setf (get new 'chart-edge-descendants) (nreverse new-ds)))
            (values new found)))))))


;;; Take an edge and build an easily traversable and self-contained representation
;;; of the tree below it - for graphical and printed output

#-tty
(defun display-parse-tree (edge display-in-chart-p
                           &key input symbol title counter)
  #-:lui (declare (ignore input))
  (when (and edge display-in-chart-p)
    (display-edge-in-chart edge))
  (let ((symbol (or symbol (and edge (make-new-parse-tree edge))))
        (edge (or edge (and symbol (get symbol 'edge-record))))
        (title (or title 
                   (and edge (format nil "Edge ~A ~A"
                               (edge-id edge)
                               (if (g-edge-p edge) "G" "P"))))))
    (when symbol
      (with-parser-lock ()
        #+:lui
        (if (lui-status-p :tree)
            (lui-show-parses (list edge) input)
            (draw-new-parse-tree symbol title nil counter))
        #-:lui
        (draw-new-parse-tree symbol title nil counter)))))
   
(defun make-new-parse-tree (edge &optional (level 1) labelp)
  (let ((s (car (make-new-parse-tree-1 edge level))))
    (with-unification-context (nil)
      (copy-full-fs (rebuild-full-fs s)))
    (when labelp (label-parse-tree s))
    s))

(defun make-new-parse-tree-1 (edge level)
  ;; show active edge nodes at first level but not thereafter
  (if (and (> level 1) (g-edge-p edge) (g-edge-needed edge))
      (mapcan
        #'(lambda (c) 
            (when c (make-new-parse-tree-1 c (1+ level))))
        (edge-children edge))
      (let ((edge-symbol (make-edge-symbol (edge-id edge)))
            (daughters (edge-children edge)))
        (setf (get edge-symbol 'edge-record) edge)
        (setf (get edge-symbol 'daughters) 
          (if daughters
              (mapcan #'(lambda (dtr)
                          (if dtr
                              (make-new-parse-tree-1 dtr (1+ level))
                              ;; active chart edge daughter
                              (list (make-symbol ""))))
                      daughters)
              (make-lex-and-morph-tree edge)))
        (when (and (g-edge-p edge) (g-edge-mod-index edge))
          (setf (get edge-symbol 'edge-mod-edge)
            ;; !!! assume modification is only binary branching
            (nth (if (eql (g-edge-mod-index edge) 0) 1 0) (get edge-symbol 'daughters))))
        (list edge-symbol))))
  
(defun make-lex-and-morph-tree (edge)
  (let ((leaf-symbol (make-edge-symbol (car (edge-leaves edge)))))
    (list leaf-symbol)))


(defun make-edge-symbol (edge-id)
  ;; Create a new symbol on which we can hang the parse/generator tree and chart
  ;; info (e.g. full tree FSes, tree node labels) needed for graphical display and
  ;; printing. This allows other chart information that's no longer required to be GCed.
  ;;
  ;; It's vital that the edge symbol be created uninterned (i.e. by make-symbol),
  ;; for 3 reasons:
  ;;
  ;; (1) because of downwards feature percolation, an edge shared between different
  ;; trees might have different full FSes (and therefore different node labels) in each
  ;; one - so each tree must have edge symbols that are distinct from all other trees
  ;;
  ;; (2) edges with the same id but resulting from different parser / generator runs
  ;; must have distinct edge symbols, otherwise later edges with the same id would
  ;; overwrite earlier ones
  ;;
  ;; (3) any data put onto the symbol's property list must be GC-able once all
  ;; references to the symbol have gone, but an interned symbol is not GC-able; we
  ;; don't want to have to unintern these symbols explicitly once we're done with them
  ;;
  (make-symbol
    (if (stringp edge-id)
        edge-id
        (format nil "EDGE~A" edge-id))))


;;; Reconstruct the full (or 'tree') FS for a parser/generator result from its
;;; component edges in the chart

(defun rebuild-full-fs (edge-symbol)
  ;; Redo unifications making up the full FS for this tree node and for all nodes
  ;; below it. All the unifications are in one big unification context, so we
  ;; must copy any rule FSes (and also in the generator any lexical item FSes) that
  ;; are used more than once - otherwise reusing them would lead to spurious
  ;; re-entrancies resulting in dag cycles and/or unification failures
  (let ((found nil))
    (labels
      ((unique-fs (fs)
         (if (member fs found :test #'eq)
             (copy-tdfs-completely fs)
             (progn (push fs found) fs)))
       (rebuild-full-fs-1 (edge-symbol)
         (let* ((edge (get edge-symbol 'edge-record))
                (rule (and edge (edge-rule edge)))
                (dtrs (mapcar #'rebuild-full-fs-1 (get edge-symbol 'daughters))))
           (setf (get edge-symbol 'full-fs) 
             (if edge
                 (cond
                   ((rule-p rule)
                     (reapply-rule
                       rule dtrs (unique-fs (rule-full-fs rule)) (edge-orth-tdfs edge)))
                   ((stringp rule) ; a stem
                     (unique-fs (edge-dag edge)))
                   ((and (symbolp rule) (get-tdfs-given-id rule))
                     ;; a start symbol with *substantive-roots-p* true
                     (reunify-fses
                       (get-tdfs-given-id rule) (get (car dtrs) 'full-fs) nil))
                   (t
                     (error
"Inconsistency - unexpected value ~S in rule field of ~A when constructing full FS"
                       rule edge-symbol)))
                 (and dtrs (get (car dtrs) 'full-fs))))
           edge-symbol)))
      (rebuild-full-fs-1 edge-symbol))))

(defun reunify-fses (fs1 fs2 path)
  (if *unify-robust-p*
      (debug-yadu! fs1 fs2 path)
      (yadu! fs1 fs2 path)))

(defun reapply-rule (rule daughters rule-fs nu-orth)
  (declare (special *unify-robust-p*))
  ;; redo rule unifications
  (loop 
      with *unify-debug* = :return
      for path in (cdr (rule-order rule))
      for dtr in daughters
      as dtr-fs = (get dtr 'full-fs)
      do 
        (when dtr-fs
          (setq rule-fs (reunify-fses rule-fs dtr-fs path))
          (unless rule-fs
            (error
"~A~%Attempt to reunify ~A into rule ~A at < ~{~A ~^: ~}> failed when constructing full FS"
               (if (and (consp %failure%) (eq (first %failure%) :clash))
                   (format nil
                     "Unification of ~A and ~A failed at < ~{~A ~^: ~}>"
                     (third %failure%) (fourth %failure%) (second %failure%))
                   (format nil "Unification failure ~A" %failure%))
               (tdfs-indef dtr-fs) (rule-id rule) path))))
  ;; redo spelling change, if any
  (let ((orth-fs (when nu-orth 
                   (copy-tdfs-completely nu-orth)))
        (mother-fs (tdfs-at-end-of (car (rule-order rule)) rule-fs)))
    (when orth-fs
      (setq mother-fs (reunify-fses mother-fs orth-fs nil)))
    (unless mother-fs
      (error "Orthography failed to reunify when constructing full FS"))
    mother-fs))


(defun copy-full-fs (edge-symbol)
  ;; Copy out the full FS for this tree node and for all nodes below it. We're
  ;; in the same unification context throughout, so the DAG is traversed only
  ;; once overall because copy-dag leaves its result in the temporary copy slot
  ;; of each sub-dag.
  ;;
  (let ((edge (get edge-symbol 'edge-record))
        (fs (get edge-symbol 'full-fs)))
    (when fs
      (setf (get edge-symbol 'full-fs) (copy-tdfs-elements fs)))
    ;;
    ;; when edge has no DAG itself (typically because it was reconstructed from
    ;; a recorded derivation in Redwoods land), record the DAG that would go
    ;; with this edge during parsing; however, no need to restrict the full DAG
    ;; (for strict parsing compliance), as no-one should ever be able to look
    ;; at this edge directly: all viewing (in the current LKB at least :-) is
    ;; through nodes in the corresponding tree (un-restricted) or a derived
    ;; form, e.g. some MRS display variant.                    (30-oct-02; oe)
    ;;
    ;; _fix_me_
    ;; apparently, with some grammars, there are nodes that have no edge
    ;; somewhere towards the leaves; work around that for now, but expect to
    ;; understand this better some day.                        (20-nov-02; oe)
    ;;
    (when (and edge (null (edge-dag edge)))
      (setf (edge-dag edge) (get edge-symbol 'full-fs))))
  (mapc #'copy-full-fs (get edge-symbol 'daughters))
  edge-symbol)


;;; Compute parse node label from the full FS at a parse tree node. NB has to be
;;; the full FS otherwise labels could be wrong for nodes that get some of their
;;; features values by percolation down the tree, e.g. for SLASH

(defun label-parse-tree (edge-symbol)
  (setf (get edge-symbol 'label) (get-string-for-edge edge-symbol))
  (mapc #'label-parse-tree (get edge-symbol 'daughters)))


(defun get-string-for-edge (edge-symbol)
  (let* ((edge (get edge-symbol 'edge-record))
         (full-fs (get edge-symbol 'full-fs))
         (label (if edge
                    (tree-node-text-string
                      (or (and full-fs (find-category-abb full-fs))
                          (edge-category edge)))
                    (tree-node-text-string edge-symbol))))
    (setf (get edge-symbol 'label) label)
    (values label (null edge))))


(defun edge-mod-edge-p (edge-symbol1 edge-symbol2)
   (eq (get edge-symbol1 'edge-mod-edge) edge-symbol2))


;;; convert tree into a nested list - for simple printing of structure
;;; (dolist (parse *parse-record*) (pprint (parse-tree-structure parse)))
;;; DPF (16-Apr-99) Modified to use the rebuilding machinery employed for
;;; fancy parse trees - needed since in the chart we throw away ARGS when
;;; parsing.  If optional complete-p flag is set to nil, then the labeled
;;; bracketing will be constructed using the current settings of the flags 
;;; *show-lex-rules* and *show-morphology*.

(defun parse-tree-structure (edge &optional (complete-p t))
   (parse-tree-structure1 (make-new-parse-tree edge 1) complete-p))

(defun parse-tree-structure1 (node complete-p)
  (let ((daughters (if complete-p
		       (get node 'daughters)
		     (find-children node))))
    (cons (get-string-for-edge node)
	  (loop for dtr in daughters
               collect (parse-tree-structure1 dtr complete-p)))))

(defun extract-syntax-tree (edge)
  (labels ((recurse (node)
             (let ((label (get-string-for-edge node))
                   (daughters 
                    (loop 
                        for daughter in (get node 'daughters)
                        collect (recurse daughter))))
               (if daughters
                 (cons (intern label) daughters)
                 label))))
    (recurse (make-new-parse-tree edge 1))))
    
;; Find the children of a node, respecting various conditional display flags

(defun find-children (node)
  (let ((edge-record (get node 'edge-record))
        (dtrs (get node 'daughters)))
    (cond ((and (or (not *show-morphology*)
                    (not *show-lex-rules*))
                (null edge-record))
           ;; Leaf node
           nil)
          ((and (not *show-lex-rules*)
                edge-record
                (lexical-rule-p (edge-rule edge-record)))
           ;; Lexical rule node
           (mapcar #'find-leaf dtrs))
          (t dtrs))))

;; Given a node, return the first leaf node dominated by it.  Assumes
;; that this node and all nodes under it are unary branching.

(defun find-leaf (node)
  (if (null (get node 'edge-record))
      node
    (find-leaf (car (get node 'daughters)))))


;;; variant on above, which gives the ids of lexical items
;;; This always shows the complete tree, i.e. with any lexical
;;; rules etc

(defun print-parse-tty (stream)
  (loop for edge in *parse-record*
      do
        (pprint (parse-tree-structure-with-ids edge) stream)))

(defun construct-parse-trees nil
  (loop for edge in *parse-record*
      collect
        (parse-tree-structure-with-ids edge)))

(defun parse-tree-structure-with-ids (edge)
   (parse-tree-structure1-with-ids (make-new-parse-tree edge 1) nil))

;;; The following fn is a bit convoluted because the tree display
;;; has `pseudo-nodes' corresponding to the input strings
;;; and we want to ignore these.  Furthermode we need the lex ids
;;; at the terminal points, which are stored in a slot on the edges
;;; but have to be retrieved correctly.  The following is a bit
;;; hacky and might not work for all grammars.

(defun parse-tree-structure1-with-ids (node lex-ids)
  (let ((daughters (get node 'daughters)))
    (multiple-value-bind 
        (str lex new-lex-ids) 
        (get-string-for-edge-with-ids node)
      (if lex
          ;;; skip the pseudo-node if there are daughters
          (if daughters
              (progn
              (when (cdr daughters) 
                (error "~%Multiple daughters under pseudonode ~A" node))
              (parse-tree-structure1-with-ids (car daughters) lex-ids))
            (progn
              (when (cdr lex-ids) 
                (error "~%Multiple lex-ids under pseudonode ~A" node))
              (car lex-ids)))
        (cons str
              (if daughters
                  (loop for dtr in daughters
                      collect 
                        (parse-tree-structure1-with-ids dtr new-lex-ids))
                (progn
                  (when (cdr lex-ids) 
                    (error "~%Multiple lex-ids under leaf node ~A" node))
                  lex-ids)))))))

(defun get-string-for-edge-with-ids (edge-symbol)
  (let ((edge (get edge-symbol 'edge-record)))
    (if edge
        ;; for a real node, return its category, as for the
        ;; usual display, and the lex ids
        (values 
          (get-string-for-edge edge-symbol)
          nil
          (edge-lex-ids edge))
        ;; return nothing much for a pseudonode
        (values nil t nil))))

;;;
;;; generate HTML-only rendering of parse tree; requires LOGON CSS and JS
;;;
(defun html-tree (edge &key tree (indentation 0) color (stream t))
  (labels ((depth (edge)
             (let ((children (edge-children edge))) 
               (if (null children)
                 1
                 (+ 1 (loop for edge in children maximize (depth edge))))))
           (label (edge)
             (cond 
              ((rule-p (edge-rule edge))
               (let ((foo (string (rule-id (edge-rule edge)))))
                 (or (inflectional-rule-p foo) foo)))
              ((and (null (edge-rule edge)) (edge-category edge))
               (string (edge-category edge)))
              (t
               (string (first (edge-lex-ids edge))))))
           (derivation (edge &optional recursivep)
             (if (edge-p edge)
               (let* ((root (label edge))
                      (from (edge-from edge))
                      (to (edge-to edge))
                      (children (when recursivep
                                  (loop
                                      for child in (edge-children edge)
                                      collect (derivation child t)))))
                 (format 
                  nil
                  "<div class=treeNode>~
                     ~:[~2*~;[~a:~a] ~]~(~a~)~@[ : ~{~a~^ ~}~]</div>"
                  (and (numberp from) (numberp to)) from to root children))
               ""))
           (index (tree cache row column)
             (let* ((width
                     (loop
                         with row = (+ row 1)
                         with daughters = (get tree 'daughters)
                         with width = 0
                         for tree in daughters
                         do
                           (incf width (index tree cache row (+ column width)))
                         finally (return (if daughters width 1))))
                    (edge (get tree 'edge-record))
                    (comment (derivation edge))
                    (leafp (null edge)))
               (setf (aref cache row column) 
                 (list (get-string-for-edge tree) width leafp comment))
               width)))
    (let* ((depth (depth edge))
           (width (- (length (edge-leaves edge)) 1))
           (cache (make-array (list (+ depth 1) (+ width 1))))
           (tree (or tree (make-new-parse-tree edge 1))))
      (index tree cache 0 0)
      (loop
          initially 
            (format 
             stream 
             "~v,0t<table cellspacing=0 class=tree ~
                          ~@[style=\"color: ~a;\"~]>~%" 
             indentation color)
          finally (format stream "~v,0t</table>" indentation)
          for row from 0 to depth
          do (format stream "~v,0t  <tr>~%" indentation)
          do
            (loop
                with span = 0
                for column from 0 to width
                for label = (aref cache row column)
                when label do
                  (let ((string (first label))
                        (size (second label))
                        (leafp (third label))
                        (comment (or (fourth label) "")))
                    (format 
                     stream 
                     "~v,0t    ~
                      <td class=tree~:[Branch~;Leaf~] colspan=~a>~%~v,0t      ~
                      <div class=tree~:[Label~;Form~]~%~v,0t           ~
                           onMouseOver=\"treeNodeSelect(this, '~a')\"~%~
                           ~v,0t           ~
                           onMouseOut=\"treeNodeUnselect(this)\">~
                        ~a</div></td>~%~
                      ~:[~*~;~v,0t    <td class=treeMargin>&nbsp;</td>~%~]"
                     indentation
                     leafp (if (= size 1) 1 (- (* size 2) 1)) indentation
                     leafp indentation
                     comment
                     indentation 
                     string
                     (< (+ column (- size 1)) width) indentation)
                    (setf span (- size 1)))
                else when (zerop span) do
                  (format 
                   stream 
                   "~v,0t    ~
                    <td class=treeNone>~
                    ~:[~;<td class=treeMargin>&nbsp;</td>~]~%"
                   indentation (< column width))
                else do (decf span))
          do (format stream "~v,0t  </tr>~%" indentation)))))

(defun latex-tree (edge &key tree (format :derivation)
                             (indentation 0) (stream t))
  (labels ((label (edge)
             (cond 
              ((rule-p (edge-rule edge))
               (let ((foo (string (rule-id (edge-rule edge)))))
                 (or (inflectional-rule-p foo) foo)))
              ;;
              ;; _fix_me_
              ;; not sure this case is ever invoked?            (29-sep-13; oe)
              ;;
              ((and (null (edge-rule edge)) (edge-category edge))
               (string (edge-category edge)))
              ((null (edge-children edge))
               (format
                nil "~(~a@~a~)"
                (first (edge-lex-ids edge)) (edge-category edge)))
              (t
               (string (first (edge-lex-ids edge)))))))
    (when (null tree)
      (format stream "~v,0t{%~%" indentation)
      (incf indentation))
    (let* ((tree (or tree (make-new-parse-tree edge 1 t))))
      (if (edge-children edge)
        (loop
            for dtree in (get tree 'daughters)
            for dedge = (get dtree 'edge-record)
            do (latex-tree
                dedge :tree dtree :format format
                :indentation indentation :stream stream))
        (format
         stream
         "~v,0t\\leaf{\\emph{~a}}~%"
         indentation (first (edge-leaves edge))))
      (format
       stream
       "~v,0t\\branch{~a}{~a}~%"
       indentation (max (length (edge-children edge)) 1)
       (mrs::latex-escape-string
        (if (eq format :derivation)
          (string-downcase (label edge))
          (get-string-for-edge tree)))))
    (when (null tree)
      (format stream "~v,0t\\qobitree}~%" indentation))))
         

;;;

(defun construct-chart-no-display nil 
  (if (> *chart-max* 0) ; anything in chart?
      (let ((root (make-symbol "")))
        (setf (get root 'chart-edge-descendants)
          (make-array (1+ *chart-max*) :initial-element nil))
	(create-chart-pointers root)
        (setf (get root 'chart-edge-descendants)
          (reduce #'append (get root 'chart-edge-descendants) :from-end t))
        (adjust-chart-pointers root)
        root)
    (lkb-beep)))