path: root/lisp/international/fontset.el

;;; fontset.el --- Commands for handling fontset.

;; Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
;; Licensed to the Free Software Foundation.

;; Keywords: mule, multilingual, fontset

;; This file is part of GNU Emacs.

;; GNU Emacs 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, or (at your option)
;; any later version.

;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Code:

;; Set standard REGISTRY of characters in the default fontset to find
;; an appropriate font for each charset.  This is used to generate a
;; font name for a fontset if the fontset doesn't specify a font name
;; for a specific character.  If the value contains a character `-',
;; the string before that is embedded in `CHARSET_REGISTRY' field, and
;; the string after that is embedded in `CHARSET_ENCODING' field.  If
;; the value does not contain `-', the whole string is embedded in
;; `CHARSET_REGISTRY' field, and a wild card character `*' is embedded
;; in `CHARSET_ENCODING' field.
;; The REGISTRY for ASCII characters are predefined as "ISO8859-1".

(let ((l `((latin-iso8859-1 . "ISO8859-1")
	   (latin-iso8859-2 . "ISO8859-2")
	   (latin-iso8859-3 . "ISO8859-3")
	   (latin-iso8859-4 . "ISO8859-4")
	   (thai-tis620 . "TIS620")
	   (greek-iso8859-7 . "ISO8859-7")
	   (arabic-iso8859-6 . "ISO8859-6")
	   (hebrew-iso8859-8 . "ISO8859-8")
	   (katakana-jisx0201 . "JISX0201")
	   (latin-jisx0201 . "JISX0201")
	   (cyrillic-iso8859-5 . "ISO8859-5")
	   (latin-iso8859-9 . "ISO8859-9")
	   (japanese-jisx0208-1978 . "JISX0208.1978")
	   (chinese-gb2312 . "GB2312")
	   (japanese-jisx0208 . "JISX0208.1983")
	   (korean-ksc5601 . "KSC5601")
	   (japanese-jisx0212 . "JISX0212")
	   (chinese-cns11643-1 . "CNS11643.1992-1")
	   (chinese-cns11643-2 . "CNS11643.1992-2")
	   (chinese-cns11643-3 . "CNS11643.1992-3")
	   (chinese-cns11643-4 . "CNS11643.1992-4")
	   (chinese-cns11643-5 . "CNS11643.1992-5")
	   (chinese-cns11643-6 . "CNS11643.1992-6")
	   (chinese-cns11643-7 . "CNS11643.1992-7")
	   (chinese-big5-1 . "Big5")
	   (chinese-big5-2 . "Big5")
	   (chinese-sisheng . "sisheng_cwnn")
	   (vietnamese-viscii-lower . "VISCII1.1")
	   (vietnamese-viscii-upper . "VISCII1.1")
	   (arabic-digit . "MuleArabic-0")
	   (arabic-1-column . "MuleArabic-1")
	   (arabic-2-column . "MuleArabic-2")
	   (ipa . "MuleIPA")
	   (ethiopic . "Ethiopic-Unicode")
	   (ascii-right-to-left . "ISO8859-1")
	   (indian-is13194 . "IS13194-Devanagari")
	   (indian-2-column . "MuleIndian-2")
	   (indian-1-column . "MuleIndian-1")
	   (lao . "MuleLao-1")
	   (tibetan . "MuleTibetan-0")
	   (tibetan-1-column . "MuleTibetan-1")
	   (latin-iso8859-14 . "ISO8859-14")
	   (latin-iso8859-15 . "ISO8859-15")
	   ))
      charset registry arg)
  (while l
    (setq charset (car (car l)) registry (cdr (car l)) l (cdr l))
    (or (string-match "-" registry)
	(setq registry (concat registry "*")))
    (if (symbolp charset)
	(setq arg (make-char charset))
      (setq arg charset))
    (set-fontset-font t arg registry)))

