4 ;;;; tfm2afm.scm -- convert tfm to afm, with the aid of tfmtodit
6 ;;;; source file of the GNU LilyPond music typesetter
8 ;;;; (c) 2000 Jan Nieuwenhuizen <janneke@gnu.org>
10 (debug-enable 'backtrace)
21 (define program-name "tfm2afm")
23 (define cur-output-name "-")
24 (define cur-output-file '())
26 (define subst-version "@TOPLEVEL_VERSION@")
28 (define program-version
29 (if (eq? subst-version (string-append "@" "TOPLEVEL_VERSION" "@"))
33 (define (show-version port)
34 (display (string-append
35 program-name " - LilyPond version " program-version "\n")
39 (display "Convert TFM to AFM
41 Usage: tfm2afm [OPTION]... TFM-FILE
45 -o,--output=FILE set output file
46 -v,--version show version
48 Example: tfm2afm `kpsewhich cmr10.tfm`
51 (define (gulp-file name)
52 (let* ((file (open-input-file name))
53 (text (read-delimited "" file)))
57 (define (dump-file name text)
58 (let ((file (open-output-file name)))
62 ;; urg, this kind of naming costs too much indenting
64 (separate-fields-discarding-char c s r))
67 ;;; Script entry point
69 (let ((options (getopt-long args
70 `((output (single-char #\o)
72 (help (single-char #\h))
73 (version (single-char #\v))))))
74 (define (opt tag default)
75 (let ((pair (assq tag options)))
76 (if pair (cdr pair) default)))
78 (if (assq 'help options)
79 (begin (show-version (current-output-port)) (show-help) (exit 0)))
81 (if (assq 'version options)
82 (begin (show-version (current-output-port)) (exit 0)))
84 (show-version (current-error-port))
85 (let ((output-name (opt 'output "-"))
86 (files (let ((foo (opt '() '())))
90 (do-file (car files) output-name))))
92 (define (string->dim scale string)
93 (/ (string->number string) scale))
95 ;; C 0 ; WX 7 ; N rests-0 ; B 0 -3125 7
96 (define (afm-char scale number name width height depth)
97 (let ((w (string->dim scale width))
98 (h (string->dim scale height))
99 (d (string->dim scale depth)))
100 ;; ARG: can't find doco for (format): ~s prints string in quotes
101 ;;(format "C ~s ; WX ~d ; N ~s ; B 0 ~,3f ~,3f ~,3f ;\n"
102 ;; number (inexact->exact w) name d w h)
103 (string-append "C " number " ; "
104 (format "WX ~d ; " (inexact->exact w))
106 (format "B 0 ~,3f ~,3f ~,3f ;\n" d w h))))
108 ;; # width[,height[,depth[,italic_correction[,left_italic_correction[,subscript_correction]]]]]
109 (define (dit-to-afm-char scale x)
110 (if (> (string-length x) 0)
111 (let* ((l (split #\ht x list))
113 (dimensions (append (split #\, (cadr l) list) '("0" "0" "0"))))
114 (let ((number (substring name (+ (string-index name #\- ) 1)))
115 (width (car dimensions))
116 (height (cadr dimensions))
117 (depth (caddr dimensions)))
118 (afm-char scale number name width height depth)))
122 ;; Hmm, this is a 10-liner in awk,
123 ;; what am I doing wrong?
125 (define (do-file tfm-name output-name)
126 (let* ((font (basename tfm-name '.tfm))
127 (afm-name (string-append font '.afm))
128 (dit-name (string-append font '.dit))
129 (chart-name (string-append font '.chart))
130 (chart (let loop ((i 0) (s ""))
133 (let ((n (number->string i)))
134 (loop (+ i 1) (string-append s n " Character-" n "\n")))))))
136 (dump-file chart-name chart)
138 (if (= 0 (primitive-fork))
139 (execlp 'tfmtodit tfm-name tfm-name chart-name dit-name)
142 (let* ((dit (gulp-file dit-name))
143 (sections (split #\np (regexp-substitute/global
145 "name \|\ninternalname \|\nspacewidth \|\nchecksum\|\ndesignsize \|\nkernpairs\n\|\ncharset\n"
148 (dit-vector (list->vector (cdr sections))))
152 (let ((name (vector-ref dit-vector 0))
153 (internalname (vector-ref dit-vector 1))
154 (spacewidth (vector-ref dit-vector 2))
155 (checksum (vector-ref dit-vector 3))
156 (designsize (vector-ref dit-vector 4))
157 (kernpairs (vector-ref dit-vector 5))
158 (charset (split #\nl (vector-ref dit-vector 6) list)))
159 (let ((scale (/ (string->number designsize) 100)))
164 (number->string (- (length charset) 2))
167 (map (lambda (x) (dit-to-afm-char scale x))