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

doc repeaters

Browse Source
main
Matthew Butterick 4 years ago
parent 7ddcf00c78
commit cba750518f
5 changed files with 102 additions and 86 deletions
Show Stats Download Patch File Download Diff File

30
quad/quad/position.rkt
Unescape Escape View File

@ -92,24 +92,24 @@
;; recursively calculates coordinates for quad & subquads ;; recursively calculates coordinates for quad & subquads
;; need to position before recurring, so subquads have accurate reference point ;; need to position before recurring, so subquads have accurate reference point
(define positioned-q (define positioned-q
(quad-copy q (struct-copy quad q
[origin (let* ([ref-pt (cond [origin (let* ([ref-pt (cond
[(quad? ref-src) [(quad? ref-src)
(anchor->global-point ref-src (or (quad-from-parent q) (quad-from q)))] (anchor->global-point ref-src (or (quad-from-parent q) (quad-from q)))]
[ref-src] ; for passing explicit points in testing [ref-src] ; for passing explicit points in testing
[else (pt 0 0)])] [else (pt 0 0)])]
[this-origin (pt- ref-pt (to-point q))] [this-origin (pt- ref-pt (to-point q))]
[shifted-origin (pt+ this-origin (quad-shift q))]) [shifted-origin (pt+ this-origin (quad-shift q))])
shifted-origin)] shifted-origin)]
;; set shift to zero because it's baked into new origin value ;; set shift to zero because it's baked into new origin value
[shift (pt 0 0)])) [shift (pt 0 0)]))
(define positioned-elems (define positioned-elems
;; for purposes of positioning the elements, we want to also bake in the `shift-elements` value ;; for purposes of positioning the elements, we want to also bake in the `shift-elements` value
;; but we don't want this origin to be permanent on the parent. ;; but we don't want this origin to be permanent on the parent.
;; akin to `push` a graphics state and then `pop` afterwards. ;; akin to `push` a graphics state and then `pop` afterwards.
(let ([parent-q (quad-copy positioned-q (let ([parent-q (struct-copy quad positioned-q
[origin (pt+ (quad-origin positioned-q) (quad-shift-elems positioned-q))] [origin (pt+ (quad-origin positioned-q) (quad-shift-elems positioned-q))]
[shift-elems (pt 0 0)])]) [shift-elems (pt 0 0)])])
;; can't use for/list here because previous quads provide context for later ones ;; can't use for/list here because previous quads provide context for later ones
(let loop ([prev-elems null] [elems (quad-elems parent-q)]) (let loop ([prev-elems null] [elems (quad-elems parent-q)])
(match elems (match elems
@ -128,7 +128,7 @@
[(list ∆x ∆y) (sqrt (+ (expt ∆x 2) (expt ∆y 2)))])) [(list ∆x ∆y) (sqrt (+ (expt ∆x 2) (expt ∆y 2)))]))
(define (flatten-quad q) (define (flatten-quad q)
(cons (quad-copy q [elems null]) (cons (struct-copy quad q [elems null])
(apply append (map flatten-quad (quad-elems q))))) (apply append (map flatten-quad (quad-elems q)))))
(define (bounding-box . qs-in) (define (bounding-box . qs-in)

3
quad/quad/quad.rkt
Unescape Escape View File

@ -91,9 +91,6 @@
(define (hash-proc h recur) (equal-hash-code h)) (define (hash-proc h recur) (equal-hash-code h))
(define (hash2-proc h recur) (equal-secondary-hash-code h))]) (define (hash2-proc h recur) (equal-secondary-hash-code h))])
(define-syntax-rule (quad-copy QID [K V] ...)
(struct-copy quad QID [K V] ...))
#;(struct quad-attr (key default-val) #:transparent) #;(struct quad-attr (key default-val) #:transparent)
#;(define (make-quad-attr key [default-val #f]) #;(define (make-quad-attr key [default-val #f])

24
quad/quad/wrap.rkt
Unescape Escape View File

@ -378,28 +378,28 @@
(module+ test (module+ test
(define q-zero (q #:size (pt 0 0))) (define q-zero (q #:size (pt 0 0)))
(define q-one (q #:size (pt 1 1) #:printable #t)) (define q-one (q #:size (pt 1 1) #:printable #t))
(define x (quad-copy q-one [elems '(#\x)])) (define x (struct-copy quad q-one [elems '(#\x)]))
(define zwx (quad-copy q-zero (define zwx (struct-copy quad q-zero
[printable (λ _ #t)] [printable (λ _ #t)]
[elems '(#\z)])) [elems '(#\z)]))
(define hyph (quad-copy q-one [elems '(#\-)])) (define hyph (struct-copy quad q-one [elems '(#\-)]))
(define shy (quad-copy q-one (define shy (struct-copy quad q-one
[printable (λ (q [sig #f]) [printable (λ (q [sig #f])
(case sig (case sig
[(end) #t] [(end) #t]
[else #f]))] [else #f]))]
[elems '(#\-)])) [elems '(#\-)]))
(define a (quad-copy q-one [elems '(#\a)])) (define a (struct-copy quad q-one [elems '(#\a)]))
(define b (quad-copy q-one [elems '(#\b)])) (define b (struct-copy quad q-one [elems '(#\b)]))
(define c (quad-copy q-one [elems '(#\c)])) (define c (struct-copy quad q-one [elems '(#\c)]))
(define d (quad-copy q-one [elems '(#\d)])) (define d (struct-copy quad q-one [elems '(#\d)]))
(define sp (quad-copy q-one (define sp (struct-copy quad q-one
[printable (λ (q [sig #f]) [printable (λ (q [sig #f])
(case sig (case sig
[(start end) #f] [(start end) #f]
[else #t]))] [else #t]))]
[elems '(#\space)])) [elems '(#\space)]))
(define lbr (quad-copy q-one (define lbr (struct-copy quad q-one
[printable (λ _ #f)] [printable (λ _ #f)]
[elems '(#\newline)])) [elems '(#\newline)]))
@ -418,8 +418,8 @@
(for/list ([x (in-list (linewrap (for/list ([c (in-string str)]) (for/list ([x (in-list (linewrap (for/list ([c (in-string str)])
(define atom (q c)) (define atom (q c))
(if (equal? (quad-elems atom) '(#\space)) (if (equal? (quad-elems atom) '(#\space))
(quad-copy sp) (struct-copy quad sp)
(quad-copy q-one (struct-copy quad q-one
[attrs (quad-attrs atom)] [attrs (quad-attrs atom)]
[elems (quad-elems atom)]))) int debug [elems (quad-elems atom)]))) int debug
#:nicely nicely?))] #:nicely nicely?))]

79
quad/quadwriter/layout.rkt
Unescape Escape View File

@ -166,18 +166,18 @@
(struct-copy draw-quad q:draw (struct-copy draw-quad q:draw
[attrs #:parent quad (quad-attrs q)] [attrs #:parent quad (quad-attrs q)]
[draw #:parent quad (λ (q doc) [draw #:parent quad (λ (q doc)
(save doc) (save doc)
(match (quad-ref q :draw) (match (quad-ref q :draw)
["line" ["line"
(move-to doc (quad-ref q :x1) (quad-ref q :y1)) (move-to doc (quad-ref q :x1) (quad-ref q :y1))
(line-to doc (quad-ref q :x2) (quad-ref q :y2)) (line-to doc (quad-ref q :x2) (quad-ref q :y2))
(stroke doc "black")] (stroke doc "black")]
["text" (move-to doc 0 0) ["text" (move-to doc 0 0)
(q:string-draw q doc (q:string-draw q doc
#:origin (pt (quad-ref q :x 0) (quad-ref q :y 0)) #:origin (pt (quad-ref q :x 0) (quad-ref q :y 0))
#:text (quad-ref q :text))] #:text (quad-ref q :text))]
[_ (void)]) [_ (void)])
(restore doc))] (restore doc))]
[size #:parent quad (pt 0 0)])) [size #:parent quad (pt 0 0)]))
(define (convert-image-quad q) (define (convert-image-quad q)
@ -298,10 +298,10 @@
(define tracking-adjustment (define tracking-adjustment
(* (sub1 (length run-pcs)) (quad-ref (car run-pcs) :font-tracking 0))) (* (sub1 (length run-pcs)) (quad-ref (car run-pcs) :font-tracking 0)))
(define new-run (define new-run
(quad-copy q:string (struct-copy string-quad q:string
[attrs (quad-attrs strq)] [attrs #:parent quad (quad-attrs strq)]
[elems (merge-adjacent-strings (apply append (map quad-elems run-pcs)))] [elems #:parent quad (merge-adjacent-strings (apply append (map quad-elems run-pcs)))]
[size (delay (pt (sum-x run-pcs) (pt-y (size strq))))])) [size #:parent quad (delay (pt (sum-x run-pcs) (pt-y (size strq))))]))
(loop (cons new-run runs) rest)] (loop (cons new-run runs) rest)]
[(cons first rest) (loop (cons first runs) rest)] [(cons first rest) (loop (cons first runs) rest)]
[_ (reverse runs)]))) [_ (reverse runs)])))
@ -340,12 +340,13 @@
(match (regexp-match #rx"[.,:;’-]$" (car (quad-elems last-q))) (match (regexp-match #rx"[.,:;’-]$" (car (quad-elems last-q)))
[#false nonspacess] [#false nonspacess]
[last-char-str [last-char-str
(define hanger-q (quad-copy last-q (define hanger-q (struct-copy string-quad last-q
[elems null] [elems #:parent quad null]
[size (let ([p (make-size-promise-for-string last-q (car last-char-str))]) [size #:parent quad
(delay (let ([p (make-size-promise-for-string last-q (car last-char-str))])
(match-define (list x y) (force p)) (delay
(pt (- x) y)))])) (match-define (list x y) (force p))
(pt (- x) y)))]))
(define last-sublist (append prev-qs (list last-q hanger-q))) (define last-sublist (append prev-qs (list last-q hanger-q)))
(append sublists (list last-sublist))])] (append sublists (list last-sublist))])]
[_ nonspacess])) [_ nonspacess]))
@ -444,7 +445,7 @@
(restore doc)) (restore doc))
(define (make-hr-quad line-q) (define (make-hr-quad line-q)
(quad-copy line-q [draw-start hr-draw])) (struct-copy quad line-q [draw-start hr-draw]))
(define ((line-wrap-finish line-prototype-q default-block-id) wrap-qs q-before q-after idx) (define ((line-wrap-finish line-prototype-q default-block-id) wrap-qs q-before q-after idx)
;; we curry line-q so that the wrap size can be communicated to this operation ;; we curry line-q so that the wrap size can be communicated to this operation
@ -467,7 +468,7 @@
[(and (cons elem-first _) elems) [(and (cons elem-first _) elems)
(match-define (list line-width line-height) (quad-size line-prototype-q)) (match-define (list line-width line-height) (quad-size line-prototype-q))
(list (list
(quad-copy (struct-copy quad
line-prototype-q line-prototype-q
;; move block attrs up, so they are visible in col wrap ;; move block attrs up, so they are visible in col wrap
[attrs (let ([h (copy-block-attrs (quad-attrs elem-first) (hash-copy (quad-attrs line-prototype-q)))]) [attrs (let ([h (copy-block-attrs (quad-attrs elem-first) (hash-copy (quad-attrs line-prototype-q)))])
@ -493,14 +494,14 @@
(match (and (eq? idx 1) (quad-ref elem-first :list-index)) (match (and (eq? idx 1) (quad-ref elem-first :list-index))
[#false null] [#false null]
[bullet [bullet
(define bq (quad-copy q:string ;; copy q:string to get draw routine (define bq (struct-copy string-quad q:string ;; copy q:string to get draw routine
;; borrow attrs from elem ;; borrow attrs from elem
[attrs (quad-attrs elem-first)] [attrs #:parent quad (quad-attrs elem-first)]
;; use bullet as elems ;; use bullet as elems
[elems (list (if (number? bullet) (format "~a." bullet) bullet))] [elems #:parent quad (list (if (number? bullet) (format "~a." bullet) bullet))]
;; size doesn't matter because nothing refers to this quad ;; size doesn't matter because nothing refers to this quad
;; just for debugging box ;; just for debugging box
[size (pt 15 (pt-y (size line-prototype-q)))])) [size #:parent quad (pt 15 (pt-y (size line-prototype-q)))]))
(from-parent (list bq) 'sw)]) (from-parent (list bq) 'sw)])
(from-parent (from-parent
(match (quad-ref elem-first :inset-left 0) (match (quad-ref elem-first :inset-left 0)
@ -528,7 +529,7 @@
(raise-argument-error 'line-wrap "positive number" wrap-size)) (raise-argument-error 'line-wrap "positive number" wrap-size))
(match qs (match qs
[(cons q _) [(cons q _)
(define line-q (quad-copy q:line [size (pt wrap-size (quad-ref q :line-height default-line-height))])) (define line-q (struct-copy quad q:line [size (pt wrap-size (quad-ref q :line-height default-line-height))]))
(define permitted-justify-overfill (define permitted-justify-overfill
(match (quad-ref q :line-align) (match (quad-ref q :line-align)
;; allow justified lines to go wider, ;; allow justified lines to go wider,
@ -686,7 +687,9 @@
#:to 'nw #:to 'nw
#:printable only-prints-in-middle)) #:printable only-prints-in-middle))
(define-quad page-quad quad)
(define q:page (q (define q:page (q
#:type page-quad
#:id 'page #:id 'page
#:from-parent 'nw #:from-parent 'nw
#:draw-start page-draw-start)) #:draw-start page-draw-start))
@ -791,7 +794,7 @@
(append (append
(match lns (match lns
[(cons line _) [(cons line _)
(list (quad-copy col-quad (list (struct-copy quad col-quad
;; move block attrs up, so they are visible in page wrap ;; move block attrs up, so they are visible in page wrap
[attrs (copy-block-attrs (quad-attrs line) [attrs (copy-block-attrs (quad-attrs line)
(hash-copy (quad-attrs col-quad)))] (hash-copy (quad-attrs col-quad)))]
@ -852,12 +855,12 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96
(when (pair? cols) (when (pair? cols)
(quad-update! (car cols) (quad-update! (car cols)
[elems (append (quad-elems (car cols)) reversed-fn-lines)])) [elems (append (quad-elems (car cols)) reversed-fn-lines)]))
(define col-spacer (quad-copy q:column-spacer [size (pt column-gap (and 'arbitrary-irrelevant-value 100))])) (define col-spacer (struct-copy quad q:column-spacer [size (pt column-gap (and 'arbitrary-irrelevant-value 100))]))
(add-between cols col-spacer)) (add-between cols col-spacer))
(verbose-quad-printing? #t) (verbose-quad-printing? #t)
(define ((page-wrap-finish make-page-quad path) cols q-before q-after page-idx) (define ((page-wrap-finish make-page-quad path) cols q-before q-after page-idx)
(define page-quad (make-page-quad (+ (section-pages-used) page-idx))) (define pq (make-page-quad (+ (section-pages-used) page-idx)))
;; get attrs from cols if we can, otherwise try q-after or q-before ;; get attrs from cols if we can, otherwise try q-after or q-before
(define q-for-attrs (cond (define q-for-attrs (cond
[(pair? cols) (car cols)] [(pair? cols) (car cols)]
@ -870,12 +873,12 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96
[(or #false "none") null] [(or #false "none") null]
[_ (list (make-footer-quad q-for-attrs page-idx path))]) [_ (list (make-footer-quad q-for-attrs page-idx path))])
(from-parent cols 'nw))) (from-parent cols 'nw)))
(list (quad-copy page-quad (list (struct-copy page-quad pq
[elems elems] [elems #:parent quad elems]
[attrs (copy-block-attrs (cond [attrs #:parent quad (copy-block-attrs (cond
[q-for-attrs => quad-attrs] [q-for-attrs => quad-attrs]
[else (hash)]) [else (hash)])
(hash-copy (quad-attrs page-quad)))]))) (hash-copy (quad-attrs pq)))])))
(define (page-wrap qs width [make-page-quad (λ (x) q:page)]) (define (page-wrap qs width [make-page-quad (λ (x) q:page)])
(unless (positive? width) (unless (positive? width)

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

@ -6,6 +6,7 @@
racket/sequence racket/sequence
racket/list racket/list
racket/dict racket/dict
racket/generator
pitfall pitfall
quad quad
hyphenate hyphenate
@ -45,7 +46,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))])
(quad-copy q [elems (list substr)]))] (struct-copy quad q [elems (list substr)]))]
[else (list q)])) [else (list q)]))
@ -245,8 +246,8 @@
(values line-qs fn-line-qs)) (values line-qs fn-line-qs))
(define (make-columns line-qs fn-line-qs line-wrap-size printable-height column-gap) (define (make-columns line-qs fn-line-qs line-wrap-size printable-height column-gap)
(define col-quad-prototype (quad-copy q:column (define col-quad-prototype (struct-copy quad q:column
[size (pt line-wrap-size printable-height)])) [size (pt line-wrap-size printable-height)]))
(time-log column-wrap (column-wrap line-qs fn-line-qs printable-height column-gap col-quad-prototype))) (time-log column-wrap (column-wrap line-qs fn-line-qs printable-height column-gap col-quad-prototype)))
(define (make-pages column-qs (define (make-pages column-qs
@ -258,12 +259,30 @@
printable-height) printable-height)
(define (page-quad-prototype page-count) (define (page-quad-prototype page-count)
(define left-shift (+ left-margin (if (odd? page-count) gutter-margin 0))) (define left-shift (+ left-margin (if (odd? page-count) gutter-margin 0)))
(quad-copy q:page (struct-copy page-quad q:page
[shift (pt left-shift top-margin)] [shift #:parent quad (pt left-shift top-margin)]
[size (pt line-wrap-size printable-height)])) [size #:parent quad (pt line-wrap-size printable-height)]))
(time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype))) (time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype)))
(define (apply-doc-repeaters secs repeaters) (define (apply-doc-repeaters secs repeaters)
(for ([page (in-list (for*/list ([sec (in-list secs)]
[elem (in-list (quad-elems sec))]
#:when (page-quad? 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)])
(memq sym (list
(if (= page-num 1) 'first 'rest)
page-side
'all))))
repeater))
(when (pair? repeaters-for-this-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)
@ -313,10 +332,7 @@
(define section-pages (define section-pages
(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 'left) values reverse) '(left right)))]) [page-side (in-cycle ((if (eq? section-starting-side 'right) values reverse) '(right left)))])
;; the first page of the section is 1,
;; so all the odd pages are the same side as the starting side
;; and even pages are the opposite side
(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)]
@ -329,8 +345,8 @@
(cond (cond
[(null? section-repeaters-for-this-page) page] [(null? section-repeaters-for-this-page) page]
[else [else
(quad-copy page (struct-copy page-quad page
[elems (append section-repeaters-for-this-page (quad-elems page))])]))) [elems #:parent quad (append section-repeaters-for-this-page (quad-elems page))])])))
(begin0 (begin0
(cond (cond
@ -341,24 +357,24 @@
['left ['left
;; blank page goes at beginning of current section ;; blank page goes at beginning of current section
(define page-from-current-section (car section-pages)) (define page-from-current-section (car section-pages))
(define blank-page (quad-copy page-from-current-section [elems null])) (define blank-page (struct-copy page-quad page-from-current-section [elems #:parent quad null]))
(define new-section (quad-copy q:section [elems (cons blank-page section-pages)])) (define new-section (struct-copy quad q:section [elems (cons blank-page section-pages)]))
(cons new-section sections-acc)] (cons new-section sections-acc)]
[_ ;; must be 'right [_ ;; must be 'right
;; blank page goes at end of previous section (if it exists) ;; blank page goes at end of previous section (if it exists)
(define new-section (quad-copy q:section [elems section-pages])) (define new-section (struct-copy quad q:section [elems section-pages]))
(match sections-acc (match sections-acc
[(cons previous-section other-sections) [(cons previous-section other-sections)
(define previous-section-pages (quad-elems previous-section)) (define previous-section-pages (quad-elems previous-section))
;; we know previous section has pages because we ignore empty sections ;; we know previous section has pages because we ignore empty sections
(define page-from-previous-section (car previous-section-pages)) (define page-from-previous-section (car previous-section-pages))
(define blank-page (quad-copy page-from-previous-section [elems null])) (define blank-page (struct-copy page-quad page-from-previous-section [elems #:parent quad null]))
(define updated-previous-section (define updated-previous-section
(quad-update! previous-section (quad-update! previous-section
[elems (append previous-section-pages (list blank-page))])) [elems (append previous-section-pages (list blank-page))]))
(list* new-section updated-previous-section other-sections)] (list* new-section updated-previous-section other-sections)]
[_ (list new-section)])])] [_ (list new-section)])])]
[else (define new-section (quad-copy q:section [elems section-pages]) ) [else (define new-section (struct-copy quad q:section [elems section-pages]) )
(cons new-section sections-acc)]) (cons new-section sections-acc)])
(section-pages-used (+ (section-pages-used) (length section-pages)))))) (section-pages-used (+ (section-pages-used) (length section-pages))))))
@ -434,7 +450,7 @@
(setup-pdf-metadata! qs (current-pdf)) (setup-pdf-metadata! qs (current-pdf))
;; all the heavy lifting happens inside `make-sections` ;; all the heavy lifting happens inside `make-sections`
;; which calls out to `make-pages`, `make-columns`, and so on. ;; which calls out to `make-pages`, `make-columns`, and so on.
(define doc (correct-line-alignment (quad-copy q:doc [elems (make-sections qs)]))) (define doc (correct-line-alignment (struct-copy quad q:doc [elems (make-sections qs)])))
;; call `position` and `draw` separately so we can print a timer for each ;; call `position` and `draw` separately so we can print a timer for each
(define positioned-doc (time-log position (position doc))) (define positioned-doc (time-log position (position doc)))
;; drawing implies that a PDF is written to disk ;; drawing implies that a PDF is written to disk

Write Preview
Loading…
Cancel
Save