;; Set arguments in `font-encoding-alist' (which see).
(defun set-font-encoding (pattern charset encoding)
  (let ((slot (assoc pattern font-encoding-alist)))
    (if slot
	(let ((place (assq charset (cdr slot))))
	  (if place
	      (setcdr place encoding)
	    (setcdr slot (cons (cons charset encoding) (cdr slot)))))
      (setq font-encoding-alist
	    (cons (list pattern (cons charset encoding)) font-encoding-alist)))
    ))

(set-font-encoding "ISO8859-1" 'ascii 0)
(set-font-encoding "JISX0201" 'latin-jisx0201 0)

;; Setting for suppressing XLoadQueryFont on big fonts.
(setq x-pixel-size-width-font-regexp
      "gb2312\\|jisx0208\\|ksc5601\\|cns11643\\|big5")

;; These fonts require vertical centering.
(setq vertical-centering-font-regexp
      "gb2312\\|jisx0208\\|jisx0212\\|ksc5601\\|cns11643\\|big5")

(defvar x-font-name-charset-alist
  '(("iso8859-1" ascii latin-iso8859-1)
    ("iso8859-2" ascii latin-iso8859-2)
    ("iso8859-3" ascii latin-iso8859-3)
    ("iso8859-4" ascii latin-iso8859-4)
    ("iso8859-5" ascii cyrillic-iso8859-5)
    ("iso8859-6" ascii arabic-iso8859-6)
    ("iso8859-7" ascii greek-iso8859-7)
    ("iso8859-8" ascii hebrew-iso8859-8)
    ("iso8859-14" ascii latin-iso8859-14)
    ("iso8859-15" ascii latin-iso8859-15)
    ("tis620" ascii thai-tis620)
    ("koi8" ascii cyrillic-iso8859-5)
    ("viscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower)
    ("vscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower)
    ("mulelao-1" ascii lao))
  "Alist of font names vs list of charsets the font can display.

When a font name which matches some element of this alist is given as
`-fn' command line argument or is specified by X resource, a fontset
which uses the specified font for the corresponding charsets are
created and used for the initial frame.")

;;; XLFD (X Logical Font Description) format handler.

;; Define XLFD's field index numbers.		; field name
(defconst xlfd-regexp-foundry-subnum 0)		; FOUNDRY
(defconst xlfd-regexp-family-subnum 1)		; FAMILY_NAME
(defconst xlfd-regexp-weight-subnum 2)		; WEIGHT_NAME
(defconst xlfd-regexp-slant-subnum 3)		; SLANT
(defconst xlfd-regexp-swidth-subnum 4)		; SETWIDTH_NAME
(defconst xlfd-regexp-adstyle-subnum 5)		; ADD_STYLE_NAME
(defconst xlfd-regexp-pixelsize-subnum 6)	; PIXEL_SIZE
(defconst xlfd-regexp-pointsize-subnum 7)	; POINT_SIZE
(defconst xlfd-regexp-resx-subnum 8)		; RESOLUTION_X
(defconst xlfd-regexp-resy-subnum 9)		; RESOLUTION_Y
(defconst xlfd-regexp-spacing-subnum 10)	; SPACING
(defconst xlfd-regexp-avgwidth-subnum 11)	; AVERAGE_WIDTH
(defconst xlfd-regexp-registry-subnum 12)	; CHARSET_REGISTRY
(defconst xlfd-regexp-encoding-subnum 13)	; CHARSET_ENCODING

;; Regular expression matching against a fontname which conforms to
;; XLFD (X Logical Font Description).  All fields in XLFD should be
;; not be omitted (but can be a wild card) to be matched.
(defconst xlfd-tight-regexp
  "^\
-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)$")

;; List of field numbers of XLFD whose values are numeric.
(defconst xlfd-regexp-numeric-subnums
  (list xlfd-regexp-pixelsize-subnum	;6
	xlfd-regexp-pointsize-subnum	;7
	xlfd-regexp-resx-subnum		;8
	xlfd-regexp-resy-subnum		;9
	xlfd-regexp-avgwidth-subnum	;11
	))

