[tex] Producing Latin-1 Extended Computer Modern VPL files
Tor Lillqvist
tml at hemuli.tik.vtt.fi
Fri Apr 6 06:26:19 AEST 1990
Archive-name: accentify/05-Apr-90
Original-posting-by: tml at hemuli.tik.vtt.fi (Tor Lillqvist)
Original-subject: Producing Latin-1 Extended Computer Modern VPL files
Reposted-by: emv at math.lsa.umich.edu (Edward Vielmetti)
[This is an experimental alt.sources re-posting from the newsgroup(s)
comp.text.tex. Comments on this service to emv at math.lsa.umich.edu
(Edward Vielmetti).]
With TeX 3.0 you have the possibility to use so called virtual fonts.
I wrote this GNU Emacs Lisp code to automatically make VPL (Virtual
font Property List) files with the ISO Latin-1 accented letters from
Computer Modern PL files.
Why GNU Emacs Lisp? Well, PL and VPL files look a bit like Lisp, so I
thought that it would be easy to hack together the necessary code in
Lisp. I considered doing it in Scheme at first, but ran into trouble
because Scheme does case conversion. On the other hand, Elisp doesn't
have floating-point numbers, so I had to represent them using
(integer-part . fraction-part) Lisp dotted pairs. I don't have any
other Lisps available.
I hope this is useful to those wanting to try the new TeX 3.0
features.
Is there any group working on a standard way to extend Computer Modern
fonts? ISO Latin-1 covers only a part of the necessary letters. (See
the article by Yannis Haralambous in TUGboat 10:3, pp 342--344.) Has
anybody written MF code for the Icelandic thorn and eth letters?
You typically would do something like:
mkdir /tmp/latin1
cd /tmp/latin1
F=/usr/local/lib/tex/fonts
for file in $F/cm*.tfm; do
tftopl $file `basename $file'.pl
done
start Emacs, and do M-x extend-directory-of-cm-fonts /tmp/latin1
for file in *.vpl; do
bn=`basename $file .vpl`
vptovf $file $F/$bn.vf $F/$bn.tfm
done
Now if only more DVI drivers would support VF files... Thanks to Tom
Rokicki and Don Knuth for virtual font support in dvips 5.01.
Enough said, here is the code: Use as you please. If you do anything
useful with it, or make enhancements, please tell me.
;; accentify.el -- extend a Computer Modern font with accented letters
;; Tor Lillqvist <tml at tik.vtt.fi>
(defvar interesting-pl-properties
'(CHARACTER CHECKSUM DESIGNSIZE FONTDIMEN KRN LABEL LIGTABLE SKIP))
(defvar accented-versions
'((?A ?\300 ?\301 ?\302 ?\303 ?\304 ?\305)
(?C ?\307)
(?E ?\310 ?\311 ?\312 ?\313)
(?I ?\314 ?\315 ?\316 ?\317)
;; (?D ?\320)
(?N ?\321)
(?O ?\322 ?\323 ?\324 ?\325 ?\326)
(?U ?\331 ?\332 ?\333 ?\334)
(?Y ?\335)
(?a ?\340 ?\341 ?\342 ?\343 ?\344 ?\345)
(?c ?\347)
(?e ?\350 ?\351 ?\352 ?\353)
(?i ?\354 ?\355 ?\356 ?\357)
(?n ?\361)
(?o ?\362 ?\363 ?\364 ?\365 ?\366)
(?u ?\371 ?\372 ?\373 ?\374)
(?y ?\375 ?\377))
"A list containing ASCII characters and the corresponding accented
ISO Latin-1 characters' codes.")
(defvar cm-text-fonts "^cm\\(r\\|bx\\|tt\\|sltt\\|vtt\\|tex\\|ss\\|ssi\\|ssdc\\|ssbx\\|ssqi\\|dunh\\|bxsl\\|b\\|ti\\|bxti\\|csc\\|tcsc\\)\\([0-9]+\\)\\(\\.pl\\)$")
(defun extend-directory-of-cm-fonts (directory)
"For all Computer Modern PL files in a direcory create the
corresponding Extended Computer Modern VP file."
(interactive "DExtend fonts in directory: ")
(mapcar 'extend-pl-file (directory-files directory nil cm-text-fonts)))
(defun extend-pl-file (filename)
"Create a Extended Computer Modern VP (Virtual font Property list) file
from the PL (font Property List) file FILENAME."
(interactive)
(set-buffer (get-buffer-create "*extend-pl-file-temp*"))
(insert-file-contents filename t)
(message "Working on %s" (file-name-nondirectory filename))
(set-buffer (extend-cm-font-in-buffer))
(write-file (buffer-file-name (current-buffer))))
(defun extend-cm-font-in-buffer ()
"Convert a Computer Modern PL file to the corresponding Latin-1
Extended Computer Modern VP file."
(interactive)
(let (font-name font-basename font-size tempbuffer vp-file)
(setq font-name (file-name-nondirectory (buffer-file-name (current-buffer))))
(if (not (string-match cm-text-fonts font-name))
(error "Cannot handle this font.")
(setq font-name (substring font-name 0 (match-beginning 3)))
(setq font-basename (substring font-name 0 (match-beginning 2)))
(setq font-size (substring font-name (match-beginning 2) (match-beginning 3))))
(setq tempbuffer (get-buffer-create "*temp*"))
(copy-to-buffer tempbuffer (point-min) (point-max))
(set-buffer tempbuffer)
(goto-char (point-min))
;; First convert C values to decimal
(clean-char-values)
(goto-char (point-min))
;; Convert R values to dotted pairs
(dotted-floatify-buffer)
(goto-char (point-min))
;; (read) will read from the temp buffer
(setq standard-input (current-buffer))
;; We produce a VP file, with l1 prefixed to the original font name
(set-buffer (get-buffer-create "*new-vp-file*"))
(set-visited-file-name (concat "l1" font-name ".vpl"))
(erase-buffer)
(setq standard-output (current-buffer))
(setq char-metrics (make-vector 256 nil))
(princ (format "(MAPFONT D 0 (FONTNAME %s))\n" font-name))
;; Parse the PL file, inserting ligtable labels and kerns
;; for the accented letters on the fly
(condition-case nil
(while t
(convert-expr (read)))
(end-of-file nil))
;; Output the character descriptions for the accented characters
(output-additions)
;; (kill-buffer temp-buffer)
(current-buffer)
))
(defun dotted-floatify-buffer ()
"Replaces floating-point values in the current buffer
with lists of the form (!fix! integer-part fraction-part).
The fraction part is multiplied by 1000000."
(interactive)
(while (re-search-forward "\\(-?\\)\\([0-9]+\\)\\.\\([0-9]+\\)" nil t)
(replace-match
(make-float-string
(string-to-int (buffer-substring (match-beginning 2)
(match-end 2)))
(buffer-substring (match-beginning 3)
(match-end 3))
(< (match-beginning 1) (match-end 1))))))
(defun clean-char-values ()
"Replace C (character) values of non-alphanumeric characters with
the corresponding D (decimal) value."
(while (re-search-forward " [Cc] \\([^A-Za-z]\\) " nil t)
(replace-match
(format " d %d " (aref (buffer-substring
(match-beginning 1)
(1+ (match-end 1))) 0)))))
(defun myprint (e)
(cond ((atom e) (prin1 e))
((and (integerp (car e)) (integerp (cdr e)))
(myprint-dottedfloat (car e) (cdr e)))
((eq (car e) 'COMMENT) nil)
(t (terpri)
(insert "(")
(myprint (car e))
(myprint-rest (cdr e)))))
(defun abs (e)
(if (< e 0) (- 0 e) e))
(defun myprint-dottedfloat (int fract)
(if (or (< int 0) (< fract 0))
(princ "-"))
(prin1 (abs int))
(princ ".")
(princ (format "%06d" (abs fract))))
(defun myprint-rest (e)
(cond ((null e) (insert ")"))
(t (insert " ")
(myprint (car e))
(myprint-rest (cdr e)))))
(defun depth (e)
(cond ((atom e) 0)
(t (max (1+ (depth (car e))) (depth (cdr e))))))
(defun convert-expr (e)
(cond ((listp e)
(let ((handler(get (car e) 'prop-handler)))
(if handler (apply handler e nil)
(myprint e))))
(t (error "Invalid property list"))))
(defun put-handler (prop)
(put prop 'prop-handler
(intern (concat (downcase (symbol-name prop)) "-handler"))))
(mapcar 'put-handler interesting-pl-properties)
(defun comment-handler (prop)
nil)
(defun checksum-handler (prop)
nil)
(defun designsize-handler (prop)
(setq designsize (car (cdr (cdr prop))))
(myprint prop))
(defun fontdimen-handler (prop)
(myprint prop)
(setq fontdimens (cdr prop))
(setq font-xheight
(car (cdr (cdr (assq 'XHEIGHT fontdimens)))))
(setq font-slant
(car (cdr (cdr (assq 'SLANT fontdimens))))))
(defun ligtable-handler (prop)
(princ "\n(LIGTABLE\n")
(mapcar 'ligstep-handler (cdr prop))
(princ ")\n"))
(defun ligstep-handler (step)
(myprint step)
(let ((handler (get (car step) 'prop-handler)))
(if handler
(apply handler step nil))))
(defun label-handler (step)
(label-accented (assq (int-value (cdr step)) accented-versions)))
(defun label-accented (list)
(while (and list (setq list (cdr list)))
(princ " ")
(prin1 (list 'LABEL 'D (car list)))))
(defun krn-handler (step)
(krn-accented (car (cdr (cdr (cdr (cdr step)))))
(assq (int-value (cdr step)) accented-versions)))
(defun krn-accented (kern list)
(while (and list (setq list (cdr list)))
(princ " ")
(princ "(KRN D ")
(prin1 (car list))
(princ " R ")
(myprint kern)
(princ ")")))
(defun skip-handler (step)
(error "Cannot handle SKIPs (yet)."))
(defun character-handler (prop)
(myprint prop)
(aset char-metrics (int-value (cdr prop)) (cdr (cdr (cdr prop)))))
(defun checksum-handler (prop)
nil)
;; The combinations list contains for each accented letter a sublist
;; with its code, the code of the unaccented letter, and the
;; code of the accent
(setq combinations
'((?\300 ?A ?\022) ; Agrave
(?\301 ?A ?\023) ; Aacute
(?\302 ?A ?\136) ; Acircumflex
(?\303 ?A ?\176) ; Atilde
(?\304 ?A ?\177) ; Adiaeresis
(?\305 ?A ?\027) ; Aring
(?\307 ?C ?\030) ; Ccedilla
(?\310 ?E ?\022) ; Egrave
(?\311 ?E ?\023) ; Eacute
(?\312 ?E ?\136) ; Ecircumflex
(?\313 ?E ?\177) ; Ediaeresis
(?\314 ?I ?\022) ; Igrave
(?\315 ?I ?\023) ; Iacute
(?\316 ?I ?\136) ; Icircumflex
(?\317 ?I ?\177) ; Idiaeresis
(?\321 ?N ?\176) ; Ntilde
(?\322 ?O ?\022) ; Ograve
(?\323 ?O ?\023) ; Oacute
(?\324 ?O ?\136) ; Ocircumflex
(?\325 ?O ?\176) ; Otilde
(?\326 ?O ?\177) ; Odiaeresis
(?\331 ?U ?\022) ; Ugrave
(?\332 ?U ?\023) ; Uacute
(?\333 ?U ?\136) ; Ucircumflex
(?\334 ?U ?\177) ; Udiaeresis
(?\335 ?Y ?\023) ; Yacute
(?\340 ?a ?\022) ; agrave
(?\341 ?a ?\023) ; aacute
(?\342 ?a ?\136) ; acircumflex
(?\343 ?a ?\176) ; atilde
(?\344 ?a ?\177) ; adiaeresis
(?\345 ?a ?\027) ; aring
(?\347 ?c ?\030) ; ccedilla
(?\350 ?e ?\022) ; egrave
(?\351 ?e ?\023) ; eacute
(?\352 ?e ?\136) ; ecircumflex
(?\353 ?e ?\177) ; ediaeresis
(?\354 ?\020 ?\022) ; igrave
(?\355 ?\020 ?\023) ; iacute
(?\356 ?\020 ?\136) ; icircumflex
(?\357 ?\020 ?\177) ; idiaeresis
(?\361 ?n ?\176) ; ntilde
(?\362 ?o ?\022) ; ograve
(?\363 ?o ?\023) ; oacute
(?\364 ?o ?\136) ; ocircumflex
(?\365 ?o ?\176) ; otilde
(?\366 ?o ?\177) ; odiaeresis
(?\371 ?u ?\022) ; ugrave
(?\372 ?u ?\023) ; uacute
(?\373 ?u ?\136) ; ucircumflex
(?\374 ?u ?\177) ; udiaeresis
(?\375 ?y ?\023) ; yacute
(?\377 ?y ?\177) ; ydiaeresis
))
(defun output-additions ()
(mapcar 'output-combination combinations))
(defun output-combination (recipe)
(let* ((basechar (car (cdr recipe)))
(accent (car (cdr (cdr recipe))))
(basechar-metrics (aref char-metrics basechar))
(accent-metrics (aref char-metrics accent))
(aw (car (cdr (cdr (assq 'CHARWD accent-metrics)))))
(cw (car (cdr (cdr (assq 'CHARWD basechar-metrics)))))
(ch (or (car (cdr (cdr (assq 'CHARHT basechar-metrics)))) '(0 . 0)))
(ah (or (car (cdr (cdr (assq 'CHARHT accent-metrics)))) '(0 . 0)))
(cd (or (car (cdr (cdr (assq 'CHARDP basechar-metrics)))) '(0 . 0)))
(ad (or (car (cdr (cdr (assq 'CHARDP accent-metrics)))) '(0 . 0)))
(ci (or (car (cdr (cdr (assq 'CHARIC basechar-metrics)))) '(0 . 0)))
(downkern (float- font-xheight ch)))
(myprint
(append
(list 'CHARACTER 'D (car recipe))
(list (list 'CHARWD 'R cw))
(list (list 'CHARHT 'R (floatmax (float- ah downkern) ch)))
(if (not (equal (floatmax cd ad) '(0 . 0)))
(list (list 'CHARDP 'R (floatmax cd ad))))
(if (not (equal ci '(0 . 0))) (list (list 'CHARIC 'R ci)))
(list
(append (list 'MAP '(PUSH))
(if (not (equal font-xheight ch))
(if (equal ah '(0 . 0)) ; Cedilla?
nil
(list (list 'MOVEDOWN 'R
downkern))))
;; Ignore slants for now
(let ((rightkern (float/ (float- cw aw) 2)))
(if (not (equal rightkern '(0 . 0)))
(list (list 'MOVERIGHT 'R rightkern))))
(list (list 'SETCHAR 'D accent))
(list '(POP))
(list (list 'SETCHAR 'D basechar))))))
(terpri)))
;; Auxiliary functions
(defun make-float-string (int fract neg)
"Returns a string containing the special dotted-pair representation of
a floating-point number. INT is the integer part (a number)
and FRACT is the fractional part (as a string!)."
(let ((x (make-float int fract (if neg -1 1))))
(format "(%d . %d)" (car x) (cdr x))))
(defun make-float (int fract neg)
"Converts a floating point number to a dotted-pair fixed-point
representation. INT is the integer part, FRACT is the fractional part
as a string, and NEG is 1 or -1.
The result is a dotted pair the car of which is the integer
part and the cdr is the fractional part multiplied by 1000000."
(interactive)
(cons int
(* neg (let ((l (length fract)) (f (string-to-int fract)))
(cond ((= l 7) (/ (+ f 5) 10))
((= l 6) f)
((= l 5) (* f 10))
((= l 4) (* f 100))
((= l 3) (* f 1000))
((= l 2) (* f 10000))
((= l 1) (* f 100000))
(t (error "Too long fractional part: %s" fract)))))))
(defun float+ (a b)
"Add two dottedfloats."
(let (i f)
(setq i (+ (car a) (car b)))
(setq f (+ (cdr a) (cdr b)))
(cond ((>= f 1000000)
(setq i (1+ i))
(setq f (- f 1000000)))
((<= f -1000000)
(setq i (1- i))
(setq f (+ f 1000000))))
(cond ((and (< i 0) (> f 0))
(setq i (1+ i))
(setq f (- f 1000000)))
((and (> i 0) (< f 0))
(setq i (1- i))
(setq f (+ 1000000 f))))
(cons i f)))
(defun float- (a &rest b)
"Negate a dottedfloat or subtract two dottedfloats."
(if b
(float+ a (float- (car b)))
(cons (- (car a)) (- (cdr a)))))
(defun float/ (a i)
"Divide a dottedfloat by an integer."
(cons (/ (car a) i) (/ (cdr a) i)))
(defun floatmax (a b)
(if (or (> (car a) (car b)) (and (= (car a) (car b)) (> (cdr a) (cdr b))))
a
b))
(defun octal-to-int (value)
(if (zerop value)
0
(+ (* 8 (octal-to-int (/ value 10))) (% value 10))))
(defun int-value (list)
(let ((type (car list)) (value (car (cdr list))))
(cond ((eq type 'C)
(cond
((symbolp value) (aref (symbol-name value) 0))
((integerp value) (+ value ?0))
(t (error "Invalid C type value."))))
((eq type 'D) value)
((eq type 'O) (octal-to-int value))
(t (error "Unknown value type.")))))
More information about the Alt.sources
mailing list