(in-package "KPML-I")

;;; File: structure-grapher-interface.lisp
;;; Original versions: 19.10.95

;;; --------------------------------------------------------
;;;    STRUCTURE GRAPHER: ACCESS FROM THE WINDOW INTERFACE
;;; --------------------------------------------------------

;;; KPML 0.9: Allegro CLIM-2 only.
;;;           Attempt to use the Allegro multiprocessing facilities
;;;           in order to maintain proper behavior with multiple graphs.
;;; 4.0       Add details of semantic associations optionally to
;;;           the structure graph too. Why wasn't this done
;;;           ages ok! (Currently limited to those associations
;;;           that are made for ONUS before traversal of a
;;;           display constituent.)

;;; 1.1 scaling made separate from resource graphing...
(defvar *inter-sibling-scaling* 10)
(defvar *inter-subconstituent-scaling* 10)
(defvar *inter-sibling-hc* 10)
(defvar *inter-subconstituent-hc* 10)

;;; 2.0.44
;;; following could be a frame slot in a more permanent pass over
;;; this code...
(defvar *show-details-in-graph* nil)
;;; and this in some menu/dialogue box...
(defvar *feature-lists-in-structure-graph-width* 20)

;;; 2.1
;;; flexible font size added...

(defvar *structure-graphing-font* *fix--bold--10*)
(defvar *structure-details-font* kpml-i::*fix--bold--8*)
(defvar *STRUCTURE-FOREGROUND-COLOUR* nil)
(defvar *STRUCTURE-BACKGROUND-COLOUR* nil)

(defvar *SHOW-CYCLE-NUMBERS-IN-GRAPH* nil)  ;; 2.1

;;; 4.0
(defvar *show-associations-in-graph* nil)
(defvar *show-expansions*            T)

;;; ----------------------------------------------------------------------
;;; Application frame definition and layout

(clim:define-application-frame STRUCTURE-GRAPH ()
  ((lg :initform nil)
   (info :initform nil)
   (expansion-info :initform nil)   ;; 4.0
   )
  (:top-level (clim:default-frame-top-level  :prompt kpml-prompt-function))
  (:command-table 
   (structure-graph
    :menu
    (("Quit Structure Grapher" :command com-quit-structure-grapher)
     ("Options" :command com-structure-graph-options)
     #-(or acl3.0 lispworks4.0)
     ("Print" :command com-printgraph)
     ("Color selection" :menu structureg-foreground-colour))))
  (:panes (graph        :application
			:display-function 'structure-displayer
		        :foreground sentence-structure-fg
		        :background sentence-structure-bg
		        :text-style *structure-graphing-font*)
	  #-lispworks
          (mouse-doc   :pointer-documentation
		       :foreground  mouse-doc-fg
		       :background  mouse-doc-bg)
          )
  (:layouts (default (clim:vertically () 
		       ;; need the fill for ACL... does it harm in Lispworks?
                       (:fill graph)
                       #-lispworks (2/32 mouse-doc)
                       )))
  (:menu-bar T)
  (:command-definer t))

;;; ----------------------------------------------------------------------
;;; 3.0 color control...
;;; ----------------------------------------------------------------------

(clim:define-command-table 
    STRUCTUREG-FOREGROUND-COLOUR
    :menu (("Red" :command structureg-fg-red)
	   ("Green" :command structureg-fg-green)
	   ("Blue" :command structureg-fg-blue)
	   ("Black" :command structureg-fg-black)
	   ("Magenta" :command structureg-fg-magenta)
           ("Yellow" :command structureg-fg-yellow)
           ("Divider" :divider)
           ("Grey" :command structureg-fg-grey)
           ("Light grey" :command structureg-fg-light-grey)))


;;; ----------------------------------------------------------------------

