(in-package "KPML-I")

;;; File: resource-grapher-option.lisp
;;; Provisional option provided at 2.1
;;;
;;; Provides a substantial change to the graphing behaviour for system
;;; networks. In particular, it makes sure that the behaviour of the
;;; system network grapher where features from different systems get
;;; run together no longer occurs. 
;;;
;;; But it has some problems still, so made available as an option.
;;; Needs checking with a wide range of graphs and modes.
;;;
;;; The presenting of system names is now also treated as part of doing
;;; the system shape. This makes sure that these names appear near
;;; the system! 
;;;
;;; ----------------------------------------------------------------------
;;; TO DO, BUGS:
;;;
;;; Some change-toggles cause the graph to mess up (e.g., gate visibility)
;;; presumably because out of date information is not being disposed of...
;;; This behaviour has not been tied down yet to particular causes.
;;; Need to accumulate cases probably.
;;;
;;; The behaviour is not yet checked for compatibility with multilingual
;;; graphs.
;;;
;;; When not in systemic notation mode, there are no arcs drawn from
;;; system names to features. Need to pick up this condition again and
;;; put it in the arc drawer.
;;; ----------------------------------------------------------------------

(defvar *X-OFFSET-FOR-SYSTEM-NAMES* 8)
(defvar *Y-OFFSET-FOR-SYSTEM-NAMES* -15)

;;; ----------------------------------------------------------------------
;;; Reset the stores of the max and min y coords for each system that
;;; is displayed as well as the general system position table.
;;; ----------------------------------------------------------------------

(defun INITIALIZE-GRAPH-POSITION-RECORDS (frame) 
  (with-slots (feature-max-y feature-min-y system-positions) frame
    (clrhash feature-max-y)
    (clrhash feature-min-y)
    (clrhash system-positions)))

;;; ----------------------------------------------------------------------
;;; For each feature, make a note of the y coord and record whether
;;; this is a new min or max for the features of the system.
;;; Print gate names if relevant...
;;; ----------------------------------------------------------------------

(defun NOTE-FEATURE-POSITIONS (stream frame from-node x1 y1 x2 y2)
  (with-slots (feature-max-y feature-min-y system-positions)
      frame
    (let ((s-x (- x2 10)))
      (if (kpml::gate-p (systemic-graph-node-value from-node))
	  (cond (*show-system-names*
		 (display-system-name 
		  (systemic-graph-node-value from-node)
		  (list (+ s-x 5) y2) stream)
		 (clim:draw-line* stream x1 y1 x2 y2))
		(t
		 (clim:draw-line* 
		  stream 
		  (- x1 (clim:text-size stream " ") 2) y1 x2 y2)))
	(let* ((old-max-0 (gethash from-node feature-max-y))
	       (old-max (if old-max-0 old-max-0 0))
	       (old-min-0 (gethash from-node feature-min-y))
	       (old-min (if old-min-0 old-min-0 100000)))
	  (when (> y2 old-max) (setf (gethash from-node feature-max-y) y2))
	  (when (< y2 old-min ) 
	    (setf (gethash from-node feature-min-y) y2))))
      (setf (gethash from-node system-positions)
	;; value of system-positions was (list s-x y1)
	(cons (list x1 y1 x2 y2 s-x)
	      (gethash from-node system-positions))))))

;;; ----------------------------------------------------------------------
;;; Create the actual system shapes. To do this, need to locate where
;;; the shape is to appear. This is now calculated on the basis of
;;; the recorded positions of each systems features.
;;; ----------------------------------------------------------------------

(defun DO-SYSTEM-SHAPES (stream)
  (with-slots (feature-min-y feature-max-y system-positions mode)  
      clim:*application-frame*
    (let ((midpoints (make-hash-table :test #'equal))
	  (displayed-system-names (make-hash-table)))
      ;; calculate midpoints between max and min y for the position
      ;; of the arrow and the system name...
      (maphash 
       #'(lambda (key value) 
	   (let* ((max-y value)
		  (min-y (gethash key feature-min-y))
		  (s-y (+ min-y (/ (- max-y min-y) 2))))
	     (setf (gethash key midpoints) s-y)))
       feature-max-y)
      (maphash 
       #'(lambda (node positions)
	   (let ((name 
		  (kpml::grammar-node-label 
		   (systemic-graph-node-value node))))
	     (loop for (x1 y1 x2 y2 s-x) in positions
		 as s-y = (gethash node midpoints)
		 when s-y
		      ;; simplest is just to draw an arrow between (x1,y1) and
		      ;; (s-x, s-y) but this looks silly if this means going
		      ;; back up or down again depending on the line that got
		      ;; us to (x1,y1) representing the system node itself.
		      ;; So we check whether y1 is already within the max and
		      ;; min y for the system, and if so do an horizontal
		      ;; arrow instead.
		 do
		   (draw-arrow-and-system-part
		    name x1 y1 x2 y2 s-x
		    (if (and (>= y1 (gethash node feature-min-y))
			     (<= y1 (gethash node feature-max-y)))
			y1
		      s-y)
		    stream)
		   (when (and kpml::*systemic-notation*
			      *show-system-names*
			      (not (gethash name displayed-system-names)))
		     (setf (gethash name displayed-system-names) T)
		     (case mode
		       ((:ml :ml-region)
			(ml-display-system-name name (list s-x s-y) stream))
		       (t
			(display-system-name 
			 name (list s-x s-y) stream)))))))
       system-positions)
      )))


