diff --git a/quad2/attr-passes.rkt b/quad2/attr-passes.rkt new file mode 100644 index 00000000..fed9dcc6 --- /dev/null +++ b/quad2/attr-passes.rkt @@ -0,0 +1,205 @@ +#lang debug racket/base +(require racket/match + racket/string + racket/set + "attr.rkt" + "dimension.rkt" + "pipeline.rkt" + "struct.rkt" + "constants.rkt" + "quad.rkt" + "param.rkt") +(provide (all-defined-out)) + +(module+ test + (require rackunit)) + +(define (for-each-attrs xs proc) + ;; apply `proc` to each set of attrs in `xs`. + ;; recursively descend from top to bottom. + ;; but also track which attrs are visited and skip any already visited. + (define attrs-seen (mutable-seteq)) + (define wants-parent-attrs? (= (procedure-arity proc) 2)) + (let loop ([xs xs][parent-attrs #false]) + (for ([x (in-list xs)] + #:when (quad? x)) + (define attrs (quad-attrs x)) + (unless (set-member? attrs-seen attrs) + (if wants-parent-attrs? (proc attrs parent-attrs) (proc attrs)) + (set-add! attrs-seen attrs)) + (loop (quad-elems x) attrs)))) + +(define (do-attr-iteration qs + #:which-attr [which-attr 'all-attributes-signal] + #:attr-proc attr-proc + #:wants-parent-attrs [wants-parent-attrs? #false]) + (define attr-predicate + (match which-attr + ['all-attributes-signal (λ (ak av) #true)] + [(? attr-key? attr-key) (λ (ak av) (eq? ak attr-key))] + [(? procedure? pred) + (if (eq? 1 (procedure-arity pred)) + (λ (ak _) (pred ak)) ; 1 arity implies key-only test + pred)] + [other (raise-argument-error 'do-attr-iteration "key predicate" other)])) + (for-each-attrs qs + (λ (attrs parent-attrs) + ;; we don't iterate with `in-hash` (or `in-hash-keys`) because + ;; `attrs` might get mutated during the loop, + ;; which invalidates the reference `in-hash` is using + (for* ([ak (in-list (hash-keys attrs))] + [av (in-value (hash-ref attrs ak no-value-signal))] + #:when (and (not (eq? av no-value-signal)) (attr-predicate ak av))) + (match (if wants-parent-attrs? + (attr-proc ak av attrs parent-attrs) + (attr-proc ak av attrs)) + ;; void value: do nothing + [(? void?) (void)] + ;; otherwise treat return value as new attr value + [new-av (hash-set! attrs ak new-av)]))))) + +(define-pass (upgrade-attr-keys qs) + ;; convert attr keys from symbols to attr struct types + ;; also lets us validate keys strictly, if we want + #:pre (list-of quad?) + #:post (list-of quad?) + (define attr-lookup-table (for/hasheq ([a (in-list (current-attr-keys))]) + (values (attr-key-name a) a))) + (define strict-attrs? (current-strict-attrs?)) + (define (do-upgrade ak av attrs) + (cond + [(attr-key? ak) av] + [(symbol? ak) + (match (hash-ref attr-lookup-table ak :unknown-key) + [(== :unknown-key eq?) #:when strict-attrs? + (raise-argument-error 'upgrade-attr-keys "known attr" ak)] + [attr-key + (hash-remove! attrs ak) + (hash-set! attrs attr-key av)])] + [else (raise-argument-error 'upgrade-attr-keys "symbol or attr" ak)])) + (do-attr-iteration qs #:attr-proc do-upgrade)) + +(define-pass (set-top-level-attr-values qs) + ;; put the default values for mandatory keys at the top level + ;; so that when we linearize, they will percolate downward + #:pre (list-of quad?) + #:post (list-of quad?) + (define mandatory-attrs (for/hasheq ([ak (in-list (current-attr-keys))] + #:when (attr-key-mandatory? ak)) + (values ak (attr-key-default ak)))) + (list (make-quad #:attrs mandatory-attrs #:elems 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 + ;; rather than linearized quads + ;; it would be faster because there are fewer copies of the attr hashes, + ;; so we do fewer tests + ;; but let's stay with the pipeline policy of operating on flat lists of quads + #:pre (list-of quad?) + #:post (list-of quad?) + (do-attr-iteration qs + #:which-attr attr-cased-string-key? + #:attr-proc (λ (ak av attrs) (string-downcase av)))) + + +(define-pass (convert-boolean-attr-values qs) + #:pre (list-of quad?) + #:post (list-of quad?) + (do-attr-iteration qs + #:which-attr attr-boolean-key? + #:attr-proc (λ (ak av attrs) + (match av + [(? boolean?) av] + [(? string? str) #:when (equal? (string-downcase str) "false") #false] + [_ #true])))) + +(define-pass (convert-numeric-attr-values qs) + #:pre (list-of quad?) + #:post (list-of quad?) + (do-attr-iteration qs + #:which-attr attr-numeric-key? + #:attr-proc (λ (ak av attrs) + (or (string->number av) + (raise-argument-error 'convert-numeric-attr-values "numeric string" av))))) + +(define-pass (convert-path-attr-values qs) + #:pre (list-of quad?) + #:post (list-of quad?) + (do-attr-iteration qs + #:which-attr attr-path-key? + #:attr-proc (λ (ak av attrs) + (or (string->path av) + (raise-argument-error 'convert-path-attr-values "path string" av))))) + +(define-pass (convert-set-attr-values qs) + #:pre (list-of quad?) + #:post (list-of quad?) + (do-attr-iteration qs + #:which-attr attr-set-key? + #:attr-proc (λ (ak av attrs) + (apply seteq (map string->symbol (string-split av)))))) + +(module+ test + (let ([q (convert-set-attr-values (upgrade-attr-keys (bootstrap-input '(div ((font-features "calt")(font-features-add "")(font-features-subtract "swsh liga"))))))]) + (check-equal? (quad-ref q :font-features) (seteq 'calt)) + (check-equal? (quad-ref q :font-features-add) (seteq)) + (check-equal? (quad-ref q :font-features-subtract) (seteq 'swsh 'liga)))) + + +(define-pass (complete-attr-paths qs) + #:pre (list-of quad?) + #:post (list-of quad?) + ;; convert every path value to a complete path + ;; so we don't get tripped up later by relative paths + ;; relies on `current-directory` being parameterized to source file's dir + (do-attr-iteration qs + #:which-attr attr-path-key? + #:attr-proc (λ (ak av attrs) + (unless (path? av) + (raise-argument-error 'complete-attr-paths "path" av)) + (path->complete-path av)))) + + +(define-pass (parse-dimension-strings qs) + #:pre (list-of quad?) + #:post (list-of quad?) + ;; certain attributes can be "dimension strings", which are strings like "3in" or "4.2cm" + ;; we parse them into the equivalent measurement in points. + (do-attr-iteration qs + #:which-attr attr-dimension-string-key? + #:attr-proc (λ (ak av attrs) (parse-dimension av)))) + +(module+ test + (define-attr-list debug-attrs + [:foo (make-attr-cased-string-key 'foo)] + [:ps (make-attr-path-key 'ps)] + [:dim (make-attr-dimension-string-key 'dim)] + [:boolt (make-attr-boolean-key 'boolt)] + [:boolf (make-attr-boolean-key 'boolf)] + [:num (make-attr-numeric-key 'num)] + [:num-def-42 (make-attr-numeric-key 'num-def-42 #true 42)]) + (parameterize ([current-attr-keys debug-attrs]) + (define (make-q) (make-quad #:attrs (list :foo "BAR" + 'ding "dong" + :ps (string->path "file.txt") + :dim "2in" + :boolt "true" + :boolf "false" + :num "42.5"))) + (define qs (list (make-q))) + (check-exn exn? (λ () + (parameterize ([current-strict-attrs? #true]) + (upgrade-attr-keys (list (make-q)))))) + (check-not-exn (λ () + (parameterize ([current-strict-attrs? #false]) + (upgrade-attr-keys (list (make-q)))))) + (check-equal? (quad-ref (car (set-top-level-attr-values (list (make-q)))) :num-def-42) 42) + (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))]) + (check-true (quad-ref q :boolt)) + (check-false (quad-ref q :boolf))) + (check-equal? (quad-ref (car (convert-numeric-attr-values qs)) :num) 42.5))) \ No newline at end of file diff --git a/quad2/attr.rkt b/quad2/attr.rkt index e80ef09b..342240b4 100644 --- a/quad2/attr.rkt +++ b/quad2/attr.rkt @@ -1,206 +1,34 @@ #lang debug racket/base -(require racket/match - racket/hash - racket/list - racket/string - racket/set - "dimension.rkt" - "pipeline.rkt" +(require racket/list "struct.rkt" - "constants.rkt" - "quad.rkt" - "param.rkt") + "constants.rkt") (provide (all-defined-out)) -(module+ test - (require rackunit)) - -(define (for-each-attrs xs proc) - ;; apply `proc` to each set of attrs in `xs`. - ;; recursively descend from top to bottom. - ;; but also track which attrs are visited and skip any already visited. - (define attrs-seen (mutable-seteq)) - (define wants-parent-attrs? (= (procedure-arity proc) 2)) - (let loop ([xs xs][parent-attrs #false]) - (for ([x (in-list xs)] - #:when (quad? x)) - (define attrs (quad-attrs x)) - (unless (set-member? attrs-seen attrs) - (if wants-parent-attrs? (proc attrs parent-attrs) (proc attrs)) - (set-add! attrs-seen attrs)) - (loop (quad-elems x) attrs)))) - -(define (do-attr-iteration qs - #:which-attr [which-attr 'all-attributes-signal] - #:attr-proc attr-proc - #:wants-parent-attrs [wants-parent-attrs? #false]) - (define attr-predicate - (match which-attr - ['all-attributes-signal (λ (ak av) #true)] - [(? attr-key? attr-key) (λ (ak av) (eq? ak attr-key))] - [(? procedure? pred) - (if (eq? 1 (procedure-arity pred)) - (λ (ak _) (pred ak)) ; 1 arity implies key-only test - pred)] - [other (raise-argument-error 'do-attr-iteration "key predicate" other)])) - (for-each-attrs qs - (λ (attrs parent-attrs) - ;; we don't iterate with `in-hash` (or `in-hash-keys`) because - ;; `attrs` might get mutated during the loop, - ;; which invalidates the reference `in-hash` is using - (for* ([ak (in-list (hash-keys attrs))] - [av (in-value (hash-ref attrs ak no-value-signal))] - #:when (and (not (eq? av no-value-signal)) (attr-predicate ak av))) - (match (if wants-parent-attrs? - (attr-proc ak av attrs parent-attrs) - (attr-proc ak av attrs)) - ;; void value: do nothing - [(? void?) (void)] - ;; otherwise treat return value as new attr value - [new-av (hash-set! attrs ak new-av)]))))) - -(define-pass (upgrade-attr-keys qs) - ;; convert attr keys from symbols to attr struct types - ;; also lets us validate keys strictly, if we want - #:pre (list-of quad?) - #:post (list-of quad?) - (define attr-lookup-table (for/hasheq ([a (in-list (current-attr-keys))]) - (values (attr-key-name a) a))) - (define strict-attrs? (current-strict-attrs?)) - (define (do-upgrade ak av attrs) - (cond - [(attr-key? ak) av] - [(symbol? ak) - (match (hash-ref attr-lookup-table ak :unknown-key) - [(== :unknown-key eq?) #:when strict-attrs? - (raise-argument-error 'upgrade-attr-keys "known attr" ak)] - [attr-key - (hash-remove! attrs ak) - (hash-set! attrs attr-key av)])] - [else (raise-argument-error 'upgrade-attr-keys "symbol or attr" ak)])) - (do-attr-iteration qs #:attr-proc do-upgrade)) - -(define-pass (set-top-level-attr-values qs) - ;; put the default values for mandatory keys at the top level - ;; so that when we linearize, they will percolate downward - #:pre (list-of quad?) - #:post (list-of quad?) - (define mandatory-attrs (for/hasheq ([ak (in-list (current-attr-keys))] - #:when (attr-key-mandatory? ak)) - (values ak (attr-key-default ak)))) - (list (make-quad #:attrs mandatory-attrs #:elems 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 - ;; rather than linearized quads - ;; it would be faster because there are fewer copies of the attr hashes, - ;; so we do fewer tests - ;; but let's stay with the pipeline policy of operating on flat lists of quads - #:pre (list-of quad?) - #:post (list-of quad?) - (do-attr-iteration qs - #:which-attr attr-cased-string-key? - #:attr-proc (λ (ak av attrs) (string-downcase av)))) - - -(define-pass (convert-boolean-attr-values qs) - #:pre (list-of quad?) - #:post (list-of quad?) - (do-attr-iteration qs - #:which-attr attr-boolean-key? - #:attr-proc (λ (ak av attrs) - (match av - [(? boolean?) av] - [(? string? str) #:when (equal? (string-downcase str) "false") #false] - [_ #true])))) - -(define-pass (convert-numeric-attr-values qs) - #:pre (list-of quad?) - #:post (list-of quad?) - (do-attr-iteration qs - #:which-attr attr-numeric-key? - #:attr-proc (λ (ak av attrs) - (or (string->number av) - (raise-argument-error 'convert-numeric-attr-values "numeric string" av))))) - -(define-pass (convert-path-attr-values qs) - #:pre (list-of quad?) - #:post (list-of quad?) - (do-attr-iteration qs - #:which-attr attr-path-key? - #:attr-proc (λ (ak av attrs) - (or (string->path av) - (raise-argument-error 'convert-path-attr-values "path string" av))))) - -(define-pass (convert-set-attr-values qs) - #:pre (list-of quad?) - #:post (list-of quad?) - (do-attr-iteration qs - #:which-attr attr-set-key? - #:attr-proc (λ (ak av attrs) - (apply seteq (map string->symbol (string-split av)))))) - -(module+ test - (let ([q (convert-set-attr-values (upgrade-attr-keys (bootstrap-input '(div ((font-features "calt")(font-features-add "")(font-features-subtract "swsh liga"))))))]) - (check-equal? (quad-ref q :font-features) (seteq 'calt)) - (check-equal? (quad-ref q :font-features-add) (seteq)) - (check-equal? (quad-ref q :font-features-subtract) (seteq 'swsh 'liga)))) - - -(define-pass (complete-attr-paths qs) - #:pre (list-of quad?) - #:post (list-of quad?) - ;; convert every path value to a complete path - ;; so we don't get tripped up later by relative paths - ;; relies on `current-directory` being parameterized to source file's dir - (do-attr-iteration qs - #:which-attr attr-path-key? - #:attr-proc (λ (ak av attrs) - (unless (path? av) - (raise-argument-error 'complete-attr-paths "path" av)) - (path->complete-path av)))) - - -(define-pass (parse-dimension-strings qs) - #:pre (list-of quad?) - #:post (list-of quad?) - ;; certain attributes can be "dimension strings", which are strings like "3in" or "4.2cm" - ;; we parse them into the equivalent measurement in points. - (do-attr-iteration qs - #:which-attr attr-dimension-string-key? - #:attr-proc (λ (ak av attrs) (parse-dimension av)))) - -(module+ test - (define-attr-list debug-attrs - [:foo (make-attr-cased-string-key 'foo)] - [:ps (make-attr-path-key 'ps)] - [:dim (make-attr-dimension-string-key 'dim)] - [:boolt (make-attr-boolean-key 'boolt)] - [:boolf (make-attr-boolean-key 'boolf)] - [:num (make-attr-numeric-key 'num)] - [:num-def-42 (make-attr-numeric-key 'num-def-42 #true 42)]) - (parameterize ([current-attr-keys debug-attrs]) - (define (make-q) (make-quad #:attrs (list :foo "BAR" - 'ding "dong" - :ps (string->path "file.txt") - :dim "2in" - :boolt "true" - :boolf "false" - :num "42.5"))) - (define qs (list (make-q))) - (check-exn exn? (λ () - (parameterize ([current-strict-attrs? #true]) - (upgrade-attr-keys (list (make-q)))))) - (check-not-exn (λ () - (parameterize ([current-strict-attrs? #false]) - (upgrade-attr-keys (list (make-q)))))) - (check-equal? (quad-ref (car (set-top-level-attr-values (list (make-q)))) :num-def-42) 42) - (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))]) - (check-true (quad-ref q :boolt)) - (check-false (quad-ref q :boolf))) - (check-equal? (quad-ref (car (convert-numeric-attr-values qs)) :num) 42.5))) \ No newline at end of file +(define-syntax-rule (define-attr-list LIST-NAME + [ATTR-NAME ATTR-EXPR] ...) + (begin + (define ATTR-NAME ATTR-EXPR) ... + (define LIST-NAME + (let ([names (list ATTR-NAME ...)]) + (cond + [(check-duplicates (map attr-key-name names)) + => + (λ (sym) (raise-user-error 'define-attr-list "duplicate attribute name: ~a" sym))] + [else names]))))) + +(define-attr-list all-attr-keys + [:unknown-key (make-attr-unknown-key (gensym))] + [:font-family (make-attr-uncased-string-key 'font-family #true default-font-family)] + [:font-path (make-attr-path-key 'font-path)] + [:font-bold (make-attr-boolean-key 'font-bold #true #false)] + [:font-italic (make-attr-boolean-key 'font-italic #true #false)] + [:font-size (make-attr-dimension-string-key 'font-size #true default-font-size)] + [:font-features (make-attr-set-key 'font-features #true default-no-features)] + [:font-features-add (make-attr-set-key 'font-features-add #false default-no-features)] + [:font-features-subtract (make-attr-set-key 'font-features-subtract #false default-no-features)] + + [:page-size (make-attr-uncased-string-key 'page-size #true default-page-size)] + [:page-orientation (make-attr-uncased-string-key 'page-orientation #true default-page-orientation)] + [:page-width (make-attr-dimension-string-key 'page-width)] + [:page-height (make-attr-dimension-string-key 'page-height)] + ) \ No newline at end of file diff --git a/quad2/constants.rkt b/quad2/constants.rkt index 2ea31c97..50b81cb5 100644 --- a/quad2/constants.rkt +++ b/quad2/constants.rkt @@ -1,7 +1,5 @@ #lang racket/base -(require racket/list - racket/set - "struct.rkt") +(require racket/set) (provide (all-defined-out)) (define default-font-family "text") @@ -13,31 +11,3 @@ (struct no-value ()) (define no-value-signal (no-value)) -(define-syntax-rule (define-attr-list LIST-NAME - [ATTR-NAME ATTR-EXPR] ...) - (begin - (define ATTR-NAME ATTR-EXPR) ... - (define LIST-NAME - (let ([names (list ATTR-NAME ...)]) - (cond - [(check-duplicates (map attr-key-name names)) - => - (λ (sym) (raise-user-error 'define-attr-list "duplicate attribute name: ~a" sym))] - [else names]))))) - -(define-attr-list all-attr-keys - [:unknown-key (make-attr-unknown-key (gensym))] - [:font-family (make-attr-uncased-string-key 'font-family #true default-font-family)] - [:font-path (make-attr-path-key 'font-path)] - [:font-bold (make-attr-boolean-key 'font-bold #true #false)] - [:font-italic (make-attr-boolean-key 'font-italic #true #false)] - [:font-size (make-attr-dimension-string-key 'font-size #true default-font-size)] - [:font-features (make-attr-set-key 'font-features #true default-no-features)] - [:font-features-add (make-attr-set-key 'font-features-add #false default-no-features)] - [:font-features-subtract (make-attr-set-key 'font-features-subtract #false default-no-features)] - - [:page-size (make-attr-uncased-string-key 'page-size #true default-page-size)] - [:page-orientation (make-attr-uncased-string-key 'page-orientation #true default-page-orientation)] - [:page-width (make-attr-dimension-string-key 'page-width)] - [:page-height (make-attr-dimension-string-key 'page-height)] - ) \ No newline at end of file diff --git a/quad2/default-fonts/default/SourceSerifPro-Regular.otf b/quad2/default-fonts/default/SourceSerifPro-Regular.otf deleted file mode 100755 index 4ff89331..00000000 Binary files a/quad2/default-fonts/default/SourceSerifPro-Regular.otf and /dev/null differ diff --git a/quad2/default-fonts/default/bold-italic/SourceSerif4-BoldIt.otf b/quad2/default-fonts/default/bold-italic/SourceSerif4-BoldIt.otf new file mode 100644 index 00000000..33cd4c55 Binary files /dev/null and b/quad2/default-fonts/default/bold-italic/SourceSerif4-BoldIt.otf differ diff --git a/quad2/default-fonts/default/bold/SourceSerif4-Bold.otf b/quad2/default-fonts/default/bold/SourceSerif4-Bold.otf new file mode 100644 index 00000000..d9791f52 Binary files /dev/null and b/quad2/default-fonts/default/bold/SourceSerif4-Bold.otf differ diff --git a/quad2/default-fonts/default/italic/SourceSerif4-It.otf b/quad2/default-fonts/default/italic/SourceSerif4-It.otf new file mode 100644 index 00000000..e0fec510 Binary files /dev/null and b/quad2/default-fonts/default/italic/SourceSerif4-It.otf differ diff --git a/quad2/default-fonts/default/regular/SourceSerif4-Regular.otf b/quad2/default-fonts/default/regular/SourceSerif4-Regular.otf new file mode 100644 index 00000000..a8a651fd Binary files /dev/null and b/quad2/default-fonts/default/regular/SourceSerif4-Regular.otf differ diff --git a/quad2/draw.rkt b/quad2/draw.rkt index 404f0669..a5a4009c 100644 --- a/quad2/draw.rkt +++ b/quad2/draw.rkt @@ -1,37 +1,36 @@ #lang debug racket/base -(require racket/list - racket/string +(require racket/string racket/format racket/match + "attr.rkt" "quad.rkt" "pipeline.rkt" - "struct.rkt" - "layout.rkt" - "constants.rkt") + "struct.rkt") (provide (all-defined-out)) (define-pass (make-drawing-insts qs) - #:pre (list-of has-position?) + ;; TODO: stronger precondition. but `has-position?` is too strong + #:pre (list-of quad?) #:post (list-of $drawing-inst?) (apply append (let ([current-font #false]) (for/list ([q (in-list qs)]) - (cond - [(eq? boq q) (list ($doc-start))] - [(eq? eoq q) (list ($doc-end))] - [(bop-quad? q) (list ($page-start (quad-ref q :page-width) (quad-ref q :page-height)))] - [(eop-quad? q) (list ($page-end))] - [(quad? q) - (append - (match (quad-ref q :font-path) - [(== current-font) null] - [font-path - (set! current-font font-path) - (list ($font font-path))]) - (if (pair? (quad-elems q)) - (list ($move (quad-origin q)) ($text (char->integer (car (string->list (car (quad-elems q))))))) - null))] - [else (raise-argument-error 'make-drawing-insts "known thing" q)]))))) + (cond + [(eq? bod q) (list ($doc-start))] + [(eq? eod q) (list ($doc-end))] + [(bop-quad? q) (list ($page-start (quad-ref q :page-width) (quad-ref q :page-height)))] + [(eop-quad? q) (list ($page-end))] + [(quad? q) + (append + (match (quad-ref q :font-path) + [(== current-font) null] + [font-path + (set! current-font font-path) + (list ($font font-path))]) + (if (pair? (quad-elems q)) + (list ($move (quad-origin q)) ($text (char->integer (car (string->list (car (quad-elems q))))))) + null))] + [else (raise-argument-error 'make-drawing-insts "known thing" q)]))))) (define valid-tokens '(doc-start doc-end page-start page-end text move set-font)) @@ -43,14 +42,14 @@ (define ymax (if (pair? move-points) (add1 (apply max (map $point-y move-points))) 0)) (string-join (for/list ([x (in-list xs)]) - (string-join (map ~a (match x - ;; TODO: embed these code-generating functions - ;; as properties of the structs - [($move ($point x y)) (list y x 'move)] - [($text charint) (list charint 'text)] - [($font path-string) (list path-string 'set-font)] - [($doc-start) '(doc-start)] - [($doc-end) '(doc-end)] - [($page-start width height) (list height width 'page-start)] - [($page-end) '(page-end)] - [_ (error 'unknown-drawing-inst)])) " ")) "\n")) \ No newline at end of file + (string-join (map ~a (match x + ;; TODO: embed these code-generating functions + ;; as properties of the structs + [($move ($point x y)) (list y x 'move)] + [($text charint) (list charint 'text)] + [($font path-string) (list path-string 'set-font)] + [($doc-start) '(doc-start)] + [($doc-end) '(doc-end)] + [($page-start width height) (list height width 'page-start)] + [($page-end) '(page-end)] + [_ (error 'unknown-drawing-inst)])) " ")) "\n")) \ No newline at end of file diff --git a/quad2/font.rkt b/quad2/font.rkt index 920c38c2..502a4bc5 100644 --- a/quad2/font.rkt +++ b/quad2/font.rkt @@ -5,31 +5,32 @@ racket/list racket/set racket/string - fontland/font-path + "attr.rkt" "quad.rkt" "constants.rkt" "pipeline.rkt" "param.rkt" "struct.rkt" - "dimension.rkt" - "attr.rkt" + "attr-passes.rkt" "glyphrun.rkt" - (prefix-in unicode: (combine-in "unicode/emoji.rkt" "unicode/math.rkt"))) + (prefix-in unicode: (combine-in "unicode/emoji.rkt"))) (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 base-extensions '(".otf" ".ttf" ".woff" ".woff2")) (define font-file-extensions (map string->bytes/utf-8 (append base-extensions (map string-upcase base-extensions)))) - (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. @@ -51,47 +52,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)) @@ -106,14 +111,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) @@ -121,38 +129,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") @@ -194,7 +210,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 @@ -202,7 +220,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)) @@ -212,11 +231,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 @@ -248,7 +267,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)) @@ -267,7 +287,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 @@ -281,7 +301,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)))) @@ -292,18 +312,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])))))) diff --git a/quad2/layout.rkt b/quad2/layout.rkt index 64c9d5c9..b723e6dc 100644 --- a/quad2/layout.rkt +++ b/quad2/layout.rkt @@ -8,14 +8,6 @@ ($point? $size? . -> . $point?) ($point (+ ($point-x p0) ($size-width p1)) (+ ($point-y p0) ($size-height p1)))) -(define/contract (size q) - (quad? . -> . $size?) - (quad-size q)) - -(define/contract (advance q) - (quad? . -> . $size?) - (quad-size q)) - (define (min-x rect) ($point-x ($rect-origin rect))) (define (width rect) ($size-width ($rect-size rect))) (define (max-x rect) (+ (min-x rect) (width rect))) @@ -49,22 +41,29 @@ (set-quad-size! q ($size (length (or (quad-elems q) null)) 0)) q) +(define (has-size? x) + (and (quad? x) (quad-size x))) + (define-pass (layout qs) - #:pre (list-of has-no-position?) - #:post (list-of has-position?) + ;; TODO: stronger pre & postcondition. + ;; but `has-size?` is too strong for precondition, + ;; and `has-position?` is too strong for postcondition. + ;; because we need to preserve signals like bop and eop + #:pre (list-of quad?) + #:post (list-of quad?) (define frame ($rect ($point 0 0) ($size (current-wrap-width) 30))) (define (quad-fits? q posn) - (rect-contains-rect? frame ($rect posn (size q)))) + (rect-contains-rect? frame ($rect posn (quad-size q)))) (for/fold ([posn0 ($point 0 0)] - #:result (filter has-position? qs)) - ([q (in-list (map make-debug-size qs))] + #:result qs) + ([q (in-list qs)] #:when (quad-size q)) (define first-posn-on-next-line ($point 0 (add1 ($point-y posn0)))) (define other-possible-posns (list first-posn-on-next-line)) (define posn1 (for/first ([posn (in-list (cons posn0 other-possible-posns))] #:when (quad-fits? q posn)) - posn)) + posn)) (unless posn1 (error 'no-posn-that-fits)) (set-quad-origin! q posn1) - (posn-add posn1 (advance q)))) \ No newline at end of file + (posn-add posn1 ($size ($size-width (quad-size q)) 0)))) \ No newline at end of file diff --git a/quad2/linearize.rkt b/quad2/linearize.rkt index bbb1b39b..d56e1180 100644 --- a/quad2/linearize.rkt +++ b/quad2/linearize.rkt @@ -38,7 +38,13 @@ [else (list (mq (list e)))])))]))))) (module+ test - (define q (make-quad #:attrs (hasheq 'foo 42) #:elems (list (make-quad #:elems (list "Hi" " idiot" (make-quad #:attrs (hasheq 'bar 84) #:elems '("There")) " Eve" "ry" "one" (make-quad #:attrs (hasheq 'zam 108) #:elems null)))))) + (define q (make-quad #:attrs (hasheq 'foo 42) + #:elems (list (make-quad + #:attrs (make-hasheq) + #:elems (list "Hi" " idiot" + (make-quad #:attrs (hasheq 'bar 84) + #:elems '("There")) " Eve" "ry" "one" (make-quad #:attrs (hasheq 'zam 108) + #:elems null)))))) (define lqs (linearize (list q))) lqs) @@ -115,18 +121,12 @@ (unless (eop-quad? (last qs)) (error 'not-an-eop-quad)) ((list-of simple-quad?) (drop-right (cdr qs) 1))) - (define bop (bop-quad)) - (define eop (eop-quad)) - (set-quad-attrs! bop (quad-attrs (first qs))) - (set-quad-attrs! eop (quad-attrs (last qs))) - (append (list bop) qs (list eop))) + (insert-at-end (insert-at-beginning qs (bop-quad)) (eop-quad))) -(define-pass (append-boq-and-eoq qs) +(define-pass (append-bod-and-eod qs) ;; attach the boq and eoq signals #:pre (list-of simple-quad?) #:post (λ (qs) (match qs - [(list (== boq) (? simple-quad?) ... (== eoq)) #true] + [(list (== bod) (? simple-quad?) ... (== eod)) #true] [_ #false])) - (set-quad-attrs! boq (quad-attrs (first qs))) - (set-quad-attrs! eoq (quad-attrs (last qs))) - (append (list boq) qs (list eoq))) \ No newline at end of file + (insert-at-end (insert-at-beginning qs bod) eod)) \ No newline at end of file diff --git a/quad2/main.rkt b/quad2/main.rkt index df682e02..8490f4aa 100644 --- a/quad2/main.rkt +++ b/quad2/main.rkt @@ -6,19 +6,24 @@ "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) + "text.rkt" + 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. @@ -37,9 +42,6 @@ parse-dimension-strings resolve-font-sizes resolve-font-features - parse-page-sizes - resolve-font-paths - complete-attr-paths ;; linearization ============= ;; we postpone this step until we're certain any @@ -50,6 +52,11 @@ linearize ;; post-linearization resolutions & parsings ============= + parse-page-sizes + print-pass + resolve-font-paths + print-pass + complete-attr-paths mark-text-runs merge-adjacent-strings split-whitespace @@ -58,7 +65,8 @@ remove-font-without-char insert-fallback-font append-bop-and-eop - append-boq-and-eoq + append-bod-and-eod + measure-text-runs layout make-drawing-insts stackify)) @@ -76,9 +84,9 @@ [current-use-postconditions? #t]) (quad-compile (bootstrap-input x)))) - (match (test-compile "WHO") + (match (test-compile "Whomever") [(? string? insts) - (displayln insts) + #;(displayln insts) #;(render insts #:using text-renderer) #;(render insts #:using drr-renderer) (render insts #:using (html-renderer (build-path (find-system-path 'desk-dir) "test.html"))) diff --git a/quad2/page.rkt b/quad2/page.rkt index 4f108bb3..27506df2 100644 --- a/quad2/page.rkt +++ b/quad2/page.rkt @@ -1,6 +1,7 @@ #lang debug racket/base (require "quad.rkt" "attr.rkt" + "attr-passes.rkt" "pipeline.rkt" "constants.rkt" "param.rkt" diff --git a/quad2/param.rkt b/quad2/param.rkt index 98365144..5b2c29fc 100644 --- a/quad2/param.rkt +++ b/quad2/param.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/match "constants.rkt" + "attr.rkt" "struct.rkt") (provide (all-defined-out)) diff --git a/quad2/pipeline.rkt b/quad2/pipeline.rkt index 7843c204..265c55ab 100644 --- a/quad2/pipeline.rkt +++ b/quad2/pipeline.rkt @@ -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) @@ -48,7 +58,7 @@ (define failure-msg (format "~a pass (as precondition)" 'PASS-NAME)) (with-handlers ([exn:fail:contract? (make-failure-handler failure-msg)]) (unless (PRECOND-PROC ARG) - (raise-argument-error 'PASS-NAME (symbol->string 'PRECOND-PROC) ARG)))) + (raise-argument-error 'PASS-NAME (format "~a" 'PRECOND-PROC) ARG)))) ;; a pass can be functional or mutational. ;; if it returns void, assume mutational ;; and return the input item. @@ -61,7 +71,7 @@ (define failure-msg (format "~a pass (as postcondition)" 'PASS-NAME)) (with-handlers ([exn:fail:contract? (make-failure-handler failure-msg)]) (unless (POSTCOND-PROC res) - (raise-argument-error 'PASS-NAME (symbol->string 'POSTCOND-PROC) ARG))))))) + (raise-argument-error 'PASS-NAME (format "~a" 'POSTCOND-PROC) ARG))))))) 'PASS-NAME)))])) (define-pass (print-pass qs) diff --git a/quad2/quad-passes.rkt b/quad2/quad-passes.rkt new file mode 100644 index 00000000..8ee00009 --- /dev/null +++ b/quad2/quad-passes.rkt @@ -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))) \ No newline at end of file diff --git a/quad2/quad.rkt b/quad2/quad.rkt index dee355f5..bcb1b7eb 100644 --- a/quad2/quad.rkt +++ b/quad2/quad.rkt @@ -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 @@ -147,9 +136,31 @@ (module+ test (define q (make-quad #:tag 'div #:attrs (make-hasheq '((hello . "world"))) #:elems (list "fine")))) -(define boq (make-quad #:tag 'boq-quad)) -(define eoq (make-quad #:tag 'eoq-quad)) +(define bod (make-quad #:tag 'bod-quad)) +(define eod (make-quad #:tag 'eod-quad)) (define (bop-quad) (make-quad #:tag 'bop-quad)) (define (bop-quad? x) (and (quad? x) (eq? (quad-tag x) 'bop-quad))) (define (eop-quad) (make-quad #:tag 'eop-quad)) (define (eop-quad? x) (and (quad? x) (eq? (quad-tag x) 'eop-quad))) + +(define (insert-at-beginning qs x) + (unless (andmap quad? qs) + (raise-argument-error 'insert-at-beginning "list of quads" qs)) + (unless (quad? x) + (raise-argument-error 'insert-at-beginning "quad" x)) + (cond + [(pair? qs) + (set-quad-attrs! x (quad-attrs (first qs))) + (cons x qs)] + [else (list x)])) + +(define (insert-at-end qs x) + (unless (andmap quad? qs) + (raise-argument-error 'insert-at-end "list of quads" qs)) + (unless (quad? x) + (raise-argument-error 'insert-at-end "quad" x)) + (cond + [(pair? qs) + (set-quad-attrs! x (quad-attrs (last qs))) + (append qs (list x))] + [else (list x)])) \ No newline at end of file diff --git a/quad2/render.rkt b/quad2/render.rkt index dc764a1e..ecdbd8f3 100644 --- a/quad2/render.rkt +++ b/quad2/render.rkt @@ -5,16 +5,54 @@ txexpr) (provide (all-defined-out)) -(struct $renderer (doc-start-func - doc-end-func - page-start-func - page-end-func - text-func - set-font-func - move-func - return-func) #:transparent) +(module inner racket/base + (provide (all-defined-out)) + (struct $renderer (doc-start-func + doc-end-func + page-start-func + page-end-func + text-func + set-font-func + move-func + return-func) #:transparent) -(define current-renderer (make-parameter ($renderer void void void void void void void void))) + (define-syntax-rule (check-arity PROCNAME [PROC ARITY] ...) + (begin + (unless (or (eq? (procedure-arity PROC) ARITY) (equal? void PROC)) + (raise-argument-error PROCNAME (format "procedure of arity ~a for ~a" ARITY 'PROC) PROC)) ...)) + + (define (make-renderer + #:doc-start-func [doc-start-func void] + #:doc-end-func [doc-end-func void] + #:page-start-func [page-start-func void] + #:page-end-func [page-end-func void] + #:text-func [text-func void] + #:set-font-func [set-font-func void] + #:move-func [move-func void] + #:return-func [return-func void]) + (check-arity 'make-renderer + [doc-start-func 0] + [doc-end-func 0] + [page-start-func 2] + [page-end-func 0] + [text-func 1] + [set-font-func 1] + [move-func 2] + [return-func 0]) + ($renderer doc-start-func + doc-end-func + page-start-func + page-end-func + text-func + set-font-func + move-func + return-func))) + +(require 'inner) + +(define null-renderer (make-renderer)) + +(define current-renderer (make-parameter null-renderer)) (define text-renderer ;; scan over the instructions and record where the chars want to go @@ -23,28 +61,27 @@ [xmax 0] [ymax 0] [results null]) - ($renderer - void - void + (make-renderer + #:page-start-func (λ (width height) (set! xmax width) (set! ymax height)) + #:page-end-func (λ () ;; fill in a character grid (define str (string-join (for/list ([y (in-range ymax)]) - (list->string - (map integer->char - (for/list ([x (in-range xmax)]) - (hash-ref char-pos-table (make-rectangular x y) (char->integer #\space)))))) "\n")) + (list->string + (map integer->char + (for/list ([x (in-range xmax)]) + (hash-ref char-pos-table (make-rectangular x y) (char->integer #\space)))))) "\n")) (set! results (cons str results))) - (λ (str) (hash-set! char-pos-table current-loc str)) - void - (λ (x y) (set! current-loc (make-rectangular x y))) - (λ () - #;(unless (pair? results) - (error 'text-renderer-failed)) - (for-each displayln results))))) + #:text-func (λ (str) (hash-set! char-pos-table current-loc str)) + #:move-func (λ (x y) (set! current-loc (make-rectangular x y))) + #:return-func (λ () + #;(unless (pair? results) + (error 'text-renderer-failed)) + (for-each displayln results))))) (require racket/gui) @@ -54,24 +91,22 @@ [dc #f] [current-loc 0+0i] [current-font #false]) - ($renderer - void - void - (let ([em-scale 30] - [my-face (match (get-face-list 'mono) + (make-renderer + #:page-start-func + (let ([my-face (match (get-face-list 'mono) [(? null?) (error 'no-mono-font-available)] [(cons face _) face])]) (λ (width height) - (define target (make-bitmap (* em-scale width) (* em-scale height))) + (define target (make-bitmap width height)) (set! targets (cons target targets)) (set! dc (new bitmap-dc% [bitmap target])) - (send dc scale em-scale em-scale) (send dc set-font (make-font #:size 1 #:face my-face)) (send dc set-text-foreground "black"))) - void + #:text-func (λ (charint) (when dc (send dc draw-text (string (integer->char charint)) (real-part current-loc) (imag-part current-loc)))) + #:set-font-func (λ (ps) ;; racket/draw can't load arbitrary user fonts from a path ;; https://github.com/racket/racket/issues/1348 @@ -80,36 +115,41 @@ ;; but it would allow slightly more accurate rendering for contexts ;; that don't support fonts by path (log-quad2-warning (format "can't load font ~a" ps))) + #:move-func (λ (x y) (set! current-loc (make-rectangular x y))) + #:return-func (λ () (for-each displayln (map (λ (target) (make-object image-snip% target)) targets)))))) (define (html-renderer html-file) (let ([xmax 0] [ymax 0] - [em-scale 30] [page-quads null] [current-loc 0+0i] [pages null] [fonts (make-hasheqv)] [current-font ""]) - ($renderer - void - void + (make-renderer + #:page-start-func (λ (width height) (set! page-quads null) (set! xmax width) (set! ymax height)) + #:page-end-func (λ () (set! pages (cons `(div ((class "page") (style ,(format "position: relative;width:~apx;height:~apx;border:1px solid black;background:white" xmax ymax))) ,@(reverse page-quads)) pages)) (set! page-quads null)) + #:text-func (λ (charint) (set! page-quads (cons - `(div ((style ,(format "position: absolute;left:~apx;top:~apx;font-family:~a" (* em-scale (real-part current-loc)) (* em-scale (imag-part current-loc)) current-font))) + `(div ((style ,(format "position: absolute;left:~apx;top:~apx;font-family:~a;font-size:~apx" (real-part current-loc) (imag-part current-loc) current-font 12))) ,(string (integer->char charint))) page-quads))) + #:set-font-func (λ (ps) (set! current-font (hash-ref! fonts ps (λ () (gensym 'font))))) + #:move-func (λ (x y) (set! current-loc (make-rectangular x y))) + #:return-func (λ () (with-output-to-file html-file #:exists 'replace @@ -120,27 +160,53 @@ (head (style ((type "text/css")) ,(string-join (for/list ([(ps fontsym) (in-hash fonts)]) - (format "@font-face { font-family: \"~a\";\nsrc: url(\"~a\");}" fontsym ps))))) + (format "@font-face { font-family: \"~a\";\nsrc: url(\"~a\");}" fontsym ps))))) (body ((style "background: #ddd")) ,@pages)))))))))) +(define-syntax (cond-eq stx) + (syntax-case stx (else) + [(MAC ARG [SYM . BODY] ... [else ELSEBODY]) + #'(cond + [(eq? ARG SYM) . BODY] ... + [else ELSEBODY])] + [(MAC ARG CLAUSE ...) + #'(MAC ARG CLAUSE ... [else (void)])])) + (define (render inst-str #:using [renderer (current-renderer)]) + (match-define ($renderer + doc-start-func + doc-end-func + page-start-func + page-end-func + text-func + set-font-func + move-func + return-func) renderer) (let/ec exit (for/fold ([stack null] #:result (void)) ([tok (in-port read (open-input-string inst-str))]) - (define next-stack (cons tok stack)) - (cond - [(memq tok valid-tokens) - (match next-stack - [(list* 'doc-start rest) (($renderer-doc-start-func renderer)) rest] - [(list* 'doc-end _) (exit (($renderer-doc-end-func renderer)))] - [(list* 'page-start x y rest) (($renderer-page-start-func renderer) x y) rest] - [(list* 'page-end rest) (($renderer-page-end-func renderer)) rest] - [(list* 'text charint rest) (($renderer-text-func renderer) charint) rest] - [(list* 'set-font path-string rest) (($renderer-set-font-func renderer) (symbol->string path-string)) rest] - [(list* 'move x y rest) (($renderer-move-func renderer) x y) rest] - [_ next-stack])] - [else next-stack]))) - (($renderer-return-func renderer))) + (cond-eq tok + ['doc-start (doc-start-func) stack] + ['doc-end (exit (doc-end-func)) (error 'should-never-reach)] + ['page-start + (match-define (list* x y tail) stack) + (page-start-func x y) + tail] + ['page-end (page-end-func) stack] + ['text + (match-define (cons charint tail) stack) + (text-func charint) + tail] + ['set-font + (match-define (cons path-string tail) stack) + (set-font-func (symbol->string path-string)) + tail] + ['move + (match-define (list* x y tail) stack) + (move-func x y) + tail] + [else (cons tok stack)]))) + (return-func)) diff --git a/quad2/text.rkt b/quad2/text.rkt new file mode 100644 index 00000000..40f5261c --- /dev/null +++ b/quad2/text.rkt @@ -0,0 +1,17 @@ +#lang debug racket/base +(require "pipeline.rkt" + "quad.rkt" + "attr.rkt" + "glyphrun.rkt" + fontland) +(provide (all-defined-out)) + +(define-pass (measure-text-runs qs) + #:pre (list-of quad?) + #:post (list-of quad?) + (for ([q (in-list qs)] + #:when (eq? (quad-tag q) 'text-run)) + (define font (get-font (quad-ref q :font-path))) + (define x-advance (glyph-position-x-advance (vector-ref (glyphrun-positions (layout font (car (quad-elems q)))) 0))) + (define font-size (quad-ref q :font-size)) + (set-quad-size! q ($size (* (/ x-advance (font-units-per-em font) 1.0) font-size) font-size)))) \ No newline at end of file