resume in missing offset for ref 8

pitfall/pitfall/document.rkt

@@ -157,9 +157,9 @@
   #;(report* (· this _offsets))
 
   (· this _root end)
-  #;(report* (· this _offsets))
+  (report* (· this _offsets))
   (· this _root payload Pages end)
-  #;(report* (· this _offsets))
+  (report* (· this _offsets))
 
   ;; generate xref
   (define xref-offset (· this _offset))

pitfall/pitfall/embedded.rkt

@@ -1,11 +1,13 @@
 #lang pitfall/racket
-(require "font.rkt" "glyph-position.rkt" "glyphrun.rkt" "subset.rkt")
+(require "font.rkt" "glyph-position.rkt" "glyphrun.rkt" "subset.rkt" "reference.rkt")
 (provide EmbeddedFont)
 
 (define-subclass PDFFont (EmbeddedFont document font id)
   (super-new)
   (field [subset (· this font createSubset)]
-         [unicode (mhash 0 0)] ; always include the missing glyph (gid = 0)
+         ;; 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 (send (send (· this font) getGlyph 0) advanceWidth))]
          ;; always include the width of the missing glyph (gid = 0)
          
@@ -19,7 +21,8 @@
   (as-methods
    widthOfString
    encode
-   embed))
+   embed
+   toUnicodeCmap))
 
 (define/contract (widthOfString this str size [features #f])
   ((string? number?) ((or/c list? #f)) . ->*m . number?)
@@ -46,7 +49,7 @@ For now, we'll just measure width of the characters.
       ([(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"))
+      (define subset-idx (toHex gid))
       (set-field! advanceWidth posn (· glyph advanceWidth))
 
       (hash-ref! (· this widths) gid (λ () (· posn advanceWidth)))
@@ -87,8 +90,8 @@ For now, we'll just measure width of the characters.
                             'FontName name
                             'Flags flags
                             'FontBBox (map (curry * (· this scale))
-                                          (list (· bbox minX) (· bbox minY)
-                                           (· bbox maxX) (· bbox maxY)))
+                                           (list (· bbox minX) (· bbox minY)
+                                                 (· bbox maxX) (· bbox maxY)))
                             'ItalicAngle (· this font italicAngle)
                             'Ascent (· this ascender)
                             'Descent (· this descender)
@@ -97,6 +100,7 @@ For now, we'll just measure width of the characters.
                             'StemV 0)))
 
   (· descriptor end)
+  (report (· descriptor toString) 'descriptor-id)
 
   (define descendantFont (send (· this document) ref
                                (mhash
@@ -110,10 +114,10 @@ For now, we'll just measure width of the characters.
                                  '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)))))))))
+                                             (hash-ref (· this widths) idx (λ () (error 'embed (format "hash key ~a not found" idx)))))))))
 
   (· descendantFont end)
-
+  (report (· descendantFont toString) 'descendantFont-id)
   (hash-set*! (· this dictionary payload)
               'Type "Font"
               'Subtype "Type0"
@@ -122,11 +126,52 @@ For now, we'll just measure width of the characters.
               'DescendantFonts (list descendantFont)
               'ToUnicode (· this toUnicodeCmap))
 
-  (· this dictionary end)
-
-  (error 'embed-unfinished)
-  )
-
+  (· 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 " "))))
+
+  (send cmap end @string-append{
+                                /CIDInit /ProcSet findresource begin
+                                         12 dict begin
+                                         begincmap
+                                         /CIDSystemInfo <<
+                                         /Registry (Adobe)
+                                         /Ordering (UCS)
+                                         /Supplement 0
+                                         >> def
+                                         /CMapName /Adobe-Identity-UCS def
+                                         /CMapType 2 def
+                                         1 begincodespacerange
+                                         <0000><ffff>
+                                         endcodespacerange
+                                         1 beginbfrange
+                                         <0000> <@(toHex (sub1 (length entries)))> [@(string-join entries " ")]
+                                         endbfrange
+                                         endcmap
+                                         CMapName currentdict /CMap defineresource pop
+                                         end
+                                         end
+                                         })
+  (report (· cmap toString) 'cmap-id)
+  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"))))
+                 
 
 (module+ test
   (require rackunit "fontkit.rkt" "bbox.rkt")

pitfall/pitfall/fontkit.rkt

@@ -108,13 +108,21 @@
 ;; The height of capital letters above the baseline.
 (define/contract (capHeight this)
   (->m number?)
-  (error 'capHeight-unimplemented))
+  (cond
+    [(send this has-table? #"OS/2")
+     (define os2-table (cast (FT_Get_Sfnt_Table (· this ft-face) 'ft_sfnt_os2) _pointer _FT_TT_OS2-pointer))
+     (FT_TT_OS2-sCapHeight os2-table)]
+    [else (· this ascent)]))
 
 
 ;; The height of lower case letters in the font.
 (define/contract (xHeight this)
   (->m number?)
-  (error 'xheight-unimplemented))
+  (cond
+    [(send this has-table? #"OS/2")
+     (define os2-table (cast (FT_Get_Sfnt_Table (· this ft-face) 'ft_sfnt_os2) _pointer _FT_TT_OS2-pointer))
+     (FT_TT_OS2-sxHeight os2-table)]
+    [else 0]))
 
 
 ;; The font’s bounding box, i.e. the box that encloses all glyphs in the font.

pitfall/pitfall/freetype-ffi.rkt

@@ -227,12 +227,30 @@
 (provide (struct-out FT_TT_Postscript)
          _FT_TT_Postscript _FT_TT_Postscript-pointer)
 
+(define-cstruct _FT_panose
+  ([a _FT_Byte]
+   [b _FT_Byte]
+   [c _FT_Byte]
+   [d _FT_Byte]
+   [e _FT_Byte]
+   [f _FT_Byte]
+   [g _FT_Byte]
+   [h _FT_Byte]
+   [i _FT_Byte]
+   [j _FT_Byte]))
+
+(define-cstruct _FT_VendID
+               ([a _FT_Char]
+                [b _FT_Char]
+                [c _FT_Char]
+                [d _FT_Char]))
+
 (define-cstruct _FT_TT_OS2
   ([version _FT_UShort]
    [xAvgCharWidth _FT_Short]
    [usWeightClass _FT_UShort]
    [usWidthClass _FT_UShort]
-   [fsType _FT_UShort] ; todo: 4 ushorts
+   [fsType _FT_Short] 
    [ySubscriptXSize _FT_Short]
    [ySubscriptYSize _FT_Short]
    [ySubscriptXOffset _FT_Short]
@@ -244,12 +262,12 @@
    [yStrikeoutSize _FT_Short]
    [yStrikeoutPosition _FT_Short]
    [sFamilyClass _FT_Short]
-   [panose _FT_Byte] ; todo: 10 bytes
+   [panose _FT_panose]
    [ulUnicodeRange1 _FT_ULong]
    [ulUnicodeRange2 _FT_ULong]
    [ulUnicodeRange3 _FT_ULong]
    [ulUnicodeRange4 _FT_ULong]
-   [achVendID _FT_Char]
+   [achVendID _FT_VendID]
    [fsSelection _FT_UShort]
    [usFirstCharIndex _FT_UShort]
    [usLastCharIndex _FT_UShort]
@@ -257,7 +275,16 @@
    [sTypoDescender _FT_Short]
    [sTypoLineGap _FT_Short]
    [usWinAscent _FT_UShort]
-   [usWinDescent _FT_UShort]))
+   [usWinDescent _FT_UShort]
+   [ulCodePageRange1 _FT_ULong]
+   [ulCodePageRange2 _FT_ULong]
+   [sxHeight _FT_Short]
+   [sCapHeight _FT_Short]
+   [usDefaultChar _FT_UShort]
+   [usBreakChar _FT_UShort]
+   [usMaxContext _FT_UShort]
+   [usLowerOpticalPointSize _FT_UShort]
+   [usUpperOpticalPointSize _FT_UShort]))
 (provide (struct-out FT_TT_OS2)
          _FT_TT_OS2 _FT_TT_OS2-pointer)
 
@@ -366,6 +393,18 @@
   (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)
 
+  (define os2-table (cast (FT_Get_Sfnt_Table face 'ft_sfnt_os2) _pointer _FT_TT_OS2-pointer))
+  (check-equal? (FT_TT_OS2-fsType os2-table) #b1000)
+  (check-equal? (FT_TT_OS2-yStrikeoutSize os2-table) 61)
+  (check-equal? (FT_TT_OS2-yStrikeoutPosition os2-table) 240)
+
+  (check-equal? (FT_panose->list (FT_TT_OS2-panose os2-table)) '(2 0 5 3 6 0 0 2 0 4))
+
+  (check-equal? (FT_TT_OS2-sTypoAscender os2-table) 762)
+  (check-equal? (FT_TT_OS2-sTypoDescender os2-table) -238)
+  (check-equal? (FT_TT_OS2-sCapHeight os2-table) 671)
+  (check-equal? (FT_TT_OS2-sxHeight os2-table) 481)
+
   (FT_Done_Face face)
   )