refacs

fontland/fontland/bbox.rkt

@@ -17,13 +17,14 @@
     (raise-argument-error 'bbox-height "bbox" bb))
   (- (bbox-max-y bb) (bbox-min-y bb)))
 
-(define (bbox-add-point bb x y)
+(define (bbox-add-point! bb x y)
   (unless (bbox? bb)
     (raise-argument-error 'bbox-add-point "bbox" bb))
   (set-bbox-min-x! bb (min x (bbox-min-x bb)))  
   (set-bbox-min-y! bb (min y (bbox-min-y bb)))
   (set-bbox-max-x! bb (max x (bbox-max-x bb)))
-  (set-bbox-max-y! bb (max y (bbox-max-y bb))))
+  (set-bbox-max-y! bb (max y (bbox-max-y bb)))
+  (void))
 
 (define (bbox-copy bb)
   (unless (bbox? bb)
@@ -31,3 +32,13 @@
   (apply +bbox (bbox->list bb)))
 
 (define bbox->list struct->list)
+
+(module+ test
+  (require rackunit)
+  (define bb (+bbox 1 2 4 8))
+  (check-equal? (bbox-width bb) 3)
+  (check-equal? (bbox-height bb) 6)
+  (bbox-add-point! bb 0 0)
+  (check-equal? (bbox-width bb) 4)
+  (check-equal? (bbox-height bb) 8)
+  (check-equal? (bbox->list (bbox-copy bb)) (bbox->list bb)))

fontland/fontland/font.rkt

@@ -1,25 +1,17 @@
 #lang debug racket/base
-(require (for-syntax racket/base)
-         "helper.rkt"
+(require "helper.rkt"
          "unsafe/freetype.rkt"
-         "subset.rkt"
          "glyph.rkt"
-         "ttf-glyph.rkt"
          "bbox.rkt"
          "glyphrun.rkt"
          "directory.rkt"
          "db.rkt"
+         "struct.rkt"
+         "table-stream.rkt"
          xenomorph
-         "tables.rkt"
-         racket/contract
-         racket/class
          racket/match
-         racket/file
-         sugar/unstable/class
-         sugar/unstable/contract
          sugar/unstable/dict
          sugar/unstable/js
-         racket/port
          "unsafe/harfbuzz.rkt"
          "glyph-position.rkt"
          sugar/list
@@ -32,136 +24,70 @@ approximates
 https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
 |#
 
-
-
-
 (test-module
- (define f (openSync (path->string charter-path)))
- (define fira (openSync (path->string fira-path)))
- (define otf (openSync (path->string fira-otf-path)))
- (check-equal? (postscriptName f) "Charter"))
-
-;; This is the base class for all SFNT-based font formats in fontkit.
-;; (including CFF)
-;;  It supports TrueType, and PostScript glyphs, and several color glyph formats.
-
-(require "struct.rkt")
+ (define f (open-font charter-path))
+ (define fira (open-font (path->string fira-path)))
+ (define otf (open-font (path->string fira-otf-path)))
+ (check-equal? (font-postscript-name f) "Charter"))
 
 (define ft-library (delay (FT_Init_FreeType)))
 
-(define (+ttf-font _port [_decoded-tables (mhash)]
-                  [_src (path->string (object-name _port))]
-                  [_directory (delay (decode Directory _port #:parent (mhash '_startOffset 0)))]
-                  [_ft-face (delay (and _src (FT_New_Face (force ft-library) _src)))]
-                  [_hb-font (delay (and _src (hb_ft_font_create (force _ft-face))))]
-                  [_hb-buf (delay (hb_buffer_create))]
-                  [_crc (begin0 (crc32c-input-port _port) (pos _port 0))]
-                  [_get-head-table #f])
-  (unless (input-port? _port)
-    (raise-argument-error '+ttf-font "input port" _port))
-  (unless (member (peek-bytes 4 0 _port) (list #"true" #"OTTO" (bytes 0 1 0 0)))
-    (raise 'probe-fail))
-  (define f
-    (ttf-font _port _decoded-tables _src _directory _ft-face _hb-font _hb-buf _crc _get-head-table))
-  
-    ;; needed for `loca` table decoding cross-reference
-  (set-ttf-font-get-head-table-proc! f (λ () (get-head-table f)))
-  f)
-
-
-(define (directory this) (force (· this _directory)))
-(define (hb-font this) (or (force (ttf-font-hb-font this)) (error 'hb-font-not-available)))
-(define (hb-buf this) (force (ttf-font-hb-buf this)))
-
-(require "table-stream.rkt")
-
-;; The unique PostScript name for this font
-(define (postscriptName this)
-  (FT_Get_Postscript_Name (ft-face this)))
-
-
-;; The size of the font’s internal coordinate grid
-(define (unitsPerEm this)
-  (· (get-head-table this) unitsPerEm))
-
-(test-module
- (check-equal? (unitsPerEm f) 1000))
-
-;; The font’s [ascender](https://en.wikipedia.org/wiki/Ascender_(typography))
-(define (ascent this)
-  (· (get-hhea-table this) ascent))
-
-(test-module
- (check-equal? (ascent f) 980))
-
-
-;; The font’s [descender](https://en.wikipedia.org/wiki/Descender)
-(define (descent this)
-  (· (get-hhea-table this) descent))
-
-(test-module
- (check-equal? (descent f) -238))
-
-;; The amount of space that should be included between lines
-(define (lineGap this)
-  (· (get-hhea-table this) lineGap))
-(define line-gap lineGap) ; todo: avoid this name collision in pitfall/embedded
-
-(test-module
- (check-equal? (lineGap f) 0))
-
-
-(define (underlinePosition this)
-  (· (get-post-table this) underlinePosition))
-
-(test-module
- (check-equal? (underlinePosition f) -178))
-
-
-(define (underlineThickness this)
-  (· (get-post-table this) underlineThickness))
-
-(test-module
- (check-equal? (underlineThickness f) 58))
-
-
-;; If this is an italic font, the angle the cursor should be drawn at to match the font design
-(define (italicAngle this)
-  (· (get-post-table this) italicAngle))
-
-(test-module
- (check-equal? (italicAngle f) 0))
-
-
-;; The height of capital letters above the baseline.
-(define (capHeight this)
-  (if (has-table? this #"OS/2")
-      (· (get-OS/2-table this) capHeight)
-      (ascent this)))
-
-(test-module
- (check-equal? (capHeight f) 671))
-
-
-;; The height of lower case letters in the font.
-(define (xHeight this)
-  (if (has-table? this #"OS/2")
-      (· (get-OS/2-table this) xHeight)
+(define (+ttf-font port
+                   [decoded-tables (mhash)]
+                   [src (path->string (object-name port))]
+                   [directory (delay (decode Directory port #:parent (mhash '_startOffset 0)))]
+                   [ft-face (delay (and src (FT_New_Face (force ft-library) src)))]
+                   [hb-font (delay (and src (hb_ft_font_create (force ft-face))))]
+                   [hb-buf (delay (hb_buffer_create))]
+                   [crc (begin0 (crc32c-input-port port) (pos port 0))]
+                   [get-head-table-proc #f])
+  (unless (input-port? port)
+    (raise-argument-error '+ttf-font "input port" port))
+  (unless (member (peek-bytes 4 0 port) (list #"true" #"OTTO" (bytes 0 1 0 0)))
+    (do-probe-fail!))
+  (define font
+    (ttf-font port decoded-tables src directory ft-face hb-font hb-buf crc get-head-table-proc))
+  ;; needed for `loca` table decoding cross-reference
+  (set-ttf-font-get-head-table-proc! font (delay (dump (get-head-table font))))
+  font)
+
+(define (font-postscript-name font) (FT_Get_Postscript_Name (ft-face font)))
+(define (font-units-per-em font) (· (get-head-table font) unitsPerEm))
+(define (font-ascent font)  (· (get-hhea-table font) ascent))
+(define (font-descent font) (· (get-hhea-table font) descent))
+(define (font-linegap font) (· (get-hhea-table font) lineGap))
+(define (font-underline-position font) (· (get-post-table font) underlinePosition))
+(define (font-underline-thickness font) (· (get-post-table font) underlineThickness))
+(define (font-italic-angle font) (· (get-post-table font) italicAngle))
+
+(define (font-cap-height font)
+  (if (has-table? font #"OS/2")
+      (· (get-OS/2-table font) capHeight)
+      (font-ascent font)))
+
+(define (font-x-height font)
+  (if (has-table? font #"OS/2")
+      (· (get-OS/2-table font) xHeight)
       0))
 
 (test-module
- (check-equal? (xHeight f) 481))
-
-
-;; The font’s bounding box, i.e. the box that encloses all glyphs in the font.
-(define (font-bbox this)
-  (define head-table (get-head-table this))
+ (check-equal? (font-units-per-em f) 1000)
+ (check-equal? (font-ascent f) 980)
+ (check-equal? (font-descent f) -238)
+ (check-equal? (font-linegap f) 0)
+ (check-equal? (font-underline-position f) -178)
+ (check-equal? (font-underline-thickness f) 58)
+ (check-equal? (font-italic-angle f) 0)
+ (check-equal? (font-cap-height f) 671)
+ (check-equal? (font-x-height f) 481))
+
+(define (font-bbox font)
+  (define head-table (get-head-table font))
   (+bbox (· head-table xMin) (· head-table yMin) (· head-table xMax) (· head-table yMax)))
 
 (test-module
  (check-equal? (bbox->list (font-bbox f)) '(-161 -236 1193 963)))
 
-
 (define current-layout-caching (make-parameter #false))
 
 (struct hb-gid (val) #:transparent)
@@ -174,36 +100,31 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
                             'hb-clusters (+Array (+Array uint16 uint16) uint16)
                             'hb-positions (+Array (+Array uint16 5) uint16))))
 
-(define (hb-layout->glyphrun this hbr)
+(define (hb-layout->glyphrun font hbr)
   (match hbr
-    [(hash-table ('hb-gids gidxs)
+    [(hash-table ('hb-gids gids)
                  ('hb-clusters clusters)
                  ('hb-positions posns))
-     (define glyphs (for/list ([gidx (in-list gidxs)]
+     (define glyphs (for/list ([gidx (in-list gids)]
                                [cluster (in-list clusters)])
-                      (get-glyph this gidx cluster)))
-     (define positions (for/list ([pos (in-list posns)])
-                         (match pos
-                           [(list xad yad xoff yoff _) (+glyph-position xad yad xoff yoff)])))
+                      (get-glyph font gidx cluster)))
+     (define positions (for/list ([posn (in-list posns)])
+                         (apply +glyph-position posn)))
      (glyphrun glyphs positions)]))
 
-
-(define (harfbuzz-layout this codepoints userFeatures script language)
-  #;(string? (listof symbol?) symbol? symbol? . ->m . GlyphRun?)
-  (define buf (hb-buf this))
+(define (harfbuzz-layout font codepoints features script language)
+  (define buf (hb-buf font))
   (hb_buffer_reset buf)
   (hb_buffer_add_codepoints buf codepoints)
   (define chars (map hb_glyph_info_t-codepoint (hb_buffer_get_glyph_infos buf)))
-  (hb_shape (hb-font this) buf (map tag->hb-feature (or userFeatures null)))
+  (hb_shape (hb-font font) buf (map tag->hb-feature (or features null)))
   (define gis (hb_buffer_get_glyph_infos buf))
   (dictify 'hb-gids (map hb_glyph_info_t-codepoint gis)
            'hb-clusters (break-at chars (map hb_glyph_info_t-cluster gis))
            'hb-positions (map hb_glyph_position_t->list (hb_buffer_get_glyph_positions buf))))
 
-
 (define layout-cache (make-hasheqv))
 
-(require xenomorph/struct)
 (define hb-input (+Struct (dictify
                            'font-crc uint32
                            'codepoints (+Array uint16)
@@ -217,18 +138,18 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
 
 
 ;; Returns a GlyphRun object, which includes an array of Glyphs and GlyphPositions for the given string.
-(define (layout this string [user-features #f] [script #f] [language #f] #:debug [debug #f])
+(define (layout font string [user-features #f] [script #f] [language #f] #:test [test #f])
   #;((string?) ((option/c (listof symbol?)) (option/c symbol?) (option/c symbol?)) . ->*m . GlyphRun?)
   (define (get-layout string)
     (define codepoints (map char->integer (string->list string)))
     (define args (list codepoints (if user-features (sort user-features symbol<?) null) script language))
-    (define key (apply layout-cache-key (ttf-font-crc this) args))
+    (define key (apply layout-cache-key (ttf-font-crc font) args))
     (hash-ref! layout-cache key
                (λ ()
-                 #;(encode hb-output (apply harfbuzz-layout this args) #f)
+                 #;(encode hb-output (apply harfbuzz-layout font args) #f)
                  (match (get-layout-from-db key)
                    [(? bytes? res) (dump (decode hb-output res))]
-                   [_  (define new-layout (apply harfbuzz-layout this args))
+                   [_  (define new-layout (apply harfbuzz-layout font args))
                        (add-record! (cons key (encode hb-output new-layout #f)))
                        (make-hasheq new-layout)])))) ;; `dump` converts to hash
   ;; work on substrs to reuse cached pieces
@@ -240,45 +161,40 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
      (define substrs (for/list ([substr (in-list (regexp-match* " " string #:gap-select? #t))]
                                 #:when (positive? (string-length substr)))
                        substr))
-     (apply append-glyphruns (map (λ (lo) (hb-layout->glyphrun this lo)) (map get-layout substrs)))]
-    [else (if debug
+     (apply append-glyphruns (map (λ (layout) (hb-layout->glyphrun font layout)) (map get-layout substrs)))]
+    [else (if test
               (get-layout string)
-              (hb-layout->glyphrun this (get-layout string)))]))
+              (hb-layout->glyphrun font (get-layout string)))]))
 
 
 ;; Returns an array of Glyph objects for the given string.
 ;; This is only a one-to-one mapping from characters to glyphs.
 ;; For most uses, you should use font.layout (described below), which
 ;; provides a much more advanced mapping supporting AAT and OpenType shaping.
-(define (glyphsForString this string)
+(define (glyphs-for-string font string)
   #;(string? . ->m . (listof glyph?))
-
   ;; todo: make this handle UTF-16 with surrogate bytes
   ;; for now, just use UTF-8
   (define codepoints (map char->integer (string->list string)))
   (for/list ([cp (in-list codepoints)])
-    (send this glyphForCodePoint cp)))
-
+    (glyph-for-codepoint font cp)))
 
 ;; Maps a single unicode code point to a Glyph object.
 ;; Does not perform any advanced substitutions (there is no context to do so).
-(define (glyph-for-codepoint this codepoint)
-  (define glyph-idx (FT_Get_Char_Index (· this ft-face) codepoint))
-  (get-glyph this glyph-idx (list codepoint)))
-
-
-(define (measure-char-width this char)
-  (define glyph-idx (FT_Get_Char_Index (ft-face this) (char->integer char)))
-  (FT_Load_Glyph (ft-face this) glyph-idx FT_LOAD_NO_RECURSE)
-  (define width (FT_Vector-x (FT_GlyphSlotRec-advance (FT_FaceRec-glyph (ft-face this)))))
+(define (glyph-for-codepoint font codepoint)
+  (define glyph-idx (FT_Get_Char_Index (· font ft-face) codepoint))
+  (get-glyph font glyph-idx (list codepoint)))
+
+(define (measure-char-width font char)
+  (define glyph-idx (FT_Get_Char_Index (ft-face font) (char->integer char)))
+  (FT_Load_Glyph (ft-face font) glyph-idx FT_LOAD_NO_RECURSE)
+  (define width (FT_Vector-x (FT_GlyphSlotRec-advance (FT_FaceRec-glyph (ft-face font)))))
   (* width 1.0))
-  
 
-(define (measure-string this str size)
+(define (measure-string font str size)
   (/ (* size
         (for/sum ([c (in-string str)])
-          (measure-char-width this c))) (unitsPerEm this)))
-
+          (measure-char-width font c))) (font-units-per-em font)))
 
 #|
 approximates
@@ -298,28 +214,29 @@ approximates
 https://github.com/mbutterick/fontkit/blob/master/src/base.js
 |#
 
-(define (openSync str-or-path)
+(define (open-font str-or-path)
   (define filename (if (path? str-or-path) (path->string str-or-path) str-or-path))
-  (create (open-input-file filename)))
+  (create-font (open-input-file filename)))
 
-(define (probe-failed? x) (eq? x 'probe-fail))
+(struct probe-fail exn ())
+(define (do-probe-fail!)
+  (raise (probe-fail "fail" (current-continuation-marks))))
 
-(define (create port)
+(define (create-font port)
   (or
    ;; rather than use a `probe` function,
    ;; just try making a font with each format and see what happens
    (for/first ([font-format (in-list font-formats)])
-     (with-handlers ([probe-failed? (λ (exn) #f)])
+     (with-handlers ([probe-fail? (λ (exn) #f)])
        (font-format port)))
-   (error 'fontland:create "unknown font format")))
-
+   (error 'create-font "unknown font format")))
 
 (test-module
- (check-equal? (measure-string f "f" (unitsPerEm f)) 321.0)
+ (check-equal? (measure-string f "f" (font-units-per-em f)) 321.0)
  (check-true (has-table? f #"cmap"))
  (check-exn exn:fail:contract? (λ () (get-table f 'nonexistent-table-tag)))
  (check-true
-  (let ([h (layout fira "Rifle" #:debug #t)])
+  (let ([h (layout fira "Rifle" #:test #t)])
     (and (equal? (hash-ref h 'hb-gids) '(227 480 732 412))
          (equal? (hash-ref h 'hb-clusters) '((82) (105) (102 108) (101)))
          (equal? (hash-ref h 'hb-positions) '((601 0 0 0 0) (279 0 0 0 0) (580 0 0 0 0) (547 0 0 0 0)))))))

fontland/fontland/glyph.rkt

@@ -1,14 +1,12 @@
 #lang racket/base
 (require (for-syntax)
          sugar/unstable/dict
-         sugar/unstable/js
          "unsafe/freetype.rkt"
+         "table-stream.rkt"
          "struct.rkt"
          "helper.rkt")
 (provide (all-defined-out))
 
-
-
 #|
 approximates
 https://github.com/mbutterick/fontkit/blob/master/src/glyph/Glyph.js
@@ -21,7 +19,6 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/Glyph.js
 ; There are several subclasses of the base Glyph class internally that may be returned depending
 ; on the font format, but they all inherit from this class.
 
-
 (struct glyph (id codepoints font is-mark? is-ligature? metrics) #:transparent #:mutable)
 
 (define (+glyph id codepoints font
@@ -31,11 +28,6 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/Glyph.js
                 #:constructor [constructor glyph])
   (constructor id codepoints font is-mark? is-ligature? metrics))
 
-#;(define-stub-stop _getPath)
-#;(define-stub-stop _getCBox)
-#;(define-stub-stop _getBBox)
-#;(define-stub-stop _getTableMetrics)
-
 (define (glyph-advance-width g)
   (hash-ref (get-glyph-metrics g) 'advanceWidth))
 
@@ -51,22 +43,16 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/Glyph.js
                 'leftBearing (FT_Glyph_Metrics-horiBearingX ft-glyph-metrics)))
   (glyph-metrics g))
 
-
-
 ;; Represents a TrueType glyph.
-
 (struct ttf-glyph glyph () #:transparent)
 
 (define (+ttf-glyph . args)
   (apply +glyph #:constructor ttf-glyph args))
 
-
 ;; Returns a glyph object for the given glyph id.
 ;; You can pass the array of code points this glyph represents for
 ;; your use later, and it will be stored in the glyph object.
-(define (get-glyph this glyph [characters null])
-  ;; no CFF
-  #;(make-object (if (· this has-cff-table?)
-                     CFFGlyph
-                     TTFGlyph) glyph characters this)
-  (+ttf-glyph glyph characters this))
+(define (get-glyph font gid [codepoints null])
+  ((if (has-table? font #"cff_")
+       (error 'cff-fonts-unsupported)
+       +ttf-glyph) gid codepoints font))

fontland/fontland/glyphrun.rkt

@@ -9,7 +9,6 @@ approximates
 https://github.com/mbutterick/fontkit/blob/master/src/layout/GlyphRun.js
 |#
 
-
 ;; Represents a run of Glyph and GlyphPosition objects.
 ;; Returned by the font layout method.
 ; An array of Glyph objects in the run

fontland/fontland/script.rkt

@@ -182,6 +182,5 @@ https://github.com/mbutterick/fontkit/blob/master/src/layout/Script.js
   phlp ;; Psalter Pahlavi
   ))
 
-(define/contract (direction script)
-  ((option/c symbol?) . -> . (or/c 'rtl 'ltr))
+(define (direction script)
   (if (memq script RTL) 'rtl 'ltr))

fontland/fontland/struct.rkt

@@ -5,4 +5,14 @@
 (struct ttf-font (port decoded-tables src directory ft-face hb-font hb-buf crc get-head-table-proc)
   #:transparent #:mutable)
 
-(define (ft-face this) (or (force (ttf-font-ft-face this)) (error 'ft-face-not-available)))
+(define (ft-face this)
+  (or (force (ttf-font-ft-face this)) (error 'ft-face-not-available)))
+
+(define (directory this)
+  (or (force (ttf-font-directory directory))  (error 'directory-not-available)))
+
+(define (hb-font this)
+  (or (force (ttf-font-hb-font this)) (error 'hb-font-not-available)))
+
+(define (hb-buf this)
+  (or (force (ttf-font-hb-buf this)) (error 'hp-buf-not-available)))

fontland/fontland/table/loca.rkt

@@ -5,6 +5,7 @@
          sugar/unstable/dict
          racket/class
          racket/list
+         racket/promise
          "../struct.rkt"
          "../helper.rkt")
 (provide (all-defined-out))
@@ -45,7 +46,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/loca.js
 
 (define loca (+Rloca
               ;; todo: address ugliness to cross-ref head table from ttffont
-              (λ (o) (hash-ref (dump ((ttf-font-get-head-table-proc o))) 'indexToLocFormat)) 
+              (λ (o) (hash-ref (force (ttf-font-get-head-table-proc o)) 'indexToLocFormat)) 
               (dictify
                0 (dictify 'offsets (+Array uint16be))
                1 (dictify 'offsets (+Array uint32be)))))