;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               pjb-font.el
;;;;LANGUAGE:           emacs lisp
;;;;SYSTEM:             POSIX
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Font stuff.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2006-11-15 <PJB> Created. Extracted code from ~/.emacs.
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal Bourguignon 2006 - 2011
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************
(require 'cl)
(require 'devices nil t)
(require 'font nil t)
(require 'pjb-list)

(defun font-exists-p (pattern)
  (unless (eq window-system 'x)
    (error "font-exists-p works only on X"))
  (zerop
   (nth-value 0 (cl:parse-integer
     (shell-command-to-string
      (format "xlsfonts -fn %S 2>&1|awk 'BEGIN{r=0;} /xlsfonts: pattern .* unmatched/{r=1;} END{printf \"%%d\",r;}'"
              pattern))))))

(defun font-canonical-to-pixel (canon &optional device)
  (let ((pix-width (float (or (cond ((fboundp 'device-pixel-width)
                                     (device-pixel-width device))
                                    ((fboundp 'display-pixel-width)
                                     (display-pixel-width) device)
                                    (t nil))
                              1024)))
        (mm-width (float (or (cond ((fboundp 'device-mm-width)
                                    (device-mm-width device))
                                   ((fboundp 'display-mm-width)
                                    (display-mm-width) device)
                                   (t nil))
                             293))))
    (/ canon (/ pix-width mm-width) (/ 25.4 72.0))))


(defun get-font-size-in-pixel (font &optional device)
  "
RETURN: The font height in pixel.
"
  (cond ((and (fboundp 'font-size)
              (fboundp 'font-create-object)
              (fboundp 'font-spatial-to-canonical))
         (let ((fs (font-size (font-create-object font))))
           (if (numberp fs)
             fs
             (font-canonical-to-pixel
              (font-spatial-to-canonical fs device) device))))
        (t  (error "How do I compute the font size in pixel for font %S?" font))))


(defun create-new-fontset (fontset-spec &optional style-variant noerror)
  (handler-case
      (create-fontset-from-fontset-spec fontset-spec style-variant noerror)
    (error ())))


(defun split-font-pattern (pattern)
  "Splits a X font pattern into a plist."
  (let ((parts (split-string pattern "-"))
        (plist nil))
    ;; (unless (and (elt parts 7) (string-match "^[0-9]" (elt parts  7)))
    ;;   (message ".EMACS: font=%S\nparts=%S\n" pattern parts))
    (loop
     for item in (cdr parts)
     for key  in '(:foundry
                   :family :weight :slant :width :style
                   :pixel-size :point-size :resolution-x :resolution-y
                   :spacing :average-width :registry :encoding)
     collect key
     collect item)))


(defun* make-font-pattern (&key foundry family weight slant width
                                style pixel-size point-size
                                resolution-x resolution-y spacing
                                average-width registry encoding
                                (defaults "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))
  "Builds a X font pattern from the keyword arguments
DEFAULTS:  either a X font pattern (string) or a plist used as default
           when the corresponding keyword is not given.
EXAMPLE:   Changing the size of a font:
          (make-font-pattern
               :defaults \"-lispm-fixed-medium-r-normal-*-13-*-*-*-*-*\"
               :pixel-size 12)"
  (when (stringp defaults)
    (setf defaults (split-font-pattern defaults)))
  (macrolet ((field (name)
               `(or ,name (getf defaults ,(intern (format ":%s" name))) "*")))
    (format "-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s"
            (field foundry) (field family) (field weight) (field slant)
            (field width) (field style) (field pixel-size) (field point-size)
            (field resolution-x) (field resolution-y) (field spacing)
            (field average-width) (field registry) (field encoding))))


(defun* get-font-parts (pattern &key foundry family weight slant width
                                style pixel-size point-size
                                resolution-x resolution-y spacing
                                average-width registry encoding)
  "
RETURN: A list of unique property lists containing the selected keys
        with all unique tuples in the fonts selected by the pattern.
"
  (let ((parts nil)
        (plist)
        (res nil))
    (dolist (font (split-string
                   (shell-command-to-string
                    (format "xlsfonts -fn '%s'|sort -u" pattern)) "\n"))
      (pushnew (split-font-pattern font) res :test (function equalp)))
    res))



(defun get-independant-font-parts (pattern &key foundry family weight
                                             slant width style
                                             pixel-size point-size
                                             resolution-x resolution-y
                                             spacing average-width
                                             registry encoding
                                             registry-encoding)
  "
RETURN:  An a-list with entries for the selected keywords,
         each being the list of unique values for the corresponding
         field in all fonts selected by the pattern.
EXAMPLE: All families in the Adobe foundry:
         (get-independant-font-parts (make-font-pattern :foundry \"adobe\")
                                     :family t)
"
  (let ((p-foundry nil)      (p-family nil)
        (p-weight nil)       (p-slant nil)
        (p-width nil)        (p-style nil)
        (p-pixel-size nil)   (p-point-size nil)
        (p-resolution-x nil) (p-resolution-y nil)
        (p-spacing nil)      (p-average-width nil)
        (p-registry nil)     (p-encoding nil)
        (p-registry-encoding nil)
        (parts nil)
        (res nil)
        (test (function string-equal)))
    (dolist (font (split-string
                   (shell-command-to-string
                    (format "xlsfonts -fn '%s'|sort -u" pattern)) "\n"))
      (setf parts (split-string font "-"))
      (when foundry
        (pushnew (elt parts  1) p-foundry       :test test))
      (when family
        (pushnew (elt parts  2) p-family        :test test))
      (when weight
        (pushnew (elt parts  3) p-weight        :test test))
      (when slant
        (pushnew (elt parts  4) p-slant         :test test))
      (when width
        (pushnew (elt parts  5) p-width         :test test))
      (when style
        (pushnew (elt parts  6) p-style         :test test))
      (when pixel-size
        (pushnew (elt parts  7) p-pixel-size    :test test))
      (when point-size
        (pushnew (elt parts  8) p-point-size    :test test))
      (when resolution-x
        (pushnew (elt parts  9) p-resolution-x  :test test))
      (when resolution-y
        (pushnew (elt parts 10) p-resolution-y  :test test))
      (when spacing
        (pushnew (elt parts 11) p-spacing       :test test))
      (when average-width
        (pushnew (elt parts 12) p-average-width :test test))
      (when registry
        (pushnew (elt parts 13) p-registry      :test test))
      (when encoding
        (pushnew (elt parts 14) p-encoding      :test test))
      (when registry-encoding
        (pushnew (format "%s-%s" (elt parts 13) (elt parts 14))
                 p-registry-encoding      :test test)))
    (when registry-encoding
      (push (cons :registry-encoding      p-registry-encoding     ) res))
    (when encoding      (push (cons :encoding      p-encoding     ) res))
    (when registry      (push (cons :registry      p-registry     ) res))
    (when average-width (push (cons :average-width p-average-width) res))
    (when spacing       (push (cons :spacing       p-spacing      ) res))
    (when resolution-y  (push (cons :resolution-y  p-resolution-y ) res))
    (when resolution-x  (push (cons :resolution-x  p-resolution-x ) res))
    (when point-size    (push (cons :point-size    p-point-size   ) res))
    (when pixel-size    (push (cons :pixel-size    p-pixel-size   ) res))
    (when style         (push (cons :style         p-style        ) res))
    (when width         (push (cons :width         p-width        ) res))
    (when slant         (push (cons :slant         p-slant        ) res))
    (when weight        (push (cons :weight        p-weight       ) res))
    (when family        (push (cons :family        p-family       ) res))
    (when foundry       (push (cons :foundry       p-foundry      ) res))
    res))

(defmacro make-my-mac-font-sets (size)
  `(progn
     (create-new-fontset
      ,(format "-*-courier-*-*-*-*-%d-*-*-*-*-*-fontset-courier,
          ascii:-*-courier-*-*-*-*-%d-*-*-*-*-*-*,
latin-iso8859-1:-*-courier-*-*-*-*-%d-*-*-*-*-*-*"
               size size size))
     (create-new-fontset
      ,(format "-apple-monaco-%s--%d-*-*-*-*-*-fontset-monaco,
          ascii:-apple-monaco-%s--%d-%d0-75-75-m-%d0-mac-roman,
latin-iso8859-1:-apple-monaco-%s--%d-%d0-75-75-m-%d0-mac-roman"
               "medium-r-normal" size
               "medium-r-normal" size size size
               "medium-r-normal" size size size))))


;; ---------------------------
;;       select-font
;; ---------------------------

(defstruct ftree label children)

(defun build-font-tree (fps &optional label)
  "
FPS:     A property list of font pattern fields (in order).
RETURN:  A tree where the child of each node are labelled with
         the corresponding pattern field.
"
  (when fps
    (setf label (or label "root"))
    (if (car fps)
      (let ((classes (equivalence-classes
                      fps (lambda (a b) (equalp (second a) (second b))))))
        (make-ftree :label label
                    :children (mapcar (lambda (class)
                                        (build-font-tree
                                         (mapcar (function cddr) class)
                                         (second (first class))))
                                      classes)))
      (make-ftree :label label))))

(defun ftree-children-named (font-tree name)
  (car (delete-if (lambda (child) (not (string-equal name (ftree-label child))))
                  (ftree-children font-tree))))

(defparameter *font-default-fields*
  '(:spacing "m" :registry "iso8859"))

(defparameter *font-tree*
  (when (eq window-system 'x)
    (build-font-tree
     (delete-if (lambda (fp)
                  (let* ((ssize (plist-get fp :pixel-size))
                         (size  (when (and ssize (not (string-equal "*" ssize)))
                                  (nth-value 0 (cl:parse-integer ssize)))))
                    (or (null size) (< size 8))))
                (get-font-parts
                 (apply (function make-font-pattern) *font-default-fields*)
                 :family t :weight t :slant t :pixel-size t)))))


(defvar *font-current-node* nil)
(defvar *font-family-history* nil)
(defvar *font-weight-history* nil)
(defvar *font-slant-history* nil)
(defvar *font-pixel-size-history* nil)

(defun select-font (family weight slant pixel-size)
  (interactive
   (list
    (completing-read
     "Family: "
     (mapcar (lambda (child) (cons (ftree-label child) child))
             (ftree-children *font-tree*))
     (lambda (item) (setq *font-current-node* (cdr item))) t nil
     '*font-family-history*)
    (completing-read
     "Weight: "
     (mapcar (lambda (child) (cons (ftree-label child) child))
             (ftree-children *font-current-node*))
     (lambda (item) (setq *font-current-node* (cdr item))) t nil
     '*font-weight-history*)
    (completing-read
     "Slant: "
     (mapcar (lambda (child) (cons (ftree-label child) child))
             (ftree-children *font-current-node*))
     (lambda (item) (setq *font-current-node* (cdr item))) t nil
     '*font-slant-history*)
    (completing-read
     "Pixel-Size: "
     (mapcar (lambda (child) (cons (ftree-label child) child))
             (ftree-children *font-current-node*))
     (lambda (item) (setq *font-current-node* (cdr item))) t nil
     '*font-pixel-size-history*)))
  (set-frame-font (make-font-pattern :family family :weight weight
                                                    :slant slant :pixel-size pixel-size
                                                    :spacing "m"))
  (when (fboundp 'single-frame) (single-frame)))



(defvar *default-font* "fixed")
(defun select-default-font ()
  (interactive)
  (set-frame-font *default-font*)
  (when (fboundp 'single-frame) (single-frame)))


(cond
 ((eq window-system 'mac)
  (make-my-mac-font-sets 9)
  (make-my-mac-font-sets 10)
  (make-my-mac-font-sets 12)
  (make-my-mac-font-sets 14))

 ((eq window-system 'x)
  (select-default-font)))


(provide 'pjb-font)
ViewGit