resume in TT_OS2 struct

pitfall/pitfall/embedded.rkt

@@ -1,12 +1,12 @@
 #lang pitfall/racket
-(require "font.rkt" "glyph-position.rkt" "glyphrun.rkt")
+(require "font.rkt" "glyph-position.rkt" "glyphrun.rkt" "subset.rkt")
 (provide EmbeddedFont)
 
 (define-subclass PDFFont (EmbeddedFont document font id)
   (super-new)
   (field [subset (· this font createSubset)]
-         [unicode '((0))] ; always include the missing glyph (gid = 0)
-         [widths (list (send (send (· this font) getGlyph 0) advanceWidth))]
+         [unicode (mhash 0 0)] ; always include the missing glyph (gid = 0)
+         [widths (mhash 0 (send (send (· this font) getGlyph 0) advanceWidth))]
          ;; always include the width of the missing glyph (gid = 0)
          
          [name (· font postscriptName)]
@@ -18,7 +18,8 @@
 
   (as-methods
    widthOfString
-   encode))
+   encode
+   embed))
 
 (define/contract (widthOfString this str size [features #f])
   ((string? number?) ((or/c list? #f)) . ->*m . number?)
@@ -42,10 +43,89 @@ For now, we'll just measure width of the characters.
   (define positions (· glyphRun positions))
   (define-values (subset-idxs new-positions)
     (for/lists (idxs posns)
-      ([(glyph i) (in-indexed glyphs)])
-      (values i (* i i))))
-  (report (list subset-idxs new-positions))
-  (error 'unimplemented-encode))
+      ([(glyph i) (in-indexed glyphs)]
+       [posn (in-list positions)])
+      (define gid (send (· this subset) includeGlyph (· glyph id)))
+      (define subset-idx (~r gid #:base 16 #:min-width 4 #:pad-string "0"))
+      (set-field! advanceWidth posn (· glyph advanceWidth))
+
+      (hash-ref! (· this widths) gid (λ () (· posn advanceWidth)))
+      (hash-ref! (· this unicode) gid (λ () (· glyph codePoints)))
+
+      (send posn scale (· this scale))
+      (values subset-idx posn)))
+  (list subset-idxs new-positions))
+
+
+(define/contract (embed this)
+  (->m void?)
+  (define isCFF (is-a? (· this subset) CFFSubset))
+  (define fontFile (· this document ref))
+
+  (when isCFF
+    (hash-set! (· fontFile payload) 'Subtype "CIDFontType0C"))
+
+  ;; todo
+  ;; (send (send (· this subset) encodeStream) pipe fontFile)
+
+  ;; todo
+  ;; (define familyClass (send (· this font) has-table? #"OS/2"))
+  (define familyClass 0)
+
+  ;; todo: flags
+  (define flags 0)
+
+  ;; generate a random tag (6 uppercase letters. 65 is the char code for 'A')
+  (define tag (list->string (for/list ([i (in-range 6)])
+                              (integer->char (random 65 (+ 65 26))))))
+  (define name (string-append tag "+" (· this font postscriptName)))
+
+  (define bbox (· this font bbox))
+  (define descriptor (send (· this document) ref
+                           (mhash
+                            'Type "FontDescriptor"
+                            'FontName name
+                            'Flags flags
+                            'FontBBox (map (curry * (· this scale))
+                                          (list (· bbox minX) (· bbox minY)
+                                           (· bbox maxX) (· bbox maxY)))
+                            'ItalicAngle (· this font italicAngle)
+                            'Ascent (· this ascender)
+                            'Descent (· this descender)
+                            'CapHeight (* (or (· this font capHeight) (· this sfont ascent)) (· this scale))
+                            'XHeight (* (or (· this font xHeight) 0) (· this scale))
+                            'StemV 0)))
+
+  (· descriptor end)
+
+  (define descendantFont (send (· this 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 (cons 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)
+
+  (hash-set*! (· this dictionary payload)
+              'Type "Font"
+              'Subtype "Type0"
+              'BaseFont name
+              'Encoding "Identity-H"
+              'DescendantFonts (list descendantFont)
+              'ToUnicode (· this toUnicodeCmap))
+
+  (· this dictionary end)
+
+  (error 'embed-unfinished)
+  )
 
 
 (module+ test
@@ -58,7 +138,7 @@ For now, we'll just measure width of the characters.
   (check-equal? (· ef lineGap) 0)
   (check-equal? (bbox->list (· ef bbox)) '(-161 -236 1193 963))
   (define H-gid 41)
-  (check-equal? (· ef widths) '(278))
+  (check-equal? (· ef widths) (mhash 0 278))
   (check-equal? (send (send (· ef font) getGlyph H-gid) advanceWidth) 738)
-  (send ef encode "foo")
+  
   )

pitfall/pitfall/fontkit.rkt

@@ -36,6 +36,11 @@
    ascent
    descent
    lineGap
+   underlinePosition
+   underlineThickness
+   italicAngle
+   capHeight
+   xHeight
    bbox
    createSubset
    has-table?
@@ -80,6 +85,38 @@
   (FT_HoriHeader-lineGap hhea-table))
 
 
+(define/contract (underlinePosition this)
+  (->m number?)
+  (define post-table (cast (FT_Get_Sfnt_Table (· this ft-face) 'ft_sfnt_post) _pointer _FT_TT_Postscript-pointer))
+  (FT_TT_Postscript-underlinePosition post-table))
+
+
+
+(define/contract (underlineThickness this)
+  (->m number?)
+  (define post-table (cast (FT_Get_Sfnt_Table (· this ft-face) 'ft_sfnt_post) _pointer _FT_TT_Postscript-pointer))
+  (FT_TT_Postscript-underlineThickness post-table))
+
+
+;; If this is an italic font, the angle the cursor should be drawn at to match the font design
+(define/contract (italicAngle this)
+  (->m number?)
+  (define post-table (cast (FT_Get_Sfnt_Table (· this ft-face) 'ft_sfnt_post) _pointer _FT_TT_Postscript-pointer))
+  (FT_TT_Postscript-italicAngle post-table))
+
+
+;; The height of capital letters above the baseline.
+(define/contract (capHeight this)
+  (->m number?)
+  (error 'capHeight-unimplemented))
+
+
+;; The height of lower case letters in the font.
+(define/contract (xHeight this)
+  (->m number?)
+  (error 'xheight-unimplemented))
+
+
 ;; The font’s bounding box, i.e. the box that encloses all glyphs in the font.
 (define/contract (bbox this)
   (->m (is-a?/c BBox))

pitfall/pitfall/freetype-ffi.rkt

@@ -214,6 +214,53 @@
 (provide (struct-out FT_HoriHeader)
          _FT_HoriHeader _FT_HoriHeader-pointer)
 
+(define-cstruct _FT_TT_Postscript
+  ([FormatType _FT_Fixed]
+   [italicAngle _FT_Fixed]
+   [underlinePosition _FT_Short]
+   [underlineThickness _FT_Short]
+   [isFixedPitch _FT_ULong]
+   [minMemType42 _FT_ULong]
+   [maxMemType42 _FT_ULong]
+   [minMemType1 _FT_ULong]
+   [maxMemType1 _FT_ULong]))
+(provide (struct-out FT_TT_Postscript)
+         _FT_TT_Postscript _FT_TT_Postscript-pointer)
+
+(define-cstruct _FT_TT_OS2
+  ([version _FT_UShort]
+   [xAvgCharWidth _FT_Short]
+   [usWeightClass _FT_UShort]
+   [usWidthClass _FT_UShort]
+   [fsType _FT_UShort] ; todo: 4 ushorts
+   [ySubscriptXSize _FT_Short]
+   [ySubscriptYSize _FT_Short]
+   [ySubscriptXOffset _FT_Short]
+   [ySubscriptYOffset _FT_Short]
+   [ySuperscriptXSize _FT_Short]
+   [ySuperscriptYSize _FT_Short]
+   [ySuperscriptXOffset _FT_Short]
+   [ySuperscriptYOffset _FT_Short]
+   [yStrikeoutSize _FT_Short]
+   [yStrikeoutPosition _FT_Short]
+   [sFamilyClass _FT_Short]
+   [panose _FT_Byte] ; todo: 10 bytes
+   [ulUnicodeRange1 _FT_ULong]
+   [ulUnicodeRange2 _FT_ULong]
+   [ulUnicodeRange3 _FT_ULong]
+   [ulUnicodeRange4 _FT_ULong]
+   [achVendID _FT_Char]
+   [fsSelection _FT_UShort]
+   [usFirstCharIndex _FT_UShort]
+   [usLastCharIndex _FT_UShort]
+   [sTypoAscender _FT_Short]
+   [sTypoDescender _FT_Short]
+   [sTypoLineGap _FT_Short]
+   [usWinAscent _FT_UShort]
+   [usWinDescent _FT_UShort]))
+(provide (struct-out FT_TT_OS2)
+         _FT_TT_OS2 _FT_TT_OS2-pointer)
+
 (define _full-path
   (make-ctype _path
               path->complete-path
@@ -299,14 +346,14 @@
   (check-equal? (FT_HoriHeader-lineGap charter-hhea-table) 0)
   (check-equal?
    (let ([bbox (FT_FaceRec-bbox face)])
-        (list (FT_BBox-xMin bbox)
-              (FT_BBox-yMin bbox)
-              (FT_BBox-xMax bbox)
-              (FT_BBox-yMax bbox))) '(-161 -236 1193 963))
+     (list (FT_BBox-xMin bbox)
+           (FT_BBox-yMin bbox)
+           (FT_BBox-xMax bbox)
+           (FT_BBox-yMax bbox))) '(-161 -236 1193 963))
 
   (define H-gid 41)
   (FT_Load_Glyph face H-gid FT_LOAD_NO_RECURSE)
-; want bearingX (lsb) and advanceX (advance width)
+  ; want bearingX (lsb) and advanceX (advance width)
   (define g (FT_FaceRec-glyph face))
   (define metrics (FT_GlyphSlotRec-metrics g))
   (define bearingX (FT_Glyph_Metrics-horiBearingX metrics))
@@ -314,6 +361,11 @@
   (define advanceX (FT_Glyph_Metrics-horiAdvance metrics))
   (check-equal? advanceX 738)
 
+  (define charter-post-table (cast (FT_Get_Sfnt_Table face 'ft_sfnt_post) _pointer _FT_TT_Postscript-pointer))
+  (check-equal? (FT_TT_Postscript-italicAngle charter-post-table) 0)
+  (check-equal? (FT_TT_Postscript-underlinePosition charter-post-table) -178) ; -207 + 1/2 of thickness = -207 + 29
+  (check-equal? (FT_TT_Postscript-underlineThickness charter-post-table) 58)
+
   (FT_Done_Face face)
   )
 

pitfall/pitfall/glyph-position.rkt

@@ -11,6 +11,20 @@
 
                           [xOffset 0]
                           ;; The offset from the pen position in the Y direction at which to render this glyph.
-                          [yOffset 0])
+                          [yOffset 0]
+                          [advanceWidth 0])
   (super-new)
+
+  (as-methods
+   scale)
   )
+
+
+(define/contract (scale this factor)
+  (number? . ->m . (is-a?/c GlyphPosition))
+  (set-field! xAdvance this (* factor (· this xAdvance)))
+  (set-field! yAdvance this (* factor (· this yAdvance)))
+  (set-field! xOffset this (* factor (· this xOffset)))
+  (set-field! yOffset this (* factor (· this xAdvance)))
+  (set-field! advanceWidth this (* factor (· this advanceWidth)))
+  this)

pitfall/pitfall/standard-font.rkt

@@ -36,11 +36,7 @@
   (define positions
     (for/list ([glyph (in-list glyphs)]
                [advance (in-list advances)])
-      (hasheq 'xAdvance advance
-              'yAdvance 0
-              'xOffset 0
-              'yOffset 0
-              'advanceWidth (send this-font widthOfGlyph glyph)))) 
+      (make-object GlyphPosition advance 0 0 0 (send this-font widthOfGlyph glyph)))) 
   (list encoded positions))