(in-package "KPML-I")

;;; File: flexible-fonts.lisp
;;; John, November98, Edinburgh.
;;;
;;; 2.0.17
;;;
;;; Note: needs to be loaded before example-mismatches.lisp !!!

;;; Adds to the X-based font setting mechanism for individual
;;; languages so that similar functionality is provided for
;;; Harlequin PC Lispworks under Windows/WindowsNT.
;;;
;;; ----------------------------------------------------------------------
;;; N.B.
;;; 2.1 there are still some problems making sure that the necessary
;;;     Lisp functionality is present, since as of May99 and Lispworks
;;;     4.0.1 they rely on unofficial Lispworks patches provided for
;;;     the Agile project. They appear not as stable as regular
;;;     releases.
;;;     
;;;     The all important function is clim:make-device-font-text-style,
;;;     when this is not defined (as it is not in base LWW4.0), then
;;;     no font changing will occur. So for now we check whether this
;;;     is bound properly and if not give a big warning and provide
;;;     no font changes (but without breaking!). Note that the double
;;;     colons are necessary for this.
;;; 4.0 
;;;     added feature marker of defect fonts was named wrongly!

#+(or lispworks4 lispworks5)
(unless (fboundp 'clim::make-device-font-text-style)
  (format *trace-output*
          "~% **** CLIM DEVICE FONTS NOT ADEQUATELY SUPPORTED IN THIS LISP!!! ****")
  (format *trace-output*
          "~% **** REFER TO YOUR LISP DEALER AND COMPLAIN!!!                  ****")
  (pushnew :clim-defect-fonts *features*))

;;; ----------------------------------------------------------------------
;;; This file could be added to the basic ui-clim directory, with
;;; an appropriate entry in the defsys. Then the support functions
;;; at the end of misc-extra-frames.lisp should be removed, because
;;; they are repeated here.
;;; 2.1 Done.

;;; ----------------------------------------------------------------------
;;; Make the basic font change mechanism into a macro that is 
;;; conditionalized for the two main approaches to font changes
;;; supported. Note that the treatment with Allegro (4.3) under
;;; Unix relies on changing the mapping between a CLIM text style
;;; and a X-windows font resource, whereas with Harlequin (4.0.1)
;;; under Windows allows the creation of a proper CLIM text style.
;;; 
;;; So, under Unix, we see properties definitions such as:
;;;
;;; (define-language-font-requirements
;;;    :language :english
;;;    :font 
;;;     "-b&h-lucidabright-demibold-r-normal--20-140-100-100-p-118-iso8859-1")
;;; 
;;; whereas under Windows, we can use instead definitions such as:
;;;
;;; (define-language-font-requirements
;;;    :language :bulgarian
;;;    :font 
;;;     "Timok")
;;;
;;; The first time that such a font is selected, it is turned into a 
;;; regular clim text style, this is kept on an association list
;;; between fonts and text styles. 
;;; ----------------------------------------------------------------------

(defmacro WITH-POSSIBLE-FONT-CHANGES-FOR-LANGUAGE 
    ((stream language text-style &optional (where :popup)) . body)
  
  ;; for Unix/Allegro use the primitive mechanism defined below.
  ;; This needs to be explicitly reset with an undo-lg-based-font-decision
  ;; outside of the process where the font change occurs: otherwise, the
  ;; fonts revert immediately and the font change has little effect...
  #+(and :unix :allegro)
  `(progn (lg-based-font-decision ,language ,text-style)
	  ,@body)

  ;; for Lispworks/Windows can use a proper text style environment;
  ;; need, however, to have set up the text style prior to use.
  ;; 4.0 make sure that we can turn this off if we want...
  #+(and lispworks4  win32)
  `(if kpml::*activate-code-page-settings*
       (let*  ((text-style-font-change 
		(get-language-font-style ,language ,where))
	       (code-page (kpml::code-page-for-lg ,language))
	       (win32::*multibyte-code-page-ef*
		`(win32:code-page :id ,code-page)))
	 (flet ((body-action () ,@body))
	       (if text-style-font-change
		   (clim:with-text-style 
		    (,stream text-style-font-change)
		    (body-action))
		 (body-action))))
     (progn ,@body))

  ;; This is not quite effective for Lispworks 5 as yet... just manage the code page
  
  #+(and lispworks5 win32)
  `(if kpml::*activate-code-page-settings*
       (let*  ((code-page (kpml::code-page-for-lg ,language))
	       (win32::*multibyte-code-page-ef*
		`(win32:code-page :id ,code-page)))
	 (flet ((body-action () ,@body))
	       (body-action)))
     (progn ,@body))
  
  ;; for other Lisps, currently do nothing; font declarations will have
  ;; no effect.
  #-(or (and :unix :allegro) (and (or :lispworks4 :lispworks5) :win32))
  `(progn ,@body))

;;; ----------------------------------------------------------------------
;;; And a similar but more restrictive environment that could become the
;;; general way of doing things should Allegro CL move to support the
;;; creation of clim text styles for any X-fonts. Currently this only
;;; does anything for LWW.
;;; ----------------------------------------------------------------------

(defmacro WITH-CONDITIONAL-FONT-CHANGES-FOR-LANGUAGE 
    ((stream language &optional (where :inspector)) . body)

  #-lispworks4
  `(progn ,@body)
  
  #+lispworks4
  `(let ((text-style-font-change 
	  (get-language-font-style ,language ,where)))
     (flet ((body-action () ,@body))
       (if text-style-font-change
	   (clim:with-text-style 
	       (,stream text-style-font-change)
	     (body-action))
	 (body-action)))))

;;; ----------------------------------------------------------------------
;;; Wraps some code around the call to language font style so that if
;;; a font mentions a text style that does not yet exist, it gets 
;;; created. Note that this is only used in Lispworks 4 with appropriate
;;; patches as yet.
;;; ----------------------------------------------------------------------

(defvar *FONT-NAME-TEXT-STYLE-ALIST* nil
  "holds an a-list of font names and clim text styles")

(defun GET-LANGUAGE-FONT-STYLE (language &optional (where :popup))
  (let ((font-name (kpml::language-font-style language where)))
    (if font-name 
	#-:clim-defect-fonts
        (cond ((assoc font-name *font-name-text-style-alist*)
               (cdr (assoc font-name *font-name-text-style-alist*)))
              (t
	       (let ((text-style (clim::make-device-font-text-style 
				  (clim:find-port) font-name)))
		 (push (cons font-name text-style)
		       *font-name-text-style-alist*)
		 text-style)))
        #+:clim-defect-fonts
        (kpml::warning "Font change requested, but this Lisp does not support it.")
       nil)))

;;; ----------------------------------------------------------------------
;;; More support functions for obtaining the appropriate fonts to use...
;;; ----------------------------------------------------------------------

(defvar *FONT-ACTUALFONT-ALIST* nil
  "holds an a-list of clim text styles and their X-resource fonts so that 
   this information does not get lost if we change it")

(defun LG-BASED-FONT-DECISION (lg font)
  (when (kpml::language-font-style lg :popup)
    (if (assoc font *font-actualfont-alist*)
	(setf (second (assoc font *font-actualfont-alist*)) 
	  (clim::text-style-mapping (clim::find-port) font))
      (push (list font (clim::text-style-mapping (clim::find-port) font))
	    *font-actualfont-alist*))
    (setf (clim::text-style-mapping (clim::find-port) font)
      (kpml::language-font-style lg :popup))))
  

(defun UNDO-LG-BASED-FONT-DECISION (font)
  ;; this only has an effect under Allegro/Unix, otherwise the font
  ;; change should be properly scoped.
  #+(and :unix :allegro)
  (progn
    (unless (assoc font *font-actualfont-alist*)
      (kpml::caution "No previous font style info for font: " font)
      (return-from UNDO-LG-BASED-FONT-DECISION nil))
    (setf (clim::text-style-mapping (clim::find-port) font)
      (second (assoc font *font-actualfont-alist*))))
  #-(and :unix :allegro)
  nil)
  
