(in-package "KPML-I")
;;; File: resource-display-tool.lisp
;;; John:Dec97:Edinburgh

;;; ----------------------------------------------------------------------
;;; 1.1 New display options...
;;;
;;;  provided a resource graph `perturbing' functionality for the
;;;  preparation of teaching materials, particular views for coding, etc.
;;;
;;;  4.0 since one of the purposes of this is to be able to present
;;;      the graph more nicely, we provide more useful export formats
;;;      here. The starting one is the scheme used by Mick's coder,
;;;      so that we can load display versions of systemic resources
;;;      directly into the coder for graphical display. 
;;;
;;;      To do this we mimic the grapher action and in addition to
;;;      drawing the graphic we collect versions of the informationb
;;;      displayed for presentation as a Mick's coder scheme.
;;;      
;;; ----------------------------------------------------------------------

(defvar *graph-display-mode* nil)
(defvar *path-starters* nil)
(defvar *constructed-path* nil)
(defvar *path-shortcuts* nil)
(defvar *combined-features* nil)
(defvar *combined-feature-set* nil)

(defvar *dashed-shortcuts* T)

(defvar *collect-information-for-export* nil)      ;; 4.0
(defvar *collected-export-information* nil)        ;; 4.0

(defun INITIALIZE-DISPLAY-TOOL-VARIABLES ()	
  (setf *graph-display-mode* nil)
  (setf *path-starters* nil)
  (setf *constructed-path* nil)
  (clim:remove-command-from-command-table
     'com-make-path-from-node
     'systemic-resource-graph
     :errorp nil)
  (clim:remove-command-from-command-table
     'com-combine-feature
     'systemic-resource-graph
     :errorp nil)
  nil)

;;; ----------------------------------------------------------------------
;;; Link to resource graphs...

(define-systemic-resource-graph-command 
    (COM-MAKE-PATH-FROM-NODE :name nil :menu nil)
    ((object 'resource-graph-node :gesture :menu))
  (let* ((node (kpml::monolingualize-node object)))
    (setf *path-starters* (list node))))

(define-systemic-resource-graph-command 
    (COM-COMBINE-FEATURE :name nil :menu nil)
    ((object 'resource-graph-node :gesture :menu))
  (let* ((node (kpml::monolingualize-node object)))
    (when (gethash node kpml::all-output-features)
      (if (member node *combined-feature-set*)
	  (setf *combined-feature-set*
	    (remove node *combined-feature-set*))
	(push node *combined-feature-set*)))))

(clim:define-command-table
    GRAPH-DISPLAY-COMMAND-TABLE
    :menu (("Toggle display view mode" :command com-toggle-display-view-mode)
           ("Divider0" :divider)
           ("Select foreground colour" :menu resourceg-foreground-colour)
	   ("Select background colour" :menu resourceg-background-colour)
           ("Divider1" :divider)
	   ("Accept display path" :command com-accept-display-path)
	   ("Accept feature combination" :command com-accept-combination)
	   ("Clear some paths" :command com-clear-shortcut-paths)
	   ("Show shortcuts dashed" :command com-toggle-dashed-shortcuts)
	   ("Divider2" :divider)
	   ("Save display settings" :command com-save-display-settings)
	   ("Export display" :command com-export-display)
	   ))

;;; ----------------------------------------------------------------------
;;; 2.1 color control added...
;;; ......................................................................

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


(clim:define-command-table 
    RESOURCEG-BACKGROUND-COLOUR
    :menu (("Red" :command resourceg-bg-red)
	   ("Green" :command resourceg-bg-green)
	   ("Blue" :command resourceg-bg-blue)
	   ("Black" :command resourceg-bg-black)
	   ("Magenta" :command resourceg-bg-magenta)
           ("Yellow" :command resourceg-bg-yellow)
           ("Divider" :divider)
           ("Grey" :command resourceg-bg-grey)
           ("Light grey" :command resourceg-bg-light-grey)))


;;; ----------------------------------------------------------------------
(clim:define-presentation-type path-continuation-option ())

(clim:define-presentation-action select-path-continuation
  (path-continuation-option nil systemic-resource-graph)
  (object)
  (setf *constructed-path* (append *constructed-path* *path-starters* ))
  (setf *path-starters* (list object))
  (clim:redisplay-frame-pane clim:*application-frame* 'graph))

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

(define-systemic-resource-graph-command 
    (COM-TOGGLE-DISPLAY-VIEW-MODE :name t)
    ()
  (setf *graph-display-mode* (not *graph-display-mode*))
  (cond (*graph-display-mode*
	 (setf *collected-export-information* nil)
	 (setf *collect-information-for-export* T)
	 (clim:add-command-to-command-table
	  'com-make-path-from-node
	  'systemic-resource-graph :name nil :menu nil :errorp nil)
	 (clim:add-command-to-command-table
	  'com-combine-feature
	  'systemic-resource-graph :name nil :menu nil :errorp nil))
	(t
	 (setf *collect-information-for-export* nil)
	 (clim:remove-command-from-command-table
	  'com-make-path-from-node 'systemic-resource-graph :errorp nil)
	 (clim:remove-command-from-command-table
	  'com-combine-feature 'systemic-resource-graph :errorp nil))))


(define-systemic-resource-graph-command 
    (COM-ACCEPT-DISPLAY-PATH :name t)
    ()
  (pushnew (cons (first *constructed-path*)(first *path-starters*))
	   *path-shortcuts*)
  (setf *path-starters* nil)
  (setf *constructed-path* nil))

(define-systemic-resource-graph-command 
    (COM-ACCEPT-COMBINATION :name t)
    ()
  (pushnew *combined-feature-set* *combined-features*)
  (setf *combined-feature-set* nil))

(define-systemic-resource-graph-command 
    (COM-CLEAR-SHORTCUT-PATHS :name t)
    ()
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	(options (mapcar #'(lambda (x)
			     (cons (format nil "~A->~A" 
					   (car x)(cdr x))
				   x))
			 *path-shortcuts*))
	(selections nil))
    #-(and acl3.0 aclpc)
    (clim:accepting-values
	(stream :own-window *own-window*
		:scroll-bars nil
		:resynchronize-every-pass t
		:label "Delete some shortcut paths" :exit-boxes 
		'((:exit "Click here to accept")
		  (:abort "Click here to cancel")))
      (setf selections
	(clim:accept `(clim:subset-sequence ,(mapcar #'car options))
		     :stream stream
		     :view #-lispworks 'clim:list-pane-view
		           #+lispworks clim:+textual-dialog-view+
		     :prompt "Delete shortcut paths"
		     :default selections))
      (kpml-i-terpri stream))
    #+(and acl3.0 aclpc)
    (setf selections 
      (kpml::get-a-subset-from (mapcar #'car options) selections
			       "Delete shortcut paths"))
    (setf *path-shortcuts*
      (loop for (x . path) in options
	  unless (member x selections :test #'string=)
	  collect path))))

