home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 1 / 1159 < prev    next >
Encoding:
Internet Message Format  |  1990-12-28  |  14.5 KB
  1. From: tml@hemuli.tik.vtt.fi (Tor Lillqvist)
  2. Newsgroups: alt.sources
  3. Subject: [tex] Producing Latin-1 Extended Computer Modern VPL files
  4. Message-ID: <11633@stag.math.lsa.umich.edu>
  5. Date: 5 Apr 90 20:26:19 GMT
  6.  
  7. Archive-name: accentify/05-Apr-90
  8. Original-posting-by: tml@hemuli.tik.vtt.fi (Tor Lillqvist)
  9. Original-subject: Producing Latin-1 Extended Computer Modern VPL files
  10. Reposted-by: emv@math.lsa.umich.edu (Edward Vielmetti)
  11.  
  12. [This is an experimental alt.sources re-posting from the newsgroup(s)
  13. comp.text.tex. Comments on this service to emv@math.lsa.umich.edu 
  14. (Edward Vielmetti).]
  15.  
  16.  
  17.  
  18. With TeX 3.0 you have the possibility to use so called virtual fonts.
  19. I wrote this GNU Emacs Lisp code to automatically make VPL (Virtual
  20. font Property List) files with the ISO Latin-1 accented letters from
  21. Computer Modern PL files.
  22.  
  23. Why GNU Emacs Lisp?  Well, PL and VPL files look a bit like Lisp, so I
  24. thought that it would be easy to hack together the necessary code in
  25. Lisp.  I considered doing it in Scheme at first, but ran into trouble
  26. because Scheme does case conversion.  On the other hand, Elisp doesn't
  27. have floating-point numbers, so I had to represent them using
  28. (integer-part . fraction-part) Lisp dotted pairs.  I don't have any
  29. other Lisps available.
  30.  
  31. I hope this is useful to those wanting to try the new TeX 3.0
  32. features.  
  33.  
  34. Is there any group working on a standard way to extend Computer Modern
  35. fonts?  ISO Latin-1 covers only a part of the necessary letters.  (See
  36. the article by Yannis Haralambous in TUGboat 10:3, pp 342--344.)  Has
  37. anybody written MF code for the Icelandic thorn and eth letters?
  38.  
  39. You typically would do something like:
  40.  
  41. mkdir /tmp/latin1
  42. cd /tmp/latin1
  43. F=/usr/local/lib/tex/fonts
  44. for file in $F/cm*.tfm; do
  45.     tftopl $file `basename $file'.pl
  46. done
  47.  
  48. start Emacs, and do M-x extend-directory-of-cm-fonts /tmp/latin1
  49.  
  50. for file in *.vpl; do
  51.     bn=`basename $file .vpl`
  52.     vptovf $file $F/$bn.vf $F/$bn.tfm
  53. done
  54.  
  55. Now if only more DVI drivers would support VF files...  Thanks to Tom
  56. Rokicki and Don Knuth for virtual font support in dvips 5.01.
  57.  
  58. Enough said, here is the code: Use as you please.  If you do anything
  59. useful with it, or make enhancements, please tell me.
  60.  
  61. ;; accentify.el -- extend a Computer Modern font with accented letters
  62. ;; Tor Lillqvist <tml@tik.vtt.fi>
  63.  
  64. (defvar interesting-pl-properties
  65.   '(CHARACTER CHECKSUM DESIGNSIZE FONTDIMEN KRN LABEL LIGTABLE SKIP))
  66.  
  67. (defvar accented-versions
  68.   '((?A ?\300 ?\301 ?\302 ?\303 ?\304 ?\305)
  69.     (?C ?\307)
  70.     (?E ?\310 ?\311 ?\312 ?\313)
  71.     (?I ?\314 ?\315 ?\316 ?\317)
  72. ;;    (?D ?\320)
  73.     (?N ?\321)
  74.     (?O ?\322 ?\323 ?\324 ?\325 ?\326)
  75.     (?U ?\331 ?\332 ?\333 ?\334)
  76.     (?Y ?\335)
  77.     (?a ?\340 ?\341 ?\342 ?\343 ?\344 ?\345)
  78.     (?c ?\347)
  79.     (?e ?\350 ?\351 ?\352 ?\353)
  80.     (?i ?\354 ?\355 ?\356 ?\357)
  81.     (?n ?\361)
  82.     (?o ?\362 ?\363 ?\364 ?\365 ?\366)
  83.     (?u ?\371 ?\372 ?\373 ?\374)
  84.     (?y ?\375 ?\377))
  85.   "A list containing ASCII characters and the corresponding accented
  86. ISO Latin-1 characters' codes.")
  87.  
  88. (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\\)$")
  89.  
  90. (defun extend-directory-of-cm-fonts (directory)
  91.   "For all Computer Modern PL files in a direcory create the
  92. corresponding Extended Computer Modern VP file."
  93.   (interactive "DExtend fonts in directory: ")
  94.   (mapcar 'extend-pl-file (directory-files directory nil cm-text-fonts)))
  95.  
  96. (defun extend-pl-file (filename)
  97.   "Create a Extended Computer Modern VP (Virtual font Property list) file
  98. from the PL (font Property List) file FILENAME."
  99.   (interactive)
  100.   (set-buffer (get-buffer-create "*extend-pl-file-temp*"))
  101.   (insert-file-contents filename t)
  102.   (message "Working on %s" (file-name-nondirectory filename))
  103.   (set-buffer (extend-cm-font-in-buffer))
  104.   (write-file (buffer-file-name (current-buffer))))
  105.  
  106. (defun extend-cm-font-in-buffer ()
  107.   "Convert a Computer Modern PL file to the corresponding Latin-1
  108. Extended Computer Modern VP file."
  109.   (interactive)
  110.   (let (font-name font-basename font-size tempbuffer vp-file)
  111.     (setq font-name (file-name-nondirectory (buffer-file-name (current-buffer))))
  112.     (if (not (string-match cm-text-fonts font-name))
  113.     (error "Cannot handle this font.")
  114.       (setq font-name (substring font-name 0 (match-beginning 3)))
  115.       (setq font-basename (substring font-name 0 (match-beginning 2)))
  116.       (setq font-size (substring font-name (match-beginning 2) (match-beginning 3))))
  117.     (setq tempbuffer (get-buffer-create "*temp*"))
  118.     (copy-to-buffer tempbuffer (point-min) (point-max))
  119.     (set-buffer tempbuffer)
  120.     (goto-char (point-min))
  121.     ;; First convert C values to decimal
  122.     (clean-char-values)
  123.     (goto-char (point-min))
  124.     ;; Convert R values to dotted pairs
  125.     (dotted-floatify-buffer)
  126.     (goto-char (point-min))
  127.     ;; (read) will read from the temp buffer
  128.     (setq standard-input (current-buffer))
  129.     ;; We produce a VP file, with l1 prefixed to the original font name
  130.     (set-buffer (get-buffer-create "*new-vp-file*"))
  131.     (set-visited-file-name (concat "l1" font-name ".vpl"))
  132.     (erase-buffer)
  133.     (setq standard-output (current-buffer))
  134.     (setq char-metrics (make-vector 256 nil))
  135.     (princ (format "(MAPFONT D 0 (FONTNAME %s))\n" font-name))
  136.     ;; Parse the PL file, inserting ligtable labels and kerns
  137.     ;; for the accented letters on the fly
  138.     (condition-case nil
  139.     (while t
  140.       (convert-expr (read)))
  141.       (end-of-file nil))
  142.     ;; Output the character descriptions for the accented characters
  143.     (output-additions)
  144. ;;  (kill-buffer temp-buffer)
  145.     (current-buffer)
  146.     ))
  147.  
  148. (defun dotted-floatify-buffer ()
  149.   "Replaces floating-point values in the current buffer
  150. with lists of the form (!fix! integer-part fraction-part).
  151. The fraction part is multiplied by 1000000."
  152.   (interactive)
  153.   (while (re-search-forward "\\(-?\\)\\([0-9]+\\)\\.\\([0-9]+\\)" nil t)
  154.     (replace-match
  155.      (make-float-string
  156.       (string-to-int (buffer-substring (match-beginning 2)
  157.                        (match-end 2)))
  158.       (buffer-substring (match-beginning 3)
  159.             (match-end 3))
  160.       (< (match-beginning 1) (match-end 1))))))
  161.  
  162. (defun clean-char-values ()
  163.   "Replace C (character) values of non-alphanumeric characters with
  164. the corresponding D (decimal) value."
  165.   (while (re-search-forward " [Cc] \\([^A-Za-z]\\) " nil t)
  166.     (replace-match
  167.      (format " d %d " (aref (buffer-substring
  168.                  (match-beginning 1)
  169.                  (1+ (match-end 1))) 0)))))
  170.  
  171. (defun myprint (e)
  172.   (cond ((atom e) (prin1 e))
  173.     ((and (integerp (car e)) (integerp (cdr e)))
  174.      (myprint-dottedfloat (car e) (cdr e)))
  175.     ((eq (car e) 'COMMENT) nil)
  176.     (t (terpri)
  177.        (insert "(")
  178.        (myprint (car e))
  179.        (myprint-rest (cdr e)))))
  180.  
  181. (defun abs (e)
  182.   (if (< e 0) (- 0 e) e))
  183.  
  184. (defun myprint-dottedfloat (int fract)
  185.   (if (or (< int 0) (< fract 0))
  186.       (princ "-"))
  187.   (prin1 (abs int))
  188.   (princ ".")
  189.   (princ (format "%06d" (abs fract))))
  190.   
  191. (defun myprint-rest (e)
  192.   (cond ((null e) (insert ")"))
  193.     (t (insert " ")
  194.        (myprint (car e))
  195.        (myprint-rest (cdr e)))))
  196.  
  197. (defun depth (e)
  198.   (cond ((atom e) 0)
  199.     (t (max (1+ (depth (car e))) (depth (cdr e))))))
  200.  
  201. (defun convert-expr (e)
  202.   (cond ((listp e)
  203.      (let ((handler(get (car e) 'prop-handler)))
  204.        (if handler (apply handler e nil)
  205.          (myprint e))))
  206.     (t (error "Invalid property list"))))
  207.  
  208. (defun put-handler (prop)
  209.   (put prop 'prop-handler
  210.        (intern (concat (downcase (symbol-name prop)) "-handler"))))
  211.  
  212. (mapcar 'put-handler interesting-pl-properties)
  213.  
  214. (defun comment-handler (prop)
  215.   nil)
  216.  
  217. (defun checksum-handler (prop)
  218.   nil)
  219.  
  220. (defun designsize-handler (prop)
  221.   (setq designsize (car (cdr (cdr prop))))
  222.   (myprint prop))
  223.  
  224. (defun fontdimen-handler (prop)
  225.   (myprint prop)
  226.   (setq fontdimens (cdr prop))
  227.   (setq font-xheight
  228.     (car (cdr (cdr (assq 'XHEIGHT fontdimens)))))
  229.   (setq font-slant
  230.     (car (cdr (cdr (assq 'SLANT fontdimens))))))
  231.  
  232. (defun ligtable-handler (prop)
  233.   (princ "\n(LIGTABLE\n")
  234.   (mapcar 'ligstep-handler (cdr prop))
  235.   (princ ")\n"))
  236.  
  237. (defun ligstep-handler (step)
  238.   (myprint step)
  239.   (let ((handler (get (car step) 'prop-handler)))
  240.     (if handler
  241.     (apply handler step nil))))
  242.  
  243. (defun label-handler (step)
  244.   (label-accented (assq (int-value (cdr step)) accented-versions)))
  245.  
  246. (defun label-accented (list)
  247.     (while (and list (setq list (cdr list)))
  248.       (princ " ")
  249.       (prin1 (list 'LABEL 'D (car list)))))
  250.  
  251. (defun krn-handler (step)
  252.   (krn-accented (car (cdr (cdr (cdr (cdr step)))))
  253.         (assq (int-value (cdr step)) accented-versions)))
  254.  
  255. (defun krn-accented (kern list)
  256.   (while (and list (setq list (cdr list)))
  257.     (princ " ")
  258.     (princ "(KRN D ")
  259.     (prin1 (car list))
  260.     (princ " R ")
  261.     (myprint kern)
  262.     (princ ")")))
  263.  
  264. (defun skip-handler (step)
  265.   (error "Cannot handle SKIPs (yet)."))
  266.  
  267. (defun character-handler (prop)
  268.   (myprint prop)
  269.   (aset char-metrics (int-value (cdr prop)) (cdr (cdr (cdr prop)))))
  270.  
  271. (defun checksum-handler (prop)
  272.   nil)
  273.  
  274. ;; The combinations list contains for each accented letter a sublist
  275. ;; with its code, the code of the unaccented letter, and the 
  276. ;; code of the accent
  277.  
  278. (setq combinations
  279.   '((?\300 ?A ?\022)            ; Agrave
  280.     (?\301 ?A ?\023)            ; Aacute
  281.     (?\302 ?A ?\136)            ; Acircumflex
  282.     (?\303 ?A ?\176)            ; Atilde
  283.     (?\304 ?A ?\177)            ; Adiaeresis
  284.     (?\305 ?A ?\027)            ; Aring
  285.     (?\307 ?C ?\030)            ; Ccedilla
  286.     (?\310 ?E ?\022)            ; Egrave
  287.     (?\311 ?E ?\023)            ; Eacute
  288.     (?\312 ?E ?\136)            ; Ecircumflex
  289.     (?\313 ?E ?\177)            ; Ediaeresis
  290.     (?\314 ?I ?\022)            ; Igrave
  291.     (?\315 ?I ?\023)            ; Iacute
  292.     (?\316 ?I ?\136)            ; Icircumflex
  293.     (?\317 ?I ?\177)            ; Idiaeresis
  294.     (?\321 ?N ?\176)            ; Ntilde
  295.     (?\322 ?O ?\022)            ; Ograve
  296.     (?\323 ?O ?\023)            ; Oacute
  297.     (?\324 ?O ?\136)            ; Ocircumflex
  298.     (?\325 ?O ?\176)            ; Otilde
  299.     (?\326 ?O ?\177)            ; Odiaeresis
  300.     (?\331 ?U ?\022)            ; Ugrave
  301.     (?\332 ?U ?\023)            ; Uacute
  302.     (?\333 ?U ?\136)            ; Ucircumflex
  303.     (?\334 ?U ?\177)            ; Udiaeresis
  304.     (?\335 ?Y ?\023)            ; Yacute
  305.     (?\340 ?a ?\022)            ; agrave
  306.     (?\341 ?a ?\023)            ; aacute
  307.     (?\342 ?a ?\136)            ; acircumflex
  308.     (?\343 ?a ?\176)            ; atilde
  309.     (?\344 ?a ?\177)            ; adiaeresis
  310.     (?\345 ?a ?\027)            ; aring
  311.     (?\347 ?c ?\030)            ; ccedilla
  312.     (?\350 ?e ?\022)            ; egrave
  313.     (?\351 ?e ?\023)            ; eacute
  314.     (?\352 ?e ?\136)            ; ecircumflex
  315.     (?\353 ?e ?\177)            ; ediaeresis
  316.     (?\354 ?\020 ?\022)            ; igrave
  317.     (?\355 ?\020 ?\023)            ; iacute
  318.     (?\356 ?\020 ?\136)            ; icircumflex
  319.     (?\357 ?\020 ?\177)            ; idiaeresis
  320.     (?\361 ?n ?\176)            ; ntilde
  321.     (?\362 ?o ?\022)            ; ograve
  322.     (?\363 ?o ?\023)            ; oacute
  323.     (?\364 ?o ?\136)            ; ocircumflex
  324.     (?\365 ?o ?\176)            ; otilde
  325.     (?\366 ?o ?\177)            ; odiaeresis
  326.     (?\371 ?u ?\022)            ; ugrave
  327.     (?\372 ?u ?\023)            ; uacute
  328.     (?\373 ?u ?\136)            ; ucircumflex
  329.     (?\374 ?u ?\177)            ; udiaeresis
  330.     (?\375 ?y ?\023)            ; yacute
  331.     (?\377 ?y ?\177)            ; ydiaeresis
  332.     ))
  333.  
  334. (defun output-additions ()
  335.   (mapcar 'output-combination combinations))
  336.  
  337. (defun output-combination (recipe)
  338.   (let* ((basechar (car (cdr recipe)))
  339.      (accent (car (cdr (cdr recipe))))
  340.      (basechar-metrics (aref char-metrics basechar))
  341.      (accent-metrics (aref char-metrics accent))
  342.      (aw (car (cdr (cdr (assq 'CHARWD accent-metrics)))))
  343.      (cw (car (cdr (cdr (assq 'CHARWD basechar-metrics)))))
  344.      (ch (or (car (cdr (cdr (assq 'CHARHT basechar-metrics)))) '(0 . 0)))
  345.      (ah (or (car (cdr (cdr (assq 'CHARHT accent-metrics)))) '(0 . 0)))
  346.      (cd (or (car (cdr (cdr (assq 'CHARDP basechar-metrics)))) '(0 . 0)))
  347.      (ad (or (car (cdr (cdr (assq 'CHARDP accent-metrics)))) '(0 . 0)))
  348.      (ci (or (car (cdr (cdr (assq 'CHARIC basechar-metrics)))) '(0 . 0)))
  349.      (downkern (float- font-xheight ch)))
  350.     (myprint
  351.      (append
  352.       (list 'CHARACTER 'D (car recipe))
  353.       (list (list 'CHARWD 'R cw))
  354.       (list (list 'CHARHT 'R (floatmax (float- ah downkern) ch)))
  355.       (if (not (equal (floatmax cd ad) '(0 . 0)))
  356.       (list (list 'CHARDP 'R (floatmax cd ad))))
  357.       (if (not (equal ci '(0 . 0))) (list (list 'CHARIC 'R ci)))
  358.       (list
  359.        (append (list 'MAP '(PUSH))
  360.            (if (not (equal font-xheight ch))
  361.            (if (equal ah '(0 . 0)) ; Cedilla?
  362.                nil
  363.              (list (list 'MOVEDOWN 'R
  364.                  downkern))))
  365.            ;; Ignore slants for now
  366.            (let ((rightkern (float/ (float- cw aw) 2)))
  367.          (if (not (equal rightkern '(0 . 0)))
  368.              (list (list 'MOVERIGHT 'R rightkern))))
  369.            (list (list 'SETCHAR 'D accent))
  370.            (list '(POP))
  371.            (list (list 'SETCHAR 'D basechar))))))
  372.     (terpri)))
  373.  
  374. ;; Auxiliary functions
  375.  
  376. (defun make-float-string (int fract neg)
  377.   "Returns a string containing the special dotted-pair representation of
  378. a floating-point number.  INT is the integer part (a number)
  379. and FRACT is the fractional part (as a string!)."
  380.   (let ((x (make-float int fract (if neg -1 1))))
  381.     (format "(%d . %d)" (car x) (cdr x))))
  382.  
  383. (defun make-float (int fract neg)
  384.   "Converts a floating point number to a dotted-pair fixed-point 
  385. representation.  INT is the integer part, FRACT is the fractional part
  386. as a string, and NEG is 1 or -1.
  387. The result is a dotted pair the car of which is the integer
  388. part and the cdr is the fractional part multiplied by 1000000."
  389.   (interactive)
  390.   (cons int
  391.     (* neg (let ((l (length fract)) (f (string-to-int fract)))
  392.          (cond ((= l 7) (/ (+ f 5) 10))
  393.                ((= l 6) f)
  394.                ((= l 5) (* f 10))
  395.                ((= l 4) (* f 100))
  396.                ((= l 3) (* f 1000))
  397.                ((= l 2) (* f 10000))
  398.                ((= l 1) (* f 100000))
  399.                (t (error "Too long fractional part: %s" fract)))))))
  400.  
  401. (defun float+ (a b)
  402.   "Add two dottedfloats."
  403.   (let (i f)
  404.     (setq i (+ (car a) (car b)))
  405.     (setq f (+ (cdr a) (cdr b)))
  406.     (cond ((>= f 1000000)
  407.        (setq i (1+ i))
  408.        (setq f (- f 1000000)))
  409.       ((<= f -1000000)
  410.        (setq i (1- i))
  411.        (setq f (+ f 1000000))))
  412.     (cond ((and (< i 0) (> f 0))
  413.        (setq i (1+ i))
  414.        (setq f (- f 1000000)))
  415.       ((and (> i 0) (< f 0))
  416.        (setq i (1- i))
  417.        (setq f (+ 1000000 f))))
  418.     (cons i f)))
  419.  
  420. (defun float- (a &rest b)
  421.   "Negate a dottedfloat or subtract two dottedfloats."
  422.   (if b
  423.       (float+ a (float- (car b)))
  424.     (cons (- (car a)) (- (cdr a)))))
  425.  
  426. (defun float/ (a i)
  427.   "Divide a dottedfloat by an integer."
  428.   (cons (/ (car a) i) (/ (cdr a) i)))
  429.  
  430. (defun floatmax (a b)
  431.   (if (or (> (car a) (car b)) (and (= (car a) (car b)) (> (cdr a) (cdr b))))
  432.       a
  433.     b))
  434.  
  435. (defun octal-to-int (value)
  436.   (if (zerop value)
  437.       0
  438.     (+ (* 8 (octal-to-int (/ value 10))) (% value 10))))
  439.  
  440. (defun int-value (list)
  441.   (let ((type (car list)) (value (car (cdr list))))
  442.     (cond ((eq type 'C)
  443.        (cond
  444.         ((symbolp value) (aref (symbol-name value) 0))
  445.         ((integerp value) (+ value ?0))
  446.         (t (error "Invalid C type value."))))
  447.       ((eq type 'D) value)
  448.       ((eq type 'O) (octal-to-int value))
  449.       (t (error "Unknown value type.")))))
  450.