From c7918f95044125c998bd60e254465621a36733ae Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sat, 22 Dec 2018 20:35:50 -0800
Subject: [PATCH] carefully

---
 pitfall/pitfall/embedded.rkt      | 313 +++++++++++++++---------------
 pitfall/pitfall/font.rkt          |  48 ++---
 pitfall/pitfall/standard-font.rkt |  77 ++++----
 3 files changed, 210 insertions(+), 228 deletions(-)

diff --git a/pitfall/pitfall/embedded.rkt b/pitfall/pitfall/embedded.rkt
index 48657ee0..fba78e22 100644
--- a/pitfall/pitfall/embedded.rkt
+++ b/pitfall/pitfall/embedded.rkt
@@ -23,159 +23,163 @@ approximates
 https://github.com/mbutterick/pdfkit/blob/master/lib/font/embedded.coffee
 |#
 
-(define-subclass PDFFont (EmbeddedFont document 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))]
-         [ascender (* (font-ascent font) scale)]
-         [descender (* (font-descent font) scale)]
-         [line-gap (* (font-linegap font) scale)]
-         [bbox (font-bbox font)])
-
-  (as-methods
-   widthOfString
-   encode
-   embed
-   toUnicodeCmap))
-
 (define width-cache (make-hash))
-(define (widthOfString this string size [features #f])
-  ((string? number?) ((option/c (listof symbol?))) . ->*m . number?)
-  ; #f disables features ; null enables default features ; list adds features
-  (hash-ref! width-cache
-             (list string size (and features (sort features symbol<?)))
-             (λ ()
-               (define run (layout (· this font) string features))
-               (define width (glyphrun-advance-width run))
-               (define scale (/ size (+ (font-units-per-em (· this font)) 0.0)))
-               (* width scale))))
-
-
-;; called from text.rkt
-(define (encode this text [features #f])
-  (define glyphRun (layout (· this 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! (· this subset) (glyph-id g)))
-      (define subset-idx (toHex gid))
-      (set-glyph-position-advance-width! posn (glyph-advance-width g))
-
-      (hash-ref! (· this widths) gid (λ () (glyph-position-advance-width posn)))
-      (hash-ref! (· this unicode) gid (λ () (glyph-codepoints g)))
-
-      (scale-glyph-position! posn (· this scale))
-      (values subset-idx posn)))
-  (list subset-idxs new-positions))
-
 
 (define-macro (sum-flags [COND VAL] ...)
   #'(for/sum ([c (in-list (list COND ...))]
               [v (in-list (list VAL ...))]
               #:when c)
-             v))
+      v))
 
