diff --git a/fontland/fontland/bbox.rkt b/fontland/fontland/bbox.rkt index b5742b8f..14802de5 100644 --- a/fontland/fontland/bbox.rkt +++ b/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))) diff --git a/fontland/fontland/font.rkt b/fontland/fontland/font.rkt index ca2d5cf2..2abaa371 100644 --- a/fontland/fontland/font.rkt +++ b/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 symbolglyphrun 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))))))) diff --git a/fontland/fontland/glyph.rkt b/fontland/fontland/glyph.rkt index e570e553..f40f21dc 100644 --- a/fontland/fontland/glyph.rkt +++ b/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)) \ No newline at end of file +(define (get-glyph font gid [codepoints null]) + ((if (has-table? font #"cff_") + (error 'cff-fonts-unsupported) + +ttf-glyph) gid codepoints font)) \ No newline at end of file diff --git a/fontland/fontland/glyphrun.rkt b/fontland/fontland/glyphrun.rkt index 48b17870..4353df84 100644 --- a/fontland/fontland/glyphrun.rkt +++ b/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 diff --git a/fontland/fontland/script.rkt b/fontland/fontland/script.rkt index 8619c46e..3c938c28 100644 --- a/fontland/fontland/script.rkt +++ b/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)) \ No newline at end of file diff --git a/fontland/fontland/struct.rkt b/fontland/fontland/struct.rkt index 60c19bf5..64582116 100644 --- a/fontland/fontland/struct.rkt +++ b/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))) \ No newline at end of file diff --git a/fontland/fontland/table/loca.rkt b/fontland/fontland/table/loca.rkt index 7ded01cd..64a78cd4 100644 --- a/fontland/fontland/table/loca.rkt +++ b/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)))))