;;; ----------------------------------------------------------------------
;;; Function that outputs the arrow to the system and the system shape.
;;; (x1, y1) is the point where the arrow should start (i.e., the
;;; last segment on the path from the previous feature). (x2, y2) is
;;; where a feature of the system should be placed. (s-x, s-y) is the
;;; place where the arrow should meet the system shape.
;;; ----------------------------------------------------------------------

(defun DRAW-ARROW-AND-SYSTEM-PART (name x1 y1 x2 y2 s-x s-y stream)
  (macrolet 
      ((draw-system ()
	 `(clim:updating-output 
	      (stream :cache-value (list x1 y1 s-x s-y)
		      :cache-test #'equal)
	    ;; the following presentation is to force the arrow to get noticed
	    ;; for purposes of incremental redisplay. Without it, it just gets
	    ;; forgotten about and so disappears irregularly... There are
	    ;; no accept methods for integers defined in this application frame
	    ;; so that it is fairly safe from getting picked up!
	    (clim:with-output-as-presentation 
		(stream name 'integer)
	      (if *show-system-names*
		  (clim:draw-arrow* stream x1 y1 s-x s-y)
		(clim:draw-arrow* 
		 stream 
		 (- x1 (clim:text-size stream " ") 2) y1 s-x s-y))
	      (clim:draw-line* stream s-x s-y s-x y2)
	      (clim:draw-line* stream s-x y2 x2 y2)))))
    (if (loop for f in (kpml::fetch-output-features name)
	    thereis (feature-on-generation-path-p f))
	(clim:with-drawing-options 
	    (stream :ink *resource-foreground-colour*)
	  (draw-system))
      (clim:with-drawing-options 
          (stream :ink *resource-background-colour*)
        (draw-system)))))


;;; ----------------------------------------------------------------------
;;; Output the system name at the calculated place...
;;; ----------------------------------------------------------------------

(defun DISPLAY-SYSTEM-NAME (name x-y stream)
  (with-slots (regions) clim:*application-frame*
    (clim:updating-output (stream :cache-value (cons name x-y))
      (clim:with-output-as-presentation 
	  (stream name 'resource-graph-node)
	(macrolet
	    ((print-it ()
	       '(draw-multiple-line-text
		 stream (string name) 
		 (first x-y) (second x-y)
		 :size *resource-graph-system-name-size*
		 :x-offset *x-offset-for-system-names*
		 :y-offset *y-offset-for-system-names*
		 :align-block :right)))
	  (macrolet 
	      ((print-it-possibly-disabled ()
		 '(if (kpml::fetch-disabled-system name)
		   (clim:with-drawing-options
		       (stream :ink *grey*)
		     (print-it))
		   (print-it))))
	    (if (and kpml::*region-external-links-visible?*
		     (kpml::region-external-system-inputs-p
		      name (first regions)))
		(clim:with-text-style  
		    (stream *fix--bold-italic--10*)
		  (print-it-possibly-disabled))
	      (print-it-possibly-disabled))))))))

;;; ----------------------------------------------------------------------
;;; And the same again for contrastive graphs...
;;; when we get here, the multilingual status of the node is no longer
;;; available unfortunately, so as a hack we work it out again... needs
;;; a re-organization.
;;; ----------------------------------------------------------------------

(defun ML-DISPLAY-SYSTEM-NAME (name x-y stream)
  (with-slots (regions languages) clim:*application-frame*
    (let ((status (shared-status name (first languages) (second languages)))
	  (object name))
      (clim:updating-output (stream :cache-value (cons name x-y))
	(clim:with-output-as-presentation 
	    (stream name 'resource-graph-node)
	  (macrolet
	      ((print-it ()
		 '(with-ml-color-contrast
		   (draw-multiple-line-text
		    stream (string name) 
		    (first x-y) (second x-y)
		    :size *resource-graph-system-name-size*
		    :x-offset *x-offset-for-system-names*
		    :y-offset *y-offset-for-system-names*
		    :align-block :right))))
	  (macrolet 
	      ((print-it-possibly-disabled ()
		 '(if (kpml::fetch-disabled-system name)
		   (clim:with-drawing-options
		       (stream :ink *grey*)
		     (print-it))
		   (print-it))))
	    (if (and kpml::*region-external-links-visible?*
		     (kpml::region-external-system-inputs-p
		      name (first regions)))
		(clim:with-text-style  
		    (stream *fix--bold-italic--10*)
		  (print-it-possibly-disabled))
	      (print-it-possibly-disabled)))))))))



