[Message Prev][Message Next][Thread Prev][Thread Next][Message Index][Thread Index]
[MD:579]create-fontset-from-request and bdf font
- X-ml-count: 579
- Subject: [MD:579]create-fontset-from-request and bdf font
- From: YAMAMOTO Akishige <yamamoto@xxxxxxxxx>
- Date: 12 Mar 1998 16:47:45 +0900
- X-mailer: Semi-gnus 6.0.8 (based on Quassia Gnus v0.34)
Miyashita Hisashi(宮下 尚:HIMI) <himi@xxxxxxxxxxxxxxxxxxxxxxxxx> writes:
> > 1. やっぱり、BDF のトップディレクトリを指定するだけで、全自動がうれ
> > しいな。ディレクトリを再起すると、当然時間がかかるから、ファイルに
> > キャッシュ。
>
> うーんと、customか、何かを使って、high-level APIの結果を
> 保存できるようにすれば、時間がかかってもいいかも、と、
> 思っています。^^
defcustom ですか。どーも、あれは好きになれないです^^;;
>
> > 2. (おそらく半田さんの書かれた) fontset.el というのがあるから、出来
> > る限り利用したい。つまり、BDF font の識別子は、XLFD を利用したい。そ
> > うすれば、font から、charset の対応が簡単になる。
>
> うーーーむむむ、BDF fontの識別子にXLFDはちょっと...;_;
どうも、himi さんのお考えになっている事が分かっていないようですので、
教えて下さい。
himi さんは、BDF フォント名から charset を求める場合は、どのような方
法をお考えでしょうか? それとも、これはユーザが指定するものとお考えで
しょうか?
もし、自動化するとなると、XLFD は使わなくするとしても、REGISTRY,
ENCODING は必要になりますよね。それとも、他に charset を求める裏技が
あるのかな?
> > 3. XLFD の取得には、時間がかかるから、1. と一緒にファイルにキャッシュ。
> > まあ、mw32bdf.c に細工すれば、それほどコストは高くなくなりますが。
>
> XLFD取得できないBDFフォントがありますし、や、やめましょうよ。^_^;;;
あ、そういうフォントもあるんですか。。。
> > 5. request, reuired に width を指定された場合、bdf の場合どう振舞う
> > のか。
>
> やっぱり、requiredなら、(w32-get-logfont-info)で一致したときだけ、
> 選択するんでしょうね。
となると、例えば、width の違うフォントを共存させたい場合は(例えば漢
字とアルファベット)、width を書かないでおくのでしょうか?
# ちなみに現在のサンプル実装だと、16dots.tar.gz しかインストールして
# いないのに、7 秒^^;; まあ、最適化すれば半分ぐらいにはすぐなるとは
# 思いますが…。むぅ。
まあ、ごたくを並べてもしょうがないので、いちおう、サンプル実装添付し
ておきます。ご意見お聞かせ下さい。
;; やまもと
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; bdf font directory maintenance
(defvar w32-bdf-font-directory "d:/fonts")
(defvar w32-bdf-logfont-list nil)
(defun w32-get-bdf-files (dir)
(let ((files nil)
(dirs (directory-files dir)))
(while dirs
(if (and (not (string= (car dirs) "."))
(not (string= (car dirs) "..")))
(let ((filename (expand-file-name (car dirs) dir)))
(if (file-directory-p filename)
(setq files (append (w32-get-bdf-files filename) files))
(if (string-match "^.*\\.bdf$" filename)
(setq files (cons filename files))))))
(setq dirs (cdr dirs)))
files))
(defun w32-get-bdf-logfont-list ()
(if (null w32-bdf-logfont-list)
(setq w32-bdf-logfont-list
(mapcar '(lambda (filename)
(list 'bdf-font filename))
(w32-get-bdf-files w32-bdf-font-directory))))
w32-bdf-logfont-list)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; bdf font table maintenance
(defvar w32-bdf-font-table-filename "~/.fonttable")
(defvar w32-bdf-font-table nil)
(defun w32-get-bdf-fontname-internal (filename)
(catch 'found
(with-temp-buffer
(let ((pt 0))
(while 1
(save-excursion
(goto-char (point-max))
(insert-file-contents filename nil (point) (+ (point) 512)))
(if (and (search-forward-regexp "^FONT \\(.*\\)" nil t)
(not (eq (point) (point-max))))
(throw 'found (match-string 1)))
(if (search-forward-regexp "^ENDPROPERTIES" nil t)
(error "can not find FONT field"))
(goto-char (point-max))
(beginning-of-line))))))
(defun w32-get-bdf-font-table-internal ()
(let ((files (w32-get-bdf-files w32-bdf-font-directory))
fonts)
(while files
(let ((fontname (w32-get-bdf-fontname-internal (car files))))
(setq fonts (cons (cons (car files)
fontname)
fonts)))
(setq files (cdr files)))
(setq w32-bdf-font-table fonts)))
(defun w32-get-bdf-font-table (&optional forcep)
(if forcep
(progn
(w32-get-bdf-font-table-internal)
(w32-save-bdf-font-table))
(if (null w32-bdf-font-table)
(if (file-exists-p w32-bdf-font-table-filename)
(w32-load-bdf-font-table)
(w32-get-bdf-font-table-internal)
(w32-save-bdf-font-table))))
w32-bdf-font-table)
(defun w32-save-bdf-font-table ()
(if w32-bdf-font-table
(with-temp-buffer
(insert ";; -*- emacs-lisp -*-\n")
(insert ";; Meadow bdf font list.\n")
(let ((print-quoted t)
(print-readably t))
(prin1 w32-bdf-font-table (current-buffer)))
(write-file w32-bdf-font-table-filename))))
(defun w32-load-bdf-font-table ()
(with-temp-buffer
(insert-file-contents w32-bdf-font-table-filename)
(setq w32-bdf-font-table (read (current-buffer)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; bdf font properties
(defun w32-get-charset-from-charset-registry (registry encoding)
(catch 'charset
(let ((regs x-charset-registries)
(charsets nil))
(while regs
(if (string-match (if (string-match "-" (cdr (car regs)))
(cdr (car regs))
(concat (cdr (car regs)) "[^-]*-" encoding))
(concat registry "-" encoding))
(throw 'charset (car (car regs))))
(setq regs (cdr regs))))))
(defun w32-get-bdf-fontname (filename)
(cdr (assoc filename (w32-get-bdf-font-table))))
(defun w32-get-charset-from-bdf-fontname (fontname)
(w32-get-charset-from-charset-registry
(aref (x-decompose-font-name fontname) xlfd-regexp-registry-subnum)
(aref (x-decompose-font-name fontname) xlfd-regexp-encoding-subnum)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; support functions
(defun xlfd-match (xlfd-pattern xlfd-name)
(let ((start 0))
(while (string-match "\\*" xlfd-pattern start)
(setq start (1+ (match-end 0)))
(setq xlfd-pattern (replace-match ".*" t t xlfd-pattern))))
(string-match xlfd-pattern xlfd-name))
(defun w32-list-bdf-fontinfo (pattern &optional charset)
(if charset
(let ((fontinfo-list (w32-list-bdf-fontinfo pattern))
matched)
(while fontinfo-list
(setq matched
(nconc matched
(and (eq (w32-get-charset-from-bdf-fontname
(cdr (car fontinfo-list)))
charset)
(list (car fontinfo-list))))
fontinfo-list (cdr fontinfo-list)))
matched)
(let ((fonts (w32-get-bdf-font-table))
matched)
(while fonts
(let ((fontinfo (car fonts)))
(if (xlfd-match pattern (cdr fontinfo))
(setq matched (cons fontinfo matched))))
(setq fonts (cdr fonts)))
matched)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun w32-bdf-logfont-list-from-request (charset required recommended fontset)
(let (request cand1)
(setq cand1 (mapcar '(lambda (fontinfo)
(list nil nil 'raster
(list 'bdf-font (car fontinfo))))
(w32-list-bdf-fontinfo
(if (setq request (cdr (assq 'family required)))
request
"*")
charset)))
(setq cand1 (w32-select-logfont-from-required cand1 required))
(nth 3 (w32-select-logfont-from-recommended cand1 recommended))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; patch for logfont property functions
(defun w32-logfont-italic-p (logfont)
"Return italic-p of logfont."
(w32-check-logfont logfont)
(if (eq (car logfont) 'bdf-font)
(let* ((xlfd-fields (x-decompose-font-name
(w32-get-bdf-fontname (car (cdr logfont)))))
(slant (aref xlfd-fields xlfd-regexp-slant-subnum)))
(string-match "^i$" slant))
(nth 6 logfont)))
(defun w32-logfont-weight (logfont)
"Return weight of logfont."
(w32-check-logfont logfont)
(if (eq (car logfont) 'bdf-font)
(let* ((xlfd-fields (x-decompose-font-name
(w32-get-bdf-fontname (car (cdr logfont)))))
(weight (aref xlfd-fields xlfd-regexp-weight-subnum)))
(cond ((string-match "^medium$" weight)
400)
((string-match "^bold$\\|^demibold$" weight)
700)))
(nth 4 logfont)))
(defun w32-logfont-fixed-p (logfont)
(or (eq (car logfont) 'bdf-font)
(/= (logand (nth 12 logfont) 1) 0)))
(defun w32-candidate-satisfy-request-p (cand request)
(let* ((item (car request))
(cont (cdr request))
(logfont (nth 3 cand))
(info (w32-get-logfont-info logfont)))
(cond ((eq item 'width) t)
;; width は無視している
;;((or (w32-candidate-scalable-p cand)
;; (= (cdr (assq 'width info)) cont)))
((eq item 'height)
(or (w32-candidate-scalable-p cand)
(= (cdr (assq 'height info)) cont)))
((eq item 'weight)
t)
; (or (w32-candidate-scalable-p cand)
; (= (cdr (assq 'weight info)) cont)))
((eq item 'italic)
(if cont
(w32-logfont-italic-p logfont)
(not (w32-logfont-italic-p logfont))))
((eq item 'fixed)
(if cont
(w32-logfont-fixed-p logfont)
(not (w32-logfont-fixed-p logfont))))
((eq item 'family)
(string= (car cand) cont))
(t
t))))
;;; patch for create-fontset-from-request
(defun create-fontset-from-request
(name required recommended)
"Create fontset from your request."
(let* ((logfont-list (logfont-list-from-request
required recommended))
(curll logfont-list)
curle
logfont fontname charset)
(while (setq curle (car curll))
(setq logfont (cdr curle)
charset (car curle)
fontname (concat name "-" (symbol-name charset)))
(set-font-from-logfont fontname logfont charset 0
(nth 2 (assq charset w32-charset-encoding-alist)))
(setcdr curle fontname)
(setq curll (cdr curll)))
(new-fontset name logfont-list)))
;;; patch for w32-charset-encoding-alist
(setq w32-charset-encoding-alist
'((ascii 0 0) ; ANSI_CHARSET
(latin-iso8859-1 0 1) ; ANSI_CHARSET
(ascii-right-to-left 0 0) ; ANSI_CHARSET
(latin-iso8859-2 238 1) ; EASTEUROPE_CHARSET
(latin-iso8859-3 1 1) ; DEFAULT_CHARSET
(latin-iso8859-4 1 1) ; DEFAULT_CHARSET
(cyrillic-iso8859-5 204 1) ; RUSSIAN_CHARSET(1251!=8859)
(arabic-iso8859-6 178 0) ; ARABIC_CHARSET
(greek-iso8859-7 161 1) ; GREEK_CHARSET
(hebrew-iso8859-8 177 1) ; HEBREW_CHARSET
(latin-iso8859-9 162 1) ; TURKISH_CHARSET
(latin-jisx0201 128 0) ; SHIFTJIS_CHARSET
(katakana-jisx0201 128 4) ; SHIFTJIS_CHARSET
(japanese-jisx0208 128 4) ; SHIFTJIS_CHARSET
(japanese-jisx0212 1 0) ; DEFAULT_CHARSET
(chinese-big5-1
136 encode-big5-font) ; CHINESEBIG5_CHARSET
(chinese-big5-2
136 encode-big5-font) ; CHINESEBIG5_CHARSET
(chinese-gb2312 134 0) ; GB2312_CHARSET
(korean-ksc5601 129 0) ; HANGEUL_CHARSET
(thai-tis620 222 1) ; THAI_CHARSET
(vietnamese-viscii-lower
163 encode-viscii-font) ; VIETNAMESE_CHARSET
(vietnamese-viscii-upper
163 encode-viscii-font) ; VIETNAMESE_CHARSET
(chinese-cns11643-1 1 0) ; DEFAULT_CHARSET
(chinese-cns11643-2 1 0) ; DEFAULT_CHARSET
; (chinese-cns11643-3 1 0) ; DEFAULT_CHARSET
; (chinese-cns11643-4 1 0) ; DEFAULT_CHARSET
; (chinese-cns11643-5 1 0) ; DEFAULT_CHARSET
; (chinese-cns11643-6 1 0) ; DEFAULT_CHARSET
; (chinese-cns11643-7 1 0) ; DEFAULT_CHARSET
(arabic-digit 1 0) ; DEFAULT_CHARSET
(arabic-1-column 1 0) ; DEFAULT_CHARSET
(arabic-2-column 1 0) ; DEFAULT_CHARSET
(lao 1 1) ; DEFAULT_CHARSET
(ipa 1 1) ; DEFAULT_CHARSET
(ethiopic 1 encode-ethio-font) ; DEFAULT_CHARSET
(indian-is13194 1 0) ; DEFAULT_CHARSET
(indian-2-column 1 0) ; DEFAULT_CHARSET
(indian-1-column 1 0) ; DEFAULT_CHARSET
))
;;; sample
(if nil
(progn
(add-hook 'logfont-from-request-functions
'w32-bdf-logfont-list-from-request
t)
(setq w32-bdf-font-directory "d:/fonts")
(setq w32-bdf-font-table-filename "~/.fonttable")
(let ((fontset-name "private-fontset22"))
(create-fontset-from-request
fontset-name
'((width . 8)
(height . 16)
(fixed . t)
(italic . nil))
'((family . "ＭＳ ゴシック")
(family . "Courier New")))
(set-default-font fontset-name)))
)