diff --git a/pitfall/pitfall/embedded.rkt b/pitfall/pitfall/embedded.rkt index 48657ee0..fba78e22 100644 --- a/pitfall/pitfall/embedded.rkt +++ b/pitfall/pitfall/embedded.rkt @@ -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> 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 #<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 #<*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) - - ) \ No newline at end of file + (check-equal? (glyph-advance-width (get-glyph (· ef font) H-gid)) 738)) \ No newline at end of file diff --git a/pitfall/pitfall/font.rkt b/pitfall/pitfall/font.rkt index 8d218b2f..ad244f0b 100644 --- a/pitfall/pitfall/font.rkt +++ b/pitfall/pitfall/font.rkt @@ -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)) - diff --git a/pitfall/pitfall/standard-font.rkt b/pitfall/pitfall/standard-font.rkt index 4e3c9ca4..b7444e3f 100644 --- a/pitfall/pitfall/standard-font.rkt +++ b/pitfall/pitfall/standard-font.rkt @@ -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)))