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

improve iteration

Browse Source 
handle flat list or tree
main
Matthew Butterick 3 years ago
parent 4ec35cd238
commit ce02eca979
5 changed files with 126 additions and 113 deletions
Show Stats Download Patch File Download Diff File

117
quad2/attr.rkt
Unescape Escape View File

@ -3,6 +3,7 @@
racket/hash
racket/list
racket/string
racket/set
"dimension.rkt"
"pipeline.rkt"
"struct.rkt"
@ -11,22 +12,28 @@
"param.rkt")
(provide (all-defined-out))
(define (do-attr-iteration qs #:which-attr which-arg #:value-proc proc)
(define key-predicate
(match which-arg
[(? attr? attr) (λ (k) (eq? k (attr-name attr)))]
[(and (list (? attr?) ...) attrs) (λ (k) (memq k (map attr-name attrs)))]
[(? procedure? pred) pred]
(define (do-attr-iteration qs
#:which-attr which-attr
#:attr-proc attr-proc)
(define attr-predicate
(match which-attr
[(? 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)]))
(define attrs-seen (make-hasheq))
(for ([q (in-list qs)])
(define attrs (quad-attrs q))
(hash-ref! attrs-seen attrs
(λ ()
(for ([k (in-hash-keys attrs)]
#:when (key-predicate k))
(hash-update! attrs k (λ (val) (proc val attrs))))
#t)))
(define attrs-seen (mutable-seteq))
(let loop ([xs qs])
(for ([x (in-list xs)]
#:when (quad? x))
(let* ([q x]
[attrs (quad-attrs q)])
(unless (set-member? attrs-seen attrs)
(for ([(ak av) (in-hash attrs)]
#:when (attr-predicate ak av))
(hash-set! attrs ak (attr-proc ak av attrs)))
(set-add! attrs-seen attrs))
(loop (quad-elems q)))))
qs)
(define-pass (upgrade-attr-keys qs)
@ -35,27 +42,23 @@
#:pre (list-of quad?)
#:post (list-of quad?)
(define attr-lookup-table (for/hasheq ([a (in-list (current-attrs))])
(values (attr-name a) a)))
(define attrs-seen (make-hasheq))
(values (attr-key-name a) a)))
(define attrs-seen (mutable-seteq))
(define strict-attrs? (current-strict-attrs?))
(for ([q (in-list qs)])
(define attrs (quad-attrs q))
(hash-ref! attrs-seen attrs
(λ ()
(for ([(k v) (in-hash attrs)]
#:unless (attr? k))
(cond
[(symbol? k)
(match (hash-ref attr-lookup-table k #false)
[(? attr? attr)
(hash-remove! attrs k)
(hash-set! attrs attr v)]
[_ #:when strict-attrs?
(raise-argument-error 'upgrade-attr-keys "known attr" k)]
[_ (void)])]
[else (raise-argument-error 'upgrade-attr-keys "symbol or attr" k)]))
#t)))
qs)
(define (do-upgrade ak av attrs)
(cond
[(symbol? ak)
(match (hash-ref attr-lookup-table ak #false)
[(? attr-key? attr)
(hash-remove! attrs ak)
(hash-set! attrs attr av)]
[_ #:when strict-attrs?
(raise-argument-error 'upgrade-attr-keys "known attr" ak)]
[_ (void)])]
[else (raise-argument-error 'upgrade-attr-keys "symbol or attr" ak)]))
(do-attr-iteration qs
#:which-attr (λ (ak) (not (attr-key? ak)))
#:attr-proc do-upgrade))
(define-pass (downcase-attr-values qs)
;; make attribute values lowercase, unless they're case-sensitive
@ -68,27 +71,29 @@
#:pre (list-of quad?)
#:post (list-of quad?)
(do-attr-iteration qs
#:which-attr attr-cased-string?
#:value-proc (λ (val attrs) (string-downcase val))))
#: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?
#:value-proc (λ (val attrs) (match (string-downcase val)
["false" #false]
[_ #true]))))
#:which-attr attr-boolean-key?
#:attr-proc (λ (ak av attrs) (match (string-downcase av)
["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?
#:value-proc (λ (val attrs)
(or (string->number val)
(raise-argument-error 'convert-numeric-attr-values "numeric string" val)))))
#:which-attr attr-numeric-key?
#:attr-proc (λ (ak av attrs)
(cond
[(string->number av)]
[else
(raise-argument-error 'convert-numeric-attr-values "numeric string" av)]))))
(define-pass (complete-attr-paths qs)
#:pre (list-of quad?)
@ -97,8 +102,8 @@
;; 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?
#:value-proc (λ (val attrs) (path->complete-path val))))
#:which-attr attr-path-key?
#:attr-proc (λ (ak av attrs) (path->complete-path av))))
(define-pass (parse-dimension-strings qs)
#:pre (list-of quad?)
@ -106,18 +111,18 @@
;; 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?
#:value-proc parse-dimension))
#:which-attr attr-dimension-string-key?
#:attr-proc (λ (ak av attrs) (parse-dimension av attrs))))
(module+ test
(require rackunit)
(define-attr-list debug-attrs
[:foo (attr-cased-string 'foo)]
[:ps (attr-path 'ps)]
[:dim (attr-dimension-string 'dim)]
[:boolt (attr-boolean 'bool)]
[:boolf (attr-boolean 'bool)]
[:num (attr-numeric 'num)])
[:foo (attr-cased-string-key 'foo)]
[:ps (attr-path-key 'ps)]
[:dim (attr-dimension-string-key 'dim)]
[:boolt (attr-boolean-key 'bool)]
[:boolf (attr-boolean-key 'bool)]
[:num (attr-numeric-key 'num)])
(parameterize ([current-attrs debug-attrs])
(define q (make-quad #:attrs (make-hasheq (list (cons :foo "BAR")
(cons 'ding "dong")
@ -134,7 +139,7 @@
(parameterize ([current-strict-attrs? #true])
(upgrade-attr-keys qs))))
(check-equal? (quad-ref (car (downcase-attr-values qs)) :foo) "bar")
(check-true (complete-path? (string->path (quad-ref (car (complete-attr-paths qs)) :ps))))
(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))

10
quad2/font.rkt
Unescape Escape View File

@ -118,12 +118,12 @@
;; 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
(define this-font-family (hash-ref! attrs (attr-name :font-family) default-font-family))
(define this-font-family (hash-ref! attrs (attr-key-name :font-family) default-font-family))
(match (string-downcase this-font-family)
[(? font-path-string? ps) (path->complete-path ps)]
[_
(define this-bold (hash-ref! attrs (attr-name :font-bold) #false))
(define this-italic (hash-ref! attrs (attr-name :font-italic) #false))
(define this-bold (hash-ref! attrs (attr-key-name :font-bold) #false))
(define this-italic (hash-ref! attrs (attr-key-name :font-italic) #false))
(font-attrs->path font-paths this-font-family this-bold this-italic)]))
(define-pass (resolve-font-paths qs)
@ -135,12 +135,12 @@
(define font-paths (setup-font-path-table))
(do-attr-iteration qs
#:which-attr :font-family
#:value-proc (λ (val attrs) (resolve-font-path font-paths val attrs))))
#:attr-proc (λ (ak av attrs) (resolve-font-path font-paths av attrs))))
(module+ test
(require rackunit)
(define-attr-list debug-attrs
[:font-family (attr-uncased-string 'font-family)])
[:font-family (attr-uncased-string-key 'font-family)])
(parameterize ([current-attrs debug-attrs])
(define (resolved-font-for-family val #:bold [bold #f] #:italic [italic #f])
(define qs (list (make-quad #:attrs (make-hasheq

28
quad2/linearize.rkt
Unescape Escape View File

@ -9,25 +9,27 @@
(define (simple-quad? x) (and (quad? x) (<= (length (quad-elems x)) 1)))
(define-pass (linearize-quad q)
(define-pass (linearize qs)
;; convert a single quad into a list of quads, with the attributes propagated downward
;; every resulting quad should have at most one element
#:pre quad?
#:pre (list-of quad?)
#:post (list-of simple-quad?)
(let loop ([q q][attrs-context (make-quad-attrs)]) ;; returns (list-of quad?)
(define current-attrs (quad-attrs-union attrs-context (quad-attrs q)))
(define (mq es) (make-quad #:tag (quad-tag q) #:attrs current-attrs #:elems es))
(match (quad-elems q)
[(? null?) (list (mq null))]
[(? pair? elems)
(apply append (for/list ([e (in-list elems)])
(cond
[(quad? e) (loop e current-attrs)]
[else (list (mq (list e)))])))])))
(append*
(for/list ([q (in-list qs)])
(let loop ([q q][attrs-context (make-quad-attrs)]) ;; returns (list-of quad?)
(define current-attrs (quad-attrs-union attrs-context (quad-attrs q)))
(define (mq es) (make-quad #:tag (quad-tag q) #:attrs current-attrs #:elems es))
(match (quad-elems q)
[(? null?) (list (mq null))]
[(? pair? elems)
(apply append (for/list ([e (in-list elems)])
(cond
[(quad? e) (loop e current-attrs)]
[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 lqs (linearize-quad q))
(define lqs (linearize (list q)))
lqs)

82
quad2/main.rkt
Unescape Escape View File

@ -12,60 +12,66 @@
"constants.rkt"
"param.rkt"
racket/string
racket/list
racket/match)
(define-pass (bootstrap-input x)
;; turn a simple string into a quad for testing layout.
#:pre string?
#:post quad?
(match x
[(or (? quad? q) (list (? quad? q))) q]
[(and (list (? quad?) ...) qs) (make-quad #:elems qs)]
[other (make-quad #:elems (list other))]))
#:post (list-of quad?)
(list (match x
[(or (? quad? q) (list (? quad? q))) q]
[(and (list (? quad?) ...) qs) (make-quad #:elems qs)]
[other (make-quad #:elems (list other))])))
(define-pass (split-into-single-char-quads qs)
;; break list of quads into single characters (keystrokes)
#:pre (list-of simple-quad?)
#:post (list-of simple-quad?)
(apply append
(for/list ([q (in-list qs)])
(match q
[(quad _ _ (list (? string? str)) _)
(for/list ([c (in-string str)])
(struct-copy quad q [elems (list (string c))]))]
[_ (list q)]))))
(append*
(for/list ([q (in-list qs)])
(match q
[(quad _ _ (list (? string? str)) _)
(for/list ([c (in-string str)])
(struct-copy quad q [elems (list (string c))]))]
[_ (list q)]))))
(define quad-compile
(make-pipeline (list
bootstrap-input
linearize-quad
;; attribute prep =============
;; all attrs start out as symbol-string pairs.
;; we convert keys & values to corresponding higher-level types.
upgrade-attr-keys
downcase-attr-values
convert-boolean-attr-values
convert-numeric-attr-values
;; we resolve dimension strings after font size
;; because they can be denoted relative to em size
parse-dimension-strings
;; attribute sanitizing =============
;; all attrs start out as symbol-string pairs.
;; we convert keys & values to corresponding higher-level types.
upgrade-attr-keys
downcase-attr-values
convert-boolean-attr-values
convert-numeric-attr-values
;; linearization =============
;; we postpone this step until we're certain any
;; information encoded from the hierarchy of quads
;; has been absorbed into the attrs
;; (e.g., cascading font sizes)
;; because once we linearize, that information is gone.
linearize
;; resolutions & parsings =============
resolve-font-paths
complete-attr-paths
;; TODO: resolve font sizes
;; we resolve dimension strings after font size
;; because they can be denoted relative to em size
parse-dimension-strings
;; TODO: parse feature strings
;; resolutions & parsings =============
resolve-font-paths
complete-attr-paths
;; TODO: resolve font sizes
;; TODO: parse feature strings
mark-text-runs
merge-adjacent-strings
split-whitespace
split-into-single-char-quads
;; TODO: missing glyphs
layout
make-drawing-insts
stackify)))
mark-text-runs
merge-adjacent-strings
split-whitespace
split-into-single-char-quads
;; TODO: missing glyphs
layout
make-drawing-insts
stackify)))
(define insts (parameterize ([current-wrap-width 13]
[current-attrs all-attrs]
@ -73,7 +79,7 @@
[current-show-timing? #f]
[current-use-preconditions? #t]
[current-use-postconditions? #t])
(quad-compile "Hello this is the earth")))
(quad-compile (bootstrap-input "Hello this is the earth"))))
(when (string? insts)
(render insts #:using text-renderer)

2
quad2/pipeline.rkt
Unescape Escape View File

@ -36,7 +36,7 @@
(list
(procedure-rename
#,(syntax/loc stx
(λ (ARG OTHER-ARG ...)
(λ (ARG)
(when (current-use-preconditions?)
(unless (PRECOND-PROC ARG)
(raise-argument-error 'PASS-NAME (format "~a (as precondition)" 'PRECOND-PROC) ARG)))

Write Preview
Loading…
Cancel
Save