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

closer

Browse Source
main
Matthew Butterick 4 years ago
parent 40dfde0f2a
commit 9485d03320
2 changed files with 75 additions and 84 deletions
Show Stats Download Patch File Download Diff File

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

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

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

@ -28,7 +28,8 @@
"doc.rkt" "doc.rkt"
"column.rkt" "column.rkt"
"keep.rkt" "keep.rkt"
"debug.rkt") "debug.rkt"
"query.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
@ -57,7 +58,7 @@
#:min-left-length 3 #:min-left-length 3
#:min-right-length 3))] #:min-right-length 3))]
[substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))]) [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)])) [else (list q)]))
@ -66,12 +67,12 @@
(unless (even? (length pcs)) (unless (even? (length pcs))
(raise-argument-error 'string->feature-list "even number of tags and values" pcs)) (raise-argument-error 'string->feature-list "even number of tags and values" pcs))
(for/list ([kv (in-slice 2 pcs)]) (for/list ([kv (in-slice 2 pcs)])
(cons (match (first kv) (cons (match (first kv)
[(? string? k) (string->bytes/utf-8 k)] [(? string? k) (string->bytes/utf-8 k)]
[k (raise-argument-error 'string->feature-list "string" k)]) [k (raise-argument-error 'string->feature-list "string" k)])
(match (string->number (second kv)) (match (string->number (second kv))
[(? number? num) num] [(? number? num) num]
[v (raise-argument-error 'string->feature-list "number string" v)])))) [v (raise-argument-error 'string->feature-list "number string" v)]))))
(define (parse-font-features! attrs) (define (parse-font-features! attrs)
;; `font-features` are OpenType font feature specifiers. ;; `font-features` are OpenType font feature specifiers.
@ -106,7 +107,7 @@
;; we parse them into the equivalent measurement in points. ;; we parse them into the equivalent measurement in points.
(for ([k (in-hash-keys attrs)] (for ([k (in-hash-keys attrs)]
#:when (takes-dimension-string? k)) #:when (takes-dimension-string? k))
(hash-update! attrs k (λ (val) (parse-dimension val attrs)))) (hash-update! attrs k (λ (val) (parse-dimension val attrs))))
attrs) attrs)
(define (downcase-values! attrs) (define (downcase-values! attrs)
@ -114,9 +115,9 @@
;; so we can check them more easily later. ;; so we can check them more easily later.
(for ([k (in-hash-keys attrs)] (for ([k (in-hash-keys attrs)]
#:unless (has-case-sensitive-value? k)) #:unless (has-case-sensitive-value? k))
(hash-update! attrs k (λ (val) (match val (hash-update! attrs k (λ (val) (match val
[(? string? str) (string-downcase str)] [(? string? str) (string-downcase str)]
[_ val])))) [_ val]))))
attrs) attrs)
(define (complete-every-path! attrs) (define (complete-every-path! attrs)
@ -125,7 +126,7 @@
;; relies on `current-directory` being parameterized to source file's dir ;; relies on `current-directory` being parameterized to source file's dir
(for ([k (in-hash-keys attrs)] (for ([k (in-hash-keys attrs)]
#:when (takes-path? k)) #: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) attrs)
(define (handle-cascading-attrs attrs) (define (handle-cascading-attrs attrs)
@ -138,7 +139,7 @@
;; because they can be denoted relative to em size ;; because they can be denoted relative to em size
parse-dimension-strings! parse-dimension-strings!
parse-font-features!))]) parse-font-features!))])
(proc attrs))) (proc attrs)))
(define (drop-leading-breaks qs) (define (drop-leading-breaks qs)
;; any leading breaks are pointless at the start of the doc, so drop them. ;; any leading breaks are pointless at the start of the doc, so drop them.
@ -163,7 +164,7 @@
(define (get-define-val q) (quad-ref q 'define)) (define (get-define-val q) (quad-ref q 'define))
(define-values (dqs not-dqs) (partition get-define-val qs)) (define-values (dqs not-dqs) (partition get-define-val qs))
(for ([dq-group (in-list (group-by get-define-val dqs))]) (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) not-dqs)
(define default-line-height-multiplier 1.42) (define default-line-height-multiplier 1.42)
@ -256,9 +257,9 @@
(cons :pdf-keywords 'Keywords)))] (cons :pdf-keywords 'Keywords)))]
[str (in-value (and (pair? qs) (quad-ref (car qs) k)))] [str (in-value (and (pair? qs) (quad-ref (car qs) k)))]
#:when str) #:when str)
(cons pdf-k str)))) (cons pdf-k str))))
(for ([(k v) (in-dict kv-dict)]) (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")) (define (footnote-flow? q) (equal? (quad-ref q 'flow) "footnote"))
@ -292,19 +293,19 @@
(for ([page (in-list (for*/list ([sec (in-list secs)] (for ([page (in-list (for*/list ([sec (in-list secs)]
[elem (in-list (quad-elems sec))] [elem (in-list (quad-elems sec))]
#:when (page-quad? elem)) #:when (page-quad? elem))
elem))] elem))]
[page-num (in-naturals 1)] [page-num (in-naturals 1)]
[page-side (in-cycle '(right left))]) [page-side (in-cycle '(right left))])
(define repeaters-for-this-page (define repeaters-for-this-page
(for/list ([repeater (in-list repeaters)] (for/list ([repeater (in-list repeaters)]
#:when (let* ([val (quad-ref repeater :page-repeat)] #:when (let* ([val (quad-ref repeater :page-repeat)]
[sym (string->symbol val)]) [sym (string->symbol val)])
(or (eq? sym 'all) (or (eq? sym 'all)
(eq? sym page-side) (eq? sym page-side)
(eq? sym (if (= page-num 1) 'first 'rest))))) (eq? sym (if (= page-num 1) 'first 'rest)))))
repeater)) repeater))
(when (pair? repeaters-for-this-page) (when (pair? repeaters-for-this-page)
(set-quad-elems! page (append repeaters-for-this-page (quad-elems page))))) (set-quad-elems! page (append repeaters-for-this-page (quad-elems page)))))
secs) secs)
(define (make-sections all-qs) (define (make-sections all-qs)
@ -355,20 +356,20 @@
(for/list ([page (in-list section-pages-without-repeaters)] (for/list ([page (in-list section-pages-without-repeaters)]
[page-num (in-naturals 1)] [page-num (in-naturals 1)]
[page-side (in-cycle ((if (eq? section-starting-side 'right) values reverse) '(right left)))]) [page-side (in-cycle ((if (eq? section-starting-side 'right) values reverse) '(right left)))])
(define section-repeaters-for-this-page (define section-repeaters-for-this-page
(for/list ([repeater (in-list section-repeaters)] (for/list ([repeater (in-list section-repeaters)]
#:when (let* ([val (quad-ref repeater :page-repeat)] #:when (let* ([val (quad-ref repeater :page-repeat)]
[sym (string->symbol (string-trim val #px"section\\s"))]) [sym (string->symbol (string-trim val #px"section\\s"))])
(or (eq? sym 'section) (or (eq? sym 'section)
(eq? sym 'all) (eq? sym 'all)
(eq? sym page-side) (eq? sym page-side)
(eq? sym (if (= page-num 1) 'first 'rest))))) (eq? sym (if (= page-num 1) 'first 'rest)))))
repeater)) repeater))
(cond (cond
[(null? section-repeaters-for-this-page) page] [(null? section-repeaters-for-this-page) page]
[else [else
(quad-copy page-quad page (quad-copy page-quad page
[elems (append section-repeaters-for-this-page (quad-elems page))])]))) [elems (append section-repeaters-for-this-page (quad-elems page))])])))
(begin0 (begin0
(cond (cond
@ -401,25 +402,13 @@
(section-pages-used (+ (section-pages-used) (length section-pages)))))) (section-pages-used (+ (section-pages-used) (length section-pages))))))
(define (resolve-parents doc) (define (resolve-parents doc)
;; resolve location of any quad with a dynamic anchor-parent attribute like @line:1 (define linearized-qs (make-linear-index doc))
(for* ([section (in-list (quad-elems doc))] (for* ([q (in-list linearized-qs)]
[(page page-idx) (in-indexed (quad-elems section))] [query-str (in-value (quad-ref q :anchor-parent))]
#:when (page-quad? page)) #:when query-str
(define unresolved-qs [parent (in-value (query linearized-qs query-str))]
(let loop ([x page]) #:when parent)
(match x (quad-update! parent [elems (append (quad-elems parent) (list q))]))
[(? quad?) ((if (quad-ref x :anchor-parent)
(λ (tail) (cons x tail))
values) (append-map loop (quad-elems x)))]
[_ null])))
(for ([line (in-list (quad-elems page))]
[line-num (in-naturals 1)]
#:when (line-quad? line))
(define line-key (format "@line:~a" line-num))
#R line-key
(for ([uq (in-list unresolved-qs)]
#:when (equal? (quad-ref uq :anchor-parent) line-key))
(quad-update! line [elems (append (quad-elems line) (list uq))]))))
doc) doc)
(define (correct-line-alignment doc) (define (correct-line-alignment doc)
@ -429,16 +418,16 @@
(for* ([section (in-list (quad-elems doc))] (for* ([section (in-list (quad-elems doc))]
[(page page-idx) (in-indexed (quad-elems section))] [(page page-idx) (in-indexed (quad-elems section))]
#:when (page-quad? page)) #:when (page-quad? page))
(define right-side? (odd? (add1 page-idx))) (define right-side? (odd? (add1 page-idx)))
(define zero-filler-side (if right-side? "inner" "outer")) (define zero-filler-side (if right-side? "inner" "outer"))
(let loop ([x page]) (let loop ([x page])
(cond (cond
[(and (line-quad? x) [(and (line-quad? x)
(equal? zero-filler-side (quad-ref x :line-align)) (equal? zero-filler-side (quad-ref x :line-align))
(filler-quad? (car (quad-elems x)))) (filler-quad? (car (quad-elems x))))
;; collapse the filler quad by setting size to 0 ;; collapse the filler quad by setting size to 0
(set-quad-size! (car (quad-elems x)) (pt 0 0))] (set-quad-size! (car (quad-elems x)) (pt 0 0))]
[(quad? x) (for-each loop (quad-elems x))]))) [(quad? x) (for-each loop (quad-elems x))])))
doc) doc)
(define/contract (render-pdf qx-arg (define/contract (render-pdf qx-arg

Write Preview
Loading…
Cancel
Save