(in-package "KPML-I")

;;; File: flag-bars.lisp
;;; 2.1 Bremen, Apr99. John.
;;; 
;;; Renate pointed out that it is difficult to know what particular
;;; values the various flags have... so this file introduces a flag
;;; status bar that is added to all frames where flags are an issue.
;;;
;;; The following has been added to each frame definition:
;;; (flag-bar   :application
;;;             :display-function 'flag-bar-displayer
;;;             :height 20
;;;             :incremental-redisplay T
;;;             :initial-cursor-visibility :inactive
;;;             :scroll-bars nil
;;;		:foreground  flag-bar-fg
;;;		:background  mouse-doc-bg)
;;;
;;; plus a repeat of the mouse-doc pane but for the flag-bar. Each
;;; frame then also inherits from the flag-bar command table.
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; First, another dummy frame to get cheap access to a command table
;;; and command definer.
;;; ----------------------------------------------------------------------

(clim:define-application-frame FLAG-BAR-FRAME ()
  ()
  (:top-level (clim:default-frame-top-level  :prompt kpml-prompt-function))
  (:panes (flag-bar     :application
			:display-function 'flag-bar-displayer
			:foreground  mouse-doc-fg
			:background  mouse-doc-bg))
  (:command-definer t))

;;; ----------------------------------------------------------------------
;;; The basic presentation type that can get clicked to select a flag
;;; value and the action that makes that happen...
;;; ----------------------------------------------------------------------

(clim:define-presentation-type FLAG-BAR-ITEM ())

(clim:define-presentation-action SET-FLAG-BAR-ITEM-VALUE
    (flag-bar-item nil flag-bar-frame
		   :documentation "Set flag")
  (object)
  (let ((var (car object))
	(val (cdr object)))
    (declare (special clim:*application-frame*))
    (if (consp var)
	(ecase (first var)
	  (:function (funcall (second var) val T))
	  (:frame (setf (slot-value clim:*application-frame* (second var))
		    val)))
      (set var val))
    (redisplay-flag-bar clim:*application-frame*)))

(defun FLAGBAR-VALUE (var)
  (declare (special clim:*application-frame*))
  (if (consp var)
      (ecase (first var)
	(:function (funcall (second var) nil nil))
	(:frame (slot-value clim:*application-frame* (second var))))
    (symbol-value var)))

;;; ----------------------------------------------------------------------
;;; Call this after setting any flag...
;;; ----------------------------------------------------------------------

(defun REDISPLAY-FLAG-BAR (frame)
  (clim:redisplay-frame-pane frame 'flag-bar :force-p nil))

;;; ----------------------------------------------------------------------
;;; The general display function for flag-bars... Not a method because
;;; it is never specialized.
;;; ----------------------------------------------------------------------

(defun FLAG-BAR-DISPLAYER (frame stream)
  (macrolet ((bold-when-set (&body body)
	       `(if (equal actual-value value)
		    (clim:with-text-face (stream #+unix ':bold #-unix '(:bold :italic))
                      #+unix
		      ,@body
                      #-unix
                      (clim:with-text-size (stream :larger)
                        ,@body)
                      )
		  ,@body)))
    (let* ((flag-bar-items (get-flag-bar-items frame))
	   (flag-bar-item-list (cdr flag-bar-items))
	   (panes-to-refresh (first flag-bar-items)))
      (when flag-bar-item-list
	(clim:updating-output (stream :unique-id flag-bar-item-list)
	  (clim:with-text-style 
              #+unix(stream *sans-serif--italic--8*)
              #-unix(stream *sans-serif--roman--6*)
	    (clim:formatting-table (stream)
	      (clim:formatting-row (stream)
		(loop for (label var values) in flag-bar-item-list
		    as actual-value = (flagbar-value var)
		    do
		      (clim:formatting-cell (stream)
			(clim:updating-output (stream :cache-value label)
			  (format stream "~A:" label))
			(clim:updating-output 
			    (stream :cache-value (cons var actual-value))
			  (loop for value in values
			      as print-name = (cond ((eq value t) 'ON)
						    ((null value) 'OFF)
						    (t value))
			      do
				(clim:with-output-as-presentation
				    (stream (cons var value) 'flag-bar-item)
				  (bold-when-set
				   (format stream " ~A" print-name))))
			  (format stream "  "))))))))
	(when panes-to-refresh 
	  (loop for pane in panes-to-refresh 
	      do (clim:redisplay-frame-pane frame pane :force-p nil)))))))

;;; ----------------------------------------------------------------------
;;; The display method relies on the frame variable flag-bar-item-list
;;; containing a structure that indicates the variables to be settable
;;; from the flagbar and the values that those variables may take,
;;; i.e.,
;;;
;;;  (Frame-id
;;;     (panes to be refreshed)
;;;     (label var (value1 value2 value3 ...))
;;;     ...)
;;;
;;; Value T is written as `on', and nil is written as `off'. If var
;;; is a cons, then it represents either a function that should be called
;;; to set the value rather than just a variable or a frame variable.
;;; Which is indicated by the car of the cons :function or :frame.
;;;
;;; The function must
;;; take two parameters, the value to be set and T/nil for whether 
;;; an update is meant. (f X nil) just gives the current value of the
;;; flag, whereas (f X T) sets the current flag value according
;;; to X
;;;
;;; When setting up the frame this frame variable must
;;; be set up appropriately. So we also put a call to the
;;; following function  in each startup function. Note that this
;;; uses a global variable allowing global reconfiguration of the
;;; flag bars rather than hardcoding... 
;;; ----------------------------------------------------------------------

(defun GET-FLAG-BAR-ITEMS (frame)
  (declare (special *global-flagbar-lists*))
  (cdr (assoc (type-of frame) *global-flagbar-lists*)))

;;; ----------------------------------------------------------------------
;;; Flag toggling support utilities...
;;; ----------------------------------------------------------------------

(defun SET-KPML-VERSIONING (value update)
  (cond (update
	 (kpml::set-kpml-versioning value)
	 value)
	(t 
	 (if (member :resource-patches kpml::*loading-saving-profile*)
	     T
	   nil))))

(defun SET-STRING-BRACKETTING (string-bracketting update)
  (cond (update
	 (cond (string-bracketting 
		(setf kpml-i::*ol-bracketting* "(" 
		      kpml-i::*or-bracketting* ")")
		T)
	       (t
		(setf kpml-i::*ol-bracketting* "" 
		      kpml-i::*or-bracketting* "")
		nil)))
	(t
	 (string= kpml-i::*ol-bracketting* "("))))

;;; ----------------------------------------------------------------------
;;; Here is the global that determines the look and behaviour of the
;;; flag bars for various frames...
;;; ----------------------------------------------------------------------

(setf *global-flagbar-lists*
    '((KPML-RESOURCE-DEVELOPMENT
       nil
       ("Versioning" (:function set-kpml-versioning) (t nil))
       ("Clearing" kpml::*clearing-flag* (t nil))
       ("Merging" kpml::*merging-active* (t nil))
       ("Structure" kpml-i::*display-structures* (t nil))
       ("Constituency" (:function set-string-bracketting) (t nil))
       ("Selective" kpml::realize-selectively-flag (t nil)))
      (EXAMPLE-OPERATIONS-FRAME
       (example-list)
       ("Punctuation" kpml::*mismatch-with-punctuation* (t nil))
       ("Case" kpml::*mismatch-with-case* (t nil))
       ("Sort" (:frame alpha) (t nil))
       ("Glosses" (:frame glosses-shown) (t nil))
       ("Display" (:frame display-string) (:target :generated :none)))
      ))

