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

introduce quad-copy

Browse Source
main
Matthew Butterick 6 years ago
parent ee2d976690
commit a1344afc96
2 changed files with 50 additions and 52 deletions
Show Stats Download Patch File Download Diff File

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

@ -89,6 +89,12 @@
(define (hash-proc h recur) (equal-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] ...))
(define-syntax-rule (quad-clone QID [K V] ...)
(struct-copy quad QID [K V] ... [attrs (hash-copy (quad-attrs QID))]))
(define (quad-ref q key [default-val #f])
(hash-ref (quad-attrs q) key (match default-val
[(? procedure? proc) (proc)]

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

@ -144,13 +144,13 @@
[(? empty?) (reverse runs)]
[(cons (? string-quad? strq) rest)
(define-values (run-pcs rest) (splitf-at pcs (λ (p) (same-run? strq p))))
(define new-run (struct-copy quad q:string
[attrs (quad-attrs strq)]
[elems (merge-adjacent-strings (apply append (for/list ([pc (in-list run-pcs)])
(quad-elems pc))))]
[size (delay (pt (for/sum ([pc (in-list run-pcs)])
(pt-x (size pc)))
(pt-y (size strq))))]))
(define new-run (quad-copy q:string
[attrs (quad-attrs strq)]
[elems (merge-adjacent-strings (apply append (for/list ([pc (in-list run-pcs)])
(quad-elems pc))))]
[size (delay (pt (for/sum ([pc (in-list run-pcs)])
(pt-x (size pc)))
(pt-y (size strq))))]))
(loop (cons new-run runs) rest)]
[(cons first rest) (loop (cons first runs) rest)])))
@ -166,9 +166,9 @@
(define str (car (quad-elems last-q)))
(define str+hyphen (string-append str "-"))
(append head
(list (struct-copy quad last-q
[elems (list str+hyphen)]
[size (make-size-promise last-q str+hyphen)])))]
(list (quad-copy last-q
[elems (list str+hyphen)]
[size (make-size-promise last-q str+hyphen)])))]
[_ qs]))
@ -205,12 +205,12 @@
(define last-char-str (regexp-match #rx"[.,:;’-]$" (car (quad-elems last-q))))
(match last-char-str
[#false word-sublists]
[_ (define hanger-q (struct-copy quad last-q
[elems null]
[size (let ([p (make-size-promise last-q (car last-char-str))])
(delay
(match-define (list x y) (force p))
(pt (- x) y)))]))
[_ (define hanger-q (quad-copy last-q
[elems null]
[size (let ([p (make-size-promise last-q (car last-char-str))])
(delay
(match-define (list x y) (force p))
(pt (- x) y)))]))
(define last-sublist (append prev-qs (list last-q hanger-q)))
(append sublists (list last-sublist))])]))
(define word-width (sum-of-widths hung-word-sublists))
@ -248,7 +248,7 @@
#:to 'bi
#:size (pt (* end-hspace space-multiplier) 0)
#:attrs (quad-attrs (car qs)))
(struct-copy quad (car qs) [from-parent #f])
(quad-copy (car qs) [from-parent #f])
(cdr qs))])])]))
(define-quad offsetter-quad quad ())
@ -265,7 +265,7 @@
(restore doc))
(define (make-hr-quad line-q)
(struct-copy quad line-q [draw-start hr-draw]))
(quad-copy line-q [draw-start hr-draw]))
(define ((finish-line-wrap line-q) pcs-in opening-q ending-q idx)
;; we curry line-q so that the wrap size can be communicated to this operation
@ -345,8 +345,7 @@
[_
(unless (positive? wrap-size)
(raise-argument-error 'line-wrap "positive number" wrap-size))
(define line-q (struct-copy quad q:line
[size (pt wrap-size (pt-y (size q:line)))]))
(define line-q (quad-copy q:line [size (pt wrap-size (pt-y (size q:line)))]))
(define permitted-justify-overfill
(match (quad-ref (car qs) :line-align)
;; allow justified lines to go wider,
@ -363,7 +362,7 @@
(quad-ref (car qs) :inset-left 0)
(quad-ref (car qs) :inset-right 0))
permitted-justify-overfill))
#:nicely (match (or (current-line-wrap) (quad-ref (car qs) 'line-wrap))
#:nicely (match (or (current-line-wrap) (quad-ref (car qs) :line-wrap))
[(or "best" "kp") #true]
[_ #false])
#:hard-break line-break-quad?
@ -425,16 +424,19 @@
(date->string (current-date) #t))
x y))
(define q:footer (q #:size (pt 50 default-line-height)
#:from-parent 'sw
#:to 'nw
#:shift (pt 0 (* 1.5 default-line-height))
#:printable #true
#:draw-start (λ (q doc)
(when draw-debug-line?
(draw-debug q doc "goldenrod" "goldenrod"))
(unless (quadwriter-test-mode)
(draw-page-footer q doc)))))
(define (make-footer-quad page-idx path)
(define-values (dir name _) (split-path (path-replace-extension path #"")))
(q #:size (pt 50 default-line-height)
#:attrs (hasheq :page-number page-idx :doc-title (string-titlecase (path->string name)))
#:from-parent 'sw
#:to 'nw
#:shift (pt 0 (* 1.5 default-line-height))
#:printable #true
#:draw-start (λ (q doc)
(when draw-debug-line?
(draw-debug q doc "goldenrod" "goldenrod"))
(unless (quadwriter-test-mode)
(draw-page-footer q doc)))))
(define q:column (q
#:id 'col
@ -526,16 +528,14 @@
;; can be repeated without damage.
[((? null?) _) null]
[((cons q rest) where)
(cons (struct-copy quad q
[from-parent (or where (quad-from q))]) rest)])
(cons (quad-copy q [from-parent (or where (quad-from q))]) rest)])
(define ((col-finish-wrap col-quad) lns . _)
(list (struct-copy quad col-quad
;; move block attrs up, so they are visible in page wrap
[attrs (copy-block-attrs (quad-attrs (car lns))
(hash-copy (quad-attrs col-quad)))]
[elems (from-parent (insert-blocks lns) 'nw)])))
(list (quad-copy col-quad
;; move block attrs up, so they are visible in page wrap
[attrs (copy-block-attrs (quad-attrs (car lns))
(hash-copy (quad-attrs col-quad)))]
[elems (from-parent (insert-blocks lns) 'nw)])))
(define (col-wrap qs vertical-height col-gap [col-quad q:column])
(unless (positive? vertical-height)
@ -546,11 +546,10 @@
;; could do it after, but it would require going back inside each col quad
;; which seems overly interdependent, because `insert-blocks` is used to determine break locations.
;; `col-wrap` should emit quads that are complete.
(define col-spacer (struct-copy quad q:column-spacer
[size (pt col-gap 100)]))
(define col-spacer (quad-copy q:column-spacer [size (pt col-gap 100)]))
(add-between
(wrap qs vertical-height
#:soft-break (λ (q) #true)
#:soft-break #true
#:hard-break column-break-quad?
#:no-break (λ (q) (quad-ref q :no-colbr)) ; cooperates with make-nobreak
#:distance (λ (q dist-so-far wrap-qs)
@ -564,21 +563,14 @@
(define elems
(match (quad-ref (car cols) :footer-display "true")
[(or "false" "none") (from-parent cols 'nw)]
[_
(define-values (dir name _) (split-path (path-replace-extension path #"")))
(define footer (struct-copy quad q:footer
[attrs (let ([h (hash-copy (quad-attrs q:footer))])
(hash-set! h :page-number page-idx)
(hash-set! h :doc-title (string-titlecase (path->string name)))
h)]))
(cons footer (from-parent cols 'nw))]))
(list (struct-copy quad page-quad [elems elems])))
[_ (cons (make-footer-quad page-idx path) (from-parent cols 'nw))]))
(list (quad-copy page-quad [elems elems])))
(define (page-wrap qs width [page-quad q:page])
(unless (positive? width)
(raise-argument-error 'page-wrap "positive number" width))
(wrap qs width
#:soft-break (λ (q) #true)
#:soft-break #true
#:hard-break page-break-quad?
#:no-break (λ (q) (quad-ref q :no-pbr))
#:distance (λ (q dist-so-far wrap-qs)

Write Preview
Loading…
Cancel
Save