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.
221 lines
8.8 KiB
Racket
221 lines
8.8 KiB
Racket
#lang debug racket/base
|
|
(require "helper.rkt"
|
|
"unsafe/freetype.rkt"
|
|
"glyph.rkt"
|
|
"bbox.rkt"
|
|
"glyphrun.rkt"
|
|
"directory.rkt"
|
|
"woff-directory.rkt"
|
|
"woff2-directory.rkt"
|
|
"struct.rkt"
|
|
"table-stream.rkt"
|
|
"font-path.rkt"
|
|
xenomorph
|
|
racket/match
|
|
racket/list
|
|
racket/string
|
|
sugar/unstable/dict
|
|
"unsafe/harfbuzz.rkt"
|
|
"glyph-position.rkt"
|
|
sugar/list
|
|
racket/promise)
|
|
(provide (all-defined-out))
|
|
|
|
|
|
|
|
(define ft-library (delay (FT_Init_FreeType)))
|
|
|
|
#|
|
|
approximates
|
|
https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
|
|
|#
|
|
|
|
(struct probe-fail exn ())
|
|
|
|
(define (+ttf-font port
|
|
#:directory [directory-class directory]
|
|
#:probe [probe-vals (list #"true" #"OTTO" (bytes 0 1 0 0))]
|
|
#:constructor [structor ttf-font])
|
|
|
|
(unless (input-port? port)
|
|
(raise-argument-error '+ttf-font "input port" port))
|
|
(unless (member (peek-bytes 4 0 port) probe-vals)
|
|
(raise (probe-fail "fail" (current-continuation-marks))))
|
|
|
|
(define decoded-tables (mhash))
|
|
(define src (path->string (object-name port)))
|
|
(define directory (delay (decode directory-class port #:parent (mhash x:start-offset-key 0))))
|
|
(define ft-face (delay (and src (FT_New_Face (force ft-library) src))))
|
|
(define hb-font (delay (and src (hb_ft_font_create (force ft-face)))))
|
|
(define hb-buf (delay (hb_buffer_create)))
|
|
(define crc (equal-hash-code port))
|
|
(define get-head-table-proc #f)
|
|
|
|
(define font
|
|
(structor 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 (get-head-table font)))
|
|
font)
|
|
|
|
(define (font-postscript-name font) (FT_Get_Postscript_Name (ft-face font)))
|
|
(define (font-units-per-em font) (hash-ref (get-head-table font) 'unitsPerEm))
|
|
(define (font-ascent font) (hash-ref (get-hhea-table font) 'ascent))
|
|
(define (font-descent font) (hash-ref (get-hhea-table font) 'descent))
|
|
(define (font-linegap font) (hash-ref (get-hhea-table font) 'lineGap))
|
|
(define (font-underline-position font) (hash-ref (get-post-table font) 'underlinePosition))
|
|
(define (font-underline-thickness font) (hash-ref (get-post-table font) 'underlineThickness))
|
|
(define (font-italic-angle font) (hash-ref (get-post-table font) 'italicAngle))
|
|
|
|
(define (font-cap-height font)
|
|
(cond
|
|
[(and (has-table? font #"OS/2") (hash-ref (get-OS/2-table font) 'capHeight #false))]
|
|
[else (font-ascent font)]))
|
|
|
|
(define (font-x-height font)
|
|
(cond
|
|
[(has-table? font #"OS/2") (hash-ref (get-OS/2-table font) 'xHeight #false)]
|
|
[else 0]))
|
|
|
|
(define (font-bbox font)
|
|
(define head-table (get-head-table font))
|
|
(+bbox (hash-ref head-table 'xMin) (hash-ref head-table 'yMin)
|
|
(hash-ref head-table 'xMax) (hash-ref head-table 'yMax)))
|
|
|
|
|
|
#|
|
|
approximates
|
|
https://github.com/mbutterick/fontkit/blob/master/src/WOFFFont.js
|
|
|#
|
|
|
|
(define (+woff-font port)
|
|
(+ttf-font port
|
|
#:directory woff-directory
|
|
#:probe (list #"wOFF")
|
|
#:constructor woff-font))
|
|
|
|
|
|
#|
|
|
approximates
|
|
https://github.com/mbutterick/fontkit/blob/master/src/WOFF2Font.js
|
|
|#
|
|
|
|
(define (+woff2-font port)
|
|
(+ttf-font port
|
|
#:directory woff2-directory
|
|
#:probe (list #"wOF2")
|
|
#:constructor woff-font))
|
|
|
|
;; 181228: disk-based caching (either with sqlite or `with-cache`) is a loser
|
|
;; reads & writes aren't worth it vs. recomputing
|
|
;; (though this is good news, as it avoids massive disk caches hanging around)
|
|
;; ram cache in pitfall suffices
|
|
|
|
(define (layout font str
|
|
#:features [features null]
|
|
#:script [script #f]
|
|
#:language [lang #f]
|
|
#:direction [direction #f])
|
|
(match (for/list ([c (in-string str)]) (char->integer c))
|
|
[(? null?) (glyphrun (vector) (vector))]
|
|
[codepoints
|
|
(define buf (hb-buf font))
|
|
(hb_buffer_reset buf)
|
|
(when script
|
|
(hb_buffer_set_script buf script))
|
|
(when lang
|
|
(hb_buffer_set_language buf (hb_language_from_string lang)))
|
|
(when direction
|
|
(hb_buffer_set_direction buf direction))
|
|
(hb_buffer_add_codepoints buf codepoints)
|
|
(hb_shape (hb-font font) buf (map (λ (fpr) (tag->hb-feature (car fpr) (cdr fpr))) features))
|
|
(define gis (hb_buffer_get_glyph_infos buf))
|
|
(define hb-gids (map hb_glyph_info_t-codepoint gis))
|
|
;; `remove-duplicates` in case we get a funny codepoint that expands into multiple glyphs (rare but possible)
|
|
(define hb-clusters (break-at codepoints (remove-duplicates (map hb_glyph_info_t-cluster gis) eq?)))
|
|
(define hb-positions (map hb_glyph_position_t->list (hb_buffer_get_glyph_positions buf)))
|
|
(define glyphs (for/vector ([gidx (in-list hb-gids)]
|
|
[cluster (in-list hb-clusters)])
|
|
(get-glyph font gidx cluster)))
|
|
(define positions (for/vector ([posn (in-list hb-positions)])
|
|
(apply +glyph-position posn)))
|
|
(glyphrun glyphs positions)]))
|
|
|
|
|
|
#|
|
|
approximates
|
|
https://github.com/mbutterick/fontkit/blob/master/src/index.js
|
|
|#
|
|
|
|
#|
|
|
approximates
|
|
https://github.com/mbutterick/fontkit/blob/master/src/base.js
|
|
|#
|
|
|
|
|
|
#;(define (query-fontconfig fam [bold #f] [italic #f])
|
|
#|
|
|
https://www.freedesktop.org/software/fontconfig/fontconfig-user.html
|
|
Fontconfig provides a textual representation for patterns that the library can both accept and generate. The representation is in three parts, first a list of family names, second a list of point sizes and finally a list of additional properties:
|
|
<families>-<point sizes>:<name1>=<values1>:<name2>=<values2>...
|
|
|#
|
|
|
|
(define pat-str (string-join (filter values
|
|
(list fam
|
|
(and bold "bold")
|
|
(and italic "italic"))) ":"))
|
|
(define fp (fc-name-parse (string->bytes/utf-8 pat-str)))
|
|
(fc-config-substitute (fc-config-get-current) fp 'FcMatchPattern)
|
|
(fc-default-substitute fp)
|
|
(define-values (res pat) (fc-font-match #f fp))
|
|
(for/hasheq ([str (cdr (string-split (bytes->string/utf-8 (fc-name-unparse pat)) ":"))])
|
|
(let loop ([kv (string-split str "=")])
|
|
(match kv
|
|
[(list k) (loop (list k "True"))]
|
|
[(list k v) (values (string->symbol k)
|
|
(match v
|
|
["True" #t]
|
|
["False" #f]
|
|
[(? string->number) (string->number v)]
|
|
[val val]))]))))
|
|
|
|
(define (open-font str-or-path #:bold [bold #f] #:italic [italic #f])
|
|
;; rather than use a `probe` function,
|
|
;; just try making a font with each format and see what happens
|
|
(define str (if (path? str-or-path) (path->string str-or-path) str-or-path))
|
|
(or
|
|
;; wrapping these in thunks so that they are not evaluated until the iteration demands it
|
|
(for*/or ([path-string-thunk (in-list (list (λ () str)
|
|
(λ () (family->path str #:bold bold #:italic italic))))]
|
|
[path-string (in-value (path-string-thunk))]
|
|
#:when (and path-string (file-exists? path-string))
|
|
[port (in-value (open-input-file path-string))]
|
|
[font-constructor (in-list (list +ttf-font +woff-font))])
|
|
(with-handlers ([probe-fail? (λ (exn) #f)])
|
|
(font-constructor port)))
|
|
(raise-argument-error 'open-font "valid font" str-or-path)))
|
|
|
|
(module+ test
|
|
(require rackunit racket/struct racket/vector)
|
|
(define charter (open-font charter-path))
|
|
(define charter-woff (open-font charter-woff-path))
|
|
(define fira (open-font (path->string fira-path)))
|
|
(define otf (open-font (path->string fira-otf-path)))
|
|
(for ([charter (list charter charter-woff)])
|
|
(check-equal? (font-postscript-name charter) "Charter")
|
|
(check-equal? (font-units-per-em charter) 1000)
|
|
(check-equal? (font-ascent charter) 980)
|
|
(check-equal? (font-descent charter) -238)
|
|
(check-equal? (font-linegap charter) 0)
|
|
(check-equal? (font-underline-thickness charter) 58)
|
|
(check-equal? (font-italic-angle charter) 0)
|
|
(check-equal? (font-cap-height charter) 671)
|
|
(check-equal? (font-x-height charter) 481)
|
|
(check-equal? (bbox->list (font-bbox charter)) '(-161 -236 1193 963))
|
|
(check-equal? (glyph-position-x-advance (vector-ref (glyphrun-positions (layout charter "f")) 0)) 321)
|
|
(check-true (has-table? charter #"cmap"))
|
|
(check-exn exn:fail:contract? (λ () (get-table charter 'nonexistent-table-tag))))
|
|
(check-true
|
|
(let ([gr (layout fira "Rifle")])
|
|
(and (equal? (vector-map glyph-id (glyphrun-glyphs gr)) '#(227 480 732 412))
|
|
(equal? (vector-map struct->list (glyphrun-positions gr)) '#((601 0 0 0 0) (279 0 0 0 0) (580 0 0 0 0) (547 0 0 0 0)))))))
|