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

carefully

Browse Source
main
Matthew Butterick 6 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 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 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] ...) (define-macro (sum-flags [COND VAL] ...)
#'(for/sum ([c (in-list (list COND ...))] #'(for/sum ([c (in-list (list COND ...))]
[v (in-list (list VAL ...))] [v (in-list (list VAL ...))]
#:when c) #:when c)
v)) v))
(define (embed this) (define (toHex . codePoints)
;; no CFF support (string-append*
(define isCFF #false) #;(is-a? (· this subset) CFFSubset) (for/list ([code (in-list codePoints)])
(define fontFile (· this document ref)) (~r code #:base 16 #:min-width 4 #:pad-string "0"))))
(when isCFF (define EmbeddedFont
(send fontFile set-key! 'Subtype "CIDFontType0C")) (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]) (send* fontFile [write (get-output-bytes (encode-to-port subset))] [end])
(define familyClass (let ([val (if (has-table? (· this font) 'OS/2) (define familyClass (let ([val (if (has-table? font 'OS/2)
(· (get-OS/2-table (· this font)) sFamilyClass) (· (get-OS/2-table font) sFamilyClass)
0)]) 0)])
(floor (/ val 256)))) ; equivalent to >> 8 (floor (/ val 256)))) ; equivalent to >> 8
;; font descriptor flags ;; font descriptor flags
(match-define (list FIXED_PITCH SERIF SYMBOLIC SCRIPT _UNUSED NONSYMBOLIC ITALIC) (match-define (list FIXED_PITCH SERIF SYMBOLIC SCRIPT _UNUSED NONSYMBOLIC ITALIC)
(map (λ (x) (expt 2 x)) (range 7))) (map (λ (x) (expt 2 x)) (range 7)))
(define flags (sum-flags (define flags (sum-flags
[(not (zero? (· (get-post-table (· this font)) isFixedPitch))) FIXED_PITCH] [(not (zero? (· (get-post-table (· this font)) isFixedPitch))) FIXED_PITCH]
[(<= 1 familyClass 7) SERIF] [(<= 1 familyClass 7) SERIF]
[#t SYMBOLIC] ; assume the font uses non-latin characters [#t SYMBOLIC] ; assume the font uses non-latin characters
[(= familyClass 10) SCRIPT] [(= familyClass 10) SCRIPT]
[(· (get-head-table (· this font)) macStyle italic) ITALIC])) [(· (get-head-table (· this font)) macStyle italic) ITALIC]))
;; generate a random tag (6 uppercase letters. 65 is the char code for 'A') ;; generate a random tag (6 uppercase letters. 65 is the char code for 'A')
(when (test-mode) (random-seed 0)) (when (test-mode) (random-seed 0))
(define tag (list->string (for/list ([i (in-range 6)]) (define tag (list->string (for/list ([i (in-range 6)])
(integer->char (random 65 (+ 65 26)))))) (integer->char (random 65 (+ 65 26))))))
(define name (string-append tag "+" (font-postscript-name (· this font)))) (define name (string-append tag "+" (font-postscript-name font)))
(define bbox (font-bbox (· this font))) (define bbox (font-bbox font))
(define descriptor (send (· this document) ref (define descriptor (send 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
(mhash (mhash
'Type "Font" 'Type "FontDescriptor"
'Subtype (string-append "CIDFontType" (if isCFF "0" "2")) 'FontName name
'BaseFont name 'Flags flags
'CIDSystemInfo 'FontBBox (map (λ (x) (* scale x))
(mhash (bbox->list bbox))
'Registry (String "Adobe") 'ItalicAngle (font-italic-angle font)
'Ordering (String "Identity") 'Ascent ascender
'Supplement 0) 'Descent descender
'FontDescriptor descriptor 'CapHeight (* (or (font-cap-height font) (· this sfont ascent)) scale)
'W (list 0 (for/list ([idx (in-range (length (hash-keys (· this widths))))]) 'XHeight (* (or (font-x-height font) 0) scale)
(hash-ref (· this widths) idx (λ () (error 'embed (format "hash key ~a not found" idx))))))))) 'StemV 0)))
(· descendantFont end) (send descriptor set-key! (if isCFF
(send* (· this dictionary) 'FontFile3
[set-key! 'Type "Font"] 'FontFile2) fontFile)
[set-key! 'Subtype "Type0"]
[set-key! 'BaseFont name] (· descriptor end)
[set-key! 'Encoding "Identity-H"]
[set-key! 'DescendantFonts (list descendantFont)] (define descendantFont (send document ref
[set-key! 'ToUnicode (· this toUnicodeCmap)]) (mhash
'Type "Font"
(· this dictionary end)) 'Subtype (string-append "CIDFontType" (if isCFF "0" "2"))
'BaseFont name
'CIDSystemInfo
(define/contract (toUnicodeCmap this) (mhash
(->m (is-a?/c PDFReference)) 'Registry (String "Adobe")
(define cmap (· this document ref)) 'Ordering (String "Identity")
(define entries 'Supplement 0)
(for/list ([idx (in-range (length (hash-keys (· this unicode))))]) 'FontDescriptor descriptor
(define codePoints (hash-ref (· this unicode) idx)) 'W (list 0 (for/list ([idx (in-range (length (hash-keys (· this widths))))])
(define encoded ; encode codePoints to utf16 (hash-ref (· this widths) idx (λ () (error 'embed (format "hash key ~a not found" idx)))))))))
;; todo: full utf16 support. for now just utf8
(for/list ([value (in-list codePoints)]) (· descendantFont end)
(toHex value))) (send* (· this dictionary)
(format "<~a>" (string-join encoded " ")))) [set-key! 'Type "Font"]
[set-key! 'Subtype "Type0"]
(define unicode-cmap-str #<<HERE [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 /CIDInit /ProcSet findresource begin
12 dict begin 12 dict begin
begincmap begincmap
@ -197,19 +201,12 @@ CMapName currentdict /CMap defineresource pop
end end
end end
HERE HERE
) )
(send* cmap [write (format unicode-cmap-str (toHex (sub1 (length entries))) (string-join entries " "))] (send* cmap
[end]) [write (format unicode-cmap-str (toHex (sub1 (length entries))) (string-join entries " "))]
[end])
cmap) 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"))))
(module+ test (module+ test
(require rackunit fontland) (require rackunit fontland)
@ -222,6 +219,4 @@ HERE
(check-equal? (bbox->list (· ef bbox)) '(-161 -236 1193 963)) (check-equal? (bbox->list (· ef bbox)) '(-161 -236 1193 963))
(define H-gid 41) (define H-gid 41)
(check-equal? (· ef widths) (mhash 0 278)) (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 #lang racket/base
(require (require racket/class)
racket/class
racket/contract
sugar/unstable/class
sugar/unstable/js
"reference.rkt")
(provide PDFFont) (provide PDFFont)
(define PDFFont (define PDFFont
(class object% (class object%
(super-new) (super-new)
(field [dictionary #f] (field [(@dictionary dictionary) #f]
[embedded #f]) [@embedded #f]
[(@document document) #f]
[(@line-gap line-gap) #f]
[(@bbox bbox) #f]
[(@ascender ascender) #f]
[(@descender descender) #f])
(as-methods (abstract embed encode widthOfString)
ref
finalize (define/public (ref)
lineHeight))) (unless @dictionary
(set! @dictionary (send @document ref)))
@dictionary)
(define/public (finalize)
(unless (or @embedded (not @dictionary))
(embed)
(set! @embedded #t)))
(define/contract (ref this) (define/public (lineHeight size [includeGap #f])
(->m (is-a?/c PDFReference)) (define gap (if includeGap @line-gap 0))
(unless (· this dictionary) (* (/ (+ @ascender gap (- @descender)) 1000.0) size))))
(set-field! dictionary this (send (· this document) ref)))
(· this dictionary))
(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) (for-syntax racket/base)
racket/class racket/class
racket/file racket/file
racket/contract
sugar/unstable/class
sugar/unstable/js sugar/unstable/js
sugar/unstable/dict sugar/unstable/dict
"afm-font.rkt" "afm-font.rkt"
@ -13,51 +11,46 @@
racket/runtime-path) racket/runtime-path)
(provide isStandardFont standard-fonts StandardFont) (provide isStandardFont standard-fonts StandardFont)
(define-subclass PDFFont (StandardFont document name id) (define StandardFont
(field [font (make-object AFMFont ((hash-ref standard-fonts name (class PDFFont
(λ () (raise-argument-error 'PDFFont "valid font name" name)))))] (super-new)
[ascender (· font ascender)] (init-field document-in name id)
[descender (· font descender)] (field [font (make-object AFMFont
[bbox (· font bbox)] ((hash-ref standard-fonts name
[line-gap (· font line-gap)]) (λ () (raise-argument-error 'PDFFont "valid font name" name)))))])
(as-methods
embed
encode
widthOfString))
(inherit-field ascender descender bbox line-gap dictionary document)
(define/contract (embed this) (set! ascender (· font ascender))
(->m void?) (set! descender (· font descender))
(set-field! payload (· this dictionary) (set! bbox (· font bbox))
(mhash 'Type "Font" (set! line-gap (· font line-gap))
'BaseFont (· this name) (set! document document-in)
'Subtype "Type1"
'Encoding "WinAnsiEncoding"))
(· this dictionary end))
(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]) (define/override (encode text [options #f])
#;((string?) ((or/c hash? #f)) . ->*m . (list/c (listof string?) (listof glyph-position?))) (define encoded (send font encodeText text))
(define this-font (· this font)) (define glyphs (send font glyphsForString text))
(define encoded (send this-font encodeText text)) (define advances (send font advancesForGlyphs glyphs))
(define glyphs (send this-font glyphsForString text)) (define positions
(define advances (send this-font advancesForGlyphs glyphs)) (for/list ([glyph (in-list glyphs)]
(define positions [advance (in-list advances)])
(for/list ([glyph (in-list glyphs)] (+glyph-position advance 0 0 0 (send font widthOfGlyph glyph))))
[advance (in-list advances)]) (list encoded positions))
(+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 (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 (module+ test
(define stdfont (make-object StandardFont #f "Helvetica" #f))) (define stdfont (make-object StandardFont #f "Helvetica" #f)))

Write Preview
Loading…
Cancel
Save