-(define (embed this)
-  ;; no CFF support
-  (define isCFF #false) #;(is-a? (· this subset) CFFSubset)
-  (define fontFile (· this document ref))
-
-  (when isCFF
-    (send fontFile set-key! 'Subtype "CIDFontType0C"))
+(define (toHex . codePoints)
+  (string-append*
+   (for/list ([code (in-list codePoints)])
+     (~r code #:base 16 #:min-width 4 #:pad-string "0"))))
+
+(define EmbeddedFont
+  (class PDFFont
+    (super-new)
+    (init-field document-in 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))])
+
+    (inherit-field ascender descender bbox line-gap dictionary document)
+
+    (set! ascender (* (font-ascent font) scale))
+    (set! descender (* (font-descent font) scale))
+    (set! line-gap (* (font-linegap font) scale))
+    (set! bbox (font-bbox font))
+    (set! document document-in)
+
+    (define/override (widthOfString 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<?)))
+                 (λ ()
+                   (define run (layout font string features))
+                   (define width (glyphrun-advance-width run))
+                   (define scale (/ size (+ (font-units-per-em font) 0.0)))
+                   (* width scale))))
+
+    ;; called from text.rkt
+    (define/override (encode text [features #f])
+      (define glyphRun (layout 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! subset (glyph-id g)))
+          (define subset-idx (toHex gid))
+          (set-glyph-position-advance-width! posn (glyph-advance-width g))
+
+          (hash-ref! widths gid (λ () (glyph-position-advance-width posn)))
+          (hash-ref! unicode gid (λ () (glyph-codepoints g)))
+
+          (scale-glyph-position! posn scale)
+          (values subset-idx posn)))
+      (list subset-idxs new-positions))
+
+
+    (define/override (embed)
+      ;; no CFF support
+      (define isCFF #false) #;(is-a? (· this subset) CFFSubset)
+      (define fontFile (send document ref))
+
+      (when isCFF
+        (send fontFile set-key! 'Subtype "CIDFontType0C"))
   
-  (send* fontFile [write (get-output-bytes (encode-to-port (· this subset)))] [end])
-
-  (define familyClass (let ([val (if (has-table? (· this font) 'OS/2)
-                                     (· (get-OS/2-table (· this font)) sFamilyClass)
-                                     0)])
-                        (floor (/ val 256)))) ; equivalent to >> 8
-
-  ;; 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? (· (get-post-table (· this font)) isFixedPitch))) FIXED_PITCH]
-                 [(<= 1 familyClass 7) SERIF]
-                 [#t SYMBOLIC] ; assume the font uses non-latin characters
-                 [(= familyClass 10) SCRIPT]
-                 [(· (get-head-table (· this 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-append tag "+" (font-postscript-name (· this font))))
-
-  (define bbox (font-bbox (· this font)))
-  (define descriptor (send (· this document) ref
-                           (mhash
-                            'Type "FontDescriptor"
-                            'FontName name
-                            'Flags flags
-                            'FontBBox (map (λ (x) (* (· this scale) x))
-                                           (bbox->list bbox))
-                            'ItalicAngle (font-italic-angle (· this font))
-                            'Ascent (· this ascender)
-                            'Descent (· this descender)
-                            'CapHeight (* (or (font-cap-height (· this font)) (· this sfont ascent)) (· this scale))
-                            'XHeight (* (or (font-x-height (· this font)) 0) (· this scale))
-                            'StemV 0)))
-
-  (send descriptor set-key! (if isCFF
-                                        'FontFile3
-                                        'FontFile2) fontFile)
-
-  (· descriptor end)
-
-  (define descendantFont (send (· this document) ref
+      (send* fontFile [write (get-output-bytes (encode-to-port subset))] [end])
+
+      (define familyClass (let ([val (if (has-table? font 'OS/2)
+                                         (· (get-OS/2-table font) sFamilyClass)
+                                         0)])
+                            (floor (/ val 256)))) ; equivalent to >> 8
+
+      ;; 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? (· (get-post-table (· this font)) isFixedPitch))) FIXED_PITCH]
+                     [(<= 1 familyClass 7) SERIF]
+                     [#t SYMBOLIC] ; assume the font uses non-latin characters
+                     [(= familyClass 10) SCRIPT]
+                     [(· (get-head-table (· this 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-append tag "+" (font-postscript-name font)))
+
+      (define bbox (font-bbox font))
+      (define descriptor (send document ref
                                (mhash
-                                'Type "Font"
-                                'Subtype (string-append "CIDFontType" (if isCFF "0" "2"))
-                                'BaseFont name
-                                'CIDSystemInfo
-                                (mhash
-                                 'Registry (String "Adobe")
-                                 'Ordering (String "Identity")
-                                 'Supplement 0)
-                                'FontDescriptor descriptor
-                                'W (list 0 (for/list ([idx (in-range (length (hash-keys (· this widths))))])
-                                                     (hash-ref (· this widths) idx (λ () (error 'embed (format "hash key ~a not found" idx)))))))))
-
-  (· descendantFont end)
-  (send* (· this dictionary)
-              [set-key! 'Type "Font"]
-              [set-key! 'Subtype "Type0"]
-              [set-key! 'BaseFont name]
-              [set-key! 'Encoding "Identity-H"]
-              [set-key! 'DescendantFonts (list descendantFont)]
-              [set-key! 'ToUnicode (· this toUnicodeCmap)])
-
-  (· this dictionary end))
-
-
-(define/contract (toUnicodeCmap this)
-  (->m (is-a?/c PDFReference))
-  (define cmap (· this document ref))
-  (define entries
-    (for/list ([idx (in-range (length (hash-keys (· this unicode))))])
-              (define codePoints (hash-ref (· this unicode) idx))
-              (define encoded ; encode codePoints to utf16
-                ;; todo: full utf16 support. for now just utf8
-                (for/list ([value (in-list codePoints)])
-                          (toHex value)))
-              (format "<~a>" (string-join encoded " "))))
-
-  (define unicode-cmap-str #<<HERE
+                                '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) (· this sfont ascent)) scale)
+                                'XHeight (* (or (font-x-height font) 0) scale)
+                                'StemV 0)))
+
+      (send descriptor set-key! (if isCFF
+                                    'FontFile3
+                                    'FontFile2) fontFile)
+
+      (· descriptor end)
+
+      (define descendantFont (send document ref
+                                   (mhash
+                                    'Type "Font"
+                                    'Subtype (string-append "CIDFontType" (if isCFF "0" "2"))
+                                    'BaseFont name
+                                    'CIDSystemInfo
+                                    (mhash
+                                     'Registry (String "Adobe")
+                                     'Ordering (String "Identity")
+                                     'Supplement 0)
+                                    'FontDescriptor descriptor
+                                    'W (list 0 (for/list ([idx (in-range (length (hash-keys (· this widths))))])
+                                                 (hash-ref (· this widths) idx (λ () (error 'embed (format "hash key ~a not found" idx)))))))))
+
+      (· descendantFont end)
+      (send* (· this dictionary)
+        [set-key! 'Type "Font"]
+        [set-key! 'Subtype "Type0"]
+        [set-key! 'BaseFont name]
+        [set-key! 'Encoding "Identity-H"]
+        [set-key! 'DescendantFonts (list descendantFont)]
+        [set-key! 'ToUnicode (· this toUnicodeCmap)])
+
+      (send dictionary end))
+
+
+    (define/public (toUnicodeCmap)
+      (define cmap (· this document ref))
+      (define entries
+        (for/list ([idx (in-range (length (hash-keys (· this unicode))))])
+          (define codePoints (hash-ref (· this unicode) idx))
+          (define encoded ; encode codePoints to utf16
+            ;; todo: full utf16 support. for now just utf8
+            (for/list ([value (in-list codePoints)])
+              (toHex value)))
+          (format "<~a>" (string-join encoded " "))))
+
+      (define unicode-cmap-str #<<HERE
 /CIDInit /ProcSet findresource begin
 12 dict begin
 begincmap
@@ -197,19 +201,12 @@ CMapName currentdict /CMap defineresource pop
 end
 end
 HERE
-    )
+        )
   
-  (send* cmap [write (format unicode-cmap-str (toHex (sub1 (length entries))) (string-join entries " "))]
-    [end])
-                                         
-  cmap)
-
-(define/contract (toHex . codePoints)
-  (() () #:rest (listof number?) . ->*m . string?)
-  (string-append*
-   (for/list ([code (in-list codePoints)])
-             (~r code #:base 16 #:min-width 4 #:pad-string "0"))))
-                 
+      (send* cmap
+        [write (format unicode-cmap-str (toHex (sub1 (length entries))) (string-join entries " "))]
+        [end])                                 
+      cmap)))
 
 (module+ test
   (require rackunit fontland)
@@ -222,6 +219,4 @@ HERE
   (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
+  (check-equal? (glyph-advance-width (get-glyph (· ef font) H-gid)) 738))
\ No newline at end of file
diff --git a/pitfall/pitfall/font.rkt b/pitfall/pitfall/font.rkt
index 8d218b2f..ad244f0b 100644
--- a/pitfall/pitfall/font.rkt
+++ b/pitfall/pitfall/font.rkt
@@ -1,41 +1,35 @@
 #lang racket/base
-(require
-  racket/class
-  racket/contract
-  sugar/unstable/class
-  sugar/unstable/js
-  "reference.rkt")
+(require racket/class)
 (provide PDFFont)
 
 (define PDFFont
   (class object%
     (super-new)
-    (field [dictionary #f]
-           [embedded #f])
+    (field [(@dictionary dictionary) #f]
+           [@embedded #f]
+           [(@document document) #f]
+           [(@line-gap line-gap) #f]
+           [(@bbox bbox) #f]
+           [(@ascender ascender) #f]
+           [(@descender descender) #f])
 
-    (as-methods
-     ref
-     finalize
-     lineHeight)))
+    (abstract embed encode widthOfString)
+    
+    (define/public (ref)
+      (unless @dictionary
+        (set! @dictionary (send @document ref)))
+      @dictionary)
 
+    (define/public (finalize)
+      (unless (or @embedded (not @dictionary))
+        (embed)
+        (set! @embedded #t)))
 
-(define/contract (ref this)
-  (->m (is-a?/c PDFReference))
-  (unless (· this dictionary)
-    (set-field! dictionary this (send (· this document) ref)))
-  (· this dictionary))
+    (define/public (lineHeight size [includeGap #f])
+      (define gap (if includeGap @line-gap 0))
+      (* (/ (+ @ascender gap (- @descender)) 1000.0) size))))
 
 
-(define/contract (finalize this)
-  (->m void?)
-  (unless (or (· this embedded) (not (· this dictionary)))
-    (send this embed)
-    (set-field! embedded this #t)))
 
 
-(define/contract (lineHeight this size [includeGap #f])
-  ((number?)(boolean?) . ->*m . number?)
-  (define gap (if includeGap (· this lineGap) 0))
-  (* (/ (+ (· this ascender) gap (- (· this descender))) 1000.0) size))
-
 
diff --git a/pitfall/pitfall/standard-font.rkt b/pitfall/pitfall/standard-font.rkt
index 4e3c9ca4..b7444e3f 100644
--- a/pitfall/pitfall/standard-font.rkt
+++ b/pitfall/pitfall/standard-font.rkt
@@ -3,8 +3,6 @@
   (for-syntax racket/base)
   racket/class
   racket/file
-  racket/contract
-  sugar/unstable/class
   sugar/unstable/js
   sugar/unstable/dict
   "afm-font.rkt"
@@ -13,51 +11,46 @@
   racket/runtime-path)
 (provide isStandardFont standard-fonts StandardFont)
 
-(define-subclass PDFFont (StandardFont document name id)
-  (field [font (make-object AFMFont ((hash-ref standard-fonts name
-                                               (λ () (raise-argument-error 'PDFFont "valid font name" name)))))]
-         [ascender (· font ascender)]
-         [descender (· font descender)]
-         [bbox (· font bbox)]
-         [line-gap (· font line-gap)])
-  (as-methods
-   embed
-   encode
-   widthOfString))
+(define StandardFont
+  (class PDFFont
+    (super-new)
+    (init-field document-in name id)
+    (field [font (make-object AFMFont
+                   ((hash-ref standard-fonts name
+                              (λ () (raise-argument-error 'PDFFont "valid font name" name)))))])
 
+    (inherit-field ascender descender bbox line-gap dictionary document)
 
-(define/contract (embed this)
-  (->m void?)
-  (set-field! payload (· this dictionary)
-              (mhash 'Type "Font"
-                     'BaseFont (· this name)
-                     'Subtype "Type1"
-                     'Encoding "WinAnsiEncoding"))
-  (· this dictionary end))
+    (set! ascender (· font ascender))
+    (set! descender (· font descender))
+    (set! bbox (· font bbox))
+    (set! line-gap (· font line-gap))
+    (set! document document-in)
 
+    (define/override (embed)
+      (set-field! payload dictionary
+                  (mhash 'Type "Font"
+                         'BaseFont name
+                         'Subtype "Type1"
+                         'Encoding "WinAnsiEncoding"))
+      (· this dictionary end))
 
-(define (encode this text [options #f])
-  #;((string?) ((or/c hash? #f)) . ->*m . (list/c (listof string?) (listof glyph-position?)))
-  (define this-font (· this font))
-  (define encoded (send this-font encodeText text))
-  (define glyphs (send this-font glyphsForString text))
-  (define advances (send this-font advancesForGlyphs glyphs))
-  (define positions
-    (for/list ([glyph (in-list glyphs)]
-               [advance (in-list advances)])
-      (+glyph-position advance 0 0 0 (send this-font widthOfGlyph glyph)))) 
-  (list encoded positions))
-
-
-(define/contract (widthOfString this str size [options #f])
-  ((string? number?) ((or/c hash? #f)) . ->*m . number?)
-  (define this-font (· this font))
-  (define glyphs (send this-font glyphsForString str))
-  (define advances (send this-font advancesForGlyphs glyphs))
-  (define width (apply + advances))
-  (define scale (/ size 1000.0))
-  (* width scale))
+    (define/override (encode text [options #f])
+      (define encoded (send font encodeText text))
+      (define glyphs (send font glyphsForString text))
+      (define advances (send font advancesForGlyphs glyphs))
+      (define positions
+        (for/list ([glyph (in-list glyphs)]
+                   [advance (in-list advances)])
+          (+glyph-position advance 0 0 0 (send font widthOfGlyph glyph)))) 
+      (list encoded positions))
 
+    (define/override (widthOfString str size [options #f])
+      (define glyphs (send font glyphsForString str))
+      (define advances (send font advancesForGlyphs glyphs))
+      (define width (apply + advances))
+      (define scale (/ size 1000.0))
+      (* width scale))))
 
 (module+ test
   (define stdfont (make-object StandardFont #f "Helvetica" #f)))