diff --git a/quad/quad/position.rkt b/quad/quad/position.rkt index 45b709fd..7a61eeee 100644 --- a/quad/quad/position.rkt +++ b/quad/quad/position.rkt @@ -92,24 +92,24 @@ ;; recursively calculates coordinates for quad & subquads ;; need to position before recurring, so subquads have accurate reference point (define positioned-q - (quad-copy q - [origin (let* ([ref-pt (cond - [(quad? ref-src) - (anchor->global-point ref-src (or (quad-from-parent q) (quad-from q)))] - [ref-src] ; for passing explicit points in testing - [else (pt 0 0)])] - [this-origin (pt- ref-pt (to-point q))] - [shifted-origin (pt+ this-origin (quad-shift q))]) - shifted-origin)] - ;; set shift to zero because it's baked into new origin value - [shift (pt 0 0)])) + (struct-copy quad q + [origin (let* ([ref-pt (cond + [(quad? ref-src) + (anchor->global-point ref-src (or (quad-from-parent q) (quad-from q)))] + [ref-src] ; for passing explicit points in testing + [else (pt 0 0)])] + [this-origin (pt- ref-pt (to-point q))] + [shifted-origin (pt+ this-origin (quad-shift q))]) + shifted-origin)] + ;; set shift to zero because it's baked into new origin value + [shift (pt 0 0)])) (define positioned-elems ;; 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. ;; akin to `push` a graphics state and then `pop` afterwards. - (let ([parent-q (quad-copy positioned-q - [origin (pt+ (quad-origin positioned-q) (quad-shift-elems positioned-q))] - [shift-elems (pt 0 0)])]) + (let ([parent-q (struct-copy quad positioned-q + [origin (pt+ (quad-origin positioned-q) (quad-shift-elems positioned-q))] + [shift-elems (pt 0 0)])]) ;; can't use for/list here because previous quads provide context for later ones (let loop ([prev-elems null] [elems (quad-elems parent-q)]) (match elems @@ -128,7 +128,7 @@ [(list ∆x ∆y) (sqrt (+ (expt ∆x 2) (expt ∆y 2)))])) (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))))) (define (bounding-box . qs-in) diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 870889ef..9e02427d 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -91,9 +91,6 @@ (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] ...)) - #;(struct quad-attr (key default-val) #:transparent) #;(define (make-quad-attr key [default-val #f]) diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt index bdf68362..b4889227 100644 --- a/quad/quad/wrap.rkt +++ b/quad/quad/wrap.rkt @@ -378,28 +378,28 @@ (module+ test (define q-zero (q #:size (pt 0 0))) (define q-one (q #:size (pt 1 1) #:printable #t)) - (define x (quad-copy q-one [elems '(#\x)])) - (define zwx (quad-copy q-zero + (define x (struct-copy quad q-one [elems '(#\x)])) + (define zwx (struct-copy quad q-zero [printable (λ _ #t)] [elems '(#\z)])) - (define hyph (quad-copy q-one [elems '(#\-)])) - (define shy (quad-copy q-one + (define hyph (struct-copy quad q-one [elems '(#\-)])) + (define shy (struct-copy quad q-one [printable (λ (q [sig #f]) (case sig [(end) #t] [else #f]))] [elems '(#\-)])) - (define a (quad-copy q-one [elems '(#\a)])) - (define b (quad-copy q-one [elems '(#\b)])) - (define c (quad-copy q-one [elems '(#\c)])) - (define d (quad-copy q-one [elems '(#\d)])) - (define sp (quad-copy q-one + (define a (struct-copy quad q-one [elems '(#\a)])) + (define b (struct-copy quad q-one [elems '(#\b)])) + (define c (struct-copy quad q-one [elems '(#\c)])) + (define d (struct-copy quad q-one [elems '(#\d)])) + (define sp (struct-copy quad q-one [printable (λ (q [sig #f]) (case sig [(start end) #f] [else #t]))] [elems '(#\space)])) - (define lbr (quad-copy q-one + (define lbr (struct-copy quad q-one [printable (λ _ #f)] [elems '(#\newline)])) @@ -418,8 +418,8 @@ (for/list ([x (in-list (linewrap (for/list ([c (in-string str)]) (define atom (q c)) (if (equal? (quad-elems atom) '(#\space)) - (quad-copy sp) - (quad-copy q-one + (struct-copy quad sp) + (struct-copy quad q-one [attrs (quad-attrs atom)] [elems (quad-elems atom)]))) int debug #:nicely nicely?))] diff --git a/quad/quadwriter/layout.rkt b/quad/quadwriter/layout.rkt index b5e8175e..706d3e19 100644 --- a/quad/quadwriter/layout.rkt +++ b/quad/quadwriter/layout.rkt @@ -166,18 +166,18 @@ (struct-copy draw-quad q:draw [attrs #:parent quad (quad-attrs q)] [draw #:parent quad (λ (q doc) - (save doc) - (match (quad-ref q :draw) - ["line" - (move-to doc (quad-ref q :x1) (quad-ref q :y1)) - (line-to doc (quad-ref q :x2) (quad-ref q :y2)) - (stroke doc "black")] - ["text" (move-to doc 0 0) - (q:string-draw q doc - #:origin (pt (quad-ref q :x 0) (quad-ref q :y 0)) - #:text (quad-ref q :text))] - [_ (void)]) - (restore doc))] + (save doc) + (match (quad-ref q :draw) + ["line" + (move-to doc (quad-ref q :x1) (quad-ref q :y1)) + (line-to doc (quad-ref q :x2) (quad-ref q :y2)) + (stroke doc "black")] + ["text" (move-to doc 0 0) + (q:string-draw q doc + #:origin (pt (quad-ref q :x 0) (quad-ref q :y 0)) + #:text (quad-ref q :text))] + [_ (void)]) + (restore doc))] [size #:parent quad (pt 0 0)])) (define (convert-image-quad q) @@ -298,10 +298,10 @@ (define tracking-adjustment (* (sub1 (length run-pcs)) (quad-ref (car run-pcs) :font-tracking 0))) (define new-run - (quad-copy q:string - [attrs (quad-attrs strq)] - [elems (merge-adjacent-strings (apply append (map quad-elems run-pcs)))] - [size (delay (pt (sum-x run-pcs) (pt-y (size strq))))])) + (struct-copy string-quad q:string + [attrs #:parent quad (quad-attrs strq)] + [elems #:parent quad (merge-adjacent-strings (apply append (map quad-elems run-pcs)))] + [size #:parent quad (delay (pt (sum-x run-pcs) (pt-y (size strq))))])) (loop (cons new-run runs) rest)] [(cons first rest) (loop (cons first runs) rest)] [_ (reverse runs)]))) @@ -340,12 +340,13 @@ (match (regexp-match #rx"[.,:;’-]$" (car (quad-elems last-q))) [#false nonspacess] [last-char-str - (define hanger-q (quad-copy last-q - [elems null] - [size (let ([p (make-size-promise-for-string last-q (car last-char-str))]) - (delay - (match-define (list x y) (force p)) - (pt (- x) y)))])) + (define hanger-q (struct-copy string-quad last-q + [elems #:parent quad null] + [size #:parent quad + (let ([p (make-size-promise-for-string 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))])] [_ nonspacess])) @@ -444,7 +445,7 @@ (restore doc)) (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) ;; we curry line-q so that the wrap size can be communicated to this operation @@ -467,7 +468,7 @@ [(and (cons elem-first _) elems) (match-define (list line-width line-height) (quad-size line-prototype-q)) (list - (quad-copy + (struct-copy quad line-prototype-q ;; 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)))]) @@ -493,14 +494,14 @@ (match (and (eq? idx 1) (quad-ref elem-first :list-index)) [#false null] [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 - [attrs (quad-attrs elem-first)] + [attrs #:parent quad (quad-attrs elem-first)] ;; 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 ;; 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 (match (quad-ref elem-first :inset-left 0) @@ -528,7 +529,7 @@ (raise-argument-error 'line-wrap "positive number" wrap-size)) (match qs [(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 (match (quad-ref q :line-align) ;; allow justified lines to go wider, @@ -686,7 +687,9 @@ #:to 'nw #:printable only-prints-in-middle)) +(define-quad page-quad quad) (define q:page (q + #:type page-quad #:id 'page #:from-parent 'nw #:draw-start page-draw-start)) @@ -791,7 +794,7 @@ (append (match lns [(cons line _) - (list (quad-copy col-quad + (list (struct-copy quad col-quad ;; move block attrs up, so they are visible in page wrap [attrs (copy-block-attrs (quad-attrs line) (hash-copy (quad-attrs col-quad)))] @@ -852,12 +855,12 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96 (when (pair? cols) (quad-update! (car cols) [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)) (verbose-quad-printing? #t) (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 (define q-for-attrs (cond [(pair? cols) (car cols)] @@ -870,12 +873,12 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96 [(or #false "none") null] [_ (list (make-footer-quad q-for-attrs page-idx path))]) (from-parent cols 'nw))) - (list (quad-copy page-quad - [elems elems] - [attrs (copy-block-attrs (cond - [q-for-attrs => quad-attrs] - [else (hash)]) - (hash-copy (quad-attrs page-quad)))]))) + (list (struct-copy page-quad pq + [elems #:parent quad elems] + [attrs #:parent quad (copy-block-attrs (cond + [q-for-attrs => quad-attrs] + [else (hash)]) + (hash-copy (quad-attrs pq)))]))) (define (page-wrap qs width [make-page-quad (λ (x) q:page)]) (unless (positive? width) diff --git a/quad/quadwriter/render.rkt b/quad/quadwriter/render.rkt index 3222a946..6f9ccc3a 100644 --- a/quad/quadwriter/render.rkt +++ b/quad/quadwriter/render.rkt @@ -6,6 +6,7 @@ racket/sequence racket/list racket/dict + racket/generator pitfall quad hyphenate @@ -45,7 +46,7 @@ #:min-left-length 3 #:min-right-length 3))] [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)])) @@ -245,8 +246,8 @@ (values line-qs fn-line-qs)) (define (make-columns line-qs fn-line-qs line-wrap-size printable-height column-gap) - (define col-quad-prototype (quad-copy q:column - [size (pt line-wrap-size printable-height)])) + (define col-quad-prototype (struct-copy quad q:column + [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))) (define (make-pages column-qs @@ -258,12 +259,30 @@ printable-height) (define (page-quad-prototype page-count) (define left-shift (+ left-margin (if (odd? page-count) gutter-margin 0))) - (quad-copy q:page - [shift (pt left-shift top-margin)] - [size (pt line-wrap-size printable-height)])) + (struct-copy page-quad q:page + [shift #:parent quad (pt left-shift top-margin)] + [size #:parent quad (pt line-wrap-size printable-height)])) (time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype))) + (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) (define (make-sections all-qs) @@ -313,10 +332,7 @@ (define section-pages (for/list ([page (in-list section-pages-without-repeaters)] [page-num (in-naturals 1)] - [page-side (in-cycle ((if (eq? section-starting-side 'left) values reverse) '(left right)))]) - ;; 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 + [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)] @@ -329,8 +345,8 @@ (cond [(null? section-repeaters-for-this-page) page] [else - (quad-copy page - [elems (append section-repeaters-for-this-page (quad-elems page))])]))) + (struct-copy page-quad page + [elems #:parent quad (append section-repeaters-for-this-page (quad-elems page))])]))) (begin0 (cond @@ -341,24 +357,24 @@ ['left ;; blank page goes at beginning of current section (define page-from-current-section (car section-pages)) - (define blank-page (quad-copy page-from-current-section [elems null])) - (define new-section (quad-copy q:section [elems (cons blank-page section-pages)])) + (define blank-page (struct-copy page-quad page-from-current-section [elems #:parent quad null])) + (define new-section (struct-copy quad q:section [elems (cons blank-page section-pages)])) (cons new-section sections-acc)] [_ ;; must be 'right ;; 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 [(cons previous-section other-sections) (define previous-section-pages (quad-elems previous-section)) ;; we know previous section has pages because we ignore empty sections (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 (quad-update! previous-section [elems (append previous-section-pages (list blank-page))])) (list* new-section updated-previous-section other-sections)] [_ (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)]) (section-pages-used (+ (section-pages-used) (length section-pages)))))) @@ -434,7 +450,7 @@ (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 (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 (define positioned-doc (time-log position (position doc))) ;; drawing implies that a PDF is written to disk