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

carefully

Browse Source
main
Matthew Butterick 5 years ago
parent d5bda5e4d1
commit c7918f9504
3 changed files with 210 additions and 228 deletions
Show Stats Download Patch File Download Diff File

313
pitfall/pitfall/embedded.rkt
Unescape Escape View File

@ -23,159 +23,163 @@ approximates
https://github.com/mbutterick/pdfkit/blob/master/lib/font/embedded.coffee
|#
(define-subclass PDFFont (EmbeddedFont document font id)
(field [subset (create-subset font)]
;; we make `unicode` and `width` fields integer-keyed hashes not lists
;; because they offer better random access and growability
[unicode (mhash 0 '(0))] ; always include the missing glyph (gid = 0)
[widths (mhash 0 (glyph-advance-width (get-glyph font 0)))]
;; always include the width of the missing glyph (gid = 0)
[name (font-postscript-name font)]
[scale (/ 1000 (font-units-per-em font))]
[ascender (* (font-ascent font) scale)]
[descender (* (font-descent font) scale)]
[line-gap (* (font-linegap font) scale)]
[bbox (font-bbox font)])
(as-methods
widthOfString
encode
embed
toUnicodeCmap))
(define width-cache (make-hash))
(define (widthOfString this string size [features #f])
((string? number?) ((option/c (listof symbol?))) . ->*m . number?)
; #f disables features ; null enables default features ; list adds features
(hash-ref! width-cache
(list string size (and features (sort features symbol<?)))
(λ ()
(define run (layout (· this font) string features))
(define width (glyphrun-advance-width run))
(define scale (/ size (+ (font-units-per-em (· this font)) 0.0)))
(* width scale))))
;; called from text.rkt
(define (encode this text [features #f])
(define glyphRun (layout (· this font) text features))
(define glyphs (glyphrun-glyphs glyphRun))
(define positions (glyphrun-positions glyphRun))
(define-values (subset-idxs new-positions)
(for/lists (idxs posns)
([(g i) (in-indexed glyphs)]
[posn (in-list positions)])
(define gid (subset-add-glyph! (· this subset) (glyph-id g)))
(define subset-idx (toHex gid))
(set-glyph-position-advance-width! posn (glyph-advance-width g))
(hash-ref! (· this widths) gid (λ () (glyph-position-advance-width posn)))
(hash-ref! (· this unicode) gid (λ () (glyph-codepoints g)))
(scale-glyph-position! posn (· this scale))
(values subset-idx posn)))
(list subset-idxs new-positions))
(define-macro (sum-flags [COND VAL] ...)
#'(for/sum ([c (in-list (list COND ...))]
[v (in-list (list VAL ...))]
#:when c)
v))
v))
(define (embed this)
;; no CFF support
(define isCFF #false) #;(is-a? (· this subset) CFFSubset)
(define fontFile (· this document ref))
(when isCFF
(send fontFile set-key! 'Subtype "CIDFontType0C"))
(define (toHex . codePoints)
(string-append*
(for/list ([code (in-list codePoints)])
(~r code #:base 16 #:min-width 4 #:pad-string "0"))))
(define EmbeddedFont
(class PDFFont
(super-new)
(init-field document-in font id)
(field [subset (create-subset font)]
;; we make `unicode` and `width` fields integer-keyed hashes not lists
;; because they offer better random access and growability
[unicode (mhash 0 '(0))] ; always include the missing glyph (gid = 0)
[widths (mhash 0 (glyph-advance-width (get-glyph font 0)))]
;; always include the width of the missing glyph (gid = 0)
[name (font-postscript-name font)]
[scale (/ 1000 (font-units-per-em font))])
(inherit-field ascender descender bbox line-gap dictionary document)
(set! ascender (* (font-ascent font) scale))
(set! descender (* (font-descent font) scale))
(set! line-gap (* (font-linegap font) scale))
(set! bbox (font-bbox font))
(set! document document-in)
(define/override (widthOfString string size [features #f])
; #f disables features ; null enables default features ; list adds features
(hash-ref! width-cache
(list string size (and features (sort features symbol<?)))
(λ ()
(define run (layout font string features))
(define width (glyphrun-advance-width run))
(define scale (/ size (+ (font-units-per-em font) 0.0)))
(* width scale))))
;; called from text.rkt
(define/override (encode text [features #f])
(define glyphRun (layout font text features))
(define glyphs (glyphrun-glyphs glyphRun))
(define positions (glyphrun-positions glyphRun))
(define-values (subset-idxs new-positions)
(for/lists (idxs posns)
([(g i) (in-indexed glyphs)]
[posn (in-list positions)])
(define gid (subset-add-glyph! subset (glyph-id g)))
(define subset-idx (toHex gid))
(set-glyph-position-advance-width! posn (glyph-advance-width g))
(hash-ref! widths gid (λ () (glyph-position-advance-width posn)))
(hash-ref! unicode gid (λ () (glyph-codepoints g)))
(scale-glyph-position! posn scale)
(values subset-idx posn)))
(list subset-idxs new-positions))
(define/override (embed)
;; no CFF support
(define isCFF #false) #;(is-a? (· this subset) CFFSubset)
(define fontFile (send document ref))
(when isCFF
(send fontFile set-key! 'Subtype "CIDFontType0C"))
(send* fontFile [write (get-output-bytes (encode-to-port (· this subset)))] [end])
(define familyClass (let ([val (if (has-table? (· this font) 'OS/2)
(· (get-OS/2-table (· this font)) sFamilyClass)
0)])
(floor (/ val 256)))) ; equivalent to >> 8
;; font descriptor flags
(match-define (list FIXED_PITCH SERIF SYMBOLIC SCRIPT _UNUSED NONSYMBOLIC ITALIC)
(map (λ (x) (expt 2 x)) (range 7)))
(define flags (sum-flags
[(not (zero? (· (get-post-table (· this font)) isFixedPitch))) FIXED_PITCH]
[(<= 1 familyClass 7) SERIF]
[#t SYMBOLIC] ; assume the font uses non-latin characters
[(= familyClass 10) SCRIPT]
[(· (get-head-table (· this font)) macStyle italic) ITALIC]))
;; generate a random tag (6 uppercase letters. 65 is the char code for 'A')
(when (test-mode) (random-seed 0))
(define tag (list->string (for/list ([i (in-range 6)])
(integer->char (random 65 (+ 65 26))))))
(define name (string-append tag "+" (font-postscript-name (· this font))))
(define bbox (font-bbox (· this font)))
(define descriptor (send (· this document) ref
(mhash
'Type "FontDescriptor"
'FontName name
'Flags flags
'FontBBox (map (λ (x) (* (· this scale) x))
(bbox->list bbox))
'ItalicAngle (font-italic-angle (· this font))
'Ascent (· this ascender)
'Descent (· this descender)
'CapHeight (* (or (font-cap-height (· this font)) (· this sfont ascent)) (· this scale))
'XHeight (* (or (font-x-height (· this font)) 0) (· this scale))
'StemV 0)))
(send descriptor set-key! (if isCFF
'FontFile3
'FontFile2) fontFile)
(· descriptor end)
(define descendantFont (send (· this document) ref
(send* fontFile [write (get-output-bytes (encode-to-port subset))] [end])
(define familyClass (let ([val (if (has-table? font 'OS/2)
(· (get-OS/2-table font) sFamilyClass)
0)])
(floor (/ val 256)))) ; equivalent to >> 8
;; font descriptor flags
(match-define (list FIXED_PITCH SERIF SYMBOLIC SCRIPT _UNUSED NONSYMBOLIC ITALIC)
(map (λ (x) (expt 2 x)) (range 7)))
(define flags (sum-flags
[(not (zero? (· (get-post-table (· this font)) isFixedPitch))) FIXED_PITCH]
[(<= 1 familyClass 7) SERIF]
[#t SYMBOLIC] ; assume the font uses non-latin characters
[(= familyClass 10) SCRIPT]
[(· (get-head-table (· this font)) macStyle italic) ITALIC]))
;; generate a random tag (6 uppercase letters. 65 is the char code for 'A')
(when (test-mode) (random-seed 0))
(define tag (list->string (for/list ([i (in-range 6)])
(integer->char (random 65 (+ 65 26))))))
(define name (string-append tag "+" (font-postscript-name font)))
(define bbox (font-bbox font))
(define descriptor (send document ref
(mhash
'Type "Font"
'Subtype (string-append "CIDFontType" (if isCFF "0" "2"))
'BaseFont name
'CIDSystemInfo
(mhash
'Registry (String "Adobe")
'Ordering (String "Identity")
'Supplement 0)
'FontDescriptor descriptor
'W (list 0 (for/list ([idx (in-range (length (hash-keys (· this widths))))])
(hash-ref (· this widths) idx (λ () (error 'embed (format "hash key ~a not found" idx)))))))))
(· descendantFont end)
(send* (· this dictionary)
[set-key! 'Type "Font"]
[set-key! 'Subtype "Type0"]
[set-key! 'BaseFont name]
[set-key! 'Encoding "Identity-H"]
[set-key! 'DescendantFonts (list descendantFont)]
[set-key! 'ToUnicode (· this toUnicodeCmap)])
(· this dictionary end))
(define/contract (toUnicodeCmap this)
(->m (is-a?/c PDFReference))
(define cmap (· this document ref))
(define entries
(for/list ([idx (in-range (length (hash-keys (· this unicode))))])
(define codePoints (hash-ref (· this unicode) idx))
(define encoded ; encode codePoints to utf16
;; todo: full utf16 support. for now just utf8
(for/list ([value (in-list codePoints)])
(toHex value)))
(format "<~a>" (string-join encoded " "))))
(define unicode-cmap-str #<<HERE
'Type "FontDescriptor"
'FontName name
'Flags flags
'FontBBox (map (λ (x) (* scale x))
(bbox->list bbox))
'ItalicAngle (font-italic-angle font)
'Ascent ascender
'Descent descender
'CapHeight (* (or (font-cap-height font) (· this sfont ascent)) scale)
'XHeight (* (or (font-x-height font) 0) scale)
'StemV 0)))
(send descriptor set-key! (if isCFF
'FontFile3
'FontFile2) fontFile)
(· descriptor end)
(define descendantFont (send document ref
(mhash
'Type "Font"
'Subtype (string-append "CIDFontType" (if isCFF "0" "2"))
'BaseFont name
'CIDSystemInfo
(mhash
'Registry (String "Adobe")
'Ordering (String "Identity")
'Supplement 0)
'FontDescriptor descriptor
'W (list 0 (for/list ([idx (in-range (length (hash-keys (· this widths))))])
(hash-ref (· this widths) idx (λ () (error 'embed (format "hash key ~a not found" idx)))))))))
(· descendantFont end)
(send* (· this dictionary)
[set-key! 'Type "Font"]
[set-key! 'Subtype "Type0"]
[set-key! 'BaseFont name]
[set-key! 'Encoding "Identity-H"]
[set-key! 'DescendantFonts (list descendantFont)]
[set-key! 'ToUnicode (· this toUnicodeCmap)])
(send dictionary end))
(define/public (toUnicodeCmap)
(define cmap (· this document ref))
(define entries
(for/list ([idx (in-range (length (hash-keys (· this unicode))))])
(define codePoints (hash-ref (· this unicode) idx))
(define encoded ; encode codePoints to utf16
;; todo: full utf16 support. for now just utf8
(for/list ([value (in-list codePoints)])
(toHex value)))
(format "<~a>" (string-join encoded " "))))
(define unicode-cmap-str #<<HERE
/CIDInit /ProcSet findresource begin
12 dict begin
begincmap
@ -197,19 +201,12 @@ CMapName currentdict /CMap defineresource pop
end
end
HERE
)
)
(send* cmap [write (format unicode-cmap-str (toHex (sub1 (length entries))) (string-join entries " "))]
[end])
cmap)
(define/contract (toHex . codePoints)
(() () #:rest (listof number?) . ->*m . string?)
(string-append*
(for/list ([code (in-list codePoints)])
(~r code #:base 16 #:min-width 4 #:pad-string "0"))))
(send* cmap
[write (format unicode-cmap-str (toHex (sub1 (length entries))) (string-join entries " "))]
[end])
cmap)))
(module+ test
(require rackunit fontland)
@ -222,6 +219,4 @@ HERE
(check-equal? (bbox->list (· ef bbox)) '(-161 -236 1193 963))
(define H-gid 41)
(check-equal? (· ef widths) (mhash 0 278))
(check-equal? (glyph-advance-width (get-glyph (· ef font) H-gid)) 738)
)
(check-equal? (glyph-advance-width (get-glyph (· ef font) H-gid)) 738))

48
pitfall/pitfall/font.rkt
Unescape Escape View File

@ -1,41 +1,35 @@
#lang racket/base
(require
racket/class
racket/contract
sugar/unstable/class
sugar/unstable/js
"reference.rkt")
(require racket/class)
(provide PDFFont)
(define PDFFont
(class object%
(super-new)
(field [dictionary #f]
[embedded #f])
(field [(@dictionary dictionary) #f]
[@embedded #f]
[(@document document) #f]
[(@line-gap line-gap) #f]
[(@bbox bbox) #f]
[(@ascender ascender) #f]
[(@descender descender) #f])
(as-methods
ref
finalize
lineHeight)))
(abstract embed encode widthOfString)
(define/public (ref)
(unless @dictionary
(set! @dictionary (send @document ref)))
@dictionary)
(define/public (finalize)
(unless (or @embedded (not @dictionary))
(embed)
(set! @embedded #t)))
(define/contract (ref this)
(->m (is-a?/c PDFReference))
(unless (· this dictionary)
(set-field! dictionary this (send (· this document) ref)))
(· this dictionary))
(define/public (lineHeight size [includeGap #f])
(define gap (if includeGap @line-gap 0))
(* (/ (+ @ascender gap (- @descender)) 1000.0) size))))
(define/contract (finalize this)
(->m void?)
(unless (or (· this embedded) (not (· this dictionary)))
(send this embed)
(set-field! embedded this #t)))
(define/contract (lineHeight this size [includeGap #f])
((number?)(boolean?) . ->*m . number?)
(define gap (if includeGap (· this lineGap) 0))
(* (/ (+ (· this ascender) gap (- (· this descender))) 1000.0) size))

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

@ -3,8 +3,6 @@
(for-syntax racket/base)
racket/class
racket/file
racket/contract
sugar/unstable/class
sugar/unstable/js
sugar/unstable/dict
"afm-font.rkt"
@ -13,51 +11,46 @@
racket/runtime-path)
(provide isStandardFont standard-fonts StandardFont)
(define-subclass PDFFont (StandardFont document name id)
(field [font (make-object AFMFont ((hash-ref standard-fonts name
(λ () (raise-argument-error 'PDFFont "valid font name" name)))))]
[ascender (· font ascender)]
[descender (· font descender)]
[bbox (· font bbox)]
[line-gap (· font line-gap)])
(as-methods
embed
encode
widthOfString))
(define StandardFont
(class PDFFont
(super-new)
(init-field document-in name id)
(field [font (make-object AFMFont
((hash-ref standard-fonts name
(λ () (raise-argument-error 'PDFFont "valid font name" name)))))])
(inherit-field ascender descender bbox line-gap dictionary document)
(define/contract (embed this)
(->m void?)
(set-field! payload (· this dictionary)
(mhash 'Type "Font"
'BaseFont (· this name)
'Subtype "Type1"
'Encoding "WinAnsiEncoding"))
(· this dictionary end))
(set! ascender (· font ascender))
(set! descender (· font descender))
(set! bbox (· font bbox))
(set! line-gap (· font line-gap))
(set! document document-in)
(define/override (embed)
(set-field! payload dictionary
(mhash 'Type "Font"
'BaseFont name
'Subtype "Type1"
'Encoding "WinAnsiEncoding"))
(· this dictionary end))
(define (encode this text [options #f])
#;((string?) ((or/c hash? #f)) . ->*m . (list/c (listof string?) (listof glyph-position?)))
(define this-font (· this font))
(define encoded (send this-font encodeText text))
(define glyphs (send this-font glyphsForString text))
(define advances (send this-font advancesForGlyphs glyphs))
(define positions
(for/list ([glyph (in-list glyphs)]
[advance (in-list advances)])
(+glyph-position advance 0 0 0 (send this-font widthOfGlyph glyph))))
(list encoded positions))
(define/contract (widthOfString this str size [options #f])
((string? number?) ((or/c hash? #f)) . ->*m . number?)
(define this-font (· this font))
(define glyphs (send this-font glyphsForString str))
(define advances (send this-font advancesForGlyphs glyphs))
(define width (apply + advances))
(define scale (/ size 1000.0))
(* width scale))
(define/override (encode text [options #f])
(define encoded (send font encodeText text))
(define glyphs (send font glyphsForString text))
(define advances (send font advancesForGlyphs glyphs))
(define positions
(for/list ([glyph (in-list glyphs)]
[advance (in-list advances)])
(+glyph-position advance 0 0 0 (send font widthOfGlyph glyph))))
(list encoded positions))
(define/override (widthOfString str size [options #f])
(define glyphs (send font glyphsForString str))
(define advances (send font advancesForGlyphs glyphs))
(define width (apply + advances))
(define scale (/ size 1000.0))
(* width scale))))
(module+ test
(define stdfont (make-object StandardFont #f "Helvetica" #f)))

Write Preview
Loading…
Cancel
Save