From 8a3110e9f46d9cafdd5ea3d13ba130fe6b15ae73 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 7 May 2022 15:34:59 -0700 Subject: [PATCH] add `resolve-font-features` --- quad2/font.rkt | 118 +++++++++++++++++++++++++++++++++++-------------- quad2/main.rkt | 2 +- 2 files changed, 85 insertions(+), 35 deletions(-) diff --git a/quad2/font.rkt b/quad2/font.rkt index a6ec51e7..8329c29e 100644 --- a/quad2/font.rkt +++ b/quad2/font.rkt @@ -3,6 +3,7 @@ racket/match racket/runtime-path racket/list + racket/set racket/string fontland/font-path "quad.rkt" @@ -23,7 +24,7 @@ (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. @@ -45,36 +46,36 @@ #: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]) @@ -100,9 +101,9 @@ (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 @@ -195,3 +196,52 @@ #:elems (list (make-quad #:tag 'span #:attrs (make-hasheq (list (cons :font-size "200%")))))))))) (check-equal? (quad-ref (quad-elems (car (resolve-font-sizes (parse-dimension-strings qs)))) :font-size) 150)) + + +(define-pass (resolve-font-features qs) + ;; put a :font-features field in every quad, + ;; Along the way, resolve any :font-features-add and :font-features-subtract attrs. + #: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 (resolve-font-features-once attrs parent-attrs) + ;; if attrs already has an explicit :font-features key, we don't need to calculate it + (unless (hash-has-key? attrs :font-features) + ;; otherwise we calculate :font-features by looking at the parent features + ;; and adding / removing any indicated. + (define previous-features + (let ([parent-attrs (or parent-attrs (hash))]) + (hash-ref parent-attrs :font-features default-no-features))) + (define features-to-add (hash-ref attrs :font-features-add default-no-features)) + (define features-to-subtract (hash-ref attrs :font-features-subtract default-no-features)) + ;; TODO: which order of operations is preferable: add then remove, or remove then add? + (define these-features + (set-subtract (set-union previous-features features-to-add) features-to-subtract)) + (hash-set! attrs :font-features these-features)) + ;; now that we've got :font-features, we can delete :font-features-add and :font-features-remove + (hash-remove! attrs :font-features-add) + (hash-remove! attrs :font-features-subtract)) + + (for-each-attrs qs resolve-font-features-once)) + + +(module+ test + (let ([qs (bootstrap-input + (make-quad #:tag 'div + #:attrs (make-hasheq (list (cons :font-features "ss01 liga"))) + #:elems (list (make-quad #:tag 'span + #:attrs (make-hasheq (list + (cons :font-features-add "swsh") + (cons :font-features-subtract "liga"))) + #:elems (list (make-quad #:tag 'span + #:attrs (make-hasheq (list (cons :font-features "hist")))))))))]) + (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)) + (check-equal? (quad-ref (car (quad-elems (car (quad-elems q)))) :font-features) (seteq 'hist)))) \ No newline at end of file diff --git a/quad2/main.rkt b/quad2/main.rkt index 02a42580..07867a13 100644 --- a/quad2/main.rkt +++ b/quad2/main.rkt @@ -36,7 +36,7 @@ ;; these need the tree shape parse-dimension-strings resolve-font-sizes - #;resolve-font-features + resolve-font-features ;; linearization ============= ;; we postpone this step until we're certain any