You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
216 lines
13 KiB
Racket
216 lines
13 KiB
Racket
#lang pitfall/racket
|
|
(provide AFMFont AFMFont-open)
|
|
|
|
(define AFMFont
|
|
(class object%
|
|
(super-new)
|
|
(init-field contents)
|
|
(field [attributes (mhasheq)]
|
|
[glyphWidths (mhash)]
|
|
[boundingBoxes (mhash)]
|
|
[kernPairs (mhash)])
|
|
|
|
(parse this)
|
|
|
|
(field [charWidths (for/list ([i (in-range 256)])
|
|
(hash-ref glyphWidths (vector-ref characters i) #f))])
|
|
(field [bbox (for/list ([attr (in-list (string-split (hash-ref attributes 'FontBBox)))])
|
|
(or (string->number attr) 0))])
|
|
(field [ascender (string->number (or (hash-ref attributes 'Ascender #f) "0"))])
|
|
(field [descender (string->number (or (hash-ref attributes 'Descender #f) "0"))])
|
|
(field [lineGap (- (- (list-ref bbox 3) (list-ref bbox 1)) (- ascender descender))])
|
|
|
|
(as-methods
|
|
parse
|
|
encodeText
|
|
glyphsForString
|
|
characterToGlyph
|
|
advancesForGlyphs
|
|
widthOfGlyph
|
|
getKernPair)
|
|
))
|
|
|
|
(define/contract (AFMFont-open filename)
|
|
(path-string? . -> . (is-a?/c AFMFont))
|
|
(make-object AFMFont (file->string filename)))
|
|
|
|
(define/contract (parse this)
|
|
(->m void?)
|
|
(for*/fold ([last-section #f])
|
|
([line (in-list (string-split (· this contents) "\n"))])
|
|
(define current-section (cond
|
|
[(regexp-match #px"^Start(\\w+)" line) => (λ (match) (cadr match))]
|
|
[(regexp-match #px"^End(\\w+)" line) #f]
|
|
[else last-section]))
|
|
(case current-section
|
|
[("FontMetrics")
|
|
;; line looks like this:
|
|
;; FontName Helvetica
|
|
;; key space value. Possibly multiple lines with same key.
|
|
(match-define (list _ key value) (regexp-match #px"^(\\w+)\\s+(.*)" line))
|
|
(hash-update! (· this attributes) (string->symbol key)
|
|
(λ (v) (if (equal? v value)
|
|
value
|
|
(append (if (pair? v) v (list v)) (list value)))) value)]
|
|
[("CharMetrics")
|
|
;; line looks like this:
|
|
;; C 33 ; WX 278 ; N exclam ; B 90 0 187 718 ;
|
|
;; need to retrieve N and WX fields
|
|
(when (regexp-match #px"^CH?\\s" line)
|
|
(define assocs (for/list ([field (in-list (string-split line #px"\\s*;\\s*"))])
|
|
(string-split field " ")))
|
|
(define name (second (assoc "N" assocs)))
|
|
(define width (string->number (second (assoc "WX" assocs))))
|
|
(hash-set! (· this glyphWidths) name width))]
|
|
[("KernPairs")
|
|
(when (string-prefix? line "KPX")
|
|
(match-define (list _ left right val) (string-split line))
|
|
(hash-set! (· this kernPairs) (make-kern-table-key left right) (string->number val)))])
|
|
current-section)
|
|
(void))
|
|
|
|
(define (make-kern-table-key left right)
|
|
(cons left right))
|
|
|
|
(define win-ansi-table
|
|
(hasheqv 402 131
|
|
8211 150
|
|
8212 151
|
|
8216 145
|
|
8217 146
|
|
8218 130
|
|
8220 147
|
|
8221 148
|
|
8222 132
|
|
8224 134
|
|
8225 135
|
|
8226 149
|
|
8230 133
|
|
8364 128
|
|
8240 137
|
|
8249 139
|
|
8250 155
|
|
710 136
|
|
8482 153
|
|
338 140
|
|
339 156
|
|
732 152
|
|
352 138
|
|
353 154
|
|
376 159
|
|
381 142
|
|
382 158))
|
|
|
|
|
|
(define/contract (encodeText this str)
|
|
(string? . ->m . (listof string?))
|
|
(for/list ([c (in-string str)])
|
|
(define cint (char->integer c))
|
|
(number->string (hash-ref win-ansi-table cint cint) 16)))
|
|
|
|
|
|
(define/contract (glyphsForString this str)
|
|
(string? . ->m . (listof any/c))
|
|
(for/list ([c (in-string str)])
|
|
(send this characterToGlyph (char->integer c))))
|
|
|
|
|
|
(define/contract (characterToGlyph this cint)
|
|
(integer? . ->m . any)
|
|
(define idx (hash-ref win-ansi-table cint cint))
|
|
(vector-ref characters (if (< idx (vector-length characters)) idx 0)))
|
|
|
|
|
|
(define/contract (widthOfGlyph this glyph)
|
|
(string? . ->m . number?)
|
|
(hash-ref (· this glyphWidths) glyph 0))
|
|
|
|
|
|
(define/contract (getKernPair this left right)
|
|
((or/c char? string?) (or/c char? string?) . ->m . number?)
|
|
(hash-ref (· this kernPairs) (make-kern-table-key left right) 0))
|
|
|
|
|
|
(define/contract (advancesForGlyphs this glyphs)
|
|
((listof any/c) . ->m . (listof number?))
|
|
(for/list ([left (in-list glyphs)]
|
|
[right (in-list (append (cdr glyphs) (list #\nul)))])
|
|
(+ (send this widthOfGlyph left) (send this getKernPair left right))))
|
|
|
|
|
|
(define characters (list->vector (string-split @string-append{
|
|
.notdef .notdef .notdef .notdef
|
|
.notdef .notdef .notdef .notdef
|
|
.notdef .notdef .notdef .notdef
|
|
.notdef .notdef .notdef .notdef
|
|
.notdef .notdef .notdef .notdef
|
|
.notdef .notdef .notdef .notdef
|
|
.notdef .notdef .notdef .notdef
|
|
.notdef .notdef .notdef .notdef
|
|
|
|
space exclam quotedbl numbersign
|
|
dollar percent ampersand quotesingle
|
|
parenleft parenright asterisk plus
|
|
comma hyphen period slash
|
|
zero one two three
|
|
four five six seven
|
|
eight nine colon semicolon
|
|
less equal greater question
|
|
|
|
at A B C
|
|
D E F G
|
|
H I J K
|
|
L M N O
|
|
P Q R S
|
|
T U V W
|
|
X Y Z bracketleft
|
|
backslash bracketright asciicircum underscore
|
|
|
|
grave a b c
|
|
d e f g
|
|
h i j k
|
|
l m n o
|
|
p q r s
|
|
t u v w
|
|
x y z braceleft
|
|
bar braceright asciitilde .notdef
|
|
|
|
Euro .notdef quotesinglbase florin
|
|
quotedblbase ellipsis dagger daggerdbl
|
|
circumflex perthousand Scaron guilsinglleft
|
|
OE .notdef Zcaron .notdef
|
|
.notdef quoteleft quoteright quotedblleft
|
|
quotedblright bullet endash emdash
|
|
tilde trademark scaron guilsinglright
|
|
oe .notdef zcaron ydieresis
|
|
|
|
space exclamdown cent sterling
|
|
currency yen brokenbar section
|
|
dieresis copyright ordfeminine guillemotleft
|
|
logicalnot hyphen registered macron
|
|
degree plusminus twosuperior threesuperior
|
|
acute mu paragraph periodcentered
|
|
cedilla onesuperior ordmasculine guillemotright
|
|
onequarter onehalf threequarters questiondown
|
|
|
|
Agrave Aacute Acircumflex Atilde
|
|
Adieresis Aring AE Ccedilla
|
|
Egrave Eacute Ecircumflex Edieresis
|
|
Igrave Iacute Icircumflex Idieresis
|
|
Eth Ntilde Ograve Oacute
|
|
Ocircumflex Otilde Odieresis multiply
|
|
Oslash Ugrave Uacute Ucircumflex
|
|
Udieresis Yacute Thorn germandbls
|
|
|
|
agrave aacute acircumflex atilde
|
|
adieresis aring ae ccedilla
|
|
egrave eacute ecircumflex edieresis
|
|
igrave iacute icircumflex idieresis
|
|
eth ntilde ograve oacute
|
|
ocircumflex otilde odieresis divide
|
|
oslash ugrave uacute ucircumflex
|
|
udieresis yacute thorn ydieresis})))
|
|
|
|
(module+ test
|
|
(define afmfont (AFMFont-open "data/helvetica.afm"))
|
|
afmfont) |