(defmethod STRUCTURE-DISPLAYER ((frame structure-graph) stream)
  ;; 2.0.49 folded in.
  (let ((kpml::show-pass-hash-table (slot-value frame 'info)))
    (with-possible-font-changes-for-language 
	(stream (slot-value frame 'lg) *structure-graphing-font*)
      (progn
	(set-structure-highlight-nomination-criteria)
	(handler-case
	  (clim:format-graph-from-roots
	   (list 'kpml::top)
	   #'print-sentence-structure-nodes
	   #'kpml::constit-children
	   :generation-separation *inter-subconstituent-scaling*
	   :within-generation-separation *inter-sibling-scaling*
	   :merge-duplicates nil
	   :move-cursor nil
	   :orientation *hardcopy-structure-orientation*
	   :stream stream)
	  (error () 
	    (clim:with-text-size (stream :larger)
	      (format stream "~2%No well-formed structure was generated!~%"))
	    (loop for m 
		in (kpml::indent-list-of-strings
		    3 
		    '("Check warnings and resources for conflation"
		      "and ordering problems. It is also worthwhile"
		      "checking the example structure graph."))
		do (format stream "~%~A" m))))))))

  ;;
  ;; Real version moved to startups.lisp
  ;;
#+ignore 
(defun GRAPH-SENTENCE-STRUCTURE ()
  (let ((grapher-application-frame (clim:make-application-frame
				    'structure-graph
				    :left 10 :top 10
				    :width *structure-graph-width*
				    :height *structure-graph-height*)))

    (setf (slot-value grapher-application-frame 'lg) kpml::curlan)
    (setf (slot-value grapher-application-frame 'info)
      (kpml::copy-pass-table kpml::show-pass-hash-table))

    (setq *structure-process*
      (process-run-function 
       "KPML-STRUCT-GR"
       #'run-structure-grapher 
       (find-package "PENMAN")
       grapher-application-frame kpml::show-pass-hash-table))
    
    (undo-lg-based-font-decision *structure-graphing-font*)))


;;; ACLPC, ACL3.0 CLIM2.1 does not appear to know about postscript!
;;; nor LWW4.0

#-(or acl3.0 lispworks4.0)
(define-structure-graph-command 
  (com-PRINTGRAPH :name "Print structure" :menu t)
  ()
  (hardcopy-structure-graph 
   (merge-pathnames *default-kpml-hardcopy-directory* 
		    (make-structure-hardcopy-filename))
   (not *suitable-for-figures?*)))

(define-structure-graph-command (com-STRUCTURE-GRAPH-OPTIONS
				 :name "Options" :menu t)
  ()
  (structure-grapher-display-options))
   
;;; ----------------------------------------------------------------------
;;; 2.0.44 toggling the showing of details...
;;; ----------------------------------------------------------------------

(define-structure-graph-command (com-STRUCTURE-GRAPH-DETAILS
				 :name "Details" :menu t)
  ()
  (setf *show-details-in-graph* (not *show-details-in-graph*)))

;;; ----------------------------------------------------------------------
;;; 2.1 very similar for showing the cycle numbers...
;;; ----------------------------------------------------------------------

(define-structure-graph-command (com-STRUCTURE-GRAPH-CYCLE-NUMBER
				 :name "Cycles" :menu t)
  ()
  (setf *show-cycle-numbers-in-graph* (not *show-cycle-numbers-in-graph*)))

;;; ----------------------------------------------------------------------
;;; 4.0 and again for associations...
;;; ----------------------------------------------------------------------

(define-structure-graph-command (com-STRUCTURE-GRAPH-ASSOCS
				 :name "Associations" :menu t)
  ()
  (setf *show-associations-in-graph* (not *show-associations-in-graph*)))

;;; ----------------------------------------------------------------------
;;; 4.0 and similarly for expansions...
;;; ----------------------------------------------------------------------

(define-structure-graph-command (com-STRUCTURE-GRAPH-EXPANSIONS
				 :name "Expansions" :menu t)
  ()
  (setf *show-expansions* (not *show-expansions*)))

;;; ----------------------------------------------------------------------
;;; 2.1 allow updating the structure graph to follow generation without
;;;     having to startup a new window, etc.
;;; ----------------------------------------------------------------------

(define-structure-graph-command 
  (com-UPDATE-STRUCTURE-GRAPH :name "Update" :menu t)
  ()
  (undo-lg-based-font-decision *structure-graphing-font*)
  (setf (slot-value clim:*application-frame* 'lg) kpml::curlan)
  (setf (slot-value clim:*application-frame* 'info)
        (kpml::copy-pass-table kpml::show-pass-hash-table)) 
  (setf (slot-value clim:*application-frame* 'expansion-info) ;; 4.0
	(kpml::extract-pass-expansion-info))
  (clim:redisplay-frame-pane clim:*application-frame* 'graph :force-p t))


(define-structure-graph-command (com-ACTIVATE-SELXPR
				 :name "Activate Selection Expression Tools" :menu t)
  ()
  (setf *selection-expression-tool* T))


;;; ----------------------------------------------------------------------

(define-structure-graph-command 
  (com-QUIT-STRUCTURE-GRAPHER :name t :menu t)
  ()
  (close-a-window clim:*application-frame*))


;;; ----------------------------------------------------------------------
;;; Following is the initialization and startup for a grapher frame
;;; and accompanying process. Unlike the other windows, resource and
;;; structure graphs always create a new frame/process.
;;;
;;; 0.9 - highlighting of selected nodes now added.
;;; Wraps the special binding of *structure-grapher* within each
;;; grapher process, also the state of generation is frozen within
;;; each grapher process...
;;; ----------------------------------------------------------------------

(defun RUN-STRUCTURE-GRAPHER 
  (*package* *structure-grapher* kpml::show-pass-hash-table)
  (declare (special *structure-grapher*
		    kpml::show-pass-hash-table))
  (clim:run-frame-top-level *structure-grapher*))


;;; ----------------------------------------------------------------------
;;; Criteria for highlighting nodes in the structure display...
;;; In order to highlight nodes, highlighting conditions should be added
;;; to the *highlights* variable. This contains a list of microfunctions
;;; that are to be highlighted. The effect is that all nodes which have
;;; the same *semantic* referent as the identified microfunctions are
;;; highlighted.

(defvar *highlights* '() "Microfunctions for controlling highlighting")
(defvar *hubs* '())
(defvar *show-last-generated-node* T)

(defun SET-STRUCTURE-HIGHLIGHT-NOMINATION-CRITERIA ()
  (setf *hubs*
	(loop for a in kpml::associations
	      when (member (kpml::function-association-function a)
			   *highlights*)
	      collect (spl-symbol (kpml::function-association-concept a)))))

;;; following was not prepared for numbers...
;;; 0.9.1
;;; 0.9.26 still wasn't quite right!
;;; 4.1    got some weird structures coming through, make absolutely
;;;        watertight so that we avoid an error.

(defun SPL-SYMBOL (x)
  (if (and 
       (not (numberp x))
       (symbolp x)
       (boundp x)
       (not (null x))
       (kpml::term-graph-p (symbol-value x)))
      (kpml::term-graph-symbol (symbol-value x))
    x))


;;; --------------------------------------------------
;;;
;;;  Presentations...
;;;
;;; --------------------------------------------------

(clim:define-presentation-type graph-node ())

;;; ----------------------------------------------------------------------
;;; Commands and support functions...
;;; ----------------------------------------------------------------------

(defun PRINT-SENTENCE-STRUCTURE-NODES (object stream)
  (macrolet ((print-node ()
	       '(if *show-details-in-graph*
		    (multiple-value-bind (up down lexified?)
					 (fetch-interrank-constraints object)
		     ;; 4.0
		     (when *show-associations-in-graph*
		       (print-associations-in-structure object stream))
		     (print-small-list-of-features up stream clim:+red+)
		     (clim:with-text-size 
		      (stream *structure-graph-major-info-size*)
		      (format stream "~%~a" (kpml::node-label object)))
		     (when (car down)
		       (print-small-list-of-features 
			(car down) stream clim:+magenta+))
		     (when (cdr down)
		       (clim:with-text-face (stream :bold)
					    (print-small-list-of-features 
					     (cdr down) stream clim:+magenta+)))
		     (when lexified?
		       (clim:with-text-style 
			(stream kpml-i::*fix--bold--8*)
			(clim:with-text-size 
			 (stream *structure-graph-info-size*)
			 (if *monochrome?*
			     (format stream "~%(lexified)")
			   (clim:with-drawing-options 
			       (stream :ink clim:+cyan+)
			     (format stream "~%(lexified)")))))))
		  (progn
		    ;; 4.0
		    (when *show-associations-in-graph*
		      (print-associations-in-structure object stream)
		      (format stream "~%"))
		    ;;
		    ;; if no extra info, this is the absolute minimum...
		    ;;
		    (clim:with-text-size 
		     (stream *structure-graph-major-info-size*)
		     (format stream "~a" (kpml::node-label object)))))))
    
    (if (and *show-last-generated-node*    
	     (currently-generated-node-p object))
	(clim:with-output-as-presentation 
	    (stream object 'incomplete-structure-node)    ;; 1.1 addition
	  (clim:surrounding-output-with-border (stream :shape :oval)
	    (clim:with-drawing-options (stream :ink clim:+magenta+) 
	      (print-node))))
      
      (clim:with-output-as-presentation 
	  (stream object 'graph-node)
        (cond ((null object)
	       (clim:surrounding-output-with-border (stream :shape :oval)
	         (clim:with-drawing-options (stream :ink clim:+red+)
		   (clim:with-text-style (stream kpml-i::*fix--bold--16*)
		     (format stream "No structure generated.")))))
	    
	      ((sentence-structure-node-highlight-p object)
	       (clim:with-drawing-options (stream :ink clim:+red+)
	         (clim:with-text-face (stream :italic) (print-node))))
	    
	      (t 
               (clim:with-drawing-options 
                   (stream :ink (if *structure-foreground-colour*
                                    *structure-foreground-colour*
                                  sentence-structure-fg))
                 (print-node))))))))


(defun SENTENCE-STRUCTURE-NODE-HIGHLIGHT-P (object)
  (if (listp object)
      (if (member (spl-symbol
		   (kpml::whiteboard-elt-hub (cdr object)))
		  *hubs*)
	  T
	nil)
    nil))


(defun CURRENTLY-GENERATED-NODE-P (object)
  (cond ((consp object)
	 (eq (first kpml::alias-function-stack)
	     (kpml::whiteboard-elt-aliasfn 
	      (cdr object))))
	((eq object 'kpml::top)
	 (eq (first kpml::alias-function-stack)
	     'kpml::-top-))
	(t  nil)))


;;; 4.0
(defun PRINT-ASSOCIATIONS-IN-STRUCTURE (element stream)
  (let ((onus (kpml::fetch-onus-associations element)))
    (when onus
      (clim:with-drawing-options 
       (stream :ink +light-but-readable-green+)
       (clim:with-text-style (stream *structure-details-font*)
	 (clim:with-text-size 
	  (stream *structure-graph-info-size*)
	  (format stream "~%[~S~% ~S]" (second onus)(third onus))))))))

;;; ----------------------------------------------------------------------

(clim:define-presentation-action present-graph-node
  (graph-node nil structure-graph :documentation "Structural constraints inspection menu"
              :gesture :menu)
  (object)
  (structure-graph-options-menu object))

(clim:define-presentation-action selexpr-graph-node
  (graph-node nil structure-graph :documentation "Selection expression")
  (object)
  (let ((message-stream 
	 (clim:get-frame-pane 
	  *resource-inspector-frame* 'inspector)))
    (kpml::display-constit-features object message-stream)))


;;; ----------------------------------------------------------------------
;;; 2.0 insertions added...
;;; 3.1 selection expression moved to left-click
  ;; --------------------------------------------------
  ;; 3.2.10
  ;;   got the case statement keys and those required mixed up...
  ;;   thereby inadvertently disabling some selections...
  ;; 3.2.59
  ;;   very primitive punctuation trace added to interface options...
  ;; --------------------------------------------------

(defun STRUCTURE-GRAPH-OPTIONS-MENU (node)
  ;; 2.0.2 add in insertions and expansions insertions...
  ;; 2.0.2a sneaked in the kpml user level additions too...
  (let ((message-stream 
	 (clim:get-frame-pane 
	  *resource-inspector-frame* 'inspector)))
    (case
     (menu-choose 
      '(|Insertions|
	|Expansions|
	|Conflations|
	|Orderings|
	|Preselections|
        |-------|
	|Lexical constraints from grammar|
        #+(or (not :kpml-level>=)        ;; this for KPML 2.0 without levels
	      (and :kpml-level>= :kpml-l3))
        |Lexicalization results|
	#+(or (not :kpml-level>=)        ;; this for KPML 2.0 without levels
	   (and :kpml-level>= :kpml-l2)) 
	|Associations|
        #+(or (not :kpml-level>=)        ;; this for KPML 2.0 without levels
	      (and :kpml-level>= :kpml-l3))
	|All structural constraints|
        |Selection expression tool|
        |-------|
	|Punctuation applied|
	)
       :associated-window (clim:frame-top-level-sheet 
			   clim:*application-frame*)
       :label "Structure Graph Options")
      
      ;; 2.1
      (|Selection expression tool|
       (let ((*selection-expression-tool* T))
         (declare (special *selection-expression-tool*))
         (kpml::display-constit-features node message-stream)))
      ;; 2.0.2
      (|Insertions|
       (kpml::display-selected-inserts node message-stream))
      ;; 2.0.2
      (|Expansions|
       (kpml::display-selected-expands node message-stream))
      (|Conflations|
       (kpml::display-selected-conflations node message-stream))
      (|Preselections|
       (kpml::display-selected-preselects node message-stream))
      (|Lexical constraints from grammar|  
       ;; 3.2.10 wrong name corrected... and precheck added.
       (unless (terminal-node-p node message-stream)
	 (kpml::display-selected-classifies node message-stream)
	 (kpml::display-selected-inflectifies node message-stream)
	 (kpml::display-selected-lexifies node message-stream)))
      (|Lexicalization results|
       (kpml::display-lexicalization-history-for node message-stream))
      (|Orderings|
       (kpml::display-selected-ordering-relations node message-stream))
      ;; 3.2.59
      (|Punctuation applied|
	(kpml-i::startup-an-info-window 
	 "Punctuation Rules Applied" kpml::*applied-punctuation-list*))
      (|All structural constraints|
       (format message-stream 
	       "~% Node contents saved to variable: *nodes*")
       (push (cons (kpml::extract-fundle node)
		   node)
	     kpml::*nodes*))
      (|Associations|
       (kpml::display-associations node message-stream))
      (t
       (format message-stream "~%No selection.")))))

;;; ----------------------------------------------------------------------
;;; 0.8 hardcopy for structure graphs....

(defun MAKE-STRUCTURE-HARDCOPY-FILENAME ()
  (multiple-value-bind 
   (second minute hour date month year) 
   (get-decoded-time)
   (format nil "~a-~a~2,'0D~2,'0D-~2,'0D~2,'0D~2,'0D.ps" 
	   kpml::*most-recent-example* year month date hour minute second)))


;;; 2.0 name of postscript stream changed...
#-acl3.0
(defun HARDCOPY-STRUCTURE-GRAPH (filename multipage?)
  (with-open-file 
   (fstr filename 
	 :direction :output :if-exists :overwrite :if-does-not-exist :create)
   (clim::with-output-to-postscript-stream 
    (*standard-output* fstr :multi-page multipage?)

    (when multipage?
	  (clim:with-text-style 
	   (*standard-output* kpml-i::*fix--bold--16*)
	   (format *standard-output* "Example: ~A; Language: ~A; ~A~10%~0T"
		   kpml::*most-recent-example*
		   kpml::curlan (kpml::time-stamp))))
    (clim:format-graph-from-roots
     (list 'kpml::top)
       #'print-sentence-structure-nodes
       #'kpml::constit-children
       :generation-separation  *inter-subconstituent-hc*
       :within-generation-separation *inter-sibling-hc*
       :merge-duplicates nil
       :move-cursor nil
       :orientation *hardcopy-structure-orientation*
       :stream *standard-output*)
    fstr))
  (when *auto-print* (auto-print filename)))

;;; ----------------------------------------------------------------------
;;; Structure graph options...

(defun STRUCTURE-GRAPHER-DISPLAY-OPTIONS
  (&optional
   (stream (clim::frame-top-level-sheet clim:*application-frame*)))
  (clim:accepting-values
   (#-acl3.0 stream #+acl3.0 *query-io* :own-window *own-window*
	   :scroll-bars :vertical
	   :resynchronize-every-pass t
	   :label "Structure Grapher Options" :exit-boxes 
	   '((:exit "Click here to exit")(:abort "")))
   (let ((stream #-acl3.0 stream #+acl3.0 *query-io*))
     (on-or-off *show-last-generated-node*
		"Highlight currently/last generated node..")
     (kpml-i-terpri stream)
     (on-or-off *auto-print*
		"Send created postscript files to printer..")
     (radio-box-accept *hardcopy-structure-orientation* (:vertical :horizontal)
                       "Structure graph orientation ............")
     (kpml-i-terpri stream)
     (setf *inter-sibling-scaling* 
	   (clim:accept 'integer :stream stream
			#+lispworks :view 
			#+lispworks clim:+textual-dialog-view+
			:prompt "Inter-sibling scaling       ................."
			:default *inter-sibling-scaling*))
     (kpml-i-terpri stream)
     (setf *inter-subconstituent-scaling* 
	   (clim:accept 'integer :stream stream
			#+lispworks :view 
			#+lispworks clim:+textual-dialog-view+
			:prompt "Inter-constituent scaling        ............"
			:default *inter-subconstituent-scaling*))
     (kpml-i-terpri stream)
     (setf *structure-graph-major-info-size*       ;; 4.0
	   (clim:accept 'integer :stream stream
			#+lispworks :view 
			#+lispworks clim:+textual-dialog-view+
			:prompt "Main font size                   ............"
			:default *structure-graph-major-info-size*))
     (kpml-i-terpri stream)
     #-(and acl3.0 aclpc)
     (progn
       (setf *inter-sibling-hc* 
	     (clim:accept 'integer :stream stream
		    #+lispworks :view #+lispworks clim:+textual-dialog-view+
		    :prompt "Hardcopy inter-sibling scaling  ............."
		    :default *inter-sibling-hc*)) ;; 4.0 default was wrong
       (kpml-i-terpri stream)
       (setf *inter-subconstituent-hc* 
	     (clim:accept 'integer :stream stream
		    #+lispworks :view #+lispworks clim:+textual-dialog-view+
		    :prompt "Hardcopy inter-constituent scaling   ........"
		    :default *inter-subconstituent-hc*))
       (kpml-i-terpri stream)
       (setf *default-kpml-hardcopy-directory*
	     (clim:accept 'clim:pathname :stream stream
			  #+lispworks :view 
			  #+lispworks clim:+textual-dialog-view+
			  :prompt "Hardcopy directory           ............"
			  :default *default-kpml-hardcopy-directory*))
       (kpml-i-terpri stream)
       (on-or-off *grapher-header*
		  "Hardcopy with header         ............")
       (kpml-i-terpri stream)
       (on-or-off *suitable-for-figures?*
		  "Suitable for eps (ie. not multipage)?  ..")
       ))))

;;; 
;;; ----------------------------------------------------------------------
;;; 1.1 addition of explicitly different treatment of incomplete
;;;     nodes that are examined in the middle of generation (ususally
;;;     because of some error condition that has arisen...)
;;; 3.1 selection expression moved to left-click here also

(clim:define-presentation-type incomplete-structure-node ())

(clim:define-presentation-action selexpr-incomplete-structure-node
    (incomplete-structure-node nil structure-graph :documentation "Selection expression")
  (object)
  (let ((message-stream (clim:get-frame-pane 
	                 *resource-inspector-frame* 'inspector)))
    (kpml::display-incomplete-constit-features object message-stream)))

(clim:define-presentation-action present-incomplete-structure-node
    (incomplete-structure-node nil structure-graph
         :documentation "Incomplete unit structural constraints inspection menu"
         :gesture :menu)
    (object)
  (incomplete-graph-node-options-menu object))

(defun INCOMPLETE-GRAPH-NODE-OPTIONS-MENU (node)
  (let ((message-stream 
	 (clim:get-frame-pane 
	  *resource-inspector-frame* 'inspector)))
    (case
     (menu-choose 
      '(
	|Current system|
	|Current chooser|
	|Associations so far|
	|Preselections|
	|Orderings|
	|Lexical constraints|
	|All structural constraints|
	)
       :associated-window (clim:frame-top-level-sheet 
			   *structure-grapher*)
       :label "Incomplete Structure Node Options")
      (|Associations so far|
       (kpml::display-incomplete-associations node message-stream))
      (|Current system|
       (kpml::describe-system kpml::message-sender))
      (|Current chooser|
       (kpml::describe-chooser 
	(kpml::fetch-system-chooser kpml::message-sender)
        ;; 2.1
        :for-constituent node))
      ;; (kpml::extract-fundle node) what was this for?
      (|Preselections|
       (kpml::display-selected-preselects node message-stream))
      (|Lexical constraints|
       (kpml::display-selected-classifies node message-stream)
       (kpml::display-selected-inflectifies node message-stream)
       (kpml::display-selected-lexifies node message-stream))
      (|Orderings|
       (kpml::display-selected-ordering-relations node message-stream))
      (|All structural constraints|
       (format message-stream 
	       "~% Node contents saved to variable: *nodes*")
       (push (cons (kpml::extract-fundle node)
		   node)
	     kpml::*nodes*))
      (t
       nil))))

;;; ----------------------------------------------------------------------
;;; 2.0 use of the above to provide a graphical means of selectively
;;;     realizing selected units of substructure... Following redefines
;;;     the stubb in generate/structure.lisp
;;;     Use of this kind of selective realization may be
;;;     avoided by setting the flag kpml::*realize-selectively-mode* to
;;;     :serial.

;;; A dummy frame to get cheap access to a command table and command definer.
(clim:define-application-frame REALIZE-SELECTIVELY-GRAPH ()
  ((selected :initform nil)
   (candidates :initform nil))
  (:top-level (clim:default-frame-top-level  :prompt kpml-prompt-function))
  (:command-table (realize-selectively-graph
		   :inherit-from (clim:accept-values-pane
				  clim:user-command-table)))
  (:panes (graph        :application
			:display-function 'structure-displayer
		        :foreground sentence-structure-fg
		        :background sentence-structure-bg
		        :text-style *structure-graphing-font*))
  (:command-definer t))


;;; It is unfortunate that within the accepting-values below 
;;; clim:*application-frame* gets hijacked so that we don't get
;;; access to the realize selectively frame. This is therefore
;;; maintained as a global. Consequences: don't do more than one
;;; generation simultaneously with selective realization!
(defvar *realize-selectively-frame* nil)

;;; Following function returns a revised  version of its parameter where the
;;; subconstituents to be generated receive status :generate. Any that
;;; will never be generated should  receive status  :unwanted. As long  as
;;; any constituent has status nil, it will be  re-offered to the user to
;;; see if  it should  be  generated or not. Possible dependencies
;;; (such as may be set up with agreement) are *not* enforced.
;;; If the function as a whole returns nil, then
;;; the user is just re-presented with the current options.
;;; Selecting abort will mean that any constituents ungenerated or unselected
;;; for generation within the rank currently highlighted
;;; are not wanted for generation at all.

(defun KPML::BRING-UP-A-CONSTITUENT-SELECTION-DIALOG (wbe-bs-pairs) 
  (let* ((kpml::show-pass-hash-table 
	  (kpml::copy-pass-table kpml::show-pass-hash-table))
	 (kpml::in-situ-use-of-pass-data kpml::show-pass-hash-table)
	 (clim:*application-frame*
	  (clim:make-application-frame
	   'realize-selectively-graph
	   :left 10 :top 10
	   :width *structure-graph-width*
	   :height *structure-graph-height*))
	 (stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (declare (special kpml::in-situ-use-of-pass-data))
    (setf kpml::in-situ-use-of-pass-data kpml::show-pass-hash-table)
    (setf (slot-value clim:*application-frame* 'candidates) wbe-bs-pairs)
    (setf *realize-selectively-frame* clim:*application-frame*)
    (labels ((set-wanted ()
	       (loop for pair 
		   in (slot-value clim:*application-frame* 'candidates)
		   when (selected-for-generation-p 
			 (kpml::constituent-to-generate-wbe pair))
		   do (setf (kpml::constituent-to-generate-status pair) 
			:generate))))
      (restart-case
	  (clim:accepting-values
	      (stream :own-window kpml-i::*own-window*
		      :resynchronize-every-pass t
		      :scroll-bars :both
		      :command-table 'realize-selectively-graph
		      :label "Selectively realize substructure" 
		      :exit-boxes 
		      #-acl3.0
		      '((:exit "Click to generate subconstituents")
			(:abort "Click to leave this rank"))
		      #+acl3.0
		      '((:exit "")
			(:abort "Click blankspace to leave this rank")))
	    (clim:with-text-style (stream kpml-i::*fix--bold--8*)
	      (set-structure-highlight-nomination-criteria)
	      (clim:format-graph-from-roots
	       (list 'kpml::top)
	       #'print-sentence-structure-nodes
	       #'kpml::constit-children
	       :generation-separation *inter-subconstituent-scaling*
	       :within-generation-separation *inter-sibling-scaling*
	       :merge-duplicates nil
	       :move-cursor nil
	       :orientation *hardcopy-structure-orientation*
	       :stream stream)))
	(abort () 
	  (progn
	    (set-wanted)
	    (loop for pair in (slot-value clim:*application-frame* 'candidates)
		unless (kpml::constituent-to-generate-status pair)
		do (setf (kpml::constituent-to-generate-status pair) 
		     :unwanted))
	    (return-from KPML::BRING-UP-A-CONSTITUENT-SELECTION-DIALOG 
	      (slot-value clim:*application-frame* 'candidates)))))
      (set-wanted)
      (setf *realize-selectively-frame* nil)
      (slot-value clim:*application-frame* 'candidates))))

(defun SELECTED-FOR-GENERATION-P (unit)
  (with-slots (selected) *realize-selectively-frame*
    (loop for s in selected
	thereis (member (kpml::whiteboard-elt-aliasfn unit) s))))

;;; Commands for selecting a unit for generation and for inspecting things
;;; done so far... Uses the presentation types defined within the
;;; standard structure grapher, just changes the command table with
;;; respect to which they are active.

(clim:define-presentation-action PRESENT-SELECTIVELY-REALIZE-NODE
    (graph-node nil realize-selectively-graph)
  (object)
  (with-slots (selected) *realize-selectively-frame*
    (pushnew (kpml::extract-fundle object) selected)))

(clim:define-presentation-action SELECTIVELY-REALIZE-OPTION
    (graph-node nil realize-selectively-graph :gesture :menu)
  (object)
  (let ((*package* (find-package "KPML")))
    (structure-graph-options-menu object)))

(clim:define-presentation-action PRESENT-CURRENT-RANK-NODE
    (incomplete-structure-node nil realize-selectively-graph)
  (object)
  (let ((*package* (find-package "KPML")))
    (structure-graph-options-menu object)))

(define-realize-selectively-graph-command 
  (com-SELREAL-BLANK-SPACE-OPTIONS :name t)
    ()
  (with-slots (candidates) *realize-selectively-frame*
    (loop for pair in candidates
	when (selected-for-generation-p 
	      (kpml::constituent-to-generate-wbe pair))
	do (setf (kpml::constituent-to-generate-status pair) :generate))
    (loop for pair in candidates
	unless (kpml::constituent-to-generate-status pair)
	do (setf (kpml::constituent-to-generate-status pair) :unwanted))))

(clim:define-presentation-to-command-translator SELGRAPH-BLANK-SPACE-OPTIONS
    (clim:blank-area com-selreal-blank-space-options realize-selectively-graph
		     :documentation "Leave this rank")
  (x y)
  (declare (ignore x y))
  (values))

;;; ----------------------------------------------------------------------
;;; 2.1 could not change the generation modes from the graphical selective
;;;     realization window, which was not good. Added here.
;;;     Although seems to be a bit delayed in when it takes effect.
;;; ----------------------------------------------------------------------

(clim:define-presentation-to-command-translator SELGRAPH-BLANK-SPACE-OPTIONS
    (clim:blank-area com-set-generation-modes-srg realize-selectively-graph
		     :gesture :menu
		     :documentation "Set generation modes")
  (x y)
  (declare (ignore x y))
  (values))

(define-realize-selectively-graph-command 
  (com-SET-GENERATION-MODES-SRG :name t)
    ()
  (run-modes))

;;; ----------------------------------------------------------------------
;;; 2.0.44
;;;  showing details of the constituents graphed...
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; Following takes a list of features and prints it, possibly in some
;;; color, as a bracketted list on stream filled according to the 
;;; *feature-lists-in-structure-graph-width* global.
;;;
;;; 4.0 added a further argument for the size of the features...
;;; ----------------------------------------------------------------------

(defun PRINT-SMALL-LIST-OF-FEATURES 
    (features stream &optional (color nil)(size *structure-graph-info-size*))
  (when features
    (macrolet 
	((print-it ()
	   `(let* ((f-list 
		    (reduce #'(lambda (x y) (concatenate 'string x " " y))
			    (mapcar #'string-downcase features)))
		   (ready-to-print 
		    (kpml::indent-and-fill 
		     f-list 
		     :right-margin *feature-lists-in-structure-graph-width* 
		     :right-margin-p T
		     :left-margin 1
		     :except-first-p T)))
	      (clim:with-text-style (stream *structure-details-font*)
		(clim:with-text-size (stream size)
		  (clim:with-text-face (stream :italic) 
		    (format stream "~%{")
		    (loop for s in (butlast ready-to-print 1)
			do (format stream "~A~%" s))
		    (format stream "~A}" (first (last ready-to-print)))))))))
      (if (and color (not *monochrome?*))
	  (clim:with-drawing-options (stream :ink color)
	    (print-it))
	(print-it)
	))))

;;; ----------------------------------------------------------------------
;;; Simply gives back the interrank constraints associated with some
;;; node as three values: preselects (classifies . inflectifies) lexified?
;;; ----------------------------------------------------------------------

(defun FETCH-INTERRANK-CONSTRAINTS (node)
  (if (or (eq node 'top)(stringp node)(null node)(symbolp node))
      (values nil nil nil)
    (let ((upwards (kpml::extract-constraints node 'kpml::preselect))
	  (downwards 
	   (cons (kpml::extract-constraints node 'kpml::classify)
		 (kpml::extract-constraints node 'kpml::inflectify)))
	  (lexified? 
	   (kpml::extract-constraints node 'kpml::lexify)))
      (values
       upwards downwards lexified?))))

;;; ----------------------------------------------------------------------
;;; 3.0
;;; More colour setting commands and colour management... (adapted en masse
;;; from resource-graphing and there from the example mismatch case).
;;; ----------------------------------------------------------------------

(defmacro STRUCTURE-COLOR-SETTER (com-label color clim-color fg?)
  `(define-structure-graph-command 
       (,(intern (format nil "STRUCTUREG-~A-~A" (if fg? :fg :bg) color)
		 "KPML-I")
	:name ,com-label :menu nil)
       ()
     (setf ,(intern (if fg? 
                        "*STRUCTURE-FOREGROUND-COLOUR*" 
                      "*STRUCTURE-BACKGROUND-COLOUR*") "KPML-I")
           ,clim-color)
     (clim:redisplay-frame-pane 
      clim:*application-frame* 'graph :force-p t)))

(defmacro DEFINE-STRUCTURE-COLOR-COMMANDS ()
  `(progn
     ,@(loop for fg in '(T)
	   append
	 (loop for (color label clim-color)
	       in *kpml-colour-wheel*
	       collect
	       `(structure-color-setter ,color ,label ,clim-color ,fg)))))

(define-structure-color-commands)

;;; ----------------------------------------------------------------------

(defun TERMINAL-NODE-P (node window)
  (cond ((eq node 'top)
	 (Format window "~% Top node: no higher constraints!")
	 T)
	((or (stringp node)(null node)(symbolp node))
	 (clim:notify-user 
	  window 
	  "Terminal node: try clicking on its parent for more information")
	 T)
	(t nil)))