improve font resolution

main
Matthew Butterick 3 years ago
parent 765426d980
commit 4297717f25

@ -17,17 +17,19 @@
(provide (all-defined-out))
(define-runtime-path quad2-fonts-dir "default-fonts")
(define-runtime-path default-font-face "default-fonts/default/SourceSerifPro-Regular.otf")
(define-runtime-path default-font-face "default-fonts/default/regular/SourceSerif4-Regular.otf")
(define-runtime-path default-font-face-b "default-fonts/default/bold/SourceSerif4-Bold.otf")
(define-runtime-path default-font-face-i "default-fonts/default/italic/SourceSerif4-It.otf")
(define-runtime-path default-font-face-bi "default-fonts/default/bold-italic/SourceSerif4-BoldIt.otf")
(define-runtime-path default-math-face "default-fonts/fallback-math/NotoSansMath-Regular.ttf")
(define-runtime-path default-emoji-face "default-fonts/fallback-emoji/NotoEmoji-Regular.ttf")
(define top-font-directory "fonts")
(define font-file-extensions '(#".otf" #".ttf" #".woff" #".woff2"))
(define (fonts-in-directory dir)
(for/list ([font-path (in-directory dir)]
#:when (member (path-get-extension font-path) font-file-extensions))
font-path))
font-path))
(define (setup-font-path-table [base-path (current-directory)])
;; create a table of font paths that we can use to resolve references to font names.
@ -49,47 +51,51 @@
#:when (directory-exists? font-family-subdir)
[fonts-in-this-directory (in-value (fonts-in-directory font-family-subdir))]
[font-path (in-list fonts-in-this-directory)])
(match-define (list font-path-string family-name)
(for/list ([x (list font-path font-family-subdir)])
(path->string (find-relative-path fonts-dir x))))
(define path-parts (for/list ([part (in-list (explode-path (string->path (string-downcase font-path-string))))])
(path->string part)))
(define key
(cons (string-downcase family-name)
(cond
;; special case: if there's only one style in the family directory,
;; treat it as the regular style, regardless of name
[(= (length fonts-in-this-directory) 1) 'r]
;; cases where fonts are in subdirectories named by style
;; infer style from subdir name
[(and (member "bold" path-parts) (member "italic" path-parts)) 'bi]
[(member "bold" path-parts) 'b]
[(member "italic" path-parts) 'i]
[else
;; try to infer from filename alone
;; TODO: what happens when there is no regular style?
(define filename (string-downcase (last path-parts)))
(define filename-contains-bold? (string-contains? filename "bold"))
(define filename-contains-italic? (string-contains? filename "italic"))
(cond
[(and filename-contains-bold? filename-contains-italic?) 'bi]
[filename-contains-bold? 'b]
[filename-contains-italic? 'i]
[else 'r])])))
;; only set value if there's not one there already.
;; this means that we only use the first eligible font we find.
(hash-ref! font-paths key font-path))
(match-define (list font-path-string family-name)
(for/list ([x (list font-path font-family-subdir)])
(path->string (find-relative-path fonts-dir x))))
(define path-parts (for/list ([part (in-list (explode-path (string->path (string-downcase font-path-string))))])
(path->string part)))
(define key
(cons (string-downcase family-name)
(cond
;; special case: if there's only one style in the family directory,
;; treat it as the regular style, regardless of name
[(= (length fonts-in-this-directory) 1) 'r]
;; cases where fonts are in subdirectories named by style
;; infer style from subdir name
[(and (member "bold" path-parts) (member "italic" path-parts)) 'bi]
[(member "bold" path-parts) 'b]
[(member "italic" path-parts) 'i]
[else
;; try to infer from filename alone
;; TODO: what happens when there is no regular style?
(define filename (string-downcase (last path-parts)))
(define filename-contains-bold? (string-contains? filename "bold"))
(define filename-contains-italic? (string-contains? filename "italic"))
(cond
[(and filename-contains-bold? filename-contains-italic?) 'bi]
[filename-contains-bold? 'b]
[filename-contains-italic? 'i]
[else 'r])])))
;; only set value if there's not one there already.
;; this means that we only use the first eligible font we find.
(hash-ref! font-paths key font-path))
font-paths)
(define (make-key font-family [bold #f] [italic #f])
(cons (string-downcase font-family)
(cond
[(and bold italic) 'bi]
[bold 'b]
[italic 'i]
[else 'r])))
(and font-family
(cons (string-downcase font-family)
(cond
[(and bold italic) 'bi]
[bold 'b]
[italic 'i]
[else 'r]))))
(define (font-attrs->path font-paths font-family bold italic)
(define (font-attrs->path font-paths
#:family font-family
#:bold bold
#:italic italic)
;; find the font-path corresponding to a certain family name and style.
(define regular-key (make-key font-family))
@ -104,14 +110,17 @@
(display "(fontconfig lookup unimplemented)")
#;(for* ([bold (in-list (list #false #true))]
[italic (in-list (list #false #true))])
(hash-set! font-paths
(make-key font-family bold italic)
(family->path font-family #:bold bold #:italic italic))))
(hash-set! font-paths
(make-key font-family bold italic)
(family->path font-family #:bold bold #:italic italic))))
(cond
[(hash-ref font-paths (make-key font-family bold italic) #false)]
;; try regular style if style-specific key isn't there for b i or bi
[(and (or bold italic) (hash-ref font-paths regular-key #false))]
;; otherwise use default
[(and bold italic) default-font-face-bi]
[bold default-font-face-b]
[italic default-font-face-i]
[else default-font-face]))
(define (font-path-string? x)
@ -119,38 +128,46 @@
(member (path-get-extension (string->path x)) font-file-extensions)
#true))
(define font-family-attr-keys (list :font-family :font-bold :font-italic))
(define (quad-without-font-family-attrs? x)
(and (quad? x) (for/and ([ak (in-list font-family-attr-keys)])
(not (quad-ref x ak #false)))))
(define-pass (resolve-font-paths qs)
;; convert references to a font family and style to an font path on disk
;; we trust it exists because we used `setup-font-path-table!` earlier,
;; but if not, fallback fonts will kick in, on the idea that a missing font shouldn't stop the show
#:pre (list-of quad?)
#:post (list-of quad?)
;; once we have a font path we don't need the family, bold, or italic keys
;; because they just exist to help select a font path
#:post (list-of quad-without-font-family-attrs?)
(define font-paths (setup-font-path-table))
(define (resolve-font-path font-paths attrs)
(define (resolve-font-path attrs)
;; convert references to a font family and style to an font path on disk
;; we trust it exists because we used `setup-font-path-table` earlier,
;; but if not, fallback fonts will kick in, on the idea that a missing font shouldn't stop the show
;; we know we have :font-family because this pass is restricted to that key
(match (hash-ref attrs :font-family)
[(? font-path-string? ps) (path->complete-path ps)]
[this-font-family
(define this-bold (hash-ref attrs :font-bold (λ () (error 'need-default-font-bold))))
(define this-italic (hash-ref attrs :font-italic (λ () (error 'need-default-font-italic))))
(font-attrs->path font-paths this-font-family this-bold this-italic)]))
(hash-ref! attrs :font-path
(λ ()
(font-attrs->path font-paths
#:family (hash-ref attrs :font-family #false)
#:bold (hash-ref attrs :font-bold #false)
#:italic (hash-ref attrs :font-italic #false))))
(for ([key font-family-attr-keys])
(hash-remove! attrs key)))
(do-attr-iteration qs
#:which-attr :font-family
#:attr-proc (λ (_ __ attrs) (resolve-font-path font-paths attrs))))
(for-each-attrs qs resolve-font-path))
(define (resolved-font-for-family val #:bold [bold #f] #:italic [italic #f])
(define qs (list (make-quad #:attrs (make-hasheq
(list (cons :font-family (string-downcase val))
(cons :font-bold bold)
(cons :font-italic italic))))))
(last (explode-path (quad-ref (car (resolve-font-paths qs)) :font-family))))
(define qs (list (make-quad
#:attrs (make-hasheq
(list (cons :font-family (string-downcase val))
(cons :font-bold bold)
(cons :font-italic italic)))
#:elems null)))
(last (explode-path (quad-ref (car (resolve-font-paths qs)) :font-path))))
(define (parse-em pstr)
(define em-suffix "em")
@ -192,7 +209,9 @@
(check-equal? (resolved-font-for-family "Heading") (build-path "fira-sans-light.otf"))
(check-equal? (resolved-font-for-family "CODE") (build-path "fira-mono.otf"))
(check-equal? (resolved-font-for-family "blockquote" #:bold #t) (build-path "fira-sans-bold.otf"))
(check-equal? (resolved-font-for-family "nonexistent-fam") (build-path "SourceSerifPro-Regular.otf")))
(check-equal? (resolved-font-for-family "nonexistent-fam") (build-path "SourceSerif4-Regular.otf"))
(check-equal? (resolved-font-for-family "nonexistent-fam" #:italic #t) (build-path "SourceSerif4-It.otf"))
(check-equal? (resolved-font-for-family "nonexistent-fam" #:bold #t #:italic #t) (build-path "SourceSerif4-BoldIt.otf")))
(define qs (bootstrap-input
(make-quad #:tag 'div
@ -200,7 +219,8 @@
#:elems (list (make-quad #:tag 'span
#:attrs (make-hasheq (list (cons :font-size "1.5em")))
#:elems (list (make-quad #:tag 'span
#:attrs (make-hasheq (list (cons :font-size "200%"))))))))))
#:attrs (make-hasheq (list (cons :font-size "200%")))
#:elems null)))))))
(check-equal? (quad-ref (quad-elems (car (resolve-font-sizes (parse-dimension-strings qs)))) :font-size) 150))
@ -210,11 +230,11 @@
#:pre (list-of quad?)
#:post (λ (qs)
(for/and ([q (in-list qs)])
(define attrs (quad-attrs q))
(and
(hash-has-key? attrs :font-features)
(not (hash-has-key? attrs :font-features-add))
(not (hash-has-key? attrs :font-features-subtract)))))
(define attrs (quad-attrs q))
(and
(hash-has-key? attrs :font-features)
(not (hash-has-key? attrs :font-features-add))
(not (hash-has-key? attrs :font-features-subtract)))))
(define (resolve-font-features-once attrs parent-attrs)
;; if attrs already has an explicit :font-features key, we don't need to calculate it
@ -246,7 +266,8 @@
(cons :font-features-add "swsh")
(cons :font-features-subtract "liga")))
#:elems (list (make-quad #:tag 'span
#:attrs (make-hasheq (list (cons :font-features "hist")))))))))])
#:attrs (make-hasheq (list (cons :font-features "hist")))
#:elems null))))))])
(define q (car (resolve-font-features (convert-set-attr-values (upgrade-attr-keys qs)))))
(check-equal? (quad-ref q :font-features) (seteq 'ss01 'liga))
(check-equal? (quad-ref (car (quad-elems q)) :font-features) (seteq 'ss01 'swsh))
@ -265,7 +286,7 @@
#:pre (list-of quad?)
#:post (list-of simple-quad-with-font-path-key?)
(for ([q (in-list qs)])
(quad-ref! q :font-path #false)))
(quad-ref! q :font-path #false)))
(define-pass (remove-font-without-char qs)
;; at this point we have a font-path value for each character
@ -279,7 +300,7 @@
[font-path (in-value (quad-ref q :font-path))]
#:when font-path
#:unless (char-in-font? font-path (car (quad-elems q))))
(quad-set! q :font-path #false)))
(quad-set! q :font-path #false)))
(define (simple-quad-with-complete-font-path? q)
(and (simple-quad? q) (complete-path? (quad-ref q :font-path))))
@ -290,18 +311,18 @@
#:pre (list-of simple-quad-with-font-path-key?)
#:post (list-of simple-quad-with-complete-font-path?)
(for ([q (in-list qs)])
(quad-update! q :font-path (λ (val)
(or
val
(match (quad-elems q)
[(cons (? string? str) _)
(match (string-ref str 0)
;; TODO: how to determine fallback priority for alphabetic chars?
;; they are all `math?`
;; for now we will use math face for everything that's not emoji
;; later: test default-font-face to see if it contains the char,
;; and if not, use math
[(? unicode:emoji? c) default-emoji-face]
#;[(? unicode:math? c) default-math-face]
[_ default-math-face])]
[_ default-math-face]))))))
(quad-update! q :font-path (λ (val)
(or
val
(match (quad-elems q)
[(cons (? string? str) _)
(match (string-ref str 0)
;; TODO: how to determine fallback priority for alphabetic chars?
;; they are all `math?`
;; for now we will use math face for everything that's not emoji
;; later: test default-font-face to see if it contains the char,
;; and if not, use math
[(? unicode:emoji? c) default-emoji-face]
#;[(? unicode:math? c) default-math-face]
[_ default-math-face])]
[_ default-math-face]))))))

@ -6,20 +6,23 @@
"layout.rkt"
"draw.rkt"
"attr.rkt"
"quad-passes.rkt"
"attr-passes.rkt"
"font.rkt"
"constants.rkt"
"param.rkt"
"page.rkt"
racket/list
racket/match
racket/file)
racket/match)
(define quad-compile
(make-pipeline
;; each pass in the pipeline is at least
;; (list-of quad?) -> (list-of quad?)
;; quad prep ==============
install-default-attrs
install-default-elems
;; attribute prep =============
;; all attrs start out as symbol-string pairs.
;; we convert keys & values to corresponding higher-level types.
@ -55,6 +58,8 @@
merge-adjacent-strings
split-whitespace
split-into-single-char-quads
print-pass
fill-missing-font-path
remove-font-without-char
insert-fallback-font

@ -6,6 +6,16 @@
"quad.rkt")
(provide (all-defined-out))
(define (list-of proc)
(λ (x)
(and (list? x)
(for/and ([xi (in-list x)])
(or (proc xi)
(let ([procname (object-name proc)])
(raise-argument-error
(string->symbol (format "list-of ~a" procname))
(symbol->string procname) xi)))))))
(struct pipeline (passes)
#:guard (λ (procs name)
(unless ((list-of procedure?) procs)

@ -0,0 +1,26 @@
#lang debug racket/base
(require "pipeline.rkt"
"quad.rkt")
(provide (all-defined-out))
(define (quad-with-attrs? x)
(and (quad? x) (quad-attrs x)))
(define-pass (install-default-attrs qs)
;; make sure attrs are not #false
#:pre (list-of quad?)
#:post (list-of quad-with-attrs?)
(for ([q (in-list qs)]
#:unless (quad-attrs q))
(set-quad-attrs! q (make-hasheq))))
(define (quad-with-elems? x)
(and (quad? x) (quad-elems x)))
(define-pass (install-default-elems qs)
;; ensure elems are not #false
#:pre (list-of quad?)
#:post (list-of quad-with-elems?)
(for ([q (in-list qs)]
#:unless (quad-elems q))
(set-quad-elems! q null)))

@ -18,16 +18,6 @@
(define current-wrap-width (make-parameter 5))
(define current-page-size (make-parameter ($size 10 10)))
(define (list-of proc)
(λ (x)
(and (list? x)
(for/and ([xi (in-list x)])
(or (proc xi)
(let ([procname (object-name proc)])
(raise-argument-error
(string->symbol (format "list-of ~a" procname))
(symbol->string procname) xi)))))))
(define-syntax-rule (auto-struct NAME (FIELD ...) . ARGS)
(struct NAME (FIELD ...) . ARGS))
@ -36,11 +26,10 @@
#:constructor-name quad-new
#:methods gen:custom-write
[(define (write-proc val out mode)
(let* ([fields (filter-map (λ (f) (f val)) (list quad-tag quad-attrs quad-elems quad-origin quad-size))]
[fields (if (null? fields) (list #f) fields)])
(fprintf out (format "<~a ~a>"
(or (car fields) "quad")
(string-join (map ~v (cdr fields)) " ")))))])
;; cdr because struct->vector puts struct descriptor in first slot
(define fields (cdr (vector->list (struct->vector val))))
;; cdr because tag is in first position
(fprintf out (format "<~a>" (string-join (cons (~a (or (quad-tag val) "quad")) (map ~v (filter values (cdr fields)))) " "))))])
(define (quad-new-default)
(apply quad-new (make-list (procedure-arity quad-new) #f)))
@ -63,8 +52,8 @@
(define (quad-elems? x) (list? x))
(define/contract (make-quad #:tag [tag #false]
#:attrs [attrs (make-quad-attrs null)]
#:elems [elems null])
#:attrs [attrs #f]
#:elems [elems #f])
(() (#:tag quad-tag? #:attrs (or/c quad-attrs? (listof any/c)) #:elems quad-elems?) . ->* . quad?)
(let ([attrs (let loop ([attrs attrs])
(cond

Loading…
Cancel
Save