From 294721c74da0efb7f5fe560a67165205bf2e467c Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 29 May 2017 17:28:04 -0700 Subject: [PATCH] resume in embedded: encode --- pitfall/pitfall/embedded.rkt | 25 +++++++- pitfall/pitfall/font.rkt | 63 ++---------------- pitfall/pitfall/fontkit.rkt | 71 +++++++++++++++++---- pitfall/pitfall/fonts.rkt | 8 +-- pitfall/pitfall/{old => }/freetype-ffi.rkt | 15 ++++- pitfall/pitfall/standard-fonts.rkt | 56 +++++++++++++++- pitfall/pitfall/test/test12.rkt | 12 +++- pitfall/pitfall/test/test12crkt.pdf | Bin 1360 -> 693 bytes 8 files changed, 167 insertions(+), 83 deletions(-) rename pitfall/pitfall/{old => }/freetype-ffi.rkt (92%) diff --git a/pitfall/pitfall/embedded.rkt b/pitfall/pitfall/embedded.rkt index 2baed24f..bc03291f 100644 --- a/pitfall/pitfall/embedded.rkt +++ b/pitfall/pitfall/embedded.rkt @@ -2,6 +2,27 @@ (require "font.rkt") (provide EmbeddedFont) -(define-subclass PDFFont (EmbeddedFont document name id) + +(define-subclass PDFFont (EmbeddedFont document font id) (super-new) - 'boing) + (field [name (· font postscriptName)] + [scale (/ 1000 (· font unitsPerEm))] + [ascender (* (· font ascent) scale)] + [descender (* (· font descent) scale)]) + + (as-methods + widthOfString + encode)) + +(define/contract (widthOfString this str size [features #f]) + ((string? number?) ((or/c list? #f)) . ->*m . number?) + #;(define run (send (· this font) layout string)) ; todo: features would be passed here + #;(define width (· run advanceWidth)) + #;(define scale (/ size (· this font unitsPerEm))) + #;(* width scale) + (send (· this font) measure-string str size)) + +;; called from text.rkt +(define/contract (encode this text [features #f]) + ((string?) ((or/c list? #f)) . ->*m . list?) + (report '(0))) \ No newline at end of file diff --git a/pitfall/pitfall/font.rkt b/pitfall/pitfall/font.rkt index 8318a450..44af67a8 100644 --- a/pitfall/pitfall/font.rkt +++ b/pitfall/pitfall/font.rkt @@ -1,6 +1,6 @@ #lang pitfall/racket -(require "standard-fonts.rkt" "afm.rkt" "reference.rkt" "fontkit.rkt") -(provide PDFFont StandardFont) +(require "reference.rkt") +(provide PDFFont) (define PDFFont (class object% @@ -11,9 +11,7 @@ (as-methods ref finalize - lineHeight) - )) - + lineHeight))) (define/contract (ref this) @@ -22,68 +20,17 @@ (set-field! dictionary this (send (· this document) ref))) (· this dictionary)) + (define/contract (finalize this) (->m void?) (unless (or (· this embedded) (not (· this dictionary))) (· 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)) -(define-subclass PDFFont (StandardFont document name id) - (super-new) - (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)] - [lineGap (· font lineGap)]) - (as-methods - embed - encode - widthOfString)) - - -(define/contract (embed this) - (->m void?) - (set-field! payload (· this dictionary) - (mhash 'Type "Font" - 'BaseFont (· this name) - 'Subtype "Type1" - 'Encoding "WinAnsiEncoding")) - (· this dictionary end)) - - -(define/contract (encode this text [options #f]) - ((string?) ((or/c hash? #f)) . ->*m . (list/c (listof string?) (listof hash?))) - (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)]) - (hasheq 'xAdvance advance - 'yAdvance 0 - 'xOffset 0 - 'yOffset 0 - 'advanceWidth (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)) - - -(module+ test - (define stdfont (make-object StandardFont #f "Helvetica" #f))) \ No newline at end of file diff --git a/pitfall/pitfall/fontkit.rkt b/pitfall/pitfall/fontkit.rkt index db6e3243..6f0888f9 100644 --- a/pitfall/pitfall/fontkit.rkt +++ b/pitfall/pitfall/fontkit.rkt @@ -1,8 +1,13 @@ #lang pitfall/racket +(require "freetype-ffi.rkt" racket/runtime-path) (provide (all-defined-out)) -(define-subclass object% (TTFFont buffer) +(define-runtime-path charter-path "test/assets/charter.ttf") + +(define-subclass object% (TTFFont filename) (super-new) + + (field [buffer (file->bytes filename)]) (define (buffer->font buffer) 'made-ttf-font) @@ -13,7 +18,48 @@ (list "true" "OTTO" "\u0\u1\u0\u0")) 'TTF-format)) - (and (probe buffer) (buffer->font buffer))) + (and (probe buffer) (buffer->font buffer)) + + (field [ft-library (FT_Init_FreeType)]) + (field [ft-face (FT_New_Face ft-library charter-path 0)]) + + (as-methods + postscriptName + measure-string + unitsPerEm + ascent + descent)) + +(define/contract (unitsPerEm this) + (->m number?) + (FT_FaceRec-units_per_EM (· this ft-face))) + +(define/contract (ascent this) + (->m number?) + (FT_FaceRec-ascender (· this ft-face))) + +(define/contract (descent this) + (->m number?) + (FT_FaceRec-descender (· this ft-face))) + +(define/contract (postscriptName this) + (->m string?) + (FT_Get_Postscript_Name (· this ft-face))) + + +(define/contract (measure-char-width this char) + (char? . ->m . number?) + (define glyph-idx (FT_Get_Char_Index (· this ft-face) (char->integer char))) + (FT_Load_Glyph (· this ft-face) glyph-idx FT_LOAD_NO_RECURSE) + (define width (FT_Vector-x (FT_GlyphSlotRec-advance (FT_FaceRec-glyph (· this ft-face))))) + (* width 1.0)) + + +(define/contract (measure-string this str size) + (string? number? . ->m . number?) + (/ (* size + (for/sum ([c (in-string str)]) + (measure-char-width this c))) (· this unitsPerEm))) ;; Register font formats @@ -23,25 +69,28 @@ ;;fontkit.registerFormat(TrueTypeCollection); ;; todo ;;fontkit.registerFormat(DFont); ;; todo -(define/contract (create buffer [postscriptName #f]) - ((bytes?) ((or/c string? #f)) . ->* . any/c) +(define/contract (create filename [postscriptName #f]) + ((string?) ((or/c string? #f)) . ->* . any/c) (or (for*/first ([format (in-list formats)] - [font (in-value (make-object format buffer))] + [font (in-value (make-object format filename))] #:when font) (if postscriptName - (send font getFont postscriptName) + (send font getFont postscriptName) ; used to select from collection files like TTC font)) (error 'create "unknown font format"))) (define/contract (openSync filename [postscriptName #f]) ((string?) ((or/c string? #f)) . ->* . any/c) - (define buffer (file->bytes filename)) - (create buffer postscriptName)) + (create filename postscriptName)) (module+ test - (require racket/runtime-path) - (define-runtime-path charter-path "test/assets/charter.ttf") - (openSync (path->string charter-path))) \ No newline at end of file + (require rackunit) + (define f (openSync (path->string charter-path))) + (check-equal? (postscriptName f) "Charter") + (check-equal? (· f unitsPerEm) 1000) + (check-equal? (· f ascent) 980) + (check-equal? (· f descent) -238) + (check-equal? (measure-string f "f" (· f unitsPerEm)) 321.0)) \ No newline at end of file diff --git a/pitfall/pitfall/fonts.rkt b/pitfall/pitfall/fonts.rkt index 8ceeba52..374def62 100644 --- a/pitfall/pitfall/fonts.rkt +++ b/pitfall/pitfall/fonts.rkt @@ -33,7 +33,6 @@ (set-field! _registeredFonts this (mhash)) ;; set the default font - (send this font "Helvetica") (void)) @@ -61,8 +60,7 @@ (cond [(hash-ref (· this _fontFamilies) cacheKey #f) => (λ (val) - (set-field! _font this val) - this)] + (set-field! _font this val))] ;; load the font [else (define id (format "F~a" (increment-field! _fontCount this))) @@ -78,8 +76,8 @@ ;; save the font for reuse later [else (when cacheKey (hash-set! this-ff cacheKey this-f)) - (hash-set! this-ff (· this-f name) this-f)])) - this])) + (hash-set! this-ff (· this-f name) this-f)]))]) + this) (define/contract (fontSize this size) (number? . ->m . object?) diff --git a/pitfall/pitfall/old/freetype-ffi.rkt b/pitfall/pitfall/freetype-ffi.rkt similarity index 92% rename from pitfall/pitfall/old/freetype-ffi.rkt rename to pitfall/pitfall/freetype-ffi.rkt index 1749a904..afbbc1bf 100644 --- a/pitfall/pitfall/old/freetype-ffi.rkt +++ b/pitfall/pitfall/freetype-ffi.rkt @@ -9,7 +9,7 @@ (provide id))) (define-runtime-lib freetype-lib - [(unix) #f] ; todo: get unix runtime path + [(unix) (ffi-lib "libfontconfig" '("1" ""))] [(macosx) (ffi-lib "libfreetype.6.dylib")] [(windows) (ffi-lib "libfreetype-6.dll")]) @@ -215,8 +215,8 @@ -> (if (zero? err) ftf (error 'FT_New_Face (format "error ~a" err))))) (define-freetype FT_Done_Face (_fun _FT_Face - -> (err : _FT_Error) - -> (unless (zero? err) (error 'FT_Done_Face (format "error ~a" err))))) + -> (err : _FT_Error) + -> (unless (zero? err) (error 'FT_Done_Face (format "error ~a" err))))) (define-freetype FT_Done_FreeType (_fun _FT_Library -> (err : _FT_Error) -> (if (zero? err) (void) (error 'FT_Done_FreeType)))) @@ -240,5 +240,14 @@ (define+provide FT_LOAD_LINEAR_DESIGN (expt 2 13)) (define+provide FT_LOAD_NO_RECURSE (expt 2 10)) +(define-freetype FT_Get_Postscript_Name (_fun _FT_Face -> _string)) + +(module+ test + (require rackunit) + (define ft-library (FT_Init_FreeType)) + (define face (FT_New_Face ft-library "test/assets/charter.ttf" 0)) + (check-equal? (FT_Get_Postscript_Name face) "Charter") + (check-equal? (FT_FaceRec-units_per_EM face) 1000)) + diff --git a/pitfall/pitfall/standard-fonts.rkt b/pitfall/pitfall/standard-fonts.rkt index f1e1db2d..b0639b06 100644 --- a/pitfall/pitfall/standard-fonts.rkt +++ b/pitfall/pitfall/standard-fonts.rkt @@ -1,7 +1,61 @@ #lang pitfall/racket +(require "afm.rkt" "font.rkt") (require racket/runtime-path (for-syntax racket/base racket/path racket/syntax sugar/debug)) -(provide isStandardFont standard-fonts) +(provide isStandardFont standard-fonts StandardFont) +(define-subclass PDFFont (StandardFont document name id) + (super-new) + (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)] + [lineGap (· font lineGap)]) + (as-methods + embed + encode + widthOfString)) + + +(define/contract (embed this) + (->m void?) + (set-field! payload (· this dictionary) + (mhash 'Type "Font" + 'BaseFont (· this name) + 'Subtype "Type1" + 'Encoding "WinAnsiEncoding")) + (· this dictionary end)) + + +(define/contract (encode this text [options #f]) + ((string?) ((or/c hash? #f)) . ->*m . (list/c (listof string?) (listof hash?))) + (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)]) + (hasheq 'xAdvance advance + 'yAdvance 0 + 'xOffset 0 + 'yOffset 0 + 'advanceWidth (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)) + + +(module+ test + (define stdfont (make-object StandardFont #f "Helvetica" #f))) (define (isStandardFont name) (hash-ref standard-fonts name #f)) diff --git a/pitfall/pitfall/test/test12.rkt b/pitfall/pitfall/test/test12.rkt index efc26228..5b6794d3 100644 --- a/pitfall/pitfall/test/test12.rkt +++ b/pitfall/pitfall/test/test12.rkt @@ -11,10 +11,16 @@ [font "Charter"] [fontSize 25] [text "Some text with an embedded font" 100 100 (hash - 'width #f)])) + 'width #f)])) (define-runtime-path this "test12rkt.pdf") (make-doc this #f proc #:test #f) -(define-runtime-path that "test12crkt.pdf") -(make-doc that #t proc #:test #f) +#;(define-runtime-path that "test12crkt.pdf") +#;(make-doc that #t proc #:test #f) + +(module+ test + (define doc (make-object PDFDocument)) + (send doc registerFont "Charter" (path->string charter-path)) + (send* doc [font "Charter"]) + #;doc) diff --git a/pitfall/pitfall/test/test12crkt.pdf b/pitfall/pitfall/test/test12crkt.pdf index a26229c24e2bede223f1f77fc9e22d3810e35c5d..f26c03b25e3bd9dd85391dad0450c75ce1ff174b 100644 GIT binary patch delta 187 zcmcb>wUw1mHNeG9*HF)xOZ7hxOlD;anViX}IQayl7n70kWKkw14dW042B%nOg~Ytf zB@^bHW@V7|WRBrV%}XgRDN0Su1+nszvbfA9zha7>yqvj^(R{KLi;T93k)eVC2q@$! zaDf>H2FB(_7-EJNW|KFv2s2tv?qpGAHnK37%*ZOuXf|1nRb0}X%g&CgxFoTtq@pM_ QjmyN`f=gA^)!&T^02$;m2mk;8 literal 1360 zcmaJ>O-vI(6uzM7ikytmh-NNDAj<4)>9!?=*dJOd5Ncavpy9A=hq6+3$nMk>L)2h` zfkY3Qcu+i$c+hx7PhPIy!YmPKeL`>G zdL_?axFi+Hhz(zsIyxk*YluiVGdV#K?ke$knroa&ot+Xjb0Wv@%DtFMpr%pIC)zR2 zGnOyVR-KLGW(lVehDBFdz*QDPqDe}^VP@s1g|afd%0p099Oll(y@oj^;S|+5$`V;d zs@m47_>dAHt$u>kpaRL|5kscQxND!FYoAEy|4@9c+@xkvlOs|dEJbZrv~+5twsIiC zOb+Wd@|NHGXwJ~WtW=&|B?|I8LpkHvC@bKmc7{x9c{hckXNB$#q=}s46$`e z=hkYPKW{!qfoF7~W>K~RGpS-PobXradi*C=lZB`=mtRRg53T`kn3gA#vw4DU~ zvP|ITT!Y|RCxcn2DVfOhBr*^If^$V3IN1s9o&-m(O7pO0Q%6hOO$%2jH*^hDG=W0H z%p-isFhizoR01xm3mfkoIMKnSlj53Qc*w5!v+Vtd#=y9(TJdyE_yQFvS!F~W+% z-j!qHbaNG!EIJ~|h$vE-4e^gupU>+=5KS=a!WG`)N;Ok33G%Y$1`x!QjBpV6oBWn Zag_>kKzy5P7I)|(avPC6p056w^bb}Ngd+d|