diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index 569a4e03..3e39a2a2 100644 --- a/pitfall/pitfall/document.rkt +++ b/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)) diff --git a/pitfall/pitfall/embedded.rkt b/pitfall/pitfall/embedded.rkt index 09717118..2d94849b 100644 --- a/pitfall/pitfall/embedded.rkt +++ b/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> + 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") diff --git a/pitfall/pitfall/fontkit.rkt b/pitfall/pitfall/fontkit.rkt index f51a5bcd..5946b885 100644 --- a/pitfall/pitfall/fontkit.rkt +++ b/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. diff --git a/pitfall/pitfall/freetype-ffi.rkt b/pitfall/pitfall/freetype-ffi.rkt index 462c75d7..aeaa8237 100644 --- a/pitfall/pitfall/freetype-ffi.rkt +++ b/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) )