(in-package "KPML-I")
;;;
;;; File: selection-expression-tool.lisp
;;; Author: John Bateman
;;; Created: 24 Sep 99
;;; KPML 2.1
;;;
;;; ----------------------------------------------------------------------
;;; Provides an additional option for imposing structure on the
;;; selection expression output when triggered from a graph.
;;; This then provides a ready method for an html-subversion that
;;; can extend the example mismatch tool information.
;;; ----------------------------------------------------------------------

(defvar *selection-expression-tool* T "true if tool active")

(defvar *re-use-selexpression-window* T)
(defvar *selexpression-frame* nil)
(defvar *reset-selection-tool* nil)
(defvar *selexpr-region-width* 2)
(defvar *selexpr-show-metafunctions* T)
(defvar *selexpr-in-color* T)
(defvar *selexpr-show-gates* T)
(defvar *features-shown-alphabetic* nil)
(defvar *regions-shown-alphabetic* T)

;; 4.0 July 2006: some more metafunctions added...

(defvar metafn-color1 (clim:make-rgb-color 0.0 0.9 0.5))
(defvar metafn-color2 (clim:make-rgb-color 0.2 0.9 0.9))

(defvar *metafunction-colour-map* 
  '((kpml::logical . *grey*)
    (kpml::experiential . clim:+blue+)
    (kpml::ideational . clim:+green+)
    (kpml::textual . clim:+magenta+)
    (kpml::interpersonal . clim:+red+)
    (kpml::unifying . metafn-color1) 
    (kpml::agreement . metafn-color2)
    (:other . clim:+yellow+)))

(clim:define-command-table 
 SELEXPR-DISPLAY-TOGGLE-MENU
 :menu (
        ("Toggle metafunctions" :command com-selexpr-metafunctions)
        ("Toggle colour" :command com-selexpr-color)
        ("Toggle gates" :command com-selexpr-gates)
        ("Toggle alphabetic ordering of regions" :command com-ORDER-REGIONS)
	("Toggle alphabetic ordering of features" :command com-ORDER-FEATURES)
	))

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

