From 728433fcde71a58aa459598a342276b720a83ad5 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 8 Apr 2022 19:00:15 -0700 Subject: [PATCH] finish resolving font sizes --- quad2/attr.rkt | 9 +++---- quad2/dimension.rkt | 57 ++++++++++++++++++++++++++------------------- quad2/font.rkt | 49 ++++++++++++++++++++++---------------- quad2/main.rkt | 29 ++++++++++++----------- quad2/quad.rkt | 8 +++++-- 5 files changed, 87 insertions(+), 65 deletions(-) diff --git a/quad2/attr.rkt b/quad2/attr.rkt index 51728185..52454182 100644 --- a/quad2/attr.rkt +++ b/quad2/attr.rkt @@ -20,7 +20,7 @@ (let loop ([xs xs][parent-attrs #false]) (for ([x (in-list xs)] #:when (quad? x)) - (let* ([attrs (quad-attrs x)]) + (let ([attrs (quad-attrs x)]) (unless (set-member? attrs-seen attrs) (proc attrs parent-attrs) (set-add! attrs-seen attrs)) @@ -79,7 +79,7 @@ (for ([ak (in-list mandatory-keys)]) (hash-ref! attrs ak (attr-key-default ak)))))) -(define-pass (downcase-attr-values qs) +(define-pass (downcase-string-attr-values qs) ;; make attribute values lowercase, unless they're case-sensitive ;; so we can check them more easily later. ;; in principle we could do this earlier and recursively process a single quad @@ -114,7 +114,6 @@ (or (string->number av) (raise-argument-error 'convert-numeric-attr-values "numeric string" av))))) - (define-pass (complete-attr-paths qs) #:pre (list-of quad?) #:post (list-of quad?) @@ -134,8 +133,6 @@ #:which-attr attr-dimension-string-key? #:attr-proc (λ (ak av attrs) (parse-dimension av)))) - - (module+ test (require rackunit) (define-attr-list debug-attrs @@ -162,7 +159,7 @@ (parameterize ([current-strict-attrs? #false]) (upgrade-attr-keys (list (make-q)))))) (check-equal? (quad-ref (car (fill-default-attr-values (list (make-q)))) :num-def-42) 42) - (check-equal? (quad-ref (car (downcase-attr-values qs)) :foo) "bar") + (check-equal? (quad-ref (car (downcase-string-attr-values qs)) :foo) "bar") (check-true (complete-path? (quad-ref (car (complete-attr-paths qs)) :ps))) (check-equal? (quad-ref (car (parse-dimension-strings qs)) :dim) 144) (let ([q (car (convert-boolean-attr-values qs))]) diff --git a/quad2/dimension.rkt b/quad2/dimension.rkt index 1568dbd4..2d173d33 100644 --- a/quad2/dimension.rkt +++ b/quad2/dimension.rkt @@ -12,34 +12,43 @@ (define (in->pts x) (* 72 x)) (define (mm->cm x) (/ x 10.0)) +(define (parse-em-or-percentage str) + ;; percentage is alternate notation for em + (and + (string? str) + (for/or ([suffix (list "em" "%")] + [divisor (list 1 100)] + #:when (string-suffix? str suffix)) + (match (string->number (string-trim str suffix)) + [(? number? num) (/ num divisor)] + [_ #false])))) + +(define pica-pat (regexp "^(p|pica)(s)?$")) + +(define (unit->converter-proc unit) + (match unit + [(regexp #rx"^(pt|point)(s)?$") values] ; points + [(regexp pica-pat) pica->pts] ; pica (no pts) + [(regexp #rx"^inch(es)?|in(s)?$") in->pts] ; inches + [(regexp #rx"^cm(s)?$") (compose1 in->pts cm->in)] ; cm + [(regexp #rx"^mm(s)?$") (compose1 in->pts cm->in mm->cm)] ; mm + [_ values])) + (define (parse-dimension x) - (define pica-pat (regexp "^(p|pica)(s)?$")) - (define (unit->converter-proc unit) - (match unit - [(regexp #rx"^(pt|point)(s)?$") values] ; points - [(regexp pica-pat) pica->pts] ; pica (no pts) - [(regexp #rx"^inch(es)?|in(s)?$") in->pts] ; inches - [(regexp #rx"^cm(s)?$") (compose1 in->pts cm->in)] ; cm - [(regexp #rx"^mm(s)?$") (compose1 in->pts cm->in mm->cm)] ; mm - [_ values])) - (define (parse-em pstr) - (define em-suffix "em") - (and - pstr - (string? pstr) - (string-suffix? pstr em-suffix) - (string->number (string-trim pstr em-suffix)))) (define parsed-thing (match x [#false #false] [(? number? num) num] - [(app parse-em em) #:when em - (procedure-rename - (λ (previous-size) - (unless (number? previous-size) - (raise-argument-error 'em-resolver "number" previous-size)) - (* em previous-size)) - 'em-resolver)] + [(app parse-em-or-percentage em) + #:when em + (procedure-rename + (λ (previous-size) + (unless (number? previous-size) + (raise-argument-error 'em-resolver "number" previous-size)) + (match (* em previous-size) + [(? integer? int) (inexact->exact int)] + [num num])) + 'em-resolver)] [(? string? str) (match (regexp-match #px"^(-?[0-9\\.]+)\\s*([a-z]+)([0-9\\.]+)?$" (string-downcase str)) [(list str @@ -53,7 +62,7 @@ (app string->number suffix-num)) #:when (and prefix-num suffix-num) ; prefix + suffix measurement (only pica + point) (pica->pts prefix-num suffix-num)] - [_ str])])) + [_ (raise-argument-error 'parse-dimension "dimension string" str)])])) (match parsed-thing [(and (? integer?) (? inexact?)) (inexact->exact parsed-thing)] [_ parsed-thing])) diff --git a/quad2/font.rkt b/quad2/font.rkt index 475d9ec0..cb743f95 100644 --- a/quad2/font.rkt +++ b/quad2/font.rkt @@ -58,7 +58,7 @@ [(= (length fonts-in-this-directory) 1) 'r] ;; cases where fonts are in subdirectories named by style ;; infer style from subdir name - [(member "bold-italic" path-parts) 'bi] + [(and (member "bold" path-parts) (member "italic" path-parts)) 'bi] [(member "bold" path-parts) 'b] [(member "italic" path-parts) 'i] [else @@ -159,35 +159,44 @@ #:pre (list-of quad?) #:post (list-of quad?) - (define (resolve-font-size-once attrs) - ;; FIXME: this technique no longer works because - ;; it depends on resolving values while attrs are being cascaded + (define (resolve-font-size-once attrs parent-attrs) (define base-size-adjusted - (match (hash-ref attrs :font-size default-font-size) + (match (hash-ref attrs :font-size 'missing) ;; if our value represents an adjustment, ;; we apply the adjustment to the previous value - [(? procedure? proc) (proc (hash-ref attrs :font-size-previous default-font-size))] + [(? procedure? proc) + (define previous-font-size (cond + [(and parent-attrs (hash-ref parent-attrs :font-size-previous #false))] + [else default-font-size])) + (proc previous-font-size)] ;; otherwise we use our value directly - [val val])) + [(? number? num) num] + [other (raise-user-error 'resolve-font-sizes "procedure or number" other)])) ;; we write our new value into both font-size and font-size-previous ;; because as we cascade down, we're likely to come across superseding values - ;; of font-size (but font-size-previous will persist) - (hash-set! attrs :font-size base-size-adjusted) - (hash-set! attrs :font-size-previous base-size-adjusted)) - - (define font-paths (setup-font-path-table)) - (do-attr-iteration qs - #:attr-proc (λ (_ __ attrs) (resolve-font-size-once attrs)))) + ;; of font-size + ;; but the font-size-previous will persist + ;; because on the next recursion, the current `attrs` will be `parent-attrs` + (hash-set*! attrs :font-size base-size-adjusted + :font-size-previous base-size-adjusted)) + + (for-each-attrs qs resolve-font-size-once)) (module+ test (require rackunit) (define-attr-list debug-attrs [:font-family (make-attr-uncased-string-key 'font-family)]) (parameterize ([current-attrs debug-attrs]) - (check-equal? (resolved-font-for-family "Heading") (string->path "fira-sans-light.otf")) - (check-equal? (resolved-font-for-family "CODE") (string->path "fira-mono.otf")) - (check-equal? (resolved-font-for-family "blockquote" #:bold #t) (string->path "fira-sans-bold.otf")) - (check-equal? (resolved-font-for-family "nonexistent-fam") (string->path "SourceSerifPro-Regular.otf"))) + (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"))) - (define qs (bootstrap-input (make-quad #:tag 'div #:attrs (make-hasheq (list (cons :font-size "100pt"))) #:elems (list (make-quad #:tag 'span #:attrs (make-hasheq (list (cons :font-size-previous "100pt") (cons :font-size "1.5em")))))))) - #;(resolve-font-sizes (parse-dimension-strings qs))) + (define qs (bootstrap-input + (make-quad #:tag 'div + #:attrs (make-hasheq (list (cons :font-size "100pt"))) + #: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%")))))))))) + (check-equal? (quad-ref (quad-elems (car (resolve-font-sizes (parse-dimension-strings qs)))) :font-size) 150)) diff --git a/quad2/main.rkt b/quad2/main.rkt index 7d6048f2..c3a985ea 100644 --- a/quad2/main.rkt +++ b/quad2/main.rkt @@ -22,9 +22,12 @@ ;; we convert keys & values to corresponding higher-level types. upgrade-attr-keys fill-default-attr-values - downcase-attr-values + downcase-string-attr-values convert-boolean-attr-values convert-numeric-attr-values + + ;; pre-linearization resolutions & parsings ============= + ;; these need the tree shape parse-dimension-strings resolve-font-sizes @@ -36,7 +39,7 @@ ;; because once we linearize, that information is gone. linearize - ;; resolutions & parsings ============= + ;; post-linearization resolutions & parsings ============= resolve-font-paths complete-attr-paths ;; TODO: parse feature strings @@ -54,18 +57,18 @@ (require "render.rkt") (define (test-compile x) (parameterize ([current-wrap-width 13] - [current-attrs all-attrs] - [current-strict-attrs? #t] - [current-show-timing? #f] - [current-use-preconditions? #t] - [current-use-postconditions? #t]) - (quad-compile (bootstrap-input x)))) + [current-attrs all-attrs] + [current-strict-attrs? #t] + [current-show-timing? #f] + [current-use-preconditions? #t] + [current-use-postconditions? #t]) + (quad-compile (bootstrap-input x)))) (match (test-compile "Hello this is the earth") [(? string? insts) - (render insts #:using text-renderer) - (render insts #:using drr-renderer) - #;(render-to-html drawing-insts) - #;(render-to-pdf drawing-insts) - ])) + (render insts #:using text-renderer) + (render insts #:using drr-renderer) + #;(render-to-html drawing-insts) + #;(render-to-pdf drawing-insts) + ])) diff --git a/quad2/quad.rkt b/quad2/quad.rkt index 80ffabb0..ea887ef2 100644 --- a/quad2/quad.rkt +++ b/quad2/quad.rkt @@ -47,10 +47,14 @@ (let ([attrs (if (immutable? attrs) (make-hasheq (hash->list attrs)) attrs)]) (quad-constructor tag attrs elems #false))) -(define (quad-ref q key [default-val #false]) +(define (quad-ref q-or-qs key [default-val #false]) (unless (attr-key? key) (raise-argument-error 'quad-ref "attr-key?" key)) - (hash-ref (quad-attrs q) key default-val)) + (hash-ref (quad-attrs (match q-or-qs + [(? quad? q) q] + [(cons q _) q] + [_ (raise-argument-error 'quad-ref "quad or list of quads" q-or-qs)])) key default-val)) + (define (quad-set! q key val) (hash-set! (quad-attrs q) key val))