diff --git a/pitfall/pitfall/core.rkt b/pitfall/pitfall/core.rkt index aa94e579..2838d32e 100644 --- a/pitfall/pitfall/core.rkt +++ b/pitfall/pitfall/core.rkt @@ -27,6 +27,12 @@ ;; for JPEG and PNG (struct $img (data label width height ref embed-proc) #:transparent #:mutable) +;; for fonts +(struct $font (name id + ascender descender line-gap bbox + dictionary embedded + embed-proc encode-proc string-width-proc) #:transparent #:mutable) + ;; for reference (struct $ref (id payload offset port) #:transparent #:mutable #:methods gen:dict diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index d95a2e52..0bada6a8 100644 --- a/pitfall/pitfall/document.rkt +++ b/pitfall/pitfall/document.rkt @@ -92,9 +92,8 @@ (define doc-info (make-ref ($doc-info doc))) (ref-end doc-info) - - (for ([font (in-hash-values ($doc-font-families doc))]) - (send font end)) + + (for-each font-end (hash-values ($doc-font-families doc))) (define pages-ref (dict-ref ($doc-root doc) 'Pages)) (dict-set! pages-ref 'Count (length ($doc-pages doc))) diff --git a/pitfall/pitfall/embedded.rkt b/pitfall/pitfall/embedded-font.rkt similarity index 99% rename from pitfall/pitfall/embedded.rkt rename to pitfall/pitfall/embedded-font.rkt index bd2a30c9..ae949d5e 100644 --- a/pitfall/pitfall/embedded.rkt +++ b/pitfall/pitfall/embedded-font.rkt @@ -12,7 +12,6 @@ sugar/unstable/dict "font.rkt" fontland) -(provide EmbeddedFont) #| approximates @@ -32,7 +31,7 @@ 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")))) -(define EmbeddedFont +#;(define EmbeddedFont (class PDFFont (init-field font id) (field [subset (create-subset font)] @@ -195,7 +194,7 @@ HERE (ref-end cmap) cmap))) -(module+ test +#;(module+ test (require rackunit fontland sugar/unstable/js) (define f (open-font "../ptest/assets/charter.ttf")) (define ef (make-object EmbeddedFont #f f #f)) diff --git a/pitfall/pitfall/font-open.rkt b/pitfall/pitfall/font-open.rkt deleted file mode 100644 index e1b6e119..00000000 --- a/pitfall/pitfall/font-open.rkt +++ /dev/null @@ -1,20 +0,0 @@ -#lang racket/base -(require - racket/class - "standard-font.rkt" - "font.rkt" - fontland - "embedded.rkt") -(provide PDFFont-open) - -(define (PDFFont-open src family id) - (cond - [(and (string? src) (standard-font? src)) (make-object StandardFont src id)] - [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-object EmbeddedFont font id)])) diff --git a/pitfall/pitfall/font.rkt b/pitfall/pitfall/font.rkt deleted file mode 100644 index 495752ca..00000000 --- a/pitfall/pitfall/font.rkt +++ /dev/null @@ -1,34 +0,0 @@ -#lang racket/base -(require racket/class "reference.rkt") -(provide PDFFont) - -(define PDFFont - (class object% - (super-new) - (init-field [(@ascender ascender) #f] - [(@descender descender) #f] - [(@line-gap line-gap) #f] - [(@bbox bbox) #f]) - (field [(@dictionary dictionary) #f] - [@embedded #f]) - - (abstract embed encode string-width) - - (define/public (make-font-ref) - (unless @dictionary - (set! @dictionary (make-ref))) - @dictionary) - - (define/public (end) - (unless (or @embedded (not @dictionary)) - (embed) - (set! @embedded #t))) - - (define/public (line-height size [include-gap #f]) - (define gap (if include-gap @line-gap 0)) - (* (/ (+ @ascender gap (- @descender)) 1000.0) size)))) - - - - - diff --git a/pitfall/pitfall/fonts.rkt b/pitfall/pitfall/fonts.rkt index 65ca1283..43bd7ed7 100644 --- a/pitfall/pitfall/fonts.rkt +++ b/pitfall/pitfall/fonts.rkt @@ -1,14 +1,47 @@ #lang debug racket/base (require "core.rkt" - racket/class + "reference.rkt" racket/match sugar/unstable/dict - "font-open.rkt") + 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))) + ($font-dictionary font)) + +(define (font-end font) + (unless (or ($font-embedded font) (not ($font-dictionary font))) + (($font-embed-proc font)) + (set-$font-embedded! font #t))) + +(define (line-height font size [include-gap #f]) + (define gap (if include-gap ($font-line-gap font) 0)) + (* (/ (+ ($font-ascender font) gap (- ($font-descender font))) 1000.0) size)) + +(define (PDFFont-open src family id) + (cond + [(and (string? src) (standard-font? src)) (make-standard-font src id)] + #;[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-object EmbeddedFont font id)])) + + (define (current-line-height doc [include-gap #f]) - (send ($doc-current-font doc) line-height ($doc-current-font-size doc) include-gap)) + (line-height ($doc-current-font doc) ($doc-current-font-size doc) include-gap)) (define (font doc src [size-or-family #f] [maybe-size #f]) (match-define (list family size) @@ -36,11 +69,11 @@ (define id (string->symbol (format "F~a" font-index))) (set-$doc-current-font! doc (PDFFont-open src family id)) ;; check for existing font families with the same name already in the PDF - (match (hash-ref ($doc-font-families doc) (get-field name ($doc-current-font doc)) #f) + (match (hash-ref ($doc-font-families doc) ($font-name ($doc-current-font doc)) #f) [(? values font) (set-$doc-current-font! doc font)] [_ ;; save the font for reuse later (when cache-key (hash-set! ($doc-font-families doc) cache-key ($doc-current-font doc))) - (hash-set! ($doc-font-families doc) (get-field name ($doc-current-font doc)) ($doc-current-font doc))])]) + (hash-set! ($doc-font-families doc) ($font-name ($doc-current-font doc)) ($doc-current-font doc))])]) doc) (define (font-size doc size) diff --git a/pitfall/pitfall/standard-font.rkt b/pitfall/pitfall/standard-font.rkt index 39ca4883..80ed614a 100644 --- a/pitfall/pitfall/standard-font.rkt +++ b/pitfall/pitfall/standard-font.rkt @@ -12,72 +12,81 @@ racket/list with-cache) -(provide standard-font? StandardFont) +(provide (all-defined-out)) (define-runtime-path here ".") -(define StandardFont - (class PDFFont - (init-field name id) +(struct $standard-font $font (attributes glyph-widths kern-pairs) #:mutable) - (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)) - (ref-end @dictionary)) +(define (make-standard-font name id) + (match-define (list atts gws kps) (parse-afm (open-input-file (build-path here (format "data/~a.afm" name))))) + [define attributes (make-hasheq atts)] + [define glyph-widths (make-hash gws)] + [define kern-pairs (make-hash kps)] + [define ascender (string->number (hash-ref attributes 'Ascender "0"))] + [define descender (string->number (hash-ref attributes 'Descender "0"))] + [define bbox (for/list ([attr (in-list (string-split (hash-ref attributes 'FontBBox)))]) + (or (string->number attr) 0))] + [define line-gap (- (list-ref bbox 3) (list-ref bbox 1) ascender descender)] + (define new-font + ($standard-font name id ascender descender line-gap bbox + #f ; no dictionary + #f ; not embedded + 'stdfont-embed-placeholder 'stdfont-encode-placeholder 'stdfont-string-width-placeholder + attributes glyph-widths kern-pairs)) + (define (embed-proc) (stdfont-embed new-font)) + (set-$font-embed-proc! new-font embed-proc) + (define (encode-proc str [options #f]) (stdfont-encode new-font str options)) + (set-$font-encode-proc! new-font encode-proc) + (define (string-width-proc str size [options #f]) (stdfont-string-width new-font str size options)) + (set-$font-string-width-proc! new-font string-width-proc) + new-font) + + +(define (stdfont-embed font) + (set-$ref-payload! ($font-dictionary font) + (mhash 'Type 'Font + 'BaseFont (string->symbol ($font-name font)) + 'Subtype 'Type1 + 'Encoding 'WinAnsiEncoding)) + (ref-end ($font-dictionary font))) - (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 (stdfont-encode font str [options #f]) + (define encoded (for/list ([c (in-string str)]) + (define cint (char->integer c)) + (number->string (hash-ref win-ansi-table cint cint) 16))) + (define glyphs (stdfont-glyphs-for-string str)) + (define positions + (for/list ([glyph (in-list glyphs)] + [advance (in-list (advances-for-glyphs font glyphs))]) + (+glyph-position advance 0 0 0 (glyph-width font glyph)))) + (list encoded positions)) - (define/public (glyph-width glyph) - (hash-ref @glyph-widths glyph 0)) +(define (stdfont-string-width font str size [options #f]) + (define glyphs (stdfont-glyphs-for-string str)) + (define width (apply + (advances-for-glyphs font glyphs))) + (define scale (/ size 1000.0)) + (* width scale)) - (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 (glyph-width font glyph) + (hash-ref ($standard-font-glyph-widths font) glyph 0)) - (define/public (get-kern-pair left right) - (hash-ref @kern-pairs (make-kern-table-key left right) 0)) +(define (advances-for-glyphs font glyphs) + (for/list ([left (in-list glyphs)] + [right (in-list (append (cdr glyphs) (list #\nul)))]) + (+ (glyph-width font left) (get-kern-pair font left right)))) - (define/override (encode text [options #f]) - (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-for-glyphs glyphs))]) - (+glyph-position advance 0 0 0 (glyph-width glyph)))) - (list encoded positions)) +(define (get-kern-pair font left right) + (hash-ref ($standard-font-kern-pairs font) (make-kern-table-key left right) 0)) - (define/override (string-width str size [options #f]) - (define glyphs (glyphs-for-string str)) - (define width (apply + (advances-for-glyphs glyphs))) - (define scale (/ size 1000.0)) - (* width scale)))) +(define (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 (stdfont-glyphs-for-string str) + (for/list ([c (in-string str)]) + (character-to-glyph c))) (define standard-fonts (map symbol->string '(Courier-Bold @@ -104,7 +113,7 @@ (check-true (standard-font? "ZapfDingbats")) (check-false (standard-font? "Not A Font Name")) - (define stdfont (make-object StandardFont "Helvetica" #f))) + (define stdfont (make-standard-font "Helvetica" #f))) (define (make-kern-table-key left right) diff --git a/pitfall/pitfall/text.rkt b/pitfall/pitfall/text.rkt index 4a42caab..c14a0d76 100644 --- a/pitfall/pitfall/text.rkt +++ b/pitfall/pitfall/text.rkt @@ -63,12 +63,12 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/mixins/text.coffee (transform doc 1 0 0 -1 0 page-height) (define y (- page-height y-in - (* (/ (get-field ascender ($doc-current-font doc)) 1000) + (* (/ ($font-ascender ($doc-current-font doc)) 1000) ($doc-current-font-size doc)))) ;; add current font to page if necessary - (define current-font-id (get-field id ($doc-current-font doc))) - (hash-ref! (page-fonts (page doc)) current-font-id (λ () (send ($doc-current-font doc) make-font-ref))) + (define current-font-id ($font-id ($doc-current-font doc))) + (hash-ref! (page-fonts (page doc)) current-font-id (λ () (make-font-ref ($doc-current-font doc)))) (add-content doc "BT") ; begin the text object (add-content doc (format "1 0 0 1 ~a ~a Tm" (numberizer x) (numberizer y))) ; text position @@ -83,8 +83,9 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/mixins/text.coffee ;; Add the actual text ;; 180321: the first call to this operation is very slow from Quad ;; 181126: because `encode` calls `layout` + (define encode-proc ($font-encode-proc ($doc-current-font doc))) (match-define (list encoded-char-strs positions) - (map list->vector (send ($doc-current-font doc) encode text (hash-ref options 'features #f)))) + (map list->vector (encode-proc text (hash-ref options 'features #f)))) (define scale (/ ($doc-current-font-size doc) 1000.0)) (define commands empty) @@ -148,5 +149,6 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/mixins/text.coffee (move-down doc #:factor -1)) (define (string-width doc str [options (mhash)]) - (+ (send ($doc-current-font doc) string-width str ($doc-current-font-size doc) (hash-ref options 'features #f)) + (define string-width-proc ($font-string-width-proc ($doc-current-font doc))) + (+ (string-width-proc str ($doc-current-font-size doc) (hash-ref options 'features #f)) (* (hash-ref options 'characterSpacing 0) (sub1 (string-length str)))))