(defun x-decompose-font-name (pattern)
  "Decompose PATTERN into XLFD's fields and return vector of the fields.
The length of the vector is 14.

If PATTERN doesn't conform to XLFD, try to get a full XLFD name from
X server and use the information of the full name to decompose
PATTERN.  If no full XLFD name is gotten, return nil."
  (let (xlfd-fields fontname)
    (if (string-match xlfd-tight-regexp pattern)
	(let ((i 0))
	  (setq xlfd-fields (make-vector 14 nil))
	  (while (< i 14)
	    (aset xlfd-fields i (match-string (1+ i) pattern))
	    (setq i (1+ i)))
	  xlfd-fields)
      (setq fontname (condition-case nil
			 (x-resolve-font-name pattern)
		       (error)))
      (if (and fontname
	       (string-match xlfd-tight-regexp fontname))
	  ;; We get a full XLFD name.
	  (let ((len (length pattern))
		(i 0)
		l)
	    ;; Setup xlfd-fields by the full XLFD name.  Each element
	    ;; should be a cons of matched index and matched string.
	    (setq xlfd-fields (make-vector 14 nil))
	    (while (< i 14)
	      (aset xlfd-fields i
		    (cons (match-beginning (1+ i))
			  (match-string (1+ i) fontname)))
	      (setq i (1+ i)))

	    ;; Replace wild cards in PATTERN by regexp codes.
	    (setq i 0)
	    (while (< i len)
	      (let ((ch (aref pattern i)))
		(if (= ch ??)
		    (setq pattern (concat (substring pattern 0 i)
					  "\\(.\\)"
					  (substring pattern (1+ i)))
			  len (+ len 4)
			  i (+ i 4))
		  (if (= ch ?*)
		      (setq pattern (concat (substring pattern 0 i)
					    "\\(.*\\)"
					    (substring pattern (1+ i)))
			    len (+ len 5)
			    i (+ i 5))
		    (setq i (1+ i))))))

	    ;; Set each element of xlfd-fields to proper strings.
	    (if (string-match pattern fontname)
		;; The regular expression PATTERN matchs the full XLFD
		;; name.  Set elements that correspond to a wild card
		;; in PATTERN to "*", set the other elements to the
		;; exact strings in PATTERN.
		(let ((l (cdr (cdr (match-data)))))
		  (setq i 0)
		  (while (< i 14)
		    (if (or (null l) (< (car (aref xlfd-fields i)) (car l)))
			(progn
			  (aset xlfd-fields i (cdr (aref xlfd-fields i)))
			  (setq i (1+ i)))
		      (if (< (car (aref xlfd-fields i)) (car (cdr l)))
			  (progn
			    (aset xlfd-fields i "*")
			    (setq i (1+ i)))
			(setq l (cdr (cdr l)))))))
	      ;; Set each element of xlfd-fields to the exact string
	      ;; in the corresonding fields in full XLFD name.
	      (setq i 0)
	      (while (< i 14)
		(aset xlfd-fields i (cdr (aref xlfd-fields i)))
		(setq i (1+ i))))
	    xlfd-fields)))))

;; Replace consecutive wild-cards (`*') in NAME to one.
;; Ex. (x-reduce-font-name "-*-*-*-iso8859-1") => "-*-iso8859-1"
(defsubst x-reduce-font-name (name)
  (while (string-match "-\\*-\\(\\*-\\)+" name)
    (setq name (replace-match "-*-" t t name)))
  name)

(defun x-compose-font-name (fields &optional reduce)
  "Compose X's fontname from FIELDS.
FIELDS is a vector of XLFD fields, the length 14.
If a field is nil, wild-card letter `*' is embedded.
Optional argument REDUCE is always ignored.  It exists just for
backward compatibility."
  (concat "-" (mapconcat (lambda (x) (or x "*")) fields "-")))

