buildscripts/tfm2afm.scm

   1 #!@GUILE@ \
   2 -e main -s
   3 !#
   4 ;;;; tfm2afm.scm -- convert tfm to afm, with the aid of tfmtodit
   5 ;;;;
   6 ;;;; source file of the GNU LilyPond music typesetter
   7 ;;;;
   8 ;;;; (c) 2000 Jan Nieuwenhuizen <janneke@gnu.org>
   9
  10 (debug-enable 'backtrace)
  11
  12 ;;;; library funtions
  13 (use-modules
  14   (ice-9 debug)
  15   (ice-9 format)
  16   (ice-9 getopt-long)
  17   (ice-9 string-fun)
  18   (ice-9 regex))
  19
  20 ;;; Script stuff
  21 (define program-name "tfm2afm")
  22
  23 (define cur-output-name "-")
  24 (define cur-output-file '())
  25
  26 (define subst-version "@TOPLEVEL_VERSION@")
  27
  28 (define program-version
  29   (if (eq? subst-version (string-append "@" "TOPLEVEL_VERSION" "@"))
  30       "unknown"
  31       subst-version))
  32
  33 (define (show-version port)
  34   (display (string-append
  35             program-name " - LilyPond version " program-version "\n")
  36            port))
  37
  38 (define (show-help)
  39   (display "Convert TFM to AFM
  40
  41 Usage: tfm2afm [OPTION]... TFM-FILE
  42
  43 Options:
  44   -h,--help          this help
  45   -o,--output=FILE   set output file
  46   -v,--version       show version
  47
  48 Example: tfm2afm `kpsewhich cmr10.tfm`
  49 "))
  50
  51 (define (gulp-file name)
  52   (let* ((file (open-input-file name))
  53          (text (read-delimited "" file)))
  54     (close file)
  55     text))
  56
  57 (define (dump-file name text)
  58   (let ((file (open-output-file name)))
  59     (display text file)
  60     (close file)))
  61
  62 ;; urg, this kind of naming costs too much indenting
  63 (define (split c s r)
  64   (separate-fields-discarding-char c s r))
  65
  66
  67 ;;; Script entry point
  68 (define (main args)
  69   (let ((options (getopt-long args
  70                               `((output (single-char #\o)
  71                                           (value #t))
  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)))
  77
  78     (if (assq 'help options)
  79         (begin (show-version (current-output-port)) (show-help) (exit 0)))
  80
  81     (if (assq 'version options)
  82         (begin (show-version (current-output-port)) (exit 0)))
  83
  84     (show-version (current-error-port))
  85     (let ((output-name (opt 'output "-"))
  86           (files (let ((foo (opt '() '())))
  87                       (if (null? foo)
  88                           (list "-")
  89                           foo))))
  90          (do-file (car files) output-name))))
  91
  92 (define (string->dim scale string)
  93   (/ (string->number string) scale))
  94
  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))
 105                    "N " name " ; "
 106                    (format "B 0 ~,3f ~,3f ~,3f ;\n" d w h))))
 107
 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))
 112              (name (car l))
 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)))
 119         ""))
 120
 121 ;;
 122 ;; Hmm, this is a 10-liner in awk,
 123 ;; what am I doing wrong?
 124 ;;
 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 ""))
 131                   (if (= i 256)
 132                       s
 133                       (let ((n (number->string i)))
 134                         (loop (+ i 1) (string-append s n " Character-" n "\n")))))))
 135
 136     (dump-file chart-name chart)
 137
 138     (if (= 0 (primitive-fork))
 139         (execlp "tfmtodit" tfm-name tfm-name chart-name dit-name)
 140         (waitpid 0))
 141
 142     (let* ((dit (gulp-file dit-name))
 143            (sections (split #\np (regexp-substitute/global
 144                                   #f
 145                                   "name \|\ninternalname \|\nspacewidth \|\nchecksum\|\ndesignsize \|\nkernpairs\n\|\ncharset\n"
 146                                   dit 'pre "\f" 'post)
 147                             list))
 148            (dit-vector (list->vector (cdr sections))))
 149
 150       (dump-file
 151        afm-name
 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)))
 160            (string-append
 161             "FontName cmr
 162 StartFontMetrics
 163 StartCharMetrics "
 164             (number->string (- (length charset) 2))
 165             "\n"
 166             (apply string-append
 167                    (map (lambda (x) (dit-to-afm-char scale x))
 168                         charset))
 169             "EndCharMetrics
 170 EndFontMetrics"
 171             )))))))
 172
 173
 174