(in-package "KPML-I")

;;; File: type-faces-and-colors.lisp
;;;
;;; Definitions of type faces and the colors used for panes in the
;;; interface.
;;; ----------------------------------------------------------------------

;;; Premixed type faces...
(defvar *sans-serif--roman--14*)
(defvar *sans-serif--roman--12*)
(defvar *sans-serif--roman--10*)
(defvar *sans-serif--roman--9*)
(defvar *sans-serif--roman--6*)

(defvar *sans-serif--italic--6*)
(defvar *sans-serif--italic--8*)

(defvar *sans-serif--bold--7*)
(defvar *sans-serif--bold--8*)
(defvar *sans-serif--bold--10*)
(defvar *sans-serif--bold--12*)

(defvar *fix--roman--12*)
(defvar *fix--roman--10*)
(defvar *fix--roman--9*)
(defvar *fix--roman--8*)

(defvar *fix--italic--9*)

(defvar *fix--bold--6*)
(defvar *fix--bold--8*)
(defvar *fix--bold--10*)
(defvar *fix--bold--11*)
(defvar *fix--bold--12*)
(defvar *fix--bold--16*)

(defvar *fix--bold-italic--10*)
(defvar *fix--bold-italic--12*)

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

(eval-when (compile load eval)
  (setf  *sans-serif--roman--14* (clim:parse-text-style
				  '(:sans-serif :roman 14)))
  (setf  *sans-serif--roman--12* (clim:parse-text-style
				  '(:sans-serif :roman 12)))
  (setf  *sans-serif--roman--10* (clim:parse-text-style
				  '(:sans-serif :roman 10)))
  (setf  *sans-serif--roman--6* (clim:parse-text-style
				 '(:sans-serif :roman 6)))
  (setf  *sans-serif--roman--9* (clim:parse-text-style
				 '(:sans-serif :roman 9)))
  (setf  *sans-serif--italic--6* (clim:parse-text-style
				  '(:sans-serif :italic 6)))
  (setf  *sans-serif--italic--8* (clim:parse-text-style
				  '(:sans-serif :italic 8)))
  (setf *sans-serif--bold--7* (clim:parse-text-style
			       '(:sans-serif :bold 7)))
  (setf  *sans-serif--bold--8* (clim:parse-text-style
				 '(:sans-serif :bold 8)))
  (setf  *sans-serif--bold--10* (clim:parse-text-style
				 '(:sans-serif :bold 10)))
  (setf  *sans-serif--bold--12* (clim:parse-text-style
				  '(:sans-serif :bold 12)))
  (setf  *fix--roman--10*        (clim:parse-text-style
				  '(:fix :roman 10)))
  (setf  *fix--roman--12*        (clim:parse-text-style
				  '(:fix :roman 12)))
  (setf  *fix--bold--6*        (clim:parse-text-style
				'(:fix :bold 6)))
  (setf  *fix--bold--8*        (clim:parse-text-style
				'(:fix :bold 8)))
  (setf  *fix--bold--10*        (clim:parse-text-style
				 '(:fix :bold 10)))
  (setf  *fix--bold--11*        (clim:parse-text-style
				 '(:fix :bold 11)))
  (setf *fix--bold-italic--10* (clim:parse-text-style
				 '(:fix (:bold :italic) 10)))
  (setf *fix--bold-italic--12* (clim:parse-text-style
				 '(:fix (:bold :italic) 12)))
  (setf  *fix--bold--12*        (clim:parse-text-style
				 '(:fix :bold 12)))
  (setf  *fix--bold--16*        (clim:parse-text-style
				 '(:fix :bold 16)))
  (setf  *fix--roman--8*         (clim:parse-text-style
				  '(:fix :roman 8)))
  (setf  *fix--roman--9*         (clim:parse-text-style
				  '(:fix :roman 9)))
  (setf  *fix--italic--9*        (clim:parse-text-style
				  '(:fix :italic 9))))


;;; ======================================================================
;;; And the color values...

;;; --------------------------------------------------------
;;; Pane colors
;;; --------------------------------------------------------

(defvar interactor-fg)
(defvar interactor-bg)
(defvar spl-fg)
(defvar spl-bg)
(defvar target-fg)
(defvar target-bg)
(defvar output-fg)
(defvar output-bg)
(defvar loom-fg)
(defvar loom-bg)
(defvar menu-fg)
(defvar menu-bg)
(defvar mode-menu-fg)
(defvar mode-menu-bg)
(defvar system-fg)
(defvar system-bg)
(defvar system-history-fg)
(defvar system-history-bg)
(defvar inquiry-fg)
(defvar inquiry-bg)
(defvar mode-fg)
(defvar mode-bg)
(defvar inquiry-history-fg)
(defvar inquiry-history-bg)
(defvar sentence-structure-fg)
(defvar sentence-structure-bg)
(defvar ask-user-fg)
(defvar ask-user-bg)
(defvar inspector-fg)
(defvar inspector-bg)
(defvar mouse-doc-fg)
(defvar mouse-doc-bg)
(defvar resource-graph-fg)
(defvar resource-graph-bg)
(defvar flag-bar-fg)

;;; ----------------------------------------------------------------------  
;;; 2.0    graying used for disabled systems...
;;; ----------------------------------------------------------------------

(defvar *grey* (clim:make-gray-color 0.6))
(defvar *light-grey* (clim:make-gray-color 0.8))

;; 2.1
(defvar *resource-foreground-colour*)
(defvar *resource-background-colour*)

;; 4.0
(defvar +light-but-readable-green+ (clim:make-rgb-color 0.0 0.7 0.5))

;;; ----------------------------------------------------------------------
;;; Color set up following Markus Fischer's extensions to KPML-I for
;;; CLIM-2.

(clim:define-application-frame color-pilot ()
			       ())

(defvar *color-pilot-palette*)
  
;;; 1.1 color name should always be a string under ACL-PC...
;;;     standard appears to be that it can be a symbol or a string...
;;; 3.0 well, appears to be more that a string is what is favoured,
;;;     ACL5.0 wants a string too.
(defun GET-COLOR (name &optional (background nil))
  (unless *color-pilot-palette*       ;; 2.0 last ditch attempt to make sure
    (setf *color-pilot-palette*       ;;     that a palette is always found...
          (clim:port-default-palette (clim:find-port))))
  (or (clim:find-named-color (string name) *color-pilot-palette* :errorp nil)
      ;; 4.0 there may not be any lisps that accept this anymore...
      #+ignore 
      (clim:find-named-color name *color-pilot-palette* :errorp nil)
      ;; 
      (if background 
	  clim:+white+
	clim:+black+)))

;;; 0.9.30 under ACL4.3 the streams are set quite strangely when
;;; this function gets executed on restart... The only bidirectional
;;; stream left seems to be that bound to *standard-output*, very
;;; strange.
;;; 2.0 Lispworks seems particularly fragile wrt unknown colors, or
;;;     rather colors that PC Windows is not good at manipulating.
;;;     So go for pretty boring standardized CLIM colors for the
;;;     most part here.

(defun COLOR (&optional (color :unspecified))
  (let ((*query-io*                         ;; 0.9.30
	 (:version-case (":ALLEGRO-V")
			("4.3" *standard-output*)
			((+ "4.3") *standard-output*)
			(t *query-io*))))
    (cond 
     ((or (equal color :color)
	  (and 
	   (equal color :unspecified)
	   (or 
	    (equal kpml::*monochrome* :color)
	    (not (or (equal kpml::*monochrome* :mono)
		     (y-or-n-p "Monochrome Display?"))))))
      (setf *monochrome?* nil)
      (setq interactor-fg          (get-color 'black))
      (setq interactor-bg          (get-color 'white t))
      (setq spl-fg                 (get-color 'black))
      (setq spl-bg                 (get-color 'white t))
      (setq target-fg              (get-color 'blue))
      (setq target-bg              (get-color 'white t))
      (setq output-fg              (get-color 'black))
      (setq output-bg              (get-color 'white t))
      (setq loom-fg                (get-color 'black))
      (setq loom-bg                (get-color 'white t))
      (setq menu-fg                clim:+black+)
      (setq menu-bg                clim:+cyan+)
      (setq mode-menu-fg           (get-color 'blue))
      (setq mode-menu-bg           #+unix(get-color 'antique-white t)
                                   #-unix(get-color 'white t))
      (setq system-fg              #+unix(get-color 'maroon)
                                   #-unix clim:+magenta+)
      (setq system-bg              (get-color 'white t))
      (setq inquiry-fg             #+unix(get-color 'maroon)
                                   #-unix clim:+magenta+)
      (setq inquiry-bg             (get-color 'white t))
      (setq mode-fg                (get-color 'black))
      (setq mode-bg                (get-color 'white t))
      (setq system-history-fg      (get-color 'black))
      (setq system-history-bg      (get-color 'white t))
      (setq inquiry-history-fg     (get-color 'black))
      (setq inquiry-history-bg     (get-color 'white t))
      (setq sentence-structure-fg  (get-color 'blue))
      (setq sentence-structure-bg  #+unix(get-color 'snow t)
                                   #-unix(get-color 'white t))
      (setq ask-user-fg            (get-color 'white))
      (setq ask-user-bg            (get-color 'blue))
      (setq inspector-fg           (get-color 'black))
      (setq inspector-bg           (get-color 'white t))
      (setq mouse-doc-fg           (get-color 'black))
      (setq mouse-doc-bg           (get-color 'blue t))
      (setq flag-bar-fg            (get-color 'white t))
      (setq resource-graph-fg      (get-color 'black))
      (setq resource-graph-bg       #+unix(get-color 'antique-white t)
	                            #-unix(get-color 'white t))
      (setq *resource-foreground-colour* clim:+magenta+)
      (setq *resource-background-colour* (get-color 'black))
      )
     (t
	 (setf *monochrome?* T)
	 (setq interactor-fg       clim::+black+)
	 (setq interactor-bg       clim::+white+)
	 (setq spl-fg              clim::+black+)
	 (setq spl-bg              clim::+white+)
	 (setq target-fg           clim::+black+)
	 (setq target-bg           clim::+white+)
	 (setq output-fg           clim::+black+)
	 (setq output-bg           clim::+white+)
	 (setq loom-fg             clim::+black+)
	 (setq loom-bg             clim::+white+)
	 (setq menu-fg             clim::+black+)
	 (setq menu-bg             clim::+white+)
	 (setq mode-menu-fg        clim::+black+)
	 (setq mode-menu-bg        clim::+white+)
	 (setq system-fg           clim::+black+)
	 (setq system-bg           clim::+white+)
	 (setq inquiry-fg          clim::+black+)
	 (setq inquiry-bg          clim::+white+)
	 (setq mode-fg             clim::+black+)
	 (setq mode-bg             clim::+white+)	 
	 (setq system-history-fg   clim::+black+)
	 (setq system-history-bg   clim::+white+)
	 (setq inquiry-history-fg  clim::+black+)
	 (setq inquiry-history-bg  clim::+white+)
	 (setq sentence-structure-fg  clim::+black+)
	 (setq sentence-structure-bg  clim::+white+)
	 (setq ask-user-fg         clim::+black+)
	 (setq ask-user-bg         clim::+white+)
	 (setq inspector-fg        clim::+black+)
	 (setq inspector-bg        clim::+white+)
	 (setq mouse-doc-fg        clim::+black+)
	 (setq flag-bar-fg         clim::+black+)
	 (setq mouse-doc-bg        clim::+white+)
	 (setq resource-graph-fg   clim::+black+)
	 (setq resource-graph-bg   clim::+white+)
         (setq *resource-foreground-colour* clim::+black+)
         (setq *resource-background-colour* *grey*)
	 
	 ))))

;;; ----------------------------------------------------------------------
;;; 0.9.35 menu font change; folded into all menu defs below...
;;; 2.0    forgot to make the change for Lispworks too.
(defvar *menu-font*
      #-(or lispworks aclPC) *sans-serif--bold--10* 
      #+(or lispworks aclPC) *sans-serif--bold--8*)
(defvar *graph-font* *fix--bold--10*)
(defvar *biggest-font* *fix--bold--16*)
(defvar *main-info-font* kpml-i::*fix--bold--11*)

;;; ----------------------------------------------------------------------
;;; 2.1 colour options...
;;; ----------------------------------------------------------------------

(defvar *kpml-colour-wheel*
  '(("Red" :red clim:+red+)
    ("Green" :green clim:+green+)
    ("Blue" :blue clim:+blue+)
    ("Black" :black clim:+black+)
    ("Magenta" :magenta clim:+magenta+)
    ("Yellow" :yellow clim:+yellow+)
    ("Grey"   :grey     kpml-i::*grey*)
    ("Light grey" :light-grey kpml-i::*light-grey*)))