(defun x-complement-fontset-spec (xlfd-fields fontlist)
  "Complement FONTLIST for charsets based on XLFD-FIELDS and return it.
XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
FONTLIST is an alist of charsets vs the corresponding font names.

The fonts are complemented as below.

If FONTLIST doesn't specify a font for ASCII charset, generate a font
name for the charset from XLFD-FIELDS, and add that information to
FONTLIST.

If a font specifid for ASCII supports the other charsets (see the
variable `x-font-name-charset-alist'), add that information to FONTLIST."
  (let ((ascii-font (cdr (assq 'ascii fontlist))))

    ;; If font for ASCII is not specified, add it.
    (unless ascii-font
      (let ((registry (cdr (fontset-font t 0)))
	    (encoding nil))
	(if (string-match "-" registry)
	    (setq encoding (substring registry (match-end 0))
		  registry (substring registry 0 (match-beginning 0))))
	(aset xlfd-fields xlfd-regexp-registry-subnum registry)
	(aset xlfd-fields xlfd-regexp-encoding-subnum encoding)
	(setq ascii-font (x-compose-font-name xlfd-fields))
	(setq fontlist (cons (cons 'ascii ascii-font) fontlist))))

    ;; If the font for ASCII also supports the other charsets, and
    ;; they are not specified in FONTLIST, add them.
    (let ((tail x-font-name-charset-alist)
	  elt)
      (while tail
	(setq elt (car tail) tail (cdr tail))
	(if (string-match (car elt) ascii-font)
	    (let ((charsets (cdr elt))
		  charset)
	      (while charsets
		(setq charset (car charsets) charsets (cdr charsets))
		(or (assq charset fontlist)
		    (setq fontlist
			  (cons (cons charset ascii-font) fontlist))))))))
    
    fontlist))

(defun fontset-name-p (fontset)
  "Return non-nil if FONTSET is valid as fontset name.
A valid fontset name should conform to XLFD (X Logical Font Description)
with \"fontset\" in `<CHARSET_REGISTRY> field."
  (and (string-match xlfd-tight-regexp fontset)
       (string= (match-string (1+ xlfd-regexp-registry-subnum) fontset)
		"fontset")))

;; Return a list to be appended to `x-fixed-font-alist' when
;; `mouse-set-font' is called.
(defun generate-fontset-menu ()
  (let ((fontsets (fontset-list))
	fontset-name
	l)
    (while fontsets
      (setq fontset-name (car fontsets) fontsets (cdr fontsets))
      (setq l (cons (list (fontset-plain-name fontset-name) fontset-name) l)))
    (cons "Fontset"
	  (sort l (function (lambda (x y) (string< (car x) (car y))))))))

(defun fontset-plain-name (fontset)
  "Return a plain and descriptive name of FONTSET."
  (if (not (setq fontset (query-fontset fontset)))
      (error "Invalid fontset: %s" fontset))
  (let ((xlfd-fields (x-decompose-font-name fontset)))
    (if xlfd-fields
	(let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
	      (slant  (aref xlfd-fields xlfd-regexp-slant-subnum))
	      (swidth (aref xlfd-fields xlfd-regexp-swidth-subnum))
	      (size   (aref xlfd-fields xlfd-regexp-pixelsize-subnum))
	      (charset (aref xlfd-fields xlfd-regexp-registry-subnum))
	      (nickname (aref xlfd-fields xlfd-regexp-encoding-subnum))
	      name)
	  (if (not (string= "fontset" charset))
	      fontset
	    (if (> (string-to-int size) 0)
		(setq name (format "%s: %s-dot" nickname size))
	      (setq name nickname))
	    (cond ((string-match "^medium$" weight)
		   (setq name (concat name " " "medium")))
		  ((string-match "^bold$\\|^demibold$" weight)
		   (setq name (concat name " " weight))))
	    (cond ((string-match "^i$" slant)
		   (setq name (concat name " " "italic")))
		  ((string-match "^o$" slant)
		   (setq name (concat name " " "slant")))
		  ((string-match "^ri$" slant)
		   (setq name (concat name " " "reverse italic")))
		  ((string-match "^ro$" slant)
		   (setq name (concat name " " "reverse slant"))))
	    name))
      fontset)))

