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

and more

Browse Source
main
Matthew Butterick 5 years ago
parent 2bd5e79704
commit 762b75a41b
4 changed files with 75 additions and 71 deletions
Show Stats Download Patch File Download Diff File

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

@ -84,17 +84,19 @@
(define (position-one q ref-src) (define (position-one q ref-src)
;; recursively calculates coordinates for quad & subquads ;; 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 ;; need to position before recurring, so subquads have accurate reference point
(define positioned-q (quad-copy q (define positioned-q
[origin shifted-origin] (quad-copy q
;; set shift to zero because it's baked into new origin value [origin (let* ([ref-pt (cond
[shift (pt 0 0)])) [(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 (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.
@ -112,7 +114,7 @@
(car prev-elems))) (car prev-elems)))
(loop (cons (position-one this-q ref-q) prev-elems) rest)] (loop (cons (position-one this-q ref-q) prev-elems) rest)]
[(cons x rest) (loop (cons x 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) (define (distance q)
(match (pt- (from-point q) (to-point q)) (match (pt- (from-point q) (to-point q))
@ -133,11 +135,9 @@
(append min-origin max-outer-pt)) (append min-origin max-outer-pt))
(define (attach-to from-q from-pt to-q to-pt) (define (attach-to from-q from-pt to-q to-pt)
(quad-copy from-q (quad-update! to-q
[elems (cons (quad-copy to-q [from-parent from-pt]
[from-parent from-pt] [to to-pt]))
[to to-pt])
(quad-elems from-q))]))
(module+ test (module+ test
(require rackunit) (require rackunit)

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

@ -93,8 +93,6 @@
(define-syntax-rule (quad-copy QID [K V] ...) (define-syntax-rule (quad-copy QID [K V] ...)
(struct-copy quad 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]) (define (quad-ref q key [default-val #f])
(hash-ref (quad-attrs q) key (match default-val (hash-ref (quad-attrs q) key (match default-val
@ -105,6 +103,15 @@
(hash-set! (quad-attrs q) key val) (hash-set! (quad-attrs q) key val)
q) 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-printable q [sig #f]) #t)
(define (default-draw q surface) (define (default-draw q surface)

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

@ -226,9 +226,9 @@
(define str (car (quad-elems last-q))) (define str (car (quad-elems last-q)))
(define str+hyphen (string-append str "-")) (define str+hyphen (string-append str "-"))
(append head (append head
(list (quad-copy last-q (list (quad-update! last-q
[elems (list str+hyphen)] [elems (list str+hyphen)]
[size (make-size-promise last-q str+hyphen)])))] [size (make-size-promise last-q str+hyphen)])))]
[_ qs])) [_ qs]))
@ -314,9 +314,7 @@
#:size (pt (* end-hspace space-multiplier) 0) #:size (pt (* end-hspace space-multiplier) 0)
#:attrs (quad-attrs (car qs)))) #:attrs (quad-attrs (car qs))))
(list* fq (list* fq
(let ([q (car qs)]) (quad-update! (car qs) [from-parent #f])
(set-quad-from-parent! q #f)
q)
(cdr qs))])])])) (cdr qs))])])]))
(define-quad offsetter-quad quad ()) (define-quad offsetter-quad quad ())
@ -361,43 +359,43 @@
(pt line-width (if (empty? line-heights) line-height (apply max line-heights))))) (pt line-width (if (empty? line-heights) line-height (apply max line-heights)))))
(list (list
(quad-copy line-q (quad-copy line-q
;; move block attrs up, so they are visible in col wrap ;; move block attrs up, so they are visible in col wrap
[attrs (copy-block-attrs (quad-attrs elem) [attrs (copy-block-attrs (quad-attrs elem)
(hash-copy (quad-attrs line-q)))] (hash-copy (quad-attrs line-q)))]
;; line width is static ;; line width is static
;; line height is the max 'line-height value or the natural height of q:line ;; line height is the max 'line-height value or the natural height of q:line
[size new-size] [size new-size]
;; handle list indexes. drop new quad into line to hold list index ;; handle list indexes. drop new quad into line to hold list index
;; could also use this for line numbers ;; could also use this for line numbers
[elems [elems
;; we assume here that a list item has already had extra inset-left ;; we assume here that a list item has already had extra inset-left
;; with room for a bullet ;; with room for a bullet
;; which we just insert at the front. ;; which we just insert at the front.
;; this is safe because line has already been filled. ;; this is safe because line has already been filled.
(append (append
;; only put bullet into line if we're at the first line of the list item ;; 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)) (match (and (eq? idx 1) (quad-ref elem :list-index))
[#false null] [#false null]
[bullet [bullet
(define bq (quad-copy q:string ;; copy q:string to get draw routine (define bq (quad-copy q:string ;; copy q:string to get draw routine
;; borrow attrs from elem ;; borrow attrs from elem
[attrs (quad-attrs elem)] [attrs (quad-attrs elem)]
;; use bullet as elems ;; use bullet as elems
[elems (list (if (number? bullet) (format "~a." bullet) bullet))] [elems (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-q)))])) [size (pt 15 (pt-y (size line-q)))]))
(from-parent (list bq) 'sw)]) (from-parent (list bq) 'sw)])
(from-parent (from-parent
(match (quad-ref elem :inset-left 0) (match (quad-ref elem :inset-left 0)
[0 elems] [0 elems]
[inset-val [inset-val
(cons (make-quad (cons (make-quad
#:draw-end q:string-draw-end #:draw-end q:string-draw-end
#:to 'sw #:to 'sw
#:size (pt inset-val 5) #:size (pt inset-val 5)
#:type offsetter-quad) #:type offsetter-quad)
elems)]) 'sw))]))] elems)]) 'sw))]))]
[_ null])])) [_ null])]))
(define maybe-first-line (match new-lines [(cons line0 _) line0][_ #false])) (define maybe-first-line (match new-lines [(cons line0 _) line0][_ #false]))
(append (match opening-q (append (match opening-q
@ -632,9 +630,8 @@
;; can be repeated without damage. ;; can be repeated without damage.
[((? null?) _) null] [((? null?) _) null]
[((cons q rest) where) [((cons q rest) where)
(set-quad-from-parent! q (or where (quad-from q))) (quad-update! q [from-parent (or where (quad-from q))])
(cons q rest) (cons q rest)])
#;(cons (quad-copy q [from-parent (or where (quad-from q))]) rest)])
(define ((col-finish-wrap col-quad) lns . _) (define ((col-finish-wrap col-quad) lns . _)
(match lns (match lns

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

@ -227,15 +227,15 @@
(define line-qs (time-log line-wrap (apply-keeps (line-wrap qs line-wrap-size)))) (define line-qs (time-log line-wrap (apply-keeps (line-wrap qs line-wrap-size))))
(define col-quad-prototype (quad-copy q:column (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 column-qs (time-log column-wrap (column-wrap line-qs printable-height column-gap col-quad-prototype)))
(define page-quad-prototype (define page-quad-prototype
(λ (page-count) (λ (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 (quad-copy q:page
[shift (pt left-shift top-margin)] [shift (pt left-shift top-margin)]
[size (pt line-wrap-size printable-height)]))) [size (pt line-wrap-size printable-height)])))
(define section-starting-side (string->symbol (quad-ref (car qs) :page-side-start "right"))) (define section-starting-side (string->symbol (quad-ref (car qs) :page-side-start "right")))
(define insert-blank-page? (define insert-blank-page?
@ -272,10 +272,10 @@
;; 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 (quad-copy page-from-previous-section [elems null]))
(define revised-previous-section (define updated-previous-section
(quad-copy 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 revised-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 (quad-copy q:section [elems section-pages]) )
(cons new-section sections-acc)]) (cons new-section sections-acc)])

Write Preview
Loading…
Cancel
Save