doc repeaters

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)

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])

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?))]

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)

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