mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

Merge branch 'main' of https://github.com/mbutterick/typesetting

Browse Source
main
Matthew Butterick 2 years ago
parent 09d7a8f939 54b2ff0bf9
commit d6e4b81675
20 changed files with 623 additions and 462 deletions
Show Stats Download Patch File Download Diff File

205
quad2/attr-passes.rkt
Unescape Escape View File

@ -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)))

232
quad2/attr.rkt
Unescape Escape View File

@ -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)))
(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)]
)

32
quad2/constants.rkt
Unescape Escape View File

@ -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)]
)

BIN
quad2/default-fonts/default/SourceSerifPro-Regular.otf
View File

Binary file not shown.

BIN
quad2/default-fonts/default/bold-italic/SourceSerif4-BoldIt.otf
View File

Binary file not shown.

BIN
quad2/default-fonts/default/bold/SourceSerif4-Bold.otf
View File

Binary file not shown.

BIN
quad2/default-fonts/default/italic/SourceSerif4-It.otf
View File

Binary file not shown.

BIN
quad2/default-fonts/default/regular/SourceSerif4-Regular.otf
View File

Binary file not shown.

65
quad2/draw.rkt
Unescape Escape View File

@ -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"))
(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"))

196
quad2/font.rkt
Unescape Escape View File

@ -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]))))))

29
quad2/layout.rkt
Unescape Escape View File

@ -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))))
(posn-add posn1 ($size ($size-width (quad-size q)) 0))))

22
quad2/linearize.rkt
Unescape Escape View File

@ -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)))
(insert-at-end (insert-at-beginning qs bod) eod))

28
quad2/main.rkt
Unescape Escape View File

@ -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")))

1
quad2/page.rkt
Unescape Escape View File

@ -1,6 +1,7 @@
#lang debug racket/base
(require "quad.rkt"
"attr.rkt"
"attr-passes.rkt"
"pipeline.rkt"
"constants.rkt"
"param.rkt"

1
quad2/param.rkt
Unescape Escape View File

@ -1,6 +1,7 @@
#lang racket/base
(require racket/match
"constants.rkt"
"attr.rkt"
"struct.rkt")
(provide (all-defined-out))

14
quad2/pipeline.rkt
Unescape Escape View File

@ -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)

26
quad2/quad-passes.rkt
Unescape Escape View File

@ -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)))

49
quad2/quad.rkt
Unescape Escape View File

@ -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)]))

168
quad2/render.rkt
Unescape Escape View File

@ -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))

17
quad2/text.rkt
Unescape Escape View File

@ -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))))
Write Preview
Loading…
Cancel
Save