From 83d941f57106d4be719fc483e887fa796a0f0edd Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 6 Dec 2018 11:46:57 -0800 Subject: [PATCH] [broken] --- fontland/fontland/font.rkt | 125 +++++++++++++++++------------ fontland/fontland/struct.rkt | 6 ++ fontland/fontland/table-stream.rkt | 13 +-- 3 files changed, 86 insertions(+), 58 deletions(-) create mode 100644 fontland/fontland/struct.rkt diff --git a/fontland/fontland/font.rkt b/fontland/fontland/font.rkt index 0c304e71..f1135ac3 100644 --- a/fontland/fontland/font.rkt +++ b/fontland/fontland/font.rkt @@ -45,61 +45,80 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js ;; (including CFF) ;; It supports TrueType, and PostScript glyphs, and several color glyph formats. +(require "struct.rkt") + (define ft-library (delay (FT_Init_FreeType))) -(define-subclass object% (TTFFont _port) +(define (+TTFFont _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 _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 'TTFFont "input port" _port)) + (raise-argument-error '+TTFFont "input port" _port)) (unless (member (peek-bytes 4 0 _port) (list #"true" #"OTTO" (bytes 0 1 0 0))) (raise 'probe-fail)) + (define f + (TTFFont _port _decoded-tables _src _directory _ft-face _hb-font _hb-buf _crc _get-head-table)) + (set-TTFFont-_get-head-table! f (λ () (get-head-table f))) + f) + +#;(define-subclass object% (TTFFont _port) + (unless (input-port? _port) + (raise-argument-error 'TTFFont "input port" _port)) + (unless (member (peek-bytes 4 0 _port) (list #"true" #"OTTO" (bytes 0 1 0 0))) + (raise 'probe-fail)) - ;; skip variationCoords - (field [_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 (· this ft-face))))] - [_hb-buf (delay (hb_buffer_create))] - [_crc (begin0 (crc32c-input-port _port) (pos _port 0))]) - - ;; needed for `loca` table decoding cross-reference - (define/public (_get-head-table) (get-head-table this)) - - (as-methods - postscriptName - measure-string - unitsPerEm - ascent - descent - lineGap - underlinePosition - underlineThickness - italicAngle - capHeight - xHeight - bbox - createSubset - getGlyph - layout - glyphsForString - glyphForCodePoint - directory - ft-face - hb-font - hb-buf)) - - - (define (directory this) (force (· this _directory))) - (define (ft-face this) (or (force (· this _ft-face)) (error 'ft-face-not-available))) - (define (hb-font this) (or (force (· this _hb-font)) (error 'hb-font-not-available))) - (define (hb-buf this) (force (· this _hb-buf))) + ;; skip variationCoords + (field [_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 (· this ft-face))))] + [_hb-buf (delay (hb_buffer_create))] + [_crc (begin0 (crc32c-input-port _port) (pos _port 0))]) + + ;; needed for `loca` table decoding cross-reference + (define/public (_get-head-table) (get-head-table this)) + + (as-methods + postscriptName + measure-string + unitsPerEm + ascent + descent + lineGap + underlinePosition + underlineThickness + italicAngle + capHeight + xHeight + bbox + createSubset + getGlyph + layout + glyphsForString + glyphForCodePoint + directory + ft-face + hb-font + hb-buf)) + + +(define (directory this) (force (· this _directory))) +(define (ft-face this) (or (force (TTFFont-_ft-face this)) (error 'ft-face-not-available))) +(define (hb-font this) (or (force (· this _hb-font)) (error 'hb-font-not-available))) +(define (hb-buf this) (force (· this _hb-buf))) (require "table-stream.rkt") ;; The unique PostScript name for this font (define/contract (postscriptName this) (->m string?) - (FT_Get_Postscript_Name (· this ft-face))) + (FT_Get_Postscript_Name (ft-face this))) ;; The size of the font’s internal coordinate grid @@ -108,7 +127,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js (· (get-head-table this) unitsPerEm)) (test-module - (check-equal? (· f unitsPerEm) 1000)) + (check-equal? #R (unitsPerEm f) 1000)) ;; The font’s [ascender](https://en.wikipedia.org/wiki/Ascender_(typography)) (define/contract (ascent this) @@ -232,10 +251,10 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js ('hb-positions posns)) (define glyphs (for/list ([gidx (in-list gidxs)] [cluster (in-list clusters)]) - (send this getGlyph gidx cluster))) + (send this getGlyph gidx cluster))) (define positions (for/list ([pos (in-list posns)]) - (match pos - [(list xad yad xoff yoff _) (+glyph-position xad yad xoff yoff)]))) + (match pos + [(list xad yad xoff yoff _) (+glyph-position xad yad xoff yoff)]))) (glyphrun glyphs positions)])) @@ -290,7 +309,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js [(current-layout-caching) (define substrs (for/list ([substr (in-list (regexp-match* " " string #:gap-select? #t))] #:when (positive? (string-length substr))) - substr)) + substr)) (apply append-glyphruns (map (λ (lo) (hb-layout->glyphrun this lo)) (map get-layout substrs)))] [else (if debug (get-layout string) @@ -308,7 +327,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js ;; for now, just use UTF-8 (define codepoints (map char->integer (string->list string))) (for/list ([cp (in-list codepoints)]) - (send this glyphForCodePoint cp))) + (send this glyphForCodePoint cp))) ;; Maps a single unicode code point to a Glyph object. @@ -331,7 +350,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js (string? number? . ->m . number?) (/ (* size (for/sum ([c (in-string str)]) - (measure-char-width this c))) (· this unitsPerEm))) + (measure-char-width this c))) (· this unitsPerEm))) #| @@ -340,7 +359,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/index.js |# ;; Register font formats -(define font-formats (list TTFFont)) +(define font-formats (list +TTFFont)) ;;fontkit.registerFormat(WOFFFont); ;; todo ;;fontkit.registerFormat(WOFF2Font); ;; todo ;;fontkit.registerFormat(TrueTypeCollection); ;; todo @@ -365,8 +384,8 @@ https://github.com/mbutterick/fontkit/blob/master/src/base.js ;; 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)]) - (make-object font-format port))) + (with-handlers ([probe-failed? (λ (exn) #f)]) + (font-format port))) (error 'fontland:create "unknown font format"))) diff --git a/fontland/fontland/struct.rkt b/fontland/fontland/struct.rkt new file mode 100644 index 00000000..9c981bba --- /dev/null +++ b/fontland/fontland/struct.rkt @@ -0,0 +1,6 @@ +#lang debug racket + +(provide (all-defined-out)) + +(struct TTFFont (_port _decoded-tables _src _directory _ft-face _hb-font _hb-buf _crc _get-head-table) + #:transparent #:mutable) diff --git a/fontland/fontland/table-stream.rkt b/fontland/fontland/table-stream.rkt index 60c3900b..f26cf684 100644 --- a/fontland/fontland/table-stream.rkt +++ b/fontland/fontland/table-stream.rkt @@ -2,6 +2,7 @@ (require sugar/unstable/js (only-in xenomorph pos decode) "tables.rkt" + "struct.rkt" (for-syntax "tables.rkt")) (provide (all-defined-out)) @@ -16,7 +17,8 @@ (define (has-table? this tag) #;((or/c bytes? symbol?) . ->m . boolean?) - (hash-has-key? (· this directory tables) (match tag + (define directory (force (TTFFont-_directory this))) + (hash-has-key? (· directory tables) (match tag [(? bytes?) (string->symbol (bytes->string/latin-1 tag))] [_ tag]))) @@ -25,7 +27,7 @@ (define (get-table this table-tag) (unless (has-table? this table-tag) (raise-argument-error 'get-table "table that exists in font" table-tag)) - (hash-ref! (· this _decoded-tables) table-tag (λ () (decode-table this table-tag)))) + (hash-ref! (TTFFont-_decoded-tables this) table-tag (λ () (decode-table this table-tag)))) (define-table-getters) @@ -36,10 +38,11 @@ (define (decode-table this table-tag) (unless (hash-has-key? table-codecs table-tag) (raise-argument-error 'decode-table "decodable table" table-tag)) - (define table (hash-ref (· this directory tables) table-tag)) + (define directory (force (TTFFont-_directory this))) + (define table (hash-ref (· directory tables) table-tag)) ;; todo: possible to avoid copying the bytes here? - (pos (· this _port) (· table offset)) - (define table-bytes (open-input-bytes (peek-bytes (· table length) 0 (· this _port)))) + (pos (TTFFont-_port this) (· table offset)) + (define table-bytes (open-input-bytes (peek-bytes (· table length) 0 (TTFFont-_port this)))) (define table-decoder (hash-ref table-codecs table-tag)) (decode table-decoder table-bytes #:parent this))