Revert "start structifying font"

This reverts commit 4a96601654.

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

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

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

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

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

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)

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)

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