resume in embedded: encode

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)))

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)))

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)))
+  (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))

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?)

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))
+
 
          

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))
 

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)