start structifying font

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

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)))

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))

pitfall/pitfall/font-open.rkt

@@ -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)]))

pitfall/pitfall/font.rkt

@@ -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))))
-
-
-
-
-

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)

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)

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)))))