(in-package "KPML")

;;; File: font-profiles.lisp

;;; ----------------------------------------------------------------------
;;; Definition for language-font associations, on the model of
;;; morphology declarations, etc. Should be placed in some file
;;; under multilinguality.
;;;
;;; Together with the additions under kpml-i-patches for 0.9.10,
;;; this permits one to give specifications such as:
;;;
;;; (define-language-font-requirements
;;;    :language :english
;;;    :font 
;;;     "-b&h-lucidabright-demibold-r-normal--20-140-100-100-p-118-iso8859-1")
;;;
;;; which will then determine the font of the popup windows for generated
;;; results. Make sure the fonts are accessible first or else there are
;;; a lot of error messages!
;;;
;;; 3.1 add the option of setting code-pages for PCs too. Only has any
;;;     effect when Lispworks is being used...
  ;; 3.2.12 Allow font-declarations that just set a code page without
  ;;        any further action...
;;; ----------------------------------------------------------------------

(defvar *LANGUAGE-FONT-PROFILES* nil)

(defmacro DEFINE-LANGUAGE-FONT-REQUIREMENTS
  (&key (language nil)(font nil)(inspector nil)(popup nil)(code-page nil))
  (if (and language (or code-page (and (or font inspector) (or font popup))))
      `(setf *language-font-profiles*
             (merge-in-font-profile-declaration 
              (intern (string ',language) :keyword)
              ,code-page
              ,(if inspector inspector
                 font)
              ,(if popup popup
                 font)
              *language-font-profiles*))
    (warning "Ill-formed language font requirement definition!")))


(defun MERGE-IN-FONT-PROFILE-DECLARATION 
       (lg code-page inspector-font popup-font profiles)

   ;; 3.2.1 "Language-code page association variable in wrong package"      

  (let ((modified-profiles nil)
	(consumed nil))
    #-lispworks (declare (ignore code-page))
    #+lispworks
    (when code-page
      (cond ((assoc lg *code-page-language-associations*)
             (setf (second (assoc lg *code-page-language-associations*))
                   code-page)
             (warning "Code page " code-page " being selected for language " lg ))
            (t
             (setf *code-page-language-associations*
                   (cons 
                    (list lg code-page)
                    *code-page-language-associations*)))))
    (loop for lg-defaults in profiles
	  do
	  (cond ((eq (first lg-defaults) lg)
		 (push (list lg inspector-font popup-font) modified-profiles)
		 (warning "Font requirement profile for language " lg 
			  " being updated.")
		 (setf consumed t))
		(t
		 (push lg-defaults modified-profiles))))
    (unless consumed (push (list lg inspector-font popup-font) 
			   modified-profiles))
    modified-profiles))

(defun LANGUAGE-FONT-STYLE (lg &optional (mode :popup)(emacs-ok nil)) ;; 0.9.41
  (let ((result (case mode
		  (:inspector
		   (second (assoc lg *language-font-profiles*)))
		  (:popup
		   (third  (assoc lg *language-font-profiles*)))
		  (otherwise
		   nil))))
    (if (or (eq result :mule)(eq result :emacs))
	(if emacs-ok result nil)
      result)))