;;;###autoload
(defun create-fontset-from-fontset-spec (fontset-spec
					 &optional style-variant noerror)
  "Create a fontset from fontset specification string FONTSET-SPEC.
FONTSET-SPEC is a string of the format:
	FONTSET-NAME,CHARSET-NAME0:FONT-NAME0,CHARSET-NAME1:FONT-NAME1, ...
Any number of SPACE, TAB, and NEWLINE can be put before and after commas.

Optional 2nd argument is ignored.  It exists just for backward
compatibility.

If this function attempts to create already existing fontset, error is
signaled unless the optional 3rd argument NOERROR is non-nil.

It returns a name of the created fontset."
  (if (not (string-match "^[^,]+" fontset-spec))
      (error "Invalid fontset spec: %s" fontset-spec))
  (setq fontset-spec (downcase fontset-spec))
  (let ((idx (match-end 0))
	(name (match-string 0 fontset-spec))
	xlfd-fields charset fontlist ascii-font)
    (if (query-fontset name)
	(or noerror 
	    (error "Fontset \"%s\" already exists" name))
      (setq xlfd-fields (x-decompose-font-name name))
      (or xlfd-fields
	  (error "Fontset \"%s\" not conforming to XLFD" name))

      ;; At first, extract pairs of charset and fontname from FONTSET-SPEC.
      (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)" fontset-spec idx)
	(setq idx (match-end 0))
	(setq charset (intern (match-string 1 fontset-spec)))
	(if (charsetp charset)
	    (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
				 fontlist))))

      ;; Complement FONTLIST.
      (setq fontlist (x-complement-fontset-spec xlfd-fields fontlist))

      (new-fontset name fontlist)

      ;; Define the short name alias.
      (if (and (string-match "fontset-.*$" name)
	       (not (assoc name fontset-alias-alist)))
	  (let ((alias (match-string 0 name)))
	    (or (rassoc alias fontset-alias-alist)
		(setq fontset-alias-alist
		      (cons (cons name alias) fontset-alias-alist)))))

      ;; Define the ASCII font name alias.
      (setq ascii-font (cdr (assq 'ascii fontlist)))
      (or (rassoc ascii-font fontset-alias-alist)
	  (setq fontset-alias-alist
		(cons (cons name ascii-font)
		      fontset-alias-alist))))

    name))

(defun create-fontset-from-ascii-font (font &optional resolved-font
					    fontset-name)
  "Create a fontset from an ASCII font FONT.

Optional 1st arg RESOLVED-FONT is a resolved name of FONT.  If
omitted, x-resolve-font-name is called to get the resolved name.  At
this time, if FONT is not available, error is signaled.

Optional 2nd arg FONTSET-NAME is a string to be used in
`<CHARSET_ENCODING>' fields of a new fontset name.  If it is omitted,
an appropriate name is generated automatically.

It returns a name of the created fontset."
  (setq font (downcase font))
  (if resolved-font
      (setq resolved-font (downcase resolved-font))
    (setq resolved-font (downcase (x-resolve-font-name font))))
  (let ((xlfd (x-decompose-font-name font))
	(resolved-xlfd (x-decompose-font-name resolved-font))
	fontset fontset-spec)
    (aset xlfd xlfd-regexp-foundry-subnum nil)
    (aset xlfd xlfd-regexp-family-subnum nil)
    (aset xlfd xlfd-regexp-registry-subnum "fontset")
    (if fontset-name
	(setq fontset-name (downcase fontset-name))
      (setq fontset-name
	    (format "%s_%s_%s"
		    (aref resolved-xlfd xlfd-regexp-registry-subnum)
		    (aref resolved-xlfd xlfd-regexp-encoding-subnum)
		    (aref resolved-xlfd xlfd-regexp-pixelsize-subnum))))
    (aset xlfd xlfd-regexp-encoding-subnum fontset-name)
    (setq fontset (x-compose-font-name xlfd))
    (or (query-fontset fontset)
	(create-fontset-from-fontset-spec (concat fontset ", ascii:" font)))))


;; Create standard fontset from 16 dots fonts which are the most widely
;; installed fonts.  Fonts for Chinese-GB, Korean, and Chinese-CNS are
;; specified here because FAMILY of those fonts are not "fixed" in
;; many cases.
(defvar standard-fontset-spec
  (purecopy "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-standard,
	chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*,
	korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*,
	chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1,
	chinese-cns11643-2:-*-medium-r-normal-*-16-*-cns11643*-2,
	chinese-cns11643-3:-*-medium-r-normal-*-16-*-cns11643*-3,
	chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4,
	chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5,
	chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6,
	chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7")
  "String of fontset spec of the standard fontset.
You have the biggest chance to display international characters
with correct glyphs by using the standard fontset.
See the documentation of `create-fontset-from-fontset-spec' for the format.")

;; Create fontsets from X resources of the name `fontset-N (class
;; Fontset-N)' where N is integer 0, 1, ...
;; The values of the resources the string of the same format as
;; `standard-fontset-spec'.

(defun create-fontset-from-x-resource ()
  (let ((idx 0)
	fontset-spec)
    (while (setq fontset-spec (x-get-resource (format "fontset-%d" idx)
					      (format "Fontset-%d" idx)))
      (create-fontset-from-fontset-spec fontset-spec t 'noerror)
      (setq idx (1+ idx)))))

;;
(provide 'fontset)

;;; fontset.el ends here