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

it lives

Browse Source
main
Matthew Butterick 5 years ago
parent 9485d03320
commit cd888b53f7
2 changed files with 86 additions and 73 deletions
Show Stats Download Patch File Download Diff File

32
quad/quadwriter/query.rkt
Unescape Escape View File

@ -3,9 +3,9 @@
(provide (all-defined-out))
(define (make-linear-index q)
(if (quad? q)
(cons q (append-map make-linear-index (quad-elems q)))
null))
(cons q (append* (for/list ([elem (in-list (quad-elems q))]
#:when (quad? elem))
(make-linear-index elem)))))
(define (string->pred str)
(match str
@ -18,13 +18,15 @@
(define (parse-query str)
(for/list ([piece (in-list (string-split str ":"))])
(match (regexp-match #px"^(.*)\\[(.*?)\\]$" piece)
[#false (cons (string->pred piece) #false)]
[(list all name arg) (cons (string->pred name) (or (string->number arg)
(string->symbol arg)))])))
(match (regexp-match #px"^(.*)\\[(.*?)\\]$" piece)
[#false (cons (string->pred piece) #false)]
[(list all name arg) (cons (string->pred name) (or (string->number arg)
(string->symbol arg)))])))
(define (query qs query-str)
(for/fold ([qs qs]
(define (query quad-or-index query-str)
(for/fold ([qs (match quad-or-index
[(? quad? q) (make-linear-index q)]
[idx idx])]
#:result (and qs (car qs)))
([query-piece (in-list (parse-query query-str))])
(match-define (cons pred count) query-piece)
@ -43,12 +45,12 @@
(define-syntax-rule (factory type proc)
(make-quad #:type type
#:elems (for/list ([i (in-range 3)])
(set! counter (add1 counter))
(define new-q (proc))
(quad-update! new-q
[tag (format "~a[~a]-~a" 'proc counter (gensym))])
(hash-set! (quad-attrs new-q) 'count counter)
new-q)))
(set! counter (add1 counter))
(define new-q (proc))
(quad-update! new-q
[tag (format "~a[~a]-~a" 'proc counter (gensym))])
(hash-set! (quad-attrs new-q) 'count counter)
new-q)))
(define (line) (make-quad #:type line-quad))
(define (block) (factory block-quad line))

127
quad/quadwriter/render.rkt
Unescape Escape View File

@ -58,7 +58,7 @@
#:min-left-length 3
#:min-right-length 3))]
[substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))])
(struct-copy quad q [elems (list substr)]))]
(struct-copy quad q [elems (list substr)]))]
[else (list q)]))
@ -67,12 +67,12 @@
(unless (even? (length pcs))
(raise-argument-error 'string->feature-list "even number of tags and values" pcs))
(for/list ([kv (in-slice 2 pcs)])
(cons (match (first kv)
[(? string? k) (string->bytes/utf-8 k)]
[k (raise-argument-error 'string->feature-list "string" k)])
(match (string->number (second kv))
[(? number? num) num]
[v (raise-argument-error 'string->feature-list "number string" v)]))))
(cons (match (first kv)
[(? string? k) (string->bytes/utf-8 k)]
[k (raise-argument-error 'string->feature-list "string" k)])
(match (string->number (second kv))
[(? number? num) num]
[v (raise-argument-error 'string->feature-list "number string" v)]))))
(define (parse-font-features! attrs)
;; `font-features` are OpenType font feature specifiers.
@ -107,7 +107,7 @@
;; we parse them into the equivalent measurement in points.
(for ([k (in-hash-keys attrs)]
#:when (takes-dimension-string? k))
(hash-update! attrs k (λ (val) (parse-dimension val attrs))))
(hash-update! attrs k (λ (val) (parse-dimension val attrs))))
attrs)
(define (downcase-values! attrs)
@ -115,9 +115,9 @@
;; so we can check them more easily later.
(for ([k (in-hash-keys attrs)]
#:unless (has-case-sensitive-value? k))
(hash-update! attrs k (λ (val) (match val
[(? string? str) (string-downcase str)]
[_ val]))))
(hash-update! attrs k (λ (val) (match val
[(? string? str) (string-downcase str)]
[_ val]))))
attrs)
(define (complete-every-path! attrs)
@ -126,7 +126,7 @@
;; relies on `current-directory` being parameterized to source file's dir
(for ([k (in-hash-keys attrs)]
#:when (takes-path? k))
(hash-update! attrs k (compose1 path->string path->complete-path)))
(hash-update! attrs k (compose1 path->string path->complete-path)))
attrs)
(define (handle-cascading-attrs attrs)
@ -139,7 +139,7 @@
;; because they can be denoted relative to em size
parse-dimension-strings!
parse-font-features!))])
(proc attrs)))
(proc attrs)))
(define (drop-leading-breaks qs)
;; any leading breaks are pointless at the start of the doc, so drop them.
@ -164,7 +164,7 @@
(define (get-define-val q) (quad-ref q 'define))
(define-values (dqs not-dqs) (partition get-define-val qs))
(for ([dq-group (in-list (group-by get-define-val dqs))])
(hash-set! (current-named-quads) (get-define-val (car dq-group)) dq-group))
(hash-set! (current-named-quads) (get-define-val (car dq-group)) dq-group))
not-dqs)
(define default-line-height-multiplier 1.42)
@ -257,9 +257,9 @@
(cons :pdf-keywords 'Keywords)))]
[str (in-value (and (pair? qs) (quad-ref (car qs) k)))]
#:when str)
(cons pdf-k str))))
(cons pdf-k str))))
(for ([(k v) (in-dict kv-dict)])
(hash-set! (pdf-info pdf) k v)))
(hash-set! (pdf-info pdf) k v)))
(define (footnote-flow? q) (equal? (quad-ref q 'flow) "footnote"))
@ -293,19 +293,19 @@
(for ([page (in-list (for*/list ([sec (in-list secs)]
[elem (in-list (quad-elems sec))]
#:when (page-quad? elem))
elem))]
elem))]
[page-num (in-naturals 1)]
[page-side (in-cycle '(right left))])
(define repeaters-for-this-page
(for/list ([repeater (in-list repeaters)]
#:when (let* ([val (quad-ref repeater :page-repeat)]
[sym (string->symbol val)])
(or (eq? sym 'all)
(eq? sym page-side)
(eq? sym (if (= page-num 1) 'first 'rest)))))
repeater))
(when (pair? repeaters-for-this-page)
(set-quad-elems! page (append repeaters-for-this-page (quad-elems page)))))
(define repeaters-for-this-page
(for/list ([repeater (in-list repeaters)]
#:when (let* ([val (quad-ref repeater :page-repeat)]
[sym (string->symbol val)])
(or (eq? sym 'all)
(eq? sym page-side)
(eq? sym (if (= page-num 1) 'first 'rest)))))
repeater))
(when (pair? repeaters-for-this-page)
(set-quad-elems! page (append repeaters-for-this-page (quad-elems page)))))
secs)
(define (make-sections all-qs)
@ -356,20 +356,20 @@
(for/list ([page (in-list section-pages-without-repeaters)]
[page-num (in-naturals 1)]
[page-side (in-cycle ((if (eq? section-starting-side 'right) values reverse) '(right left)))])
(define section-repeaters-for-this-page
(for/list ([repeater (in-list section-repeaters)]
#:when (let* ([val (quad-ref repeater :page-repeat)]
[sym (string->symbol (string-trim val #px"section\\s"))])
(or (eq? sym 'section)
(eq? sym 'all)
(eq? sym page-side)
(eq? sym (if (= page-num 1) 'first 'rest)))))
repeater))
(cond
[(null? section-repeaters-for-this-page) page]
[else
(quad-copy page-quad page
[elems (append section-repeaters-for-this-page (quad-elems page))])])))
(define section-repeaters-for-this-page
(for/list ([repeater (in-list section-repeaters)]
#:when (let* ([val (quad-ref repeater :page-repeat)]
[sym (string->symbol (string-trim val #px"section\\s"))])
(or (eq? sym 'section)
(eq? sym 'all)
(eq? sym page-side)
(eq? sym (if (= page-num 1) 'first 'rest)))))
repeater))
(cond
[(null? section-repeaters-for-this-page) page]
[else
(quad-copy page-quad page
[elems (append section-repeaters-for-this-page (quad-elems page))])])))
(begin0
(cond
@ -402,13 +402,24 @@
(section-pages-used (+ (section-pages-used) (length section-pages))))))
(define (resolve-parents doc)
(define (wants-parent? x) (and (quad? x) (quad-ref x :anchor-parent)))
(define parent-wanter-acc null)
(let loop ([x doc])
(match x
[(? quad?) (define-values (parent-wanters others)
(partition wants-parent? (quad-elems x)))
(when (pair? parent-wanters)
(set! parent-wanter-acc (append parent-wanter-acc parent-wanters))
(quad-update! x [elems others]))
(map loop others)]
[_ x]))
(define linearized-qs (make-linear-index doc))
(for* ([q (in-list linearized-qs)]
[query-str (in-value (quad-ref q :anchor-parent))]
(for* ([wp (in-list parent-wanter-acc)]
[query-str (in-value (quad-ref wp :anchor-parent))]
#:when query-str
[parent (in-value (query linearized-qs query-str))]
#:when parent)
(quad-update! parent [elems (append (quad-elems parent) (list q))]))
(quad-update! parent [elems (append (quad-elems parent) (list wp))]))
doc)
(define (correct-line-alignment doc)
@ -418,16 +429,16 @@
(for* ([section (in-list (quad-elems doc))]
[(page page-idx) (in-indexed (quad-elems section))]
#:when (page-quad? page))
(define right-side? (odd? (add1 page-idx)))
(define zero-filler-side (if right-side? "inner" "outer"))
(let loop ([x page])
(cond
[(and (line-quad? x)
(equal? zero-filler-side (quad-ref x :line-align))
(filler-quad? (car (quad-elems x))))
;; collapse the filler quad by setting size to 0
(set-quad-size! (car (quad-elems x)) (pt 0 0))]
[(quad? x) (for-each loop (quad-elems x))])))
(define right-side? (odd? (add1 page-idx)))
(define zero-filler-side (if right-side? "inner" "outer"))
(let loop ([x page])
(cond
[(and (line-quad? x)
(equal? zero-filler-side (quad-ref x :line-align))
(filler-quad? (car (quad-elems x))))
;; collapse the filler quad by setting size to 0
(set-quad-size! (car (quad-elems x)) (pt 0 0))]
[(quad? x) (for-each loop (quad-elems x))])))
doc)
(define/contract (render-pdf qx-arg
@ -485,10 +496,10 @@
(setup-pdf-metadata! qs (current-pdf))
;; all the heavy lifting happens inside `make-sections`
;; which calls out to `make-pages`, `make-columns`, and so on.
(define doc (let* ([doc (quad-update! q:doc [elems (make-sections qs)])]
[doc (correct-line-alignment doc)]
[doc (resolve-parents doc)])
doc))
(define doc (let ([doc (quad-update! q:doc [elems (make-sections qs)])])
(time-log prep-doc (let* ([doc (correct-line-alignment doc)]
[doc (resolve-parents doc)])
doc))))
;; call `position` and `draw` separately so we can print a timer for each
(define positioned-doc (time-log position (position doc)))
;; drawing implies that a PDF is written to disk

Write Preview
Loading…
Cancel
Save