(define-systemic-resource-graph-command 
    (COM-TOGGLE-DASHED-SHORTCUTS :name t)
    ()
  (setf *dashed-shortcuts* (not *dashed-shortcuts*)))

;;; ----------------------------------------------------------------------
(clim:define-presentation-type combined-displayed-feature ())

(clim:define-presentation-action expand-feature-combination
  (combined-displayed-feature nil systemic-resource-graph)
  (object)
  (setf *combined-features*
    (loop for s in *combined-features*
	unless (member object s)
	collect s))
  (clim:redisplay-frame-pane clim:*application-frame* 'graph))

	   
(defun PRUNE-COMBINED-FEATURES (descendents)
  (let* ((combi nil)
	 (pruned
	  (loop for e in descendents
	      when (loop for fs in *combined-features*
		       thereis (member (cdr e) fs))
	      do (setf combi (cdr e))
	      else
	      collect e)))
    (if combi
	(cons (cons 'kpml::combi 
		    (cons
		     (if (= (length pruned) 1)
			 (intern
			  (string-downcase 
			   (concatenate 'string
			     kpml::*default-negation-prefix*
			     "-"
			     (string (cdar pruned))))
			  "KPML")
		       'kpml::|other...|)
		     combi))
	      pruned)
      	descendents)))

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

(defun CHECK-SHORTCUT-PATH-SYSTEM-TO-SYSTEM (children)
  (if (and kpml-i::*graph-display-mode* 
	   children
	   kpml-i::*path-shortcuts*)
      (loop for c in children
	  when (member 
		(systemic-graph-node-value c) 
		(mapcar #'car kpml-i::*path-shortcuts*))
	  collect (make-systemic-graph-node
		   :type (systemic-graph-node-type c)
		   :value
		   (cdr (assoc (systemic-graph-node-value c) 
			       kpml-i::*path-shortcuts*)))
	  else
	  collect c)
    children))
	     
;;; ----------------------------------------------------------------------
;;; 4.0 Beginnings of a scheme for saving display parameters...

(define-systemic-resource-graph-command 
    (com-SAVE-DISPLAY-SETTINGS :name t)
    ()
  ;; what needs to be saved here is:
  ;;
  (list
   *path-shortcuts*
   *combined-features*)
  (clim:notify-user clim:*application-frame* "Not yet available."))


;;; ----------------------------------------------------------------------
;;; 4.0  export of displayed graph in various forms.
;;; ----------------------------------------------------------------------

(defvar *supported-export-forms*
  '(:micks-coder-scheme :straight))

(define-systemic-resource-graph-command 
    (com-EXPORT-DISPLAY :name t)
    ()
    (let ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	  (format (car *supported-export-forms*)))
      (kpml-i::positioned-accepting-values
       (stream :own-window kpml-i::*own-window*
	       :x-position (first kpml-i::*confirmation-popups-xy*)
	       :y-position (second kpml-i::*confirmation-popups-xy*)
	       :resynchronize-every-pass t
	       :label "Select export format" 
	       :exit-boxes 
		'((:exit "Click to export")
		  (:abort "Click to cancel")))
       (kpml::kpml-i-terpri stream)
       (setf format
	     (clim:accept 
	      `(member ,@*supported-export-forms*) :stream stream
	      #-lispworks4.0 :view #-lispworks4.0 'clim:list-pane-view
	      :prompt "Export format"
	      :default format))
       #+lispworks (dialog-end-spacing))
      (if format 
	  (export-display-graph format)
	(clim:notify-user clim:*application-frame* 
			  "No export format selected."))))


;;; ......................................................................-
;;; base cases and straight records (for debugging and extension mostly)
;;; ......................................................................

(defun PLUCK-FEATURE-NAME (feature)
  (case (first feature)
	(kpml::combi (second feature))
	(kpml::feature
	 (cdr feature))))

  ;;
  ;; Different export formats might dislike particular characters, so
  ;; drop them without ceremony.
  ;;
(defun KILL-DANGEROUS-CHARACTERS (s hit-list)
  (coerce  
   (loop for i from 0 to (1- (length s)) 
	 as ch = (char s i) 
	 when (loop for h in hit-list never (char= ch h))
	 collect (char s i))
   'string))

;;; ......................................................................

(defmethod EXPORT-DISPLAY-GRAPH (mode)
  (clim:notify-user clim:*application-frame* "No export mode specified.")
  nil)

(defmethod EXPORT-DISPLAY-GRAPH ((mode (eql :straight)))
  (declare (special *default-kpml-hardcopy-directory*))
  (if kpml-i::*collected-export-information*
      (let* ((file
	      (make-new-typed-filename "resource" "KPML" "txt"))
	     (pathname 
	      (merge-pathnames file *default-kpml-hardcopy-directory*))
	     (first-time T))
	(with-open-file 
	 (stream pathname :direction :output :if-exists :supersede)
	 (loop for rec in (reverse kpml-i::*collected-export-information*)  
	       do (format stream "~%~S" rec))))
    ;;
    ;; should actually never get here...
    ;;
    (clim:notify-user clim:*application-frame* "No export information accumulated: redisplay!")))

  ;; ---------------------------------------------------------------
  ;;  (i) Mick's coder scheme
  ;;
  ;;      Format:
  ;;        systems and features are written separately, realizations
  ;;        together with the feature definitions. Entry conditions
  ;;        are limited to single disjunctions or conjunctions and
  ;;        are given with the system definition. Features do not
  ;;        have to be explicitly defined if they do not have any
  ;;        realization statements.

  ;;
  ;; Main work in this method, which simply writes out the
  ;; the converted information to a new file in the default
  ;; output directory. Does not yet handle condensed paths
  ;; from the resource display tool, although combined features
  ;; are ok.
  ;;
(defmethod EXPORT-DISPLAY-GRAPH ((mode (eql :micks-coder-scheme)))
  (declare (special *default-kpml-hardcopy-directory*))
  (let* ((file
	  (make-new-typed-filename "resource" "KPML" "scheme"))
	 (pathname 
	  (merge-pathnames file *default-kpml-hardcopy-directory*))
	 (first-time T)
	 (use-check (make-hash-table)))
    (with-open-file 
     (stream pathname :direction :output :if-exists :supersede)
     (loop for (s f . r) 
	   on (reverse kpml-i::*collected-export-information*)
	   when (and (systemic-graph-node-p s) 
		     (equal (systemic-graph-node-type s) 'kpml::system))
	   do 
	   (let* ((system (systemic-graph-node-value s))
		  (ec (kpml::fetch-system-inputs system))
		  (*pending-ecs* nil))
	     (declare (special *pending-ecs*))
	     (unless (gethash system use-check)
	       (setf (gethash system use-check) T)
	       (when first-time
		 (format stream "defroot ~(~A~)" 
			 (create-a-unique-root ec)) 
		 (setf first-time nil))
	       (when f
		 (format stream "~%defsystem ~A ~S {~{~( ~A~)~}} active"
			 system 
			 (create-mick-coder-entry-condition ec)
			 (mapcar #'pluck-feature-name f))
		 (unless (equal *show-realizations-in-graphs* :never)
		   (loop for feature in f
			 as rs = (kpml::fetch-realization-statements-of-feature 
				  (cdr feature))
			 do 
			 (when rs 
			   (format stream "~%def-feature ~(~A~) ~S"
				   (pluck-feature-name feature)
				   (kill-dangerous-characters
				    (let ((rs-string 
					   (with-output-to-string 
					     (stream) 
					     (kpml::pprint-rs rs stream))))
				      (subseq rs-string 0 (- (length rs-string) 1)))
				    '(#\( #\) ))
				   )))))
	       (loop for ec in *pending-ecs*
		     do (format stream "~%~A" ec))
	       ))))))
  

(defun CREATE-A-UNIQUE-ROOT (ec)
  (if (symbolp ec)
      ec
    (create-a-unique-root (second ec))))

  ;; 
  ;; Mick's coder only allows single conjunctions and disjunctions...
  ;; anything more complex must be broken up. 
  ;;
(defun CREATE-MICK-CODER-ENTRY-CONDITION (ec)
  (declare (special *pending-ecs*))
  (setf *pending-ecs* nil)
  (if (consp ec)
      (if (loop for e in ec always (symbolp e))
	  (format nil 
		  "~{ ~A~}" 
		  (loop for e in ec collect (string-downcase (string e))))
	(multiple-value-bind 
	 (simplified-ec pending)
	 (flatten-ec ec)
	 (progn
	   (setf *pending-ecs* pending)
	   (format nil 
		   "~{ ~A~}" 
		   (loop for e in simplified-ec collect (string-downcase (string e))))
	   )))
    (format nil "~A" (string-downcase (string ec)))))
  
(defun FLATTEN-EC (ec)
  (let ((pending-internal-ec-systems nil))
    (labels ((FLATTEN-INTERN 
	      (ec)
	      (let* ((ec-intern (loop for i in ec
				      if (symbolp i)
				      collect i
				      else 
				      collect (flatten-intern i)))
		     (created-intern (gensym)))
		(push 
		 (format nil "defsystem ~A-EC \"~{~(~A~) ~}\" {~(~A~)} active"
			 created-intern ec-intern created-intern)
		 pending-internal-ec-systems)
		created-intern
		)))
	    (values
	     (loop for i in ec
		   if (symbolp i)
		   collect i
		   else 
		   collect (flatten-intern i))
	     pending-internal-ec-systems))))

