(in-package "KPML-I")

;;; File: genre-grapher.lisp
;;; KPML 0.8: separated to a different kind of frame than the
;;;           old-style structure graphs.


;;; --------------------------------------------------
;;;
;;;  WINDOW DEFINITIONS AND ACCESS...
;;;
;;; --------------------------------------------------

(clim:define-application-frame genre-structure-graph ()
  ()
  (:top-level (clim:default-frame-top-level  :prompt kpml-prompt-function))
  (:panes (graph        :application
		        :foreground spl-fg
		        :background spl-bg
		        :text-style *fix--bold--10*)
	  (menu         :command-menu
			:foreground menu-fg
			:background menu-bg			
		        :text-style *fix--bold--12*))
  (:layouts (default (clim:horizontally () graph)))
  (:command-definer t))

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

(clim:define-presentation-action present-genre-graph-node
  (gsp-graph-node nil genre-structure-graph)
  (object)
  (gsp-graph-options-menu object))

(define-genre-structure-graph-command 
  (com-QUIT-GENRE-STRUCTURE-GRAPHER :name t :menu t)
  ()
  (clim:frame-exit clim:*application-frame*))

;;; ----------------------------------------------------------------------
;;; Genre graphing commands....


(defvar *genre-structure-grapher* nil)
(defvar *genre-structure-process* nil)


(defun GRAPH-GENRE-STRUCTURE ()
  (let ((gen-sep 100)
	(inter-gen-sep 10)
	stream )
    (when (and (stringp kpml::*the-text*)
	       (string= kpml::*the-text* ""))
      (return-from GRAPH-GENRE-STRUCTURE nil))
    (unless kpml::*the-text* (return-from GRAPH-GENRE-STRUCTURE nil))

    (setf *genre-structure-grapher*
      (clim:make-application-frame
       'genre-structure-graph
       :left 10 :top 10
       :width *structure-graph-width*
       :height *structure-graph-height*))

     (setq *genre-structure-process*
	   (process-run-function 
	    "KPML-GSP-GR"
	    #'run-packaged-frame
	    *genre-structure-grapher* *package*))    
    (setf stream
	  (clim:get-frame-pane
	    *genre-structure-grapher* 'graph))
    (clim::window-expose stream)
    (clim::window-stack-on-top stream)
    (clim:window-clear stream)
    (clim:format-graph-from-roots
     (list (kpml::inter-axis-relation-synt kpml::*the-text*))
     #'print-generic-structure-nodes
     #'generic-stage-children
     :generation-separation gen-sep
     :within-generation-separation inter-gen-sep
     :merge-duplicates nil
     :move-cursor nil
     :orientation :vertical
     :stream stream)))


(defun GENERIC-STAGE-CHILDREN (gsp-info)
  (typecase gsp-info
	    (kpml::syntagmatic-configuration
	     (mapcar #'kpml::label-deref
		     (kpml::syntagmatic-configuration-units gsp-info)))
	    (kpml::syntagmatic-unit
	     (mapcar #'kpml::label-deref
		     (kpml::syntagmatic-unit-children gsp-info)))
	    (t nil)))

(defun PRINT-GENERIC-STRUCTURE-NODES (gsp-node stream)
  (clim:with-text-style 
   (stream kpml-i::*sans-serif--bold--12*)
   (clim:with-output-as-presentation 
    (stream gsp-node 'gsp-graph-node)
    (format stream "~a"   
	    (typecase gsp-node
		      (kpml::syntagmatic-configuration 
		       "*TEXT*")
		      (t
		       (kpml::feature-pack 
			(kpml::syntagmatic-unit-labels gsp-node))))))))


(defun GSP-GRAPH-OPTIONS-MENU (node)
  (let ((message-stream (clim:get-frame-pane 
			 *resource-development-frame* 'inspector)))
    (case
     (menu-choose 
      '(|Show constraints on register| |Realize this stage|)
       :associated-window (clim:frame-top-level-sheet 
				    clim:*application-frame*)
       :label "generic structure graph options")
     (|Show constraints on register|
      (typecase node
		(kpml::syntagmatic-unit
		 (format message-stream
			 "~% Register constraints on unit: ~A~{~%...~A~}"
			 (kpml::feature-pack
			  (kpml::syntagmatic-unit-labels node))
			 (kpml::syntagmatic-unit-inter-stratal-constraints-below 
			  node)))
		(t
		 (format message-stream "~%Inappropriate element."))))
     (|Realize this stage|
      (if *one-generation-per-graph-semaphor*
	  (format message-stream "~% Regenerate GSP first...")
	(typecase node
		  (kpml::syntagmatic-unit
		   (format message-stream
			   "~% Generate Stage: ~A~%"
			   (kpml::feature-pack
			    (kpml::syntagmatic-unit-labels node)))
		   (let ((*standard-output* message-stream)
			 (kpml::*interactive* nil))
		     (declare (special kpml::*interactive*))
		     (kpml::realize-stage 
		      (kpml::micro-fn-label 
		       (first (kpml::syntagmatic-unit-labels node))
		       kpml::*current-cycle*)))
		   (setf *one-generation-per-graph-semaphor* t))
		  (t
		   (format message-stream "~%Inappropriate element.")))))
     (t
      (format message-stream "~%Not there yet!")))))



;;; ----------------------------------------------------------------------
;;; Hardcopy...



(define-genre-structure-graph-command (com-PRINT-GENRE-STRUCTURE
				       :name t :menu t)
  ()
  (hardcopy-genre-structure-graph 
   (merge-pathnames *default-kpml-hardcopy-directory* 
		    (make-hardcopy-filename "STRUCTURE"))
   (not *suitable-for-figures?*)))



(defun HARDCOPY-GENRE-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 
    (pstr fstr :multi-page multipage?)
    (clim:format-graph-from-roots
     (list (kpml::inter-axis-relation-synt kpml::*the-text*))
     #'print-generic-structure-nodes
     #'generic-stage-children
     :generation-separation *hardcopy-vertical-scaling*
     :within-generation-separation *hardcopy-vertical-scaling*
     :merge-duplicates nil
     :move-cursor nil
     :orientation :vertical
     :stream pstr)
    fstr))
  (when *auto-print*
	#+allegro (excl:shell (format NIL "lpr ~A" filename))
	#+lucid   (lcl:shell (format NIL "lpr ~A" filename))))