(clim:define-application-frame SELECTION-EXPRESSION-FRAME ()
  ((label :initform nil)
   (string :initform nil)
   (selexpr :initform nil)
   (origin :initform nil)
   (whereami :initform nil)         ;; 4.1
   (preselections :initform nil)
   (incomplete-p :initform nil)
   (features-size :initform Kpml-i::*structure-graph-info-size*)
   (selexpr-region-width :initform 4)
   (hidden-metafunction-list :initform nil))
  (:menu-bar T)
  (:top-level (clim:default-frame-top-level))
  (:command-table 
   (selection-expression-commands
    :menu
    (
     #-acl3.0
     ("Quit" :command com-selexpr-quit)
     ("Redisplay" :command com-selexpr-redisplay)
     ("Reuse window" :command com-reuse-selexpr)
     ("Toggles" :menu selexpr-display-toggle-menu)
     ("Deactivate" :command com-selexpr-deactivate))
    :inherit-from (kpml-resource-inspector)))
  (:panes 
   (status :application
           :display-function 'selexpr-status-display
           :foreground interactor-fg
           :background interactor-bg
           :end-of-line-action :allow
           :end-of-page-action :allow
           :initial-cursor-visibility :inactive
           :scroll-bars nil
           :text-style *fix--bold--8*)
   (label :application 
          :display-function 'selexpr-label-display
          :scroll-bars nil
          :text-style *fix--bold--8*
          :foreground interactor-fg
          :background interactor-bg
          :end-of-line-action :allow
          :end-of-page-action :allow
          :initial-cursor-visibility :inactive)
   (selexpr :application
            :foreground interactor-fg
            :background interactor-bg
            :incremental-redisplay T
	    :display-function 'selection-expression-display
	    :text-style *sans-serif--roman--9*)
   #-lispworks4.0
   (option-palette :accept-values
                   :text-style *sans-serif--roman--6*
                   :scroll-bars nil
                   :height 50
                   :display-function '(clim:accept-values-pane-displayer
                                       :align-prompts t
                                       :displayer
                                       selection-expression-palette)
                   :help-callback "Define selection expression options.")
   (mouse-doc   :pointer-documentation
		:foreground  mouse-doc-fg
		:background  mouse-doc-bg))
  (:layouts (first 
	     (clim:vertically
		 ()
               (1/10 (clim:horizontally
                        ()
                      (:fill label)
                      (1/6 status)))
	       (:fill selexpr)
               #-lispworks4.0 option-palette
	       #-lispworks mouse-doc))))

(defun REDISPLAY-SELEXPR-PANES (frame)
  (loop for f in '(selexpr label status option-palette)
        do (clim:redisplay-frame-pane frame f :force-p t)))

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

(define-selection-expression-frame-command 
    (com-SELEXPR-QUIT :name t :menu "Quit")
    ()
  (setf *selexpression-frame* nil)
  (setf *re-use-selexpression-window* nil
        *reset-selection-tool* T)
  (close-a-window clim:*application-frame*)
  )

(define-selection-expression-frame-command 
    (com-REUSE-SELEXPR :name "Re-use window" :menu t)
    ()
  (setf *re-use-selexpression-window* T
        *reset-selection-tool* nil))

(define-selection-expression-frame-command 
    (com-MAKE-NEW-SELEXPR :name "Make new window" :menu t)
    ()
  (setf *re-use-selexpression-window* nil
        *reset-selection-tool* nil))

(define-selection-expression-frame-command 
    (com-SELEXPR-REDISPLAY :name "Redisplay" :menu t)
    ()
  (redisplay-selexpr-panes clim:*application-frame*))

(define-selection-expression-frame-command 
    (com-SELEXPR-DEACTIVATE :name "Deactivate" :menu t)
    ()
  (setf *selection-expression-tool* nil))
     
(define-selection-expression-frame-command 
    (com-SELEXPR-METAFUNCTIONS :name "Toggle metafunctions"  :menu T)
    ()
  (setf *selexpr-show-metafunctions* (not *selexpr-show-metafunctions*)))
  
(define-selection-expression-frame-command 
    (com-SELEXPR-COLOR :name "Toggle colour" :menu t)
    ()
  (setf *selexpr-in-color* (not *selexpr-in-color*)))

(define-selection-expression-frame-command 
    (com-SELEXPR-GATES :name "Toggle gates" :menu t)
    ()
  (setf *selexpr-show-gates* (not *selexpr-show-gates*)))

(define-selection-expression-frame-command 
    (com-ORDER-FEATURES
     :name "Toggle alphabetic ordering of features" :menu nil)
    ()
  (setf *features-shown-alphabetic* (not *features-shown-alphabetic*)))

(define-selection-expression-frame-command 
    (com-ORDER-REGIONS
     :name "Toggle alphabetic ordering of regions" :menu nil)
    ()
  (setf *regions-shown-alphabetic* (not *regions-shown-alphabetic*)))

;; 4.1
#-(or acl3.0 lispworks4.0)
(define-selection-expression-frame-command 
  (com-PRINT-SELEXP :name "Print selection expression" :menu T)
  ()
  (hardcopy-selection-expression
   (merge-pathnames *default-kpml-hardcopy-directory* 
		    (make-structure-hardcopy-filename))
   (not *suitable-for-figures?*)
   clim:*application-frame*))

;;; ----------------------------------------------------------------------
;;; Options in-frame...
;;; ----------------------------------------------------------------------

(defun SELECTION-EXPRESSION-PALETTE (frame stream)
  "Function to display the selection expression tool's options."
  (with-slots (selexpr-region-width features-size hidden-metafunction-list) frame
    (clim:formatting-table (stream)
      (clim:formatting-row (stream)
	(clim:formatting-cell (stream)
	  (format stream "Text size (~A):" features-size)
	  (hd-accepts features-size '(integer 4 18) "Text size"
		      '(clim:slider-view :show-value-p t)))
        (clim:formatting-cell (stream)
	  (format stream "Columns (~A):" selexpr-region-width)
	  (hd-accepts selexpr-region-width '(integer 1 8) "Columns"
		      '(clim:slider-view :show-value-p t)))
        (clim:formatting-cell (stream)
          (format stream "Hidden: ")
          (if hidden-metafunction-list
              (loop for m in hidden-metafunction-list
                    do (clim:with-output-as-presentation (stream m 'metafunction)
                         (format stream "~a " m)))
            (format stream "nothing")))))))


;;; ----------------------------------------------------------------------
;;; Frame startup, launched when the tool flag is set instead of calling
;;; POP-UP-A-SELECTION-EXPRESSION in structure-grapher.lisp from the
;;; function DISPLAY-CONSTIT-FEATURES, also in structure-grapher.lisp.
;;; This latter is the function actually called from the structure
;;; grapher frame.
;;; ----------------------------------------------------------------------

(defun STARTUP-SELEXPRESSION-TOOL (node pass-tree window
                                        &key 
                                        (incomplete-p nil)
                                        (reuse *re-use-selexpression-window*)
                                        (reset *reset-selection-tool*))
  (let ((label (kpml::constit-label node :horizontal))
	(whereami (kpml::fetch-node-where-am-i-value node))                 ;; 4.1
        (selexpr (kpml::constituent-pass-selection-expression pass-tree))
        (origin (kpml::extract-fundle node))
        (preselections (if (equal node 'kpml::top) nil
	                 (kpml::extract-constraints node 'kpml::preselect)))
        (reset-required (if (and *selexpression-frame*
                                 (eq (clim:frame-state *selexpression-frame*) :disabled))
                            T
                          reset)))

    (startup-selexpression-tool-internal
     label 
     (let ((clim:*application-frame* window))
       (declare (special clim:*application-frame*))
       (kpml::make-substring-from-structure node))
     selexpr origin whereami preselections incomplete-p reuse reset-required)))


;;; ----------------------------------------------------------------------
;;; Frame startup, for example records...
;;; ----------------------------------------------------------------------

(defun STARTUP-SELEXPRESSION-TOOL-ON-EXAMPLE-RECORD
       (example node selexpr preselections
             &key 
             (incomplete-p nil)
             (reuse *re-use-selexpression-window*)
             (reset *reset-selection-tool*))
  (let ((label (kpml::function-pack 
                (kpml::printable-constituent-functions node))))
    (startup-selexpression-tool-internal
     label 
     ;;
     ;;  4.0 we have to watch out a bit here, as the mousable-processed-string...
     ;;      functions are pretty free and easy with respect to their willingness
     ;;      to side-effect their supplied arguments.
     ;;
     (kpml::mouseable-processed-string-from-printable-constituent
      node :no-changes-p T)  
     selexpr example nil preselections incomplete-p reuse reset)))

;;; ----------------------------------------------------------------------
;;; Frame startup, the real thing... (No longer! moved to startups.lisp)
;;; ----------------------------------------------------------------------

#+ignore
(defun STARTUP-SELEXPRESSION-TOOL-INTERNAL
       (label string selexpr origin whereami preselections incomplete-p 
              &optional 
              (reuse *re-use-selexpression-window*)
              (reset *reset-selection-tool*))
  (let ((new-frame nil))
    (when reset
      (close-a-window *selexpression-frame*)
      (setf *selexpression-frame* nil))
    (when (or (not *selexpression-frame*)
              (not (clim:get-frame-pane *selexpression-frame* 'selexpr :errorp nil))
              (not reuse))
      (setf new-frame T)
      (setf *selexpression-frame*
            (clim:make-application-frame
                'selection-expression-frame
              :pretty-name "Selection expression tool"
              :left 100 :top 25
              :width 600 :height 400)))
    
    (setf (slot-value *selexpression-frame* 'label)         label
          (slot-value *selexpression-frame* 'selexpr)       (reverse selexpr)
          (slot-value *selexpression-frame* 'origin)        origin
	  (slot-value *selexpression-frame* 'whereami)      whereami
          (slot-value *selexpression-frame* 'string)        string
          (slot-value *selexpression-frame* 'preselections) preselections
          (slot-value *selexpression-frame* 'incomplete-p)  incomplete-p
          (slot-value *selexpression-frame* 'selexpr-region-width) *selexpr-region-width*)
    
    (if new-frame
        (let ((process 
               (process-run-function "KPML-SELEXPR-TOOL" 
                                     #'run-packaged-frame
                                     *selexpression-frame* 
                                     (find-package "KPML"))))
          (push (cons *selexpression-frame* process) *frame-process-alist*))
      (redisplay-selexpr-panes *selexpression-frame*))
    T))

    
;;; ----------------------------------------------------------------------
;;; Display methods... Now, this can get as fancy as you like...
;;; ----------------------------------------------------------------------

(defmethod SELEXPR-STATUS-DISPLAY ((frame selection-expression-frame) stream)
  (with-slots (incomplete-p selexpr preselections) frame
    (clim:with-output-recording-options (stream :record T)
      (clim:with-text-style (stream kpml-i::*sans-serif--bold--12*)
        (if incomplete-p
            (clim:with-drawing-options (stream :ink clim:+red+) 
              (format stream "INCOMPLETE"))
          (clim:with-drawing-options (stream :ink clim:+green+) 
            (format stream "COMPLETE"))))
      (format stream "~%  (~A features)" (1- (length selexpr))) ;; 3.1 remove 'start' feature
      (when preselections 
          (format stream "~%  (~A preselections)" (length preselections))))))


(defmethod SELEXPR-LABEL-DISPLAY ((frame selection-expression-frame) stream)
  (with-slots (label origin string preselections) frame
    (clim:with-output-recording-options (stream :record T)
      (clim:with-text-style (stream kpml-i::*fix--bold--8*)
	(clim:with-text-size 
            (stream *structure-graph-info-size*)
          (format stream "Selection expression for: ~A  " label)
          (format stream
                  (if *selexpr-show-gates* "(gates included)" "(no gates)"  ))
          (when preselections (format stream "(preselections italicized)"))
	  (with-possible-font-changes-for-language 
	   (stream kpml::curlan kpml-i::*fix--bold--8*)
	   (clim:with-text-size 
	    (stream *structure-graph-info-size*)
	    (clim:with-text-face 
	     (stream :italic)
	     (if (kpml::printable-constituent-p string)
		 (mouseable-sentence-display string stream)
	       (if string
		   (format stream "~%  ~A" string)
		 (format stream "~%  (no string)")))))))))))

(defmethod SELECTION-EXPRESSION-DISPLAY ((frame selection-expression-frame) stream)
  (with-slots 
      (label selexpr incomplete-p selexpr-region-width features-size 
             hidden-metafunction-list preselections)
      frame
    (clim:with-output-recording-options (stream :record T)
      (let* ((selexpr2 (if *selexpr-show-gates*
                           (remove 'kpml::start selexpr)
                         (delete-if #'(lambda (f)
                                        (kpml::gate-p
                                         (first (kpml::who-has-as-output f))))
                                    (copy-list (remove 'kpml::start selexpr)))))
             (region->features (make-hash-table))
             (metafunctions nil)
             (metafunctions->regions (make-hash-table))
             (regions 
              (remove-duplicates
               (loop for f in selexpr2
                     as s = (first (kpml::who-has-as-output f))
                     as r = (kpml::fetch-system-region s)
                     as m = (kpml::fetch-system-metafunction s)
                     collect r
                     do
                     (if (gethash r region->features)
                         (push f (gethash r region->features))
                       (setf (gethash r region->features) (list f)))
                     (pushnew m metafunctions)
                     (if (gethash m metafunctions->regions)
                         (push r (gethash m metafunctions->regions))
                       (setf (gethash m metafunctions->regions) (list r)))))))
        
        (loop for m in (sort metafunctions #'string<)
              as regions = (let ((regions
				  (remove-duplicates 
				   (gethash m metafunctions->regions))))
			     (if *regions-shown-alphabetic*
				 (sort regions #'string<)
			       regions))
              as color = (if *selexpr-in-color*
                             (symbol-value
                              (cdr (assoc (if (member m (mapcar #'car *metafunction-colour-map*))
                                              m :other)
                                          *metafunction-colour-map*)))
                           clim:+black+)
              unless (member m hidden-metafunction-list)
              do
              (clim:with-output-as-presentation (stream m 'metafunction)
                (format stream "~2%~20A~40T" m))
              (clim:with-drawing-options (stream :ink color)
              (clim:formatting-table (stream :move-cursor T :x-spacing 6 :y-spacing 15)
                (loop while regions do
                      (clim:formatting-row (stream)
                        (loop for region-count from 1 to selexpr-region-width
                              while regions
                              do
                              (let ((r (pop regions)))
                                (clim:formatting-cell (stream)
                                  (clim:surrounding-output-with-border 
                                      (stream :shape :rectangle)
                                    (clim:with-text-size (stream (1+ features-size))
                                      (if r 
                                          (clim:with-output-as-presentation 
                                              (stream r 'kpml-i::region)
                                            (format stream "~%Region: ~A  ~25T" r))
                                        (format stream "~%Unassigned to any region were:")))
                                    (clim:with-text-style (stream *structure-details-font*)
                                      (clim:with-text-size (stream features-size)
                                        (loop for f 
                                              in (let ((features (gethash r region->features)))
                                                   (if *features-shown-alphabetic*
                                                       (sort features #'string<)
                                                     (reverse features)))
                                              do
                                              (clim:with-output-as-presentation 
                                                  (stream f 'kpml-i::feature)
                                                (if (member f preselections)
                                                    (clim:with-text-size
                                                     (stream :larger)
                                                     (clim:with-text-face 
                                                         (stream '(:italic :bold))
                                                       (format stream "~%~(~a~)" f)))
                                                  (format stream "~%~(~a~)" f)
                                                  ))))))))))))))))))

  

;;; ----------------------------------------------------------------------
;;; Make access to the regions...
;;; ----------------------------------------------------------------------

(clim:define-presentation-action present-region-in-selexpr
    (region nil selection-expression-commands
            :documentation "Graph region")
  (object)
  (with-slots (whereami) clim:*application-frame*
     (graph-under-current-options object :region-flag T :whereami whereami)))

(clim:define-presentation-action region-overview-from-selexpr
    (region nil selection-expression-commands
	    :gesture :menu
            :documentation "Spawn dependent regions graph")
  (object)
  (display-region-overview object))

(clim:define-presentation-action hide-metafunction
    (metafunction nil selection-expression-commands
            :documentation "Hide/Show metafunction")
  (object)
  (with-slots (hidden-metafunction-list) clim:*application-frame*
    (if (member object hidden-metafunction-list)
        (setf hidden-metafunction-list
              (remove object hidden-metafunction-list))
      (pushnew object hidden-metafunction-list))
    (redisplay-selexpr-panes clim:*application-frame*)))
  
;;; ----------------------------------------------------------------------
;;; ... and to the parts of an example structure...
;;; ----------------------------------------------------------------------

(clim:define-presentation-action PRESENT-MOUSABLE-KPML-OUTPUT-IN-SELEXPR
    (mousable-kpml-output nil selection-expression-commands
			  :documentation "Inspect constituent")
  (object)
  (mouseable-sentence-menu object clim:*application-frame*))
      
;;; ----------------------------------------------------------------------
;;; 4.1 addition, hardcopy of the selection expression display...
  ;;
  ;; body is mostly just taken from the display method for 
  ;; selection expressions but with the output recording
  ;; calls removed... and with a postscript stream wrapped
  ;; around it.
  ;; 29th July, 2006: Darmstadt -> Bremen  
  ;;
;;;
;;; ----------------------------------------------------------------------

#-acl3.0
(defun HARDCOPY-SELECTION-EXPRESSION (filename multipage? frame)
  (with-slots 
   (label selexpr incomplete-p selexpr-region-width 
	  hidden-metafunction-list preselections)
   frame
   
   (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?
       (format *standard-output* "Selection Expression for Example: ~A; Language: ~A; ~A~2%~0T"
	       kpml::*most-recent-example*
	       kpml::curlan (kpml::time-stamp)))
    
     (let* ((features-size 7)
	    (selexpr-region-width 4)
	    (selexpr2 (if *selexpr-show-gates*
			  (remove 'kpml::start selexpr)
			(delete-if #'(lambda (f)
				       (kpml::gate-p
					(first (kpml::who-has-as-output f))))
				   (copy-list (remove 'kpml::start selexpr)))))
	    (region->features (make-hash-table))
	    (metafunctions nil)
	    (metafunctions->regions (make-hash-table))
	    (regions 
	     (remove-duplicates
	      (loop for f in selexpr2
		    as s = (first (kpml::who-has-as-output f))
		    as r = (kpml::fetch-system-region s)
		    as m = (kpml::fetch-system-metafunction s)
		    collect r
		    do
		    (if (gethash r region->features)
			(push f (gethash r region->features))
		      (setf (gethash r region->features) (list f)))
		    (pushnew m metafunctions)
		    (if (gethash m metafunctions->regions)
			(push r (gethash m metafunctions->regions))
		      (setf (gethash m metafunctions->regions) (list r)))))))
        
       (loop for m in (sort metafunctions #'string<)
	     as regions = (let ((regions
				 (remove-duplicates 
				  (gethash m metafunctions->regions))))
			    (if *regions-shown-alphabetic*
				(sort regions #'string<)
			      regions))
	     as color = (if *selexpr-in-color*
			    (symbol-value
			     (cdr (assoc (if (member m (mapcar #'car *metafunction-colour-map*))
					     m :other)
					 *metafunction-colour-map*)))
			  clim:+black+)
	     unless (member m hidden-metafunction-list)
	     do
	     (format *standard-output* "~2%~20A~40T" m)
	     (clim:with-drawing-options 
	      (*standard-output* :ink color)
	      (clim:formatting-table 
	       (*standard-output* :move-cursor T :x-spacing 6 :y-spacing 15)
	       (loop while regions do
		     (clim:formatting-row 
		      (*standard-output*)
		      (loop for region-count from 1 to selexpr-region-width
			    while regions
			    do
			    (let ((r (pop regions)))
			      (clim:formatting-cell 
				 (*standard-output*)
				(clim:surrounding-output-with-border 
				  (*standard-output* :shape :rectangle)
				(clim:with-text-size 
				 (*standard-output* (1+ features-size))
				 (if r 
				     (format *standard-output* "~%Region: ~A  ~25T" r)
				   (format *standard-output* "~%Unassigned to any region were:")))
				(progn ; clim:with-text-style 
				  ; (*standard-output* *structure-details-font*)
				 (clim:with-text-size 
				  (*standard-output* features-size)
				  (loop for f 
					in (let ((features (gethash r region->features)))
					     (if *features-shown-alphabetic*
						 (sort features #'string<)
                                                     (reverse features)))
					do
					(if (member f preselections)
					    (clim:with-text-size
					     (*standard-output* :larger)
					     (clim:with-text-face 
					      (*standard-output* '(:italic :bold))
					      (format *standard-output* "~%~(~a~)" f)))
					  (format *standard-output* "~%~(~a~)" f)))))))))))))))
    *standard-output*))
   (when *auto-print* (auto-print filename)))
  )









