diff --git a/quad/quad/position.rkt b/quad/quad/position.rkt index d8ef356b..3dd4bf7d 100644 --- a/quad/quad/position.rkt +++ b/quad/quad/position.rkt @@ -84,17 +84,19 @@ (define (position-one q ref-src) ;; recursively calculates coordinates for quad & subquads - (define 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)])) - (define this-origin (pt- ref-pt (to-point q))) - (define shifted-origin (pt+ this-origin (quad-shift q))) ;; need to position before recurring, so subquads have accurate reference point - (define positioned-q (quad-copy q - [origin shifted-origin] - ;; set shift to zero because it's baked into new origin value - [shift (pt 0 0)])) + (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)])) (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. @@ -112,7 +114,7 @@ (car prev-elems))) (loop (cons (position-one this-q ref-q) prev-elems) rest)] [(cons x rest) (loop (cons x prev-elems) rest)])))) - (quad-copy positioned-q [elems positioned-elems])) + (quad-update! positioned-q [elems positioned-elems])) (define (distance q) (match (pt- (from-point q) (to-point q)) @@ -133,11 +135,9 @@ (append min-origin max-outer-pt)) (define (attach-to from-q from-pt to-q to-pt) - (quad-copy from-q - [elems (cons (quad-copy to-q - [from-parent from-pt] - [to to-pt]) - (quad-elems from-q))])) + (quad-update! to-q + [from-parent from-pt] + [to to-pt])) (module+ test (require rackunit) diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index c6bc7f87..2474cada 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -93,8 +93,6 @@ (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 @@ -105,6 +103,15 @@ (hash-set! (quad-attrs q) key val) q) +(define-syntax (quad-update! stx) + (syntax-case stx () + [(_ ID [K V] ...) + (with-syntax ([(K-SETTER ...) (for/list ([kstx (in-list (syntax->list #'(K ...)))]) + (format-id kstx "set-quad-~a!" kstx))]) + #'(let ([q ID]) + (K-SETTER q V) ... + q))])) + (define (default-printable q [sig #f]) #t) (define (default-draw q surface) diff --git a/quad/quadwriter/layout.rkt b/quad/quadwriter/layout.rkt index 1eae8cd1..9a78ef12 100644 --- a/quad/quadwriter/layout.rkt +++ b/quad/quadwriter/layout.rkt @@ -226,9 +226,9 @@ (define str (car (quad-elems last-q))) (define str+hyphen (string-append str "-")) (append head - (list (quad-copy last-q - [elems (list str+hyphen)] - [size (make-size-promise last-q str+hyphen)])))] + (list (quad-update! last-q + [elems (list str+hyphen)] + [size (make-size-promise last-q str+hyphen)])))] [_ qs])) @@ -314,9 +314,7 @@ #:size (pt (* end-hspace space-multiplier) 0) #:attrs (quad-attrs (car qs)))) (list* fq - (let ([q (car qs)]) - (set-quad-from-parent! q #f) - q) + (quad-update! (car qs) [from-parent #f]) (cdr qs))])])])) (define-quad offsetter-quad quad ()) @@ -361,43 +359,43 @@ (pt line-width (if (empty? line-heights) line-height (apply max line-heights))))) (list (quad-copy line-q - ;; move block attrs up, so they are visible in col wrap - [attrs (copy-block-attrs (quad-attrs elem) - (hash-copy (quad-attrs line-q)))] - ;; line width is static - ;; line height is the max 'line-height value or the natural height of q:line - [size new-size] - ;; handle list indexes. drop new quad into line to hold list index - ;; could also use this for line numbers - [elems - ;; we assume here that a list item has already had extra inset-left - ;; with room for a bullet - ;; which we just insert at the front. - ;; this is safe because line has already been filled. - (append - ;; only put bullet into line if we're at the first line of the list item - (match (and (eq? idx 1) (quad-ref elem :list-index)) - [#false null] - [bullet - (define bq (quad-copy q:string ;; copy q:string to get draw routine - ;; borrow attrs from elem - [attrs (quad-attrs elem)] - ;; use bullet as elems - [elems (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-q)))])) - (from-parent (list bq) 'sw)]) - (from-parent - (match (quad-ref elem :inset-left 0) - [0 elems] - [inset-val - (cons (make-quad - #:draw-end q:string-draw-end - #:to 'sw - #:size (pt inset-val 5) - #:type offsetter-quad) - elems)]) 'sw))]))] + ;; move block attrs up, so they are visible in col wrap + [attrs (copy-block-attrs (quad-attrs elem) + (hash-copy (quad-attrs line-q)))] + ;; line width is static + ;; line height is the max 'line-height value or the natural height of q:line + [size new-size] + ;; handle list indexes. drop new quad into line to hold list index + ;; could also use this for line numbers + [elems + ;; we assume here that a list item has already had extra inset-left + ;; with room for a bullet + ;; which we just insert at the front. + ;; this is safe because line has already been filled. + (append + ;; only put bullet into line if we're at the first line of the list item + (match (and (eq? idx 1) (quad-ref elem :list-index)) + [#false null] + [bullet + (define bq (quad-copy q:string ;; copy q:string to get draw routine + ;; borrow attrs from elem + [attrs (quad-attrs elem)] + ;; use bullet as elems + [elems (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-q)))])) + (from-parent (list bq) 'sw)]) + (from-parent + (match (quad-ref elem :inset-left 0) + [0 elems] + [inset-val + (cons (make-quad + #:draw-end q:string-draw-end + #:to 'sw + #:size (pt inset-val 5) + #:type offsetter-quad) + elems)]) 'sw))]))] [_ null])])) (define maybe-first-line (match new-lines [(cons line0 _) line0][_ #false])) (append (match opening-q @@ -632,9 +630,8 @@ ;; can be repeated without damage. [((? null?) _) null] [((cons q rest) where) - (set-quad-from-parent! q (or where (quad-from q))) - (cons q rest) - #;(cons (quad-copy q [from-parent (or where (quad-from q))]) rest)]) + (quad-update! q [from-parent (or where (quad-from q))]) + (cons q rest)]) (define ((col-finish-wrap col-quad) lns . _) (match lns diff --git a/quad/quadwriter/render.rkt b/quad/quadwriter/render.rkt index de0dc43d..bff05a77 100644 --- a/quad/quadwriter/render.rkt +++ b/quad/quadwriter/render.rkt @@ -227,15 +227,15 @@ (define line-qs (time-log line-wrap (apply-keeps (line-wrap qs line-wrap-size)))) (define col-quad-prototype (quad-copy q:column - [size (pt line-wrap-size printable-height)])) + [size (pt line-wrap-size printable-height)])) (define column-qs (time-log column-wrap (column-wrap line-qs printable-height column-gap col-quad-prototype))) (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)]))) + [shift (pt left-shift top-margin)] + [size (pt line-wrap-size printable-height)]))) (define section-starting-side (string->symbol (quad-ref (car qs) :page-side-start "right"))) (define insert-blank-page? @@ -272,10 +272,10 @@ ;; 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 revised-previous-section - (quad-copy previous-section - [elems (append previous-section-pages (list blank-page))])) - (list* new-section revised-previous-section other-sections)] + (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]) ) (cons new-section sections-acc)])