+++ /dev/null
-#!@GUILE@ \
--e main -s
-!#
-;;;; tfm2afm.scm -- convert tfm to afm, with the aid of tfmtodit
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2000 Jan Nieuwenhuizen <janneke@gnu.org>
-
-(debug-enable 'backtrace)
-
-;;;; library funtions
-(use-modules
- (ice-9 debug)
- (ice-9 format)
- (ice-9 getopt-long)
- (ice-9 string-fun)
- (ice-9 regex))
-
-;;; Script stuff
-(define program-name "tfm2afm")
-
-(define cur-output-name "-")
-(define cur-output-file '())
-
-(define subst-version "@TOPLEVEL_VERSION@")
-
-(define program-version
- (if (eq? subst-version (string-append "@" "TOPLEVEL_VERSION" "@"))
- "unknown"
- subst-version))
-
-(define (show-version port)
- (display (string-append
- program-name " - LilyPond version " program-version "\n")
- port))
-
-(define (show-help)
- (display "Convert TFM to AFM
-
-Usage: tfm2afm [OPTION]... TFM-FILE
-
-Options:
- -h,--help this help
- -o,--output=FILE set output file
- -v,--version show version
-
-Example: tfm2afm `kpsewhich cmr10.tfm`
-"))
-
-(define (gulp-file name)
- (let* ((file (open-input-file name))
- (text (read-delimited "" file)))
- (close file)
- text))
-
-(define (dump-file name text)
- (let ((file (open-output-file name)))
- (display text file)
- (close file)))
-
-;; urg, this kind of naming costs too much indenting
-(define (split c s r)
- (separate-fields-discarding-char c s r))
-
-
-;;; Script entry point
-(define (main args)
- (let ((options (getopt-long args
- `((output (single-char #\o)
- (value #t))
- (help (single-char #\h))
- (version (single-char #\v))))))
- (define (opt tag default)
- (let ((pair (assq tag options)))
- (if pair (cdr pair) default)))
-
- (if (assq 'help options)
- (begin (show-version (current-output-port)) (show-help) (exit 0)))
-
- (if (assq 'version options)
- (begin (show-version (current-output-port)) (exit 0)))
-
- (show-version (current-error-port))
- (let ((output-name (opt 'output "-"))
- (files (let ((foo (opt '() '())))
- (if (null? foo)
- (list "-")
- foo))))
- (do-file (car files) output-name))))
-
-(define (string->dim scale string)
- (/ (string->number string) scale))
-
-;; C 0 ; WX 7 ; N rests-0 ; B 0 -3125 7
-(define (afm-char scale number name width height depth)
- (let ((w (string->dim scale width))
- (h (string->dim scale height))
- (d (string->dim scale depth)))
- ;; ARG: can't find doco for (format): ~s prints string in quotes
- ;;(format "C ~s ; WX ~d ; N ~s ; B 0 ~,3f ~,3f ~,3f ;\n"
- ;; number (inexact->exact w) name d w h)
- (string-append "C " number " ; "
- (format "WX ~d ; " (inexact->exact w))
- "N " name " ; "
- (format "B 0 ~,3f ~,3f ~,3f ;\n" d w h))))
-
-;; # width[,height[,depth[,italic_correction[,left_italic_correction[,subscript_correction]]]]]
-(define (dit-to-afm-char scale x)
- (if (> (string-length x) 0)
- (let* ((l (split #\ht x list))
- (name (car l))
- (dimensions (append (split #\, (cadr l) list) '("0" "0" "0"))))
- (let ((number (substring name (+ (string-index name #\- ) 1)))
- (width (car dimensions))
- (height (cadr dimensions))
- (depth (caddr dimensions)))
- (afm-char scale number name width height depth)))
- ""))
-
-;;
-;; Hmm, this is a 10-liner in awk,
-;; what am I doing wrong?
-;;
-(define (do-file tfm-name output-name)
- (let* ((font (basename tfm-name ".tfm"))
- (afm-name (string-append font ".afm"))
- (dit-name (string-append font ".dit"))
- (chart-name (string-append font ".chart"))
- (chart (let loop ((i 0) (s ""))
- (if (= i 256)
- s
- (let ((n (number->string i)))
- (loop (+ i 1) (string-append s n " Character-" n "\n")))))))
-
- (dump-file chart-name chart)
-
- (if (= 0 (primitive-fork))
- (execlp "tfmtodit" tfm-name tfm-name chart-name dit-name)
- (waitpid 0))
-
- (let* ((dit (gulp-file dit-name))
- (sections (split #\np (regexp-substitute/global
- #f
- "name \|\ninternalname \|\nspacewidth \|\nchecksum\|\ndesignsize \|\nkernpairs\n\|\ncharset\n"
- dit 'pre "\f" 'post)
- list))
- (dit-vector (list->vector (cdr sections))))
-
- (dump-file
- afm-name
- (let ((name (vector-ref dit-vector 0))
- (internalname (vector-ref dit-vector 1))
- (spacewidth (vector-ref dit-vector 2))
- (checksum (vector-ref dit-vector 3))
- (designsize (vector-ref dit-vector 4))
- (kernpairs (vector-ref dit-vector 5))
- (charset (split #\nl (vector-ref dit-vector 6) list)))
- (let ((scale (/ (string->number designsize) 100)))
- (string-append
- "FontName cmr
-StartFontMetrics
-StartCharMetrics "
- (number->string (- (length charset) 2))
- "\n"
- (apply string-append
- (map (lambda (x) (dit-to-afm-char scale x))
- charset))
- "EndCharMetrics
-EndFontMetrics"
- )))))))
-
-
-
\ No newline at end of file