[Message Prev][Message Next][Thread Prev][Thread Next][Message Index][Thread Index]
[MD:704]customize fontset (Re: bdf font)
- X-ml-count: 704
- Subject: [MD:704]customize fontset (Re: bdf font)
- From: Yoshiki Hayashi <penny@xxxxxxxxxxxxxxxx>
- Date: 10 Apr 1998 11:32:09 +0900
- X-mailer: Semi-gnus 6.0.4 (based on Quassia Gnus v0.23)
誰からも反応がないのがかなしひ。(^^;;
> ;;; 本当はこのコードを見るのがいい加減嫌になったからだったりする
と、書いていたのですが、そのままにしておくと寝覚めが悪い(^^;;;ので、
bdf font対応以外はしてしまいました。
まだまだelispに関しては、初心者の域を出てませんので、fileにsave
しているところなどをどなたかが添削してくださると非常に嬉しいです。
少し、質問です。
familyはメニューにして、一覧から選べるようにしたほうがよいですか?
やっぱり、フォントは固定ではなくて、メニュー形式ですべてのフォント
から選べるほうが嬉しいでしょうか。
ファイル名は何がよろしいでしょうか。
皆さんの感想をお聞かせください。
もうちょっと仕様を煮詰めてから、mule-win32のほうでも発表しようかな、と
思っています。
よろしくお願いします。
結構変更を加えましたので、diffではなくて、そのまま流します。
# やっぱりこのスクリプトはあんまりみたくないなぁ(^^;;;
----
Yoshiki Hayashi
(defvar request-list nil)
(defvar fontset-name nil)
(defvar family nil)
(require 'widget)
(require 'wid-edit)
(defun create-fontset-customize ()
"customizable font backend"
(interactive)
(switch-to-buffer "*Fontset create*")
(erase-buffer)
(kill-all-local-variables)
(make-variable-buffer-local 'request-list)
(make-variable-buffer-local 'family)
(let ((all (overlay-lists)))
;; Delete all the overlays.
(mapcar 'delete-overlay (car all))
(mapcar 'delete-overlay (cdr all))
(setq request-list nil
family nil)
(widget-insert "This buffer is for customizing fontset.\n\n")
(setq family (widget-create '(group (choice
:tag "select"
:value recommended
(item required)
(item recommended)
(item ignore))
(list
:format "%v"
(const
:format ""
family)
(repeat
:tag "family"
(string
:tag "family name"
:help-echo "family name of the font"
:value "FixedSys"))))))
(widget-insert "\n")
(setq request-list (cons
(widget-create '(group (choice
:tag "select"
:value required
(item required)
(item recommended)
(item ignore))
(cons
:format "%v"
(const
:format ""
width)
(number
:tag "width"
:help-echo "width of the font(pixel)"
8))))
request-list))
(widget-insert "\n")
(setq request-list (cons
(widget-create '(group (choice
:tag "select"
:value required
(item required)
(item recommended)
(item ignore))
(cons
:format "%v"
(const
:format ""
height)
(number
:tag "height"
:help-echo "height of the font(pixel)"
16))))
request-list))
(widget-insert "\n")
(setq request-list (cons
(widget-create '(group (choice
:tag "select"
:value required
(item required)
(item recommended)
(item ignore))
(cons
:format "%v"
(const
:format ""
weight)
(number
:tag "weight"
:help-echo "weight of the font(pixel)"
400))))
request-list))
(widget-insert "\n")
(setq request-list (cons
(widget-create '(group (choice
:tag "select"
:value required
(item required)
(item recommended)
(item ignore))
(cons
:format "%v"
(const
:format ""
fixed)
(boolean
:tag "fixed"
:help-echo "nil means that the font is \
not fixed pitch."
:on "t"
:off "nil"
t))))
request-list))
(widget-insert "\n")
(setq request-list (cons
(widget-create '(group (choice
:tag "select"
:value required
(item required)
(item recommended)
(item ignore))
(cons
:format "%v"
(const
:format ""
italic)
(boolean
:tag "italic"
:help-echo "nil means that the font is \
not italic."
:on "t"
:off "nil"
nil))))
request-list))
(widget-insert "\n")
(widget-create 'push-button
:tag "Create fontset customization buffer"
:action (lambda (widget &optional event)
(create-fontset-buffer)))
(goto-char (point-min))
(use-local-map widget-keymap)
(widget-setup)))
(defun create-fontset-buffer ()
(let ((rql request-list)
(familyname (widget-value family))
required recommended val
widget fml)
(while (setq widget (car rql))
(setq value (widget-value widget))
(setq val (nth 1 value))
(cond ((eq (car value) 'required)
(setq required (cons val
required)))
((eq (car value) 'recommended)
(setq recommended (cons val
recommended))))
(setq rql (cdr rql)))
(if (and (not (eq (car familyname) 'ignore))
(setq value (nth 1 (nth 1 familyname))))
(progn
(while value
(setq fml (cons (cons 'family (car value))
fml))
(setq value (cdr value)))
(if (eq (car familyname) 'required)
(setq required (append fml
required))
(setq recommended (append fml
recommended)))))
(create-fontset-buffer-internal required recommended)))
(defun create-fontset-buffer-internal (required recommended)
(switch-to-buffer "*Fontset customize*")
(kill-all-local-variables)
(erase-buffer)
(kill-all-local-variables)
(make-variable-buffer-local 'fontset-name)
(make-variable-buffer-local 'request-list)
(let ((all (overlay-lists))
(charset-list charset-list)
count length
chlf group charset)
;; Delete all the overlays.
(mapcar 'delete-overlay (car all))
(mapcar 'delete-overlay (cdr all))
(setq request-list nil)
(setq fontset-name nil)
(widget-insert "This buffer is for customizing fontset.\n\n")
(message "Creating customization items...")
(setq fontset-name
(widget-create '(group
(string
:tag "fontset-name"
:value "private-fontset")
(choice
:tag "property"
:value 0
(item 0) (item 1) (item 2) (item 3)
(item 8) (item 9) (item 10) (item 11))
(choice (const :tag "Your Meadow init file" nil)
(file
:value "~/")))))
(widget-insert "\n\n")
(setq w32-font-list-cache (w32-enum-logfont))
(setq count 1)
(setq length (length charset-list))
(while (setq charset (car charset-list))
(setq chlf (w32-logfont-list-from-request charset required recommended nil))
(if chlf
(progn (setq group (cons 'list
(list
':tag (nth 1 chlf)
(list 'const
':format ""
(nth 0 chlf))
(list 'const
':format ""
(nth 1 chlf))
(list 'integer
':tag "width"
':size 4
':help-echo "width of the font"
':value (nth 2 chlf))
(list 'integer
':tag "height"
':size 4
':help-echo "height of the font"
':value (nth 3 chlf))
(list 'integer
':tag "weight"
':size 4
':help-echo "weight of the font"
':value (nth 4 chlf))
(list 'const
':format "orientation %v "
(nth 5 chlf))
(list 'boolean
':tag "italic"
':on "t"
':off "nil"
':help-echo "nil means font is not the italic"
':value (nth 6 chlf))
(list 'const
':format "underline %v "
':value (nth 7 chlf))
(list 'boolean
':tag "strike-out"
':on "t"
':off "nil"
':help-echo "nil means font is \
not the strike out"
':value (nth 8 chlf))
(list 'const
:format "charset: %v "
(nth 9 chlf))
(list 'integer
':tag "quality"
':size 4
':value (nth 10 chlf))
(list 'integer
':tag "outprecision"
':size 4
':value (nth 11 chlf))
(list 'integer
':tag "pitch and family"
':size 4
':value (nth 12 chlf)))))
(setq request-list (cons (widget-create 'group
:tag (symbol-name (car charset-list))
group)
request-list))
(widget-insert "\n\n"))
(progn (widget-insert (symbol-name (car charset-list)))
(widget-insert "\n\n")))
(message "Creating customization items %2d%%..."
(/ (* 100 count) length))
(setq charset-list (cdr charset-list))
(setq count (1+ count))))
(message "Creating customization items %2d%% ... done" 100)
(widget-create 'push-button
:tag "Create fontset"
:action (lambda (widget &optional event)
(create-change-fontset-from-customize-buffer)))
(widget-create 'push-button
:tag "Save fontset"
:action (lambda (widget &optional event)
(save-fontset-from-customize-buffer)))
(message "Setting up customization buffer")
(goto-char (point-min))
(use-local-map widget-keymap)
(widget-setup))
(defun create-change-fontset-from-customize-buffer (&optional save)
(let ((fname (car (widget-value fontset-name))))
(if (or (string-match " " fname)
(string= "" fname))
(error "Fontset name can't contain whitespaces"))
(w32-candidate-satisfy-request-customize-p)
(if (query-fontset fname)
(change-fontset-from-customize-buffer fname)
(create-fontset-from-customize-buffer fname))))
(defun w32-candidate-satisfy-request-customize-p ()
(let ((rql request-list)
widget logfont info lflist)
(while (setq widget (car rql))
(setq logfont (car (widget-value widget)))
(setq info (w32-get-logfont-info logfont))
(if (not (setq lflist (w32-enum-logfont (nth 1 logfont))))
(error "Such family does not exist")
(if (and (or (eq (nth 2 (car lflist)) 'scalable)
(= (cdr (assq 'width info)) (nth 2 logfont)))
(or (eq (nth 2 (car lflist)) 'scalable)
(= (cdr (assq 'height info)) (nth 3 logfont)))
(if (nth 6 logfont)
(w32-logfont-italic-p logfont)
(not (w32-logfont-italic-p logfont))))
nil
(error "Specified font %s is not valid (width or height or italic)"
(nth 1 logfont))))
(setq rql (cdr rql)))))
(defun create-fontset-from-customize-buffer (fname)
(let ((property (nth 1 (widget-value fontset-name)))
(rql request-list)
logfont logfont-list fontname charset widget)
(while (setq widget (car rql))
(setq logfont (car (widget-value widget))
charset (widget-get widget ':tag)
fontname (concat fname "-" charset)
logfont-list (cons (cons
(intern charset) fontname)
logfont-list))
(set-font-from-logfont fontname logfont (intern charset) property)
(setq rql (cdr rql)))
(message "create fontset ... done")
(new-fontset fname logfont-list)))
(defun change-fontset-from-customize-buffer (fname)
(let ((property (nth 1 (widget-value fontset-name)))
(rql request-list)
(fontset-font-data (aref (fontset-info fname) 2))
logfont fontname widget)
(while (setq widget (car rql))
(setq logfont (car (widget-value widget))
charset (intern (widget-get widget ':tag))
fontname (nth 1 (assq charset fontset-font-data)))
(w32-change-font-logfont fontname property logfont)
(setq rql (cdr rql)))
(message "change property of the fontset ... done")))
(defun save-fontset-from-customize-buffer ()
(let ((inhibit-read-only t)
(property (nth 1 (widget-value fontset-name)))
(rql request-list)
(init-file (expand-file-name user-init-file))
(fontsetname (car (widget-value fontset-name)))
(file (nth 2 (widget-value fontset-name)))
filename standard-output exist widget logfont-list
charset buff1 buff2)
(w32-candidate-satisfy-request-customize-p)
(setq filename
(if file
(if (file-directory-p (expand-file-name file))
(concat (expand-file-name file) ".fontset")
(expand-file-name file))
init-file))
(unwind-protect
(save-excursion
(setq buff1 (find-file-noselect filename))
(set-buffer buff1)
(setq standard-output (current-buffer))
(goto-char (point-min))
(setq exist (save-fontset-check fontsetname property))
(cond ((eq exist 'exist)
(error "Specified fontset and property already exist"))
((eq exist t)
(goto-char (point-max))
(if (not (bolp))
(princ "\n"))
(princ ";;; Create fontset using widget package\n")
(princ ";;; ")
(prin1 (concat fontsetname " " property))
(princ "\n(mapcar (lambda (list)\n")
(princ " (w32-change-font-logfont (car list) ")
(prin1 property)
(princ " (nth 1 list)))\n")
(princ "'(")
(while (setq widget (car rql))
(prin1 (list (concat fontsetname "-"
(widget-get widget ':tag))
(car (widget-value widget))))
(princ "\n")
(setq rql (cdr rql)))
(princ "))\n")
(princ ";;;Create fontset ends here\n")
(if (not (looking-at "\n"))
(princ "\n"))
(save-buffer)
(message "Wrote %s" filename))
((eq exist nil)
(goto-char (point-max))
(if (not (bolp))
(princ "\n"))
(princ ";;; Create fontset using widget package\n")
(princ ";;; ")
(prin1 (concat fontsetname " " property))
(princ "\n(mapcar (lambda (list)\n")
(princ " (set-font-from-logfont (car list) (nth 1 list) (nth 2 list) ")
(prin1 property)
(princ "))\n'(")
(while (setq widget (car rql))
(setq charset (widget-get widget ':tag)
fontname (concat fontsetname "-" charset)
logfont-list (cons (cons (intern charset)
fontname)
logfont-list))
(prin1 (list fontname (car (widget-value widget))
(intern charset)))
(princ "\n")
(setq rql (cdr rql)))
(princ "))\n")
(princ " (new-fontset ")
(prin1 fontsetname)
(princ " '")
(prin1 logfont-list)
(princ ")\n")
(princ ";;;Create fontset ends here\n")
(if (not (looking-at "\n"))
(princ "\n"))
(save-buffer)
(message "Wrote %s" filename)))
(if (not (string= init-file filename))
(save-excursion
(setq buff2 (find-file-noselect init-file))
(set-buffer buff2)
(setq standard-output (current-buffer))
(goto-char (point-max))
(princ "(load ")
(prin1 filename)
(princ ")")
(save-buffer)))))
(kill-buffer buff1)
(if buff2
(kill-buffer buff2))))
(defun save-fontset-check (fontsetname property)
(catch 'check
(let ((fset))
(while t
(if (search-forward (concat ";;; " "\"" fontsetname)
(point-max) t)
(if (string-match (concat (number-to-string property) "\"" "\n")
(buffer-substring-no-properties (1+ (point)) (+ (point) 4)))
(throw 'check 'exist)
(setq fset t))
(throw 'check fset))))))