;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: XIT; Base: 10; -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: FONTS
;;;                       (Version 2.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Hubertus Hohl
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/fonts.lisp
;;; File Creation Date: 02/28/91 11:13:23
;;; Last Modification Time: 06/11/92 09:13:49
;;; Last Modification By: Hubertus Hohl
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 06/13/1991 (Hubertus)  added support for automatic installation of font
;;;                        tables when the display is opened. Automatic 
;;;                        installation is controlled by the global variables
;;;                        *skip-automatic-font-table-installation* and 
;;;                        *default-server-font-table-mappings*.
;;;   
;;; 06/13/1991 (Hubertus)  reimplemented internals of font lookup: 
;;;                        font table mappings may be accessed in both 
;;;                        directions by use of the following functions:
;;;                         GET-FONT (family face size) 
;;;                         GET-FONT-FAMILY-FACE-SIZE (font-name-or-object)
;;;                         GET-FONT-FAMILY (font-name-or-object)
;;;                         GET-FONT-FACE (font-name-or-object)
;;;                         GET-FONT-SIZE (font-name-or-object)
;;;
;;; 10/16/1991 (Hubertus)  fixed a bug in verifying font tables for X11/NeWS
;;;
;;; 11/15/1991 (Matthias) Added automatic-font-table-installation as a hook
;;;                        
;;;_____________________________________________________________________________


(in-package :xit)


;;;__________________________________________
;;;
;;; Determining the Height of a Text (font)
;;;__________________________________________


(defun text-height (font &optional text)
  (declare
    (ignore text)
    (type font font))
  (+ (max-char-ascent font) (max-char-descent font)))


;;;________________
;;;
;;;  Installation
;;;________________

(defun install-font-table (filename)
  (let ((truepath (find-file filename *font-table-directory* '("lisp"))))
    (when truepath
      (load truepath))
    truepath))

(defun x11/news-server-p (&optional (display *display*))
  (string= (display-vendor display)
	   "X11/NeWS - Sun Microsystems Inc."))

(defparameter *skip-automatic-font-table-installation* nil)

(defparameter *default-server-font-table-mappings*
    '(("MIT X Consortium" . "X11-R4-font-table")
      ("MIT X Consortium R4" . "X11-R4-font-table")
      ("X11/NeWS - Sun Microsystems Inc." . "OPENWIN-X11-font-table")
      ("X11/NeWS - Sun Microsystems Inc. R2000" . "OPENWIN-X11-font-table")
      ))

(defmethod get-font-table ((display t))
  (multiple-value-bind (vendor-name release-number)
      (display-vendor display)
    (or (cdr (assoc (concatenate 'string vendor-name " R"
				 (format nil "~D" release-number))
		    *default-server-font-table-mappings*
		    :test #'string=))
	(cdr (assoc vendor-name
		    *default-server-font-table-mappings*
		    :test #'string=))
	(cdar *default-server-font-table-mappings*))))

(defun automatic-font-table-installation (display)
  (unless *skip-automatic-font-table-installation*
    (let ((table (get-font-table display)))
      (when table
	(install-font-table table)))))

(add-open-display-hook 'automatic-font-table-installation)


;;;______________________
;;;
;;; Font Table Internals
;;;______________________

(defvar *font-table* (make-hash-table :size 16))

(defmacro get_font_face_table (family)
  `(gethash ,family *font-table*))

(defun get_font_size_table (face face_table)
  (cdr (assoc face face_table)))

(defun map_font_face_table (function face_table)
  (mapc #'(lambda (face-entry)
	    (funcall function (car face-entry) (cdr face-entry)))
	face_table))

(defstruct font_size_table
  for-specification   ; originally specified size - font pairs
  for-lookup)         ; size-threshold - font pairs for faster lookup

(defun get_font_size_entry (size size_table)
  (when size_table
    (let ((entry
	   (find_font_size size (font_size_table-for-lookup size_table))))
      (values (cadr entry) (car entry)))))

(defun find_font_size (size size_table)
  (labels ((binary-search (low high)
	     (if (= low high)
		 (svref size_table low)
	       (let ((mid (floor (+ low high) 2)))
		 (if (< size (car (svref size_table mid)))
		     (binary-search low mid)
		     (binary-search (1+ mid) high))))))
    (let ((length (length size_table)))
      (when (plusp length)
	(binary-search 0 (1- length))))))

(defun map_font_size_table (function size_table &optional for-lookup)
  (map nil #'(lambda (size-entry)
	       (funcall function (car size-entry) (cadr size-entry)))
       (if for-lookup
	   (font_size_table-for-lookup size_table)
	   (font_size_table-for-specification size_table))))

(defun add_font_family (mapping)
  (setf (get_font_face_table (car mapping))
        (canonicalize_font_family (cdr mapping))))

(defun canonicalize_font_family (faces&sizes)
  ;; converts faces&sizes into appropriate face_size_tables
  (mapcar #'(lambda (face&sizes)
	      (let ((original-sizes (copy-alist (cdr face&sizes)))
		    (sorted-sizes
		     (sort
		      (delete-duplicates
		       (delete-if-not #'numberp
				      (copy-list (cdr face&sizes))
				      :key #'car)
		       :key #'car :test #'= :from-end t)
		      #'< :key #'car)))
		(mapl #'(lambda (sizes)
			  (setf (caar sizes)
			        (if (cdr sizes)
				    (font_size_threshold (caar sizes)
							 (caadr sizes))
				    most-positive-fixnum)))
		      sorted-sizes)
	       	(cons (car face&sizes)
		      (make-font_size_table
		        :for-specification original-sizes
			:for-lookup 
			(coerce sorted-sizes 'simple-vector)))))
	  faces&sizes))

(defun font_size_threshold (low high)
  (sqrt (* low high)))


;;;__________________________________________
;;;
;;; User Interface Functions for Font Tables
;;;__________________________________________

;;; defining font table mappings
;;;
(defmacro define-font-families (&rest mappings)
  `(progn (clear-font-table)
	  (mapc #'add_font_family ',mappings)))

(defun clear-font-table (&optional (font-table *font-table*))
  (clrhash font-table))

(defun font_equal (font1 font2)
  ;; font1/2 may be font objects or font names
  ;; (wildcarding for font names is not supported)
  (cond ((and (font-p font1)
	      (font-p font2))
	 (font-equal font1 font2))
	((font-p font1)
	 (string= (font-name font1) font2))
	((font-p font2)
	 (string= (font-name font2) font1))
	(t (string= font1 font2))))

(defun get-font (family face size)
  (get_font_size_entry
    size
    (get_font_size_table
      face
      (get_font_face_table family))))

(defun get-font-family-face-size (font)
  ;; font may be a font object or font name
  (map-font-table #'(lambda (family face size fnt)
		      (when (font_equal font fnt)
			(return-from
			    get-font-family-face-size
			    (values family face size))))))

(defun get-font-family (font)
  (multiple-value-bind (family) (get-font-family-face-size font)
    family))

(defun get-font-face (font)
  (multiple-value-bind (ignore face) (get-font-family-face-size font)
    (declare (ignore ignore))
    face))

(defun get-font-size (font)
  (multiple-value-bind (ignore1 ignore2 size) (get-font-family-face-size font)
    (declare (ignore ignore1 ignore2))
    size))

(defun map-font-table (function &optional (font-table *font-table*) for-lookup)
  (maphash
    #'(lambda (family face_table)
	(map_font_face_table
	  #'(lambda (face size_table)
	      (map_font_size_table
	        #'(lambda (size font)
		    (funcall function family face size font))
		size_table
		for-lookup))
	  face_table))
    font-table))


;;;__________________
;;;
;;; Looking up Fonts
;;;__________________

(defun lookup-font (font-spec)
  ;; Returns a font-name or font-object corresponding to font-spec
  ;; or NIL if no font can be derived from font-spec.
  ;;
  ;; font-spec is a plist containing :family :face :size keywords, where
  ;; size spec is: <absolute-size> or (<absolute-size> . <relative-size>)
  ;; If some of the keywords are missing appropriate defaults will be used
  ;; and warnings issued.
  
  (let* ((family (getf font-spec :family))
	 (face (getf font-spec :face))
	 (size-spec (getf font-spec :size))
	 (absolute-size (if (consp size-spec) (car size-spec) size-spec)))
    (cond ((not (numberp absolute-size))
	   (warn "Non-number absolute size for font spec ~S." font-spec)
	   nil)
	  (t
	   (let* ((relative-size
		   (if (consp size-spec) (cdr size-spec) :normal))
		  (real-size (* absolute-size
				(font-relative-size-factor relative-size))))
	     (or (get-font family face real-size) 
		 (let ((any-family (block any
				     (map-font-table
				      #'(lambda (family face size fnt)
					  (return-from any family))))))
		   (warn "No font mapping defined for family ~S, face ~S, size ~s."
			 family face size-spec)
		   ;; try to use defaults instead
		   (or (get-font family :normal real-size)
		       (and any-family
			    (or (get-font any-family face real-size)
				(get-font any-family :normal real-size))))))))
	  )))

(defun font-relative-size-factor (relative-size)
  (case relative-size
    (:tiny       #.(/ 1 1.2 1.2 1.2))
    (:very-small #.(/ 1 1.2 1.2))
    ((:small :smaller) #.(/ 1 1.2))
    (:normal      1)
    ((:large :larger) 1.2)
    (:very-large  #.(* 1.2 1.2))
    (:huge        #.(* 1.2 1.2 1.2))
    (otherwise    1)))


;;;_________________________
;;;
;;; Describing Font Tables
;;;_________________________

(defun describe-font-families (&optional (font-table *font-table*))
  (maphash #'describe-font-family font-table)
  (values))

(defun describe-font-family (family &optional face_table)
  (format t "~&Family ~S~%" family)
  (map_font_face_table
   #'(lambda (face size_table)
       (format t "~&Face ~S~%" face)
       (map_font_size_table
	#'(lambda (size-threshold font)
	    (format t "~&Size < ~S: ~S~%" size-threshold font))
	size_table
	T))
   (or face_table
       (get_font_face_table family)))
  (values))


;;;________________________
;;;
;;; Verifying a font table
;;;________________________

(defun verify-font-table (&optional (display *display*))
  "Checks if font mappings are valid in the current X Server environment."
  (declare (special *display*))
  (map-font-table
   #'(lambda (family face size font)
       (setq font (if (font-p font)
		      (font-name font)
		    font))
       (if (verify-font display font)
	   (format t ".")
	 (format t "~&For family ~S, face ~S, size ~S:~%  undefined font ~S.~%"
		 family face size font)))))
			
(defun verify-font-table-for-host (host)
  "Checks if font mappings are valid in HOST's current X Server environment."
  (let ((display (open-contact-display "Verifying Font Table" :host host)))
    (unwind-protect
	(verify-font-table display)
      (close-display display))))

(defun verify-font (display font-name)
  (or ;; test for a bitmap fonts (including X font)
      (list-fonts display font-name :max-fonts 1)
      ;; otherwise it may be an OpenFont
      ;; (infinitely scalable NeWS fonts in OpenWindows)
      (and (x11/news-server-p display)
	   (verify-openfont display font-name))))

(defun verify-openfont (display font-name)
  (let ((error-handler (display-error-handler display))
	(font-exists-p t))
    (flet ((font-error-handler (display error-key &rest key-vals)
	     (if (member error-key '(xlib::name-error xlib::font-error))
		 (setf font-exists-p nil)
	       (apply error-handler display error-key key-vals))))
      (process-all-events display)   ; make event queue empty
      (setf (display-error-handler display) #'font-error-handler)
      (unwind-protect
	  (progn
	    ;; Note that open-font and close-font might not generate
	    ;; protocol requests if the font is reference counted locally.
	    ;; So this function fails for invalid fonts already contained
	    ;; in the font-cache.
	    (close-font (open-font display font-name))
	    (process-all-events display))
	(setf (display-error-handler display) error-handler))
       font-exists-p)))


;;;________________
;;; 
;;; Font Defaults
;;;________________

(defparameter *font-defaults* '(:family :helvetica
				:face   :normal
				:size   14)
  "a list of keyword-value pairs specifying global default font characteristics")

(defun merge-font-spec-with-defaults (font-spec contact-defaults global-defaults)
  (when font-spec
    (when (eq font-spec :default)
      (setq font-spec nil))
    (list* :family
	   (or (getf font-spec :family)
	       (getf contact-defaults :family)
	       (getf global-defaults :family))
	   :face
	   (or (getf font-spec :face)
	       (getf contact-defaults :face)
	       (getf global-defaults :face))
	   :size
	   (let ((size (getf font-spec :size))
		 dsize)
	     (cond ((numberp size) size) ; absolute size 
		   (size		; relative size 
		    (let ((dsize (getf contact-defaults :size)))
		      (if (numberp dsize)
			  (cons dsize size)
			(cons (getf global-defaults :size) size))))
		   ((numberp (setq dsize (getf contact-defaults :size)))
		    dsize)
		   (dsize
		    (cons (getf global-defaults :size) dsize))
		   (t
		    (getf global-defaults :size))))
	   ;; all the other font characteristics
	   font-spec)
    ))


(defcontact font-mixin ()
  ((font :type font :reader font :initarg :font)
   (font-defaults :initform ()
		  :allocation :class
		  :reader font-defaults
		  :documentation "class-specific font defaults"))
  (:resources
   (font :initform :default))
  )

(defmethod (setf font) (font-spec (self font-mixin))
  (with-slots (font) self
    (setf font (convert self font-spec 'font))
    font-spec))

(defmethod merge-font-spec ((self font-mixin) font-spec &optional
			    (contact-defaults (font-defaults self))
			    (global-defaults *font-defaults*))
  ;; merge font-spec against contact-specific and global font-defaults
  (merge-font-spec-with-defaults font-spec contact-defaults global-defaults))


(defmethod merge-font-spec ((self basic-contact) font-spec &optional
			    (contact-defaults nil)
			    (global-defaults *font-defaults*))
  ;; merge font-spec against global font-defaults
  (merge-font-spec-with-defaults font-spec contact-defaults global-defaults))

(defmethod any-font ((self basic-contact))
  ;; should return a font existing on any server implementation
  (with-slots (display) self
    (first (list-fonts display "*" :max-fonts 1))))

(defmethod convert ((contact basic-contact) value (type (eql 'font)))
  ;; Note that the value returned may be a font object or NIL, however
  ;; there is no guarantee that the font object is really known by
  ;; the current X Server.
  (if (or (consp value)
	  (eq value :default))
      (call-next-method contact
			(or (lookup-font
			     (merge-font-spec contact value))
			    (any-font contact))
			type)
      (call-next-method)))


