diff --git a/pitfall/pitfall/core.rkt b/pitfall/pitfall/core.rkt index 2838d32e..aa94e579 100644 --- a/pitfall/pitfall/core.rkt +++ b/pitfall/pitfall/core.rkt @@ -27,12 +27,6 @@ ;; 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 0bada6a8..d95a2e52 100644 --- a/pitfall/pitfall/document.rkt +++ b/pitfall/pitfall/document.rkt @@ -92,8 +92,9 @@ (define doc-info (make-ref ($doc-info doc))) (ref-end doc-info) - - (for-each font-end (hash-values ($doc-font-families doc))) + + (for ([font (in-hash-values ($doc-font-families doc))]) + (send font end)) (define pages-ref (dict-ref ($doc-root doc) 'Pages)) (dict-set! pages-ref 'Count (length ($doc-pages doc))) diff --git a/pitfall/pitfall/embedded-font.rkt b/pitfall/pitfall/embedded.rkt similarity index 99% rename from pitfall/pitfall/embedded-font.rkt rename to pitfall/pitfall/embedded.rkt index ae949d5e..bd2a30c9 100644 --- a/pitfall/pitfall/embedded-font.rkt +++ b/pitfall/pitfall/embedded.rkt @@ -12,6 +12,7 @@ sugar/unstable/dict "font.rkt" fontland) +(provide EmbeddedFont) #| approximates @@ -31,7 +32,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)] @@ -194,7 +195,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 new file mode 100644 index 00000000..e1b6e119 --- /dev/null +++ b/pitfall/pitfall/font-open.rkt @@ -0,0 +1,20 @@ +#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 new file mode 100644 index 00000000..495752ca --- /dev/null +++ b/pitfall/pitfall/font.rkt @@ -0,0 +1,34 @@ +#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 43bd7ed7..65ca1283 100644 --- a/pitfall/pitfall/fonts.rkt +++ b/pitfall/pitfall/fonts.rkt @@ -1,47 +1,14 @@ #lang debug racket/base (require "core.rkt" - "reference.rkt" + racket/class racket/match sugar/unstable/dict - racket/class - "standard-font.rkt" - "font.rkt" - fontland - "embedded-font.rkt") - + "font-open.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]) - (line-height ($doc-current-font doc) ($doc-current-font-size doc) include-gap)) + (send ($doc-current-font doc) line-height ($doc-current-font-size doc) include-gap)) (define (font doc src [size-or-family #f] [maybe-size #f]) (match-define (list family size) @@ -69,11 +36,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) ($font-name ($doc-current-font doc)) #f) + (match (hash-ref ($doc-font-families doc) (get-field 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) ($font-name ($doc-current-font doc)) ($doc-current-font doc))])]) + (hash-set! ($doc-font-families doc) (get-field 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 80ed614a..39ca4883 100644 --- a/pitfall/pitfall/standard-font.rkt +++ b/pitfall/pitfall/standard-font.rkt @@ -12,81 +12,72 @@ racket/list with-cache) -(provide (all-defined-out)) +(provide standard-font? StandardFont) (define-runtime-path here ".") -(struct $standard-font $font (attributes glyph-widths kern-pairs) #:mutable) +(define StandardFont + (class PDFFont + (init-field name id) -(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))) + (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)]) -(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)) + (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])) -(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)) + (inherit-field [@dictionary dictionary]) -(define (glyph-width font glyph) - (hash-ref ($standard-font-glyph-widths font) glyph 0)) + (define/override (embed) + (set-$ref-payload! @dictionary + (mhash 'Type 'Font + 'BaseFont (string->symbol name) + 'Subtype 'Type1 + 'Encoding 'WinAnsiEncoding)) + (ref-end @dictionary)) -(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/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 (get-kern-pair font left right) - (hash-ref ($standard-font-kern-pairs font) (make-kern-table-key left right) 0)) + (define/public (glyph-width glyph) + (hash-ref @glyph-widths glyph 0)) -(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/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/public (get-kern-pair left right) + (hash-ref @kern-pairs (make-kern-table-key left right) 0)) + + (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/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 standard-fonts (map symbol->string '(Courier-Bold @@ -113,7 +104,7 @@ (check-true (standard-font? "ZapfDingbats")) (check-false (standard-font? "Not A Font Name")) - (define stdfont (make-standard-font "Helvetica" #f))) + (define stdfont (make-object StandardFont "Helvetica" #f))) (define (make-kern-table-key left right) diff --git a/pitfall/pitfall/text.rkt b/pitfall/pitfall/text.rkt index c14a0d76..4a42caab 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 - (* (/ ($font-ascender ($doc-current-font doc)) 1000) + (* (/ (get-field ascender ($doc-current-font doc)) 1000) ($doc-current-font-size doc)))) ;; add current font to page if necessary - (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)))) + (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))) (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,9 +83,8 @@ 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 (encode-proc text (hash-ref options 'features #f)))) + (map list->vector (send ($doc-current-font doc) encode text (hash-ref options 'features #f)))) (define scale (/ ($doc-current-font-size doc) 1000.0)) (define commands empty) @@ -149,6 +148,5 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/mixins/text.coffee (move-down doc #:factor -1)) (define (string-width doc str [options (mhash)]) - (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)) + (+ (send ($doc-current-font doc) string-width str ($doc-current-font-size doc) (hash-ref options 'features #f)) (* (hash-ref options 'characterSpacing 0) (sub1 (string-length str)))))