diff --git a/pitfall/pitfall/embedded-font.rkt b/pitfall/pitfall/embedded-font.rkt index befe82b7..ae949d5e 100644 --- a/pitfall/pitfall/embedded-font.rkt +++ b/pitfall/pitfall/embedded-font.rkt @@ -3,14 +3,15 @@ (for-syntax racket/base) "core.rkt" "reference.rkt" + racket/class racket/match racket/string racket/format racket/list racket/dict sugar/unstable/dict + "font.rkt" fontland) -(provide make-embedded-font) #| approximates @@ -30,149 +31,142 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/font/embedded.coffee (for/list ([code (in-list codePoints)]) (~r code #:base 16 #:min-width 4 #:pad-string "0")))) -(struct $embedded-font $font (font subset unicode widths scale) #:mutable) - -(define (make-embedded-font font id) - [define subset (create-subset font)] - ;; we make `unicode` and `width` fields integer-keyed hashes not lists - ;; because they offer better random access and growability - [define unicode (mhasheqv 0 '(0))] ; always include the missing glyph (gid = 0) - [define widths (mhasheqv 0 (glyph-advance-width (get-glyph font 0)))] - ;; always include the width of the missing glyph (gid = 0) - [define name (font-postscript-name font)] - [define scale (/ 1000 (font-units-per-em font))] - [define ascender (* (font-ascent font) scale)] - [define descender (* (font-descent font) scale)] - [define bbox (font-bbox font)] - [define line-gap (* (font-linegap font) scale)] - (define new-font - ($embedded-font name id ascender descender line-gap bbox - #f ; no dictionary - #f ; not embedded - 'embfont-embed-placeholder 'embfont-encode-placeholder 'embfont-string-width-placeholder - font subset unicode widths scale)) - (define (embed-proc) (embfont-embed new-font)) - (set-$font-embed-proc! new-font embed-proc) - (define (encode-proc str [options #f]) (embfont-encode new-font str options)) - (set-$font-encode-proc! new-font encode-proc) - (define (string-width-proc str size [options #f]) (embfont-string-width new-font str size options)) - (set-$font-string-width-proc! new-font string-width-proc) - new-font) - -(define (embfont-embed font) - ;; no CFF support - - (define isCFF #false) #;(is-a? subset CFFSubset) - (define font-file (make-ref)) - - (when isCFF - (dict-set! font-file 'Subtype 'CIDFontType0C)) - - (ref-write font-file (get-output-bytes (encode-to-port ($embedded-font-subset font)))) - (ref-end font-file) - - (define family-class (if (has-table? ($embedded-font-font font) 'OS/2) - (floor (/ (hash-ref (get-OS/2-table ($embedded-font-font font)) 'sFamilyClass) 256)) ; >> 8 - 0)) - ;; 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? (hash-ref (get-post-table ($embedded-font-font font)) 'isFixedPitch))) FIXED_PITCH] - [(<= 1 family-class 7) SERIF] - [#t SYMBOLIC] ; assume the font uses non-latin characters - [(= family-class 10) SCRIPT] - [(hash-ref (hash-ref (get-head-table ($embedded-font-font 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->symbol (string-append tag "+" (font-postscript-name ($embedded-font-font font))))) - (define bbox (font-bbox ($embedded-font-font font))) - (define descriptor (make-ref - (mhash - 'Type 'FontDescriptor - 'FontName name - 'Flags flags - 'FontBBox (map (λ (x) (* ($embedded-font-scale font) x)) - (bbox->list bbox)) - 'ItalicAngle (font-italic-angle ($embedded-font-font font)) - 'Ascent ($font-ascender font) - 'Descent ($font-descender font) - 'CapHeight (* (or (font-cap-height ($embedded-font-font font)) (font-ascent ($embedded-font-font font))) ($embedded-font-scale font)) - 'XHeight (* (or (font-x-height ($embedded-font-font font)) 0) ($embedded-font-scale font)) - 'StemV 0))) - - (dict-set! descriptor (if isCFF 'FontFile3 'FontFile2) font-file) - (ref-end descriptor) - - (define descendant-font (make-ref - (mhash - 'Type 'Font - 'Subtype (string->symbol (string-append "CIDFontType" (if isCFF "0" "2"))) - 'BaseFont name - 'CIDSystemInfo - (mhash - 'Registry "Adobe" - 'Ordering "Identity" - 'Supplement 0) - 'FontDescriptor descriptor - 'W (list 0 (for/list ([idx (in-range (length (hash-keys ($embedded-font-widths font))))]) - (hash-ref ($embedded-font-widths font) idx (λ () (error 'embed (format "hash key ~a not found" idx))))))))) - (ref-end descendant-font) +#;(define EmbeddedFont + (class PDFFont + (init-field 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))]) + (super-new [ascender (* (font-ascent font) scale)] + [descender (* (font-descent font) scale)] + [bbox (font-bbox font)] + [line-gap (* (font-linegap font) scale)]) + + (inherit-field [@ascender ascender] + [@descender descender] + [@dictionary dictionary]) + + (define/override (string-width 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> 8 + 0)) + ;; 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? (hash-ref (get-post-table font) 'isFixedPitch))) FIXED_PITCH] + [(<= 1 family-class 7) SERIF] + [#t SYMBOLIC] ; assume the font uses non-latin characters + [(= family-class 10) SCRIPT] + [(hash-ref (hash-ref (get-head-table 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->symbol (string-append tag "+" (font-postscript-name font)))) + (define bbox (font-bbox font)) + (define descriptor (make-ref + (mhash + '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) (font-ascent font)) scale) + 'XHeight (* (or (font-x-height font) 0) scale) + 'StemV 0))) + + (dict-set! descriptor (if isCFF 'FontFile3 'FontFile2) font-file) + (ref-end descriptor) + + (define descendant-font (make-ref + (mhash + 'Type 'Font + 'Subtype (string->symbol (string-append "CIDFontType" (if isCFF "0" "2"))) + 'BaseFont name + 'CIDSystemInfo + (mhash + 'Registry "Adobe" + 'Ordering "Identity" + 'Supplement 0) + 'FontDescriptor descriptor + 'W (list 0 (for/list ([idx (in-range (length (hash-keys widths)))]) + (hash-ref widths idx (λ () (error 'embed (format "hash key ~a not found" idx))))))))) + (ref-end descendant-font) - [dict-set! ($font-dictionary font) 'Type 'Font] - [dict-set! ($font-dictionary font) 'Subtype 'Type0] - [dict-set! ($font-dictionary font) 'BaseFont name] - [dict-set! ($font-dictionary font) 'Encoding 'Identity-H] - [dict-set! ($font-dictionary font) 'DescendantFonts (list descendant-font)] - [dict-set! ($font-dictionary font) 'ToUnicode (to-unicode-cmap font)] - - (ref-end ($font-dictionary font))) - -(define (embfont-encode font text [features #f]) - (define glyphRun (layout ($embedded-font-font 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! ($embedded-font-subset font) (glyph-id g))) - (define subset-idx (to-hex gid)) - (set-glyph-position-advance-width! posn (glyph-advance-width g)) - - (hash-ref! ($embedded-font-widths font) gid (λ () (glyph-position-advance-width posn))) - (hash-ref! ($embedded-font-unicode font) gid (λ () (glyph-codepoints g))) - - (scale-glyph-position! posn ($embedded-font-scale font)) - (values subset-idx posn))) - (list subset-idxs new-positions)) - -(define (embfont-string-width font 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" (string-join encoded " ")))) - - (define unicode-cmap-str #<" (string-join encoded " ")))) + + (define unicode-cmap-str #<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 + (require rackunit fontland sugar/unstable/js) + (define f (open-font "../ptest/assets/charter.ttf")) + (define ef (make-object EmbeddedFont #f f #f)) + (check-equal? (send ef string-width "f" 1000) 321.0) + (check-equal? (· ef ascender) 980) + (check-equal? (· ef descender) -238) + (check-equal? (· ef line-gap) 0) + (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 diff --git a/pitfall/pitfall/fonts.rkt b/pitfall/pitfall/fonts.rkt index 42aa3d1f..43bd7ed7 100644 --- a/pitfall/pitfall/fonts.rkt +++ b/pitfall/pitfall/fonts.rkt @@ -4,12 +4,15 @@ "reference.rkt" racket/match sugar/unstable/dict + racket/class "standard-font.rkt" + "font.rkt" fontland "embedded-font.rkt") (provide (all-defined-out)) + (define (make-font-ref font) (unless ($font-dictionary font) (set-$font-dictionary! font (make-ref))) @@ -27,14 +30,14 @@ (define (PDFFont-open src family id) (cond [(and (string? src) (standard-font? src)) (make-standard-font src id)] - [else + #;[else (define font (cond [(string? src) (open-font src)] [(path? src) (open-font (path->string src))] ;; todo: other font-loading cases [else (raise-argument-error 'PDFFont-open "loadable font thingy" src)])) - (make-embedded-font font id)])) + (make-object EmbeddedFont font id)])) (define (current-line-height doc [include-gap #f]) diff --git a/pitfall/pitfall/standard-font.rkt b/pitfall/pitfall/standard-font.rkt index 19747f8e..80ed614a 100644 --- a/pitfall/pitfall/standard-font.rkt +++ b/pitfall/pitfall/standard-font.rkt @@ -1,8 +1,10 @@ #lang racket/base (require + racket/class racket/string racket/match sugar/unstable/dict + "font.rkt" "core.rkt" "reference.rkt" fontland