;;;; -*- 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)