mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

gbye

Browse Source
main
Matthew Butterick 6 years ago
parent 3aa77f32fb
commit 347b82f9b5
5 changed files with 229 additions and 298 deletions
Show Stats Download Patch File Download Diff File

208
pitfall/pitfall/afm-font.rkt
Unescape Escape View File

@ -1,208 +0,0 @@
#lang debug racket/base
(require
racket/class
racket/match
racket/string
racket/list
with-cache)
(provide AFMFont AFMFont-open)
(define (AFMFont-open filename)
(make-object AFMFont (open-input-file filename)))
(define (make-kern-table-key left right)
(cons left right))
(define (parse-afm input-file)
(parameterize ([*current-cache-keys* (list (λ () (file-or-directory-modify-seconds (path->string (object-name input-file)))))])
(with-cache (path-replace-extension (object-name input-file) #".rktd")
(λ ()
(define @attributes (make-hasheq))
(define @glyph-widths (make-hash))
(define @kern-pairs (make-hash))
(for/fold ([last-section #f]
#:result (list (hash->list @attributes)
(hash->list @glyph-widths)
(hash->list @kern-pairs)))
([line (in-lines input-file)])
(define current-section (cond
[(regexp-match #px"(?<=^Start)\\w+" line) => car]
[(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! @attributes (string->symbol key)
(λ (v) (if (eq? v 'init-val)
value
(append (if (pair? v) v (list v)) (list value))))
'init-val)]
[("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! @glyph-widths name width))]
[("KernPairs")
(when (string-prefix? line "KPX")
(match-define (list _ left right val) (string-split line))
(hash-set! @kern-pairs (make-kern-table-key left right) (string->number val)))])
current-section)))))
(define AFMFont
(class object%
(super-new)
(init-field input-file)
(match-define (list atts gws kps) (parse-afm input-file))
(field [@attributes (make-hasheq atts)]
[@glyph-widths (make-hash gws)]
[@kern-pairs (make-hash kps)])
(field [charWidths (for/list ([i (in-range 256)])
(hash-ref @glyph-widths (vector-ref characters i) #f))])
(field [(@bbox bbox) (for/list ([attr (in-list (string-split (hash-ref @attributes 'FontBBox)))])
(or (string->number attr) 0))])
(field [(@ascender ascender) (string->number (or (hash-ref @attributes 'Ascender #f) "0"))])
(field [(@descender descender) (string->number (or (hash-ref @attributes 'Descender #f) "0"))])
(field [line-gap (- (list-ref @bbox 3) (list-ref @bbox 1) @ascender @descender)])
(define/public (encode-text str)
(for/list ([c (in-string str)])
(define cint (char->integer c))
(number->string (hash-ref win-ansi-table cint cint) 16)))
(define/public (glyphs-for-string str)
(for/list ([c (in-string str)])
(character-to-glyph (char->integer c))))
(define/public (character-to-glyph cint)
(define idx (hash-ref win-ansi-table cint cint))
(vector-ref characters (if (< idx (vector-length characters)) idx 0)))
(define/public (glyph-width glyph)
(hash-ref @glyph-widths glyph 0))
(define/public (get-kern-pair left right)
(hash-ref @kern-pairs (make-kern-table-key left right) 0))
(define/public (advances-for-glyphs glyphs)
(for/list ([left (in-list glyphs)]
[right (in-list (append (cdr glyphs) (list #\nul)))])
(+ (glyph-width left) (get-kern-pair 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 characters
(list->vector
(map symbol->string
'(.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)

3
pitfall/pitfall/font-open.rkt
Unescape Escape View File

@ -9,8 +9,7 @@
(define (PDFFont-open src family id)
(cond
[(and (string? src) (isStandardFont src))
(make-object StandardFont src id)]
[(and (string? src) (standard-font? src)) (make-object StandardFont src id)]
[else
(define font
(cond

27
pitfall/pitfall/helper.rkt
Unescape Escape View File

@ -1,27 +0,0 @@
#lang racket/base
(require (for-syntax racket/base racket/syntax br/syntax) br/define racket/class sugar/list racket/list (only-in br/list push! pop!) racket/string racket/format racket/contract)
(provide (all-defined-out) push! pop!)
(struct exn:pitfall:test exn (data))
(define (raise-test-exn val)
(raise (exn:pitfall:test "pitfall test exn" (current-continuation-marks) val)))
(define-syntax-rule (test-when cond expr)
(if cond (raise-test-exn expr) expr))
(define (color-string? x)
(and (string? x)
(if (string-prefix? x "#")
(or (= (string-length x) 4) (= (string-length x) 7))
#t)))
(define (layout? x)
(and (hash? x) (hash-has-key? x 'glyphs) (hash-has-key? x 'positions)))
(define index? (and/c number? integer? (not/c negative?)))

1
pitfall/pitfall/png.rkt
Unescape Escape View File

@ -95,7 +95,6 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/image/png.coffee
(ref-write ($img-ref png) ($png-img-data png))
(ref-end ($img-ref png)))
(define (split-alpha-channel png)
(define ip ($img-data png))
(file-position ip 0)

288
pitfall/pitfall/standard-font.rkt
Unescape Escape View File

@ -1,91 +1,259 @@
#lang racket/base
(require
(for-syntax racket/base)
racket/class
racket/file
racket/string
racket/match
sugar/unstable/dict
"afm-font.rkt"
"font.rkt"
"core.rkt"
"reference.rkt"
fontland
racket/runtime-path)
(provide isStandardFont standard-fonts StandardFont)
racket/runtime-path
racket/list
with-cache)
(provide standard-font? StandardFont)
(define-runtime-path here ".")
(define StandardFont
(class PDFFont
(init-field name id)
(field [font (make-object AFMFont
((hash-ref standard-fonts name
(λ () (raise-argument-error 'PDFFont "valid font name" name)))))])
(super-new [ascender (get-field ascender font)]
[descender (get-field descender font)]
[bbox (get-field bbox font)]
[line-gap (get-field line-gap font)])
(inherit-field [@ascender ascender]
[@descender descender]
[@line-gap line-gap]
[@bbox bbox]
[@dictionary dictionary])
(match-define (list atts gws kps) (parse-afm (open-input-file (build-path here (format "data/~a.afm" name)))))
(field [@attributes (make-hasheq atts)]
[@glyph-widths (make-hash gws)]
[@kern-pairs (make-hash kps)])
(let* ([ascender (string->number (hash-ref @attributes 'Ascender "0"))]
[descender (string->number (hash-ref @attributes 'Descender "0"))]
[bbox (for/list ([attr (in-list (string-split (hash-ref @attributes 'FontBBox)))])
(or (string->number attr) 0))]
[line-gap (- (list-ref bbox 3) (list-ref bbox 1) ascender descender)])
(super-new [ascender ascender] [descender descender] [bbox bbox] [line-gap line-gap]))
(inherit-field [@dictionary dictionary])
(define/override (embed)
(set-$ref-payload! @dictionary
(mhash 'Type 'Font
'BaseFont (string->symbol name)
'Subtype 'Type1
'Encoding 'WinAnsiEncoding))
(mhash 'Type 'Font
'BaseFont (string->symbol name)
'Subtype 'Type1
'Encoding 'WinAnsiEncoding))
(ref-end @dictionary))
(define/public (character-to-glyph char)
(define cint (char->integer char))
(define idx (hash-ref win-ansi-table cint cint))
(vector-ref characters (if (< idx (vector-length characters)) idx 0)))
(define/public (glyphs-for-string str)
(for/list ([c (in-string str)])
(character-to-glyph c)))
(define/public (glyph-width glyph)
(hash-ref @glyph-widths glyph 0))
(define/public (advances-for-glyphs glyphs)
(for/list ([left (in-list glyphs)]
[right (in-list (append (cdr glyphs) (list #\nul)))])
(+ (glyph-width left) (get-kern-pair left right))))
(define/public (get-kern-pair left right)
(hash-ref @kern-pairs (make-kern-table-key left right) 0))
(define/override (encode text [options #f])
(define encoded (send font encode-text text))
(define glyphs (send font glyphs-for-string text))
(define advances (send font advances-for-glyphs glyphs))
(define encoded (for/list ([c (in-string text)])
(define cint (char->integer c))
(number->string (hash-ref win-ansi-table cint cint) 16)))
(define glyphs (glyphs-for-string text))
(define positions
(for/list ([glyph (in-list glyphs)]
[advance (in-list advances)])
(+glyph-position advance 0 0 0 (send font glyph-width glyph))))
[advance (in-list (advances-for-glyphs glyphs))])
(+glyph-position advance 0 0 0 (glyph-width glyph))))
(list encoded positions))
(define/override (string-width str size [options #f])
(define glyphs (send font glyphs-for-string str))
(define advances (send font advances-for-glyphs glyphs))
(define width (apply + advances))
(define glyphs (glyphs-for-string str))
(define width (apply + (advances-for-glyphs glyphs)))
(define scale (/ size 1000.0))
(* width scale))))
(define standard-fonts
(map symbol->string '(Courier-Bold
Courier-BoldOblique
Courier-Oblique
Courier
Helvetica-Bold
Helvetica-BoldOblique
Helvetica-Oblique
Helvetica
Symbol
Times-Bold
Times-BoldItalic
Times-Italic
Times-Roman
ZapfDingbats)))
(define (standard-font? name) (and (member name standard-fonts) #t))
(module+ test
(require rackunit)
(check-true (standard-font? "Helvetica"))
(check-true (standard-font? "Courier"))
(check-true (standard-font? "ZapfDingbats"))
(check-false (standard-font? "Not A Font Name"))
(define stdfont (make-object StandardFont "Helvetica" #f)))
(define (isStandardFont name) (hash-ref standard-fonts name #f))
(define-syntax (define-afm-table stx)
(syntax-case stx ()
[(_ HASH-ID FONT-ID ...)
(with-syntax ([(PATH-STR ...) (map (λ (stx) (format "data/~a.afm" (syntax->datum stx))) (syntax->list #'(FONT-ID ...)))])
#'(begin (define-runtime-path FONT-ID PATH-STR) ...
(define HASH-ID (make-hash (list (cons (symbol->string 'FONT-ID) (procedure-rename (λ () (open-input-file FONT-ID)) 'FONT-ID)) ...)))))]))
(define-afm-table standard-fonts
Courier-Bold
Courier-BoldOblique
Courier-Oblique
Courier
Helvetica-Bold
Helvetica-BoldOblique
Helvetica-Oblique
Helvetica
Symbol
Times-Bold
Times-BoldItalic
Times-Italic
Times-Roman
ZapfDingbats)
(define (make-kern-table-key left right)
(cons left right))
(define (parse-afm input-file)
(parameterize ([*current-cache-keys* (list (λ () (file-or-directory-modify-seconds (path->string (object-name input-file)))))])
(with-cache (path-replace-extension (object-name input-file) #".rktd")
(λ ()
(define @attributes (make-hasheq))
(define @glyph-widths (make-hash))
(define @kern-pairs (make-hash))
(for/fold ([last-section #f]
#:result (list (hash->list @attributes)
(hash->list @glyph-widths)
(hash->list @kern-pairs)))
([line (in-lines input-file)])
(define current-section (cond
[(regexp-match #px"(?<=^Start)\\w+" line) => car]
[(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! @attributes (string->symbol key)
(λ (v) (if (eq? v 'init-val)
value
(append (if (pair? v) v (list v)) (list value))))
'init-val)]
[("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! @glyph-widths name width))]
[("KernPairs")
(when (string-prefix? line "KPX")
(match-define (list _ left right val) (string-split line))
(hash-set! @kern-pairs (make-kern-table-key left right) (string->number val)))])
current-section)))))
(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 characters
(list->vector
(map symbol->string
'(.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
(require rackunit)
(check-true (and (isStandardFont "Helvetica") #t))
(check-true (and (isStandardFont "Courier") #t))
(check-true (and (isStandardFont "ZapfDingbats") #t))
(check-false (isStandardFont "Not A Font Name")))

Write Preview
Loading…
Cancel
Save