You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/fontland/fontland/font.rkt

401 lines
13 KiB
Racket

6 years ago
#lang debug racket/base
6 years ago
(require (for-syntax racket/base)
"helper.rkt"
6 years ago
"unsafe/freetype.rkt"
6 years ago
"subset.rkt"
"glyph.rkt"
"ttf-glyph.rkt"
6 years ago
"bbox.rkt"
"glyphrun.rkt"
6 years ago
"directory.rkt"
6 years ago
"db.rkt"
6 years ago
xenomorph
"tables.rkt"
racket/contract
racket/class
racket/match
racket/file
sugar/unstable/class
sugar/unstable/contract
sugar/unstable/dict
6 years ago
sugar/unstable/js
6 years ago
racket/port
6 years ago
"unsafe/harfbuzz.rkt"
6 years ago
"glyph-position.rkt"
sugar/list
6 years ago
racket/promise
crc32c)
6 years ago
(provide (all-defined-out))
6 years ago
#|
approximates
https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
|#
6 years ago
6 years ago
(test-module
(define f (openSync (path->string charter-path)))
6 years ago
(define fira (openSync (path->string fira-path)))
6 years ago
(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.
6 years ago
6 years ago
(require "struct.rkt")
(define ft-library (delay (FT_Init_FreeType)))
6 years ago
6 years ago
(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])
6 years ago
(unless (input-port? _port)
6 years ago
(raise-argument-error '+TTFFont "input port" _port))
6 years ago
(unless (member (peek-bytes 4 0 _port) (list #"true" #"OTTO" (bytes 0 1 0 0)))
6 years ago
(raise 'probe-fail))
6 years ago
(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))
6 years ago
6 years ago
;; 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)))
6 years ago
6 years ago
(require "table-stream.rkt")
6 years ago
;; The unique PostScript name for this font
(define/contract (postscriptName this)
(->m string?)
6 years ago
(FT_Get_Postscript_Name (ft-face this)))
6 years ago
;; The size of the fonts internal coordinate grid
(define/contract (unitsPerEm this)
(->m number?)
6 years ago
(· (get-head-table this) unitsPerEm))
6 years ago
(test-module
6 years ago
(check-equal? #R (unitsPerEm f) 1000))
6 years ago
;; The fonts [ascender](https://en.wikipedia.org/wiki/Ascender_(typography))
(define/contract (ascent this)
(->m number?)
6 years ago
(· (get-hhea-table this) ascent))
6 years ago
(test-module
(check-equal? (· f ascent) 980))
;; The fonts [descender](https://en.wikipedia.org/wiki/Descender)
(define/contract (descent this)
(->m number?)
6 years ago
(· (get-hhea-table this) descent))
6 years ago
(test-module
(check-equal? (· f descent) -238))
;; The amount of space that should be included between lines
(define/contract (lineGap this)
(->m number?)
6 years ago
(· (get-hhea-table this) lineGap))
6 years ago
(test-module
(check-equal? (· f lineGap) 0))
(define/contract (underlinePosition this)
(->m number?)
6 years ago
(· (get-post-table this) underlinePosition))
6 years ago
(test-module
(check-equal? (· f underlinePosition) -178))
(define/contract (underlineThickness this)
(->m number?)
6 years ago
(· (get-post-table this) underlineThickness))
6 years ago
(test-module
(check-equal? (· f underlineThickness) 58))
;; If this is an italic font, the angle the cursor should be drawn at to match the font design
(define/contract (italicAngle this)
(->m number?)
6 years ago
(· (get-post-table this) italicAngle))
6 years ago
(test-module
(check-equal? (· f italicAngle) 0))
;; The height of capital letters above the baseline.
(define/contract (capHeight this)
(->m number?)
6 years ago
(if (has-table? this #"OS/2")
6 years ago
(· (get-OS/2-table this) capHeight)
6 years ago
(· this ascent)))
(test-module
(check-equal? (· f capHeight) 671))
;; The height of lower case letters in the font.
(define/contract (xHeight this)
(->m number?)
6 years ago
(if (has-table? this #"OS/2")
6 years ago
(· (get-OS/2-table this) xHeight)
6 years ago
0))
(test-module
(check-equal? (· f xHeight) 481))
;; The fonts bounding box, i.e. the box that encloses all glyphs in the font.
(define/contract (bbox this)
6 years ago
(->m BBox?)
6 years ago
(define head-table (get-head-table this))
(make-BBox (· head-table xMin) (· head-table yMin) (· head-table xMax) (· head-table yMax)))
6 years ago
(test-module
(check-equal? (bbox->list (· f bbox)) '(-161 -236 1193 963)))
;; Returns a Subset for this font.
6 years ago
(define (createSubset this)
#;(->m Subset?)
6 years ago
;; no CFF support
#;(make-object (if (· this has-cff-table?)
CFFSubset
TTFSubset) this)
6 years ago
(+ttf-subset this))
6 years ago
;; 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.
6 years ago
(define (getGlyph this glyph [characters null])
#;((index?) ((listof index?)) . ->*m . glyph?)
6 years ago
;; no CFF
#;(make-object (if (· this has-cff-table?)
CFFGlyph
TTFGlyph) glyph characters this)
6 years ago
(+ttf-glyph glyph characters this))
6 years ago
6 years ago
(define current-layout-caching (make-parameter #false))
6 years ago
6 years ago
(struct hb-gid (val) #:transparent)
(struct hb-cluster (chars) #:transparent)
(struct hb-position (xad yad xoff yoff etc) #:transparent)
(struct hb-layout (hb-gids hb-clusters hb-positions) #:transparent)
(define hb-output (+Struct (dictify
'hb-gids (+Array uint16 uint16)
'hb-clusters (+Array (+Array uint16 uint16) uint16)
'hb-positions (+Array (+Array uint16 5) uint16))))
(define (hb-layout->glyphrun this hbr)
(match hbr
[(hash-table ('hb-gids gidxs)
6 years ago
('hb-clusters clusters)
('hb-positions posns))
6 years ago
(define glyphs (for/list ([gidx (in-list gidxs)]
[cluster (in-list clusters)])
6 years ago
(send this getGlyph gidx cluster)))
6 years ago
(define positions (for/list ([pos (in-list posns)])
6 years ago
(match pos
[(list xad yad xoff yoff _) (+glyph-position xad yad xoff yoff)])))
(glyphrun glyphs positions)]))
6 years ago
(define (harfbuzz-layout this codepoints userFeatures script language)
6 years ago
#;(string? (listof symbol?) symbol? symbol? . ->m . GlyphRun?)
6 years ago
(define buf (· this hb-buf))
(hb_buffer_reset buf)
6 years ago
(hb_buffer_add_codepoints buf codepoints)
6 years ago
(define chars (map hb_glyph_info_t-codepoint (hb_buffer_get_glyph_infos buf)))
6 years ago
(hb_shape (· this hb-font) buf (map tag->hb-feature (or userFeatures null)))
6 years ago
(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)
'userFeatures (+Array (+String uint8)))))
(define (layout-cache-key font-crc codepoints user-features . _)
(crc32c-bytes (encode hb-input (dictify
'font-crc font-crc
'codepoints codepoints
'userFeatures user-features) #f)))
6 years ago
6 years ago
;; Returns a GlyphRun object, which includes an array of Glyphs and GlyphPositions for the given string.
6 years ago
(define (layout this string [userFeatures #f] [script #f] [language #f] #:debug [debug #f])
#;((string?) ((option/c (listof symbol?)) (option/c symbol?) (option/c symbol?)) . ->*m . GlyphRun?)
6 years ago
(define (get-layout string)
6 years ago
(define codepoints (map char->integer (string->list string)))
(define args (list codepoints (if userFeatures (sort userFeatures symbol<?) null) script language))
6 years ago
(define key (apply layout-cache-key (· this _crc) args))
(hash-ref! layout-cache key
(λ ()
#;(encode hb-output (apply harfbuzz-layout this args) #f)
(match (get-layout-from-db key)
[(? bytes? res) (dump (decode hb-output res))]
[_ (define new-layout (apply harfbuzz-layout this args))
(add-record! (cons key (encode hb-output new-layout #f)))
(make-hasheq new-layout)])))) ;; `dump` converts to hash
6 years ago
;; work on substrs to reuse cached pieces
;; caveat: no shaping / positioning that involve word spaces
6 years ago
;; todo: why does caching produce slightly different results in test files
;; theory: because word space is not included in shaping
6 years ago
(cond
[(current-layout-caching)
(define substrs (for/list ([substr (in-list (regexp-match* " " string #:gap-select? #t))]
#:when (positive? (string-length substr)))
6 years ago
substr))
6 years ago
(apply append-glyphruns (map (λ (lo) (hb-layout->glyphrun this lo)) (map get-layout substrs)))]
6 years ago
[else (if debug
(get-layout string)
(hb-layout->glyphrun this (get-layout string)))]))
6 years ago
;; 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.
6 years ago
(define (glyphsForString this string)
#;(string? . ->m . (listof glyph?))
6 years ago
;; 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)])
6 years ago
(send this glyphForCodePoint cp)))
6 years ago
;; Maps a single unicode code point to a Glyph object.
;; Does not perform any advanced substitutions (there is no context to do so).
6 years ago
(define (glyphForCodePoint this codePoint)
#;(index? . ->m . glyph?)
6 years ago
(define glyph-idx (FT_Get_Char_Index (· this ft-face) codePoint))
(send this getGlyph glyph-idx (list codePoint)))
(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)])
6 years ago
(measure-char-width this c))) (· this unitsPerEm)))
6 years ago
#|
approximates
https://github.com/mbutterick/fontkit/blob/master/src/index.js
|#
;; Register font formats
6 years ago
(define font-formats (list +TTFFont))
6 years ago
;;fontkit.registerFormat(WOFFFont); ;; todo
;;fontkit.registerFormat(WOFF2Font); ;; todo
;;fontkit.registerFormat(TrueTypeCollection); ;; todo
;;fontkit.registerFormat(DFont); ;; todo
#|
approximates
https://github.com/mbutterick/fontkit/blob/master/src/base.js
|#
6 years ago
(define/contract (openSync str-or-path)
((or/c path? string?) . -> . TTFFont?)
6 years ago
(define filename (if (path? str-or-path) (path->string str-or-path) str-or-path))
6 years ago
(create (open-input-file filename)))
6 years ago
6 years ago
(define (probe-failed? x) (eq? x 'probe-fail))
6 years ago
6 years ago
(define/contract (create port)
(input-port? . -> . TTFFont?)
6 years ago
(or
6 years ago
;; 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)])
6 years ago
(with-handlers ([probe-failed? (λ (exn) #f)])
(font-format port)))
6 years ago
(error 'fontland:create "unknown font format")))
6 years ago
(test-module
(check-equal? (measure-string f "f" (· f unitsPerEm)) 321.0)
6 years ago
(check-true (has-table? f #"cmap"))
6 years ago
(check-exn exn:fail:contract? (λ () (get-table f 'nonexistent-table-tag)))
6 years ago
(check-true
(let ([h (layout fira "Rifle" #:debug #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)))))))