diff --git a/pitfall/pitfall/embedded.rkt b/pitfall/pitfall/embedded.rkt index ff3d2449..09717118 100644 --- a/pitfall/pitfall/embedded.rkt +++ b/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") + ) \ No newline at end of file diff --git a/pitfall/pitfall/fontkit.rkt b/pitfall/pitfall/fontkit.rkt index dc979f32..f51a5bcd 100644 --- a/pitfall/pitfall/fontkit.rkt +++ b/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)) diff --git a/pitfall/pitfall/freetype-ffi.rkt b/pitfall/pitfall/freetype-ffi.rkt index 64ac17b7..462c75d7 100644 --- a/pitfall/pitfall/freetype-ffi.rkt +++ b/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) ) diff --git a/pitfall/pitfall/glyph-position.rkt b/pitfall/pitfall/glyph-position.rkt index 853bc101..04b81bf8 100644 --- a/pitfall/pitfall/glyph-position.rkt +++ b/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) diff --git a/pitfall/pitfall/standard-font.rkt b/pitfall/pitfall/standard-font.rkt index 22129581..f4cd9ade 100644 --- a/pitfall/pitfall/standard-font.rkt +++ b/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))