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

save some keystrokes

Browse Source
main
Matthew Butterick 4 years ago
parent cba750518f
commit 171951b76e
3 changed files with 136 additions and 126 deletions
Show Stats Download Patch File Download Diff File

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

@ -92,7 +92,7 @@
;; recursively calculates coordinates for quad & subquads ;; recursively calculates coordinates for quad & subquads
;; 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 (define positioned-q
(struct-copy quad q (quad-copy q
[origin (let* ([ref-pt (cond [origin (let* ([ref-pt (cond
[(quad? ref-src) [(quad? ref-src)
(anchor->global-point ref-src (or (quad-from-parent q) (quad-from q)))] (anchor->global-point ref-src (or (quad-from-parent q) (quad-from q)))]
@ -107,7 +107,7 @@
;; 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.
;; akin to `push` a graphics state and then `pop` afterwards. ;; akin to `push` a graphics state and then `pop` afterwards.
(let ([parent-q (struct-copy quad positioned-q (let ([parent-q (quad-copy positioned-q
[origin (pt+ (quad-origin positioned-q) (quad-shift-elems positioned-q))] [origin (pt+ (quad-origin positioned-q) (quad-shift-elems positioned-q))]
[shift-elems (pt 0 0)])]) [shift-elems (pt 0 0)])])
;; can't use for/list here because previous quads provide context for later ones ;; can't use for/list here because previous quads provide context for later ones

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

@ -94,22 +94,33 @@
#;(struct quad-attr (key default-val) #:transparent) #;(struct quad-attr (key default-val) #:transparent)
#;(define (make-quad-attr key [default-val #f]) #;(define (make-quad-attr key [default-val #f])
(quad-attr key default-val)) (quad-attr key default-val))
(define (quad-ref q key-arg [default-val-arg #f]) (define (quad-ref q key-arg [default-val-arg #f])
(define key (match key-arg (define key (match key-arg
#;[(quad-attr key _) key] #;[(quad-attr key _) key]
[_ key-arg])) [_ key-arg]))
(define default-val #;(cond (define default-val #;(cond
[default-val-arg] [default-val-arg]
[(quad-attr? key-arg) (quad-attr-default-val key-arg)] [(quad-attr? key-arg) (quad-attr-default-val key-arg)]
[else #false]) default-val-arg) [else #false]) default-val-arg)
(hash-ref (quad-attrs q) key default-val)) (hash-ref (quad-attrs q) key default-val))
(define (quad-set! q key val) (define (quad-set! q key val)
(hash-set! (quad-attrs q) key val) (hash-set! (quad-attrs q) key val)
q) q)
(define-syntax (quad-copy stx)
(syntax-case stx ()
[(_ ID [K V] ...)
#'(quad-copy quad ID [K V] ...)]
[(_ QUAD-TYPE ID [K V] ...)
(if (free-identifier=? #'quad #'QUAD-TYPE)
#'(struct-copy QUAD-TYPE ID
[K V] ...)
#'(struct-copy QUAD-TYPE ID
[K #:parent quad V] ...))]))
(define-syntax (quad-update! stx) (define-syntax (quad-update! stx)
(syntax-case stx () (syntax-case stx ()
[(_ ID [K V] ...) [(_ ID [K V] ...)

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

@ -136,18 +136,12 @@
;; this is verbose & ugly because `struct-copy` is a macro ;; this is verbose & ugly because `struct-copy` is a macro
;; we want to use break prototypes but also preserve their type ;; we want to use break prototypes but also preserve their type
(match (quad-ref q :break) (match (quad-ref q :break)
["para" (struct-copy para-break-quad q:para-break ["para" (quad-copy para-break-quad q:para-break [attrs (quad-attrs q)])]
[attrs #:parent quad (quad-attrs q)])] ["line" (quad-copy line-break-quad q:line-break [attrs (quad-attrs q)])]
["line" (struct-copy line-break-quad q:line-break ["page" (quad-copy page-break-quad q:page-break [attrs (quad-attrs q)])]
[attrs #:parent quad (quad-attrs q)])] ["column" (quad-copy column-break-quad q:column-break [attrs (quad-attrs q)])]
["page" (struct-copy page-break-quad q:page-break ["hr" (quad-copy hr-break-quad q:hr-break [attrs (quad-attrs q)])]
[attrs #:parent quad (quad-attrs q)])] ["section" (quad-copy section-break-quad q:section-break [attrs (quad-attrs q)])]
["column" (struct-copy column-break-quad q:column-break
[attrs #:parent quad (quad-attrs q)])]
["hr" (struct-copy hr-break-quad q:hr-break
[attrs #:parent quad (quad-attrs q)])]
["section" (struct-copy section-break-quad q:section-break
[attrs #:parent quad (quad-attrs q)])]
[_ q])) [_ q]))
(module+ test (module+ test
@ -163,22 +157,22 @@
#:draw-end q:string-draw-end)) #:draw-end q:string-draw-end))
(define (convert-draw-quad q) (define (convert-draw-quad q)
(struct-copy draw-quad q:draw (quad-copy draw-quad q:draw
[attrs #:parent quad (quad-attrs q)] [attrs (quad-attrs q)]
[draw #:parent quad (λ (q doc) [draw (λ (q doc)
(save doc) (save doc)
(match (quad-ref q :draw) (match (quad-ref q :draw)
["line" ["line"
(move-to doc (quad-ref q :x1) (quad-ref q :y1)) (move-to doc (quad-ref q :x1) (quad-ref q :y1))
(line-to doc (quad-ref q :x2) (quad-ref q :y2)) (line-to doc (quad-ref q :x2) (quad-ref q :y2))
(stroke doc "black")] (stroke doc "black")]
["text" (move-to doc 0 0) ["text" (move-to doc 0 0)
(q:string-draw q doc (q:string-draw q doc
#:origin (pt (quad-ref q :x 0) (quad-ref q :y 0)) #:origin (pt (quad-ref q :x 0) (quad-ref q :y 0))
#:text (quad-ref q :text))] #:text (quad-ref q :text))]
[_ (void)]) [_ (void)])
(restore doc))] (restore doc))]
[size #:parent quad (pt 0 0)])) [size (pt 0 0)]))
(define (convert-image-quad q) (define (convert-image-quad q)
(define path-string (quad-ref q :image-file)) (define path-string (quad-ref q :image-file))
@ -197,15 +191,14 @@
(define ratio (/ w img-width)) (define ratio (/ w img-width))
(list w (* ratio img-height))] (list w (* ratio img-height))]
[(list #false #false) (list img-width img-height)])) [(list #false #false) (list img-width img-height)]))
(struct-copy (quad-copy image-quad q:image
image-quad q:image [attrs (let ([h (hash-copy (quad-attrs q))])
[attrs #:parent quad (let ([h (hash-copy (quad-attrs q))]) ;; defeat 'bi 'bo positioning by removing font reference
;; defeat 'bi 'bo positioning by removing font reference (hash-set! h font-path-key #false)
(hash-set! h font-path-key #false) ;; save the img-obj for later
;; save the img-obj for later (hash-set! h :image-object img-obj)
(hash-set! h :image-object img-obj) h)]
h)] [size (pt layout-width layout-height)]))
[size #:parent quad (pt layout-width layout-height)]))
(define (convert-string-quad q) (define (convert-string-quad q)
;; need to handle casing here so that it's reflected in subsequent sizing ops ;; need to handle casing here so that it's reflected in subsequent sizing ops
@ -218,13 +211,12 @@
[_ values])) [_ values]))
(proc str)] (proc str)]
[_ ""])) ; a string quad should always contain a string [_ ""])) ; a string quad should always contain a string
(struct-copy (quad-copy string-quad q:string
string-quad q:string [attrs (let ([attrs (quad-attrs q)])
[attrs #:parent quad (let ([attrs (quad-attrs q)]) (hash-ref! attrs :font-size default-font-size)
(hash-ref! attrs :font-size default-font-size) attrs)]
attrs)] [elems (list cased-str)]
[elems #:parent quad (list cased-str)] [size (make-size-promise-for-string q cased-str)]))
[size #:parent quad (make-size-promise-for-string q cased-str)]))
(define (generic->typed-quad q) (define (generic->typed-quad q)
;; replaces quads representing certain things ;; replaces quads representing certain things
@ -298,10 +290,10 @@
(define tracking-adjustment (define tracking-adjustment
(* (sub1 (length run-pcs)) (quad-ref (car run-pcs) :font-tracking 0))) (* (sub1 (length run-pcs)) (quad-ref (car run-pcs) :font-tracking 0)))
(define new-run (define new-run
(struct-copy string-quad q:string (quad-copy string-quad q:string
[attrs #:parent quad (quad-attrs strq)] [attrs (quad-attrs strq)]
[elems #:parent quad (merge-adjacent-strings (apply append (map quad-elems run-pcs)))] [elems (merge-adjacent-strings (apply append (map quad-elems run-pcs)))]
[size #:parent quad (delay (pt (sum-x run-pcs) (pt-y (size strq))))])) [size (delay (pt (sum-x run-pcs) (pt-y (size strq))))]))
(loop (cons new-run runs) rest)] (loop (cons new-run runs) rest)]
[(cons first rest) (loop (cons first runs) rest)] [(cons first rest) (loop (cons first runs) rest)]
[_ (reverse runs)]))) [_ (reverse runs)])))
@ -340,13 +332,12 @@
(match (regexp-match #rx"[.,:;’-]$" (car (quad-elems last-q))) (match (regexp-match #rx"[.,:;’-]$" (car (quad-elems last-q)))
[#false nonspacess] [#false nonspacess]
[last-char-str [last-char-str
(define hanger-q (struct-copy string-quad last-q (define hanger-q (quad-copy string-quad last-q
[elems #:parent quad null] [elems null]
[size #:parent quad [size (let ([p (make-size-promise-for-string last-q (car last-char-str))])
(let ([p (make-size-promise-for-string last-q (car last-char-str))]) (delay
(delay (match-define (list x y) (force p))
(match-define (list x y) (force p)) (pt (- x) y)))]))
(pt (- x) y)))]))
(define last-sublist (append prev-qs (list last-q hanger-q))) (define last-sublist (append prev-qs (list last-q hanger-q)))
(append sublists (list last-sublist))])] (append sublists (list last-sublist))])]
[_ nonspacess])) [_ nonspacess]))
@ -445,7 +436,7 @@
(restore doc)) (restore doc))
(define (make-hr-quad line-q) (define (make-hr-quad line-q)
(struct-copy quad line-q [draw-start hr-draw])) (quad-copy line-q [draw-start hr-draw]))
(define ((line-wrap-finish line-prototype-q default-block-id) wrap-qs q-before q-after idx) (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 ;; we curry line-q so that the wrap size can be communicated to this operation
@ -468,50 +459,49 @@
[(and (cons elem-first _) elems) [(and (cons elem-first _) elems)
(match-define (list line-width line-height) (quad-size line-prototype-q)) (match-define (list line-width line-height) (quad-size line-prototype-q))
(list (list
(struct-copy quad (quad-copy line-prototype-q
line-prototype-q ;; move block attrs up, so they are visible in col wrap
;; 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)))])
[attrs (let ([h (copy-block-attrs (quad-attrs elem-first) (hash-copy (quad-attrs line-prototype-q)))]) ;; we want every group of lines in a paragraph to have a block id
;; we want every group of lines in a paragraph to have a block id ;; so that it will be wrapped as a block later.
;; so that it will be wrapped as a block later. ;; we only set this if there is no value for :display.
;; we only set this if there is no value for :display. (hash-ref! h :display default-block-id)
(hash-ref! h :display default-block-id) h)]
h)] ;; 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 (pt line-width (match (filter-map (λ (q) (or (quad-ref q :line-height) (pt-y (size q)))) pcs)
[size (pt line-width (match (filter-map (λ (q) (or (quad-ref q :line-height) (pt-y (size q)))) pcs) [(? null?) line-height]
[(? null?) line-height] [line-heights (apply max line-heights)]))]
[line-heights (apply max line-heights)]))] ;; 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-first :list-index))
(match (and (eq? idx 1) (quad-ref elem-first :list-index)) [#false null]
[#false null] [bullet
[bullet (define bq (quad-copy string-quad 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
;; borrow attrs from elem [attrs (quad-attrs elem-first)]
[attrs #:parent quad (quad-attrs elem-first)] ;; use bullet as elems
;; 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
;; 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-prototype-q)))]))
[size #:parent quad (pt 15 (pt-y (size line-prototype-q)))])) (from-parent (list bq) 'sw)])
(from-parent (list bq) 'sw)]) (from-parent
(from-parent (match (quad-ref elem-first :inset-left 0)
(match (quad-ref elem-first :inset-left 0) [0 elems]
[0 elems] [inset-val (cons (make-quad
[inset-val (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 (and (pair? new-lines) (car new-lines))) (define maybe-first-line (and (pair? new-lines) (car new-lines)))
(append (match q-before (append (match q-before
@ -529,7 +519,7 @@
(raise-argument-error 'line-wrap "positive number" wrap-size)) (raise-argument-error 'line-wrap "positive number" wrap-size))
(match qs (match qs
[(cons q _) [(cons q _)
(define line-q (struct-copy quad q:line [size (pt wrap-size (quad-ref q :line-height default-line-height))])) (define line-q (quad-copy q:line [size (pt wrap-size (quad-ref q :line-height default-line-height))]))
(define permitted-justify-overfill (define permitted-justify-overfill
(match (quad-ref q :line-align) (match (quad-ref q :line-align)
;; allow justified lines to go wider, ;; allow justified lines to go wider,
@ -676,28 +666,36 @@
(draw-debug q doc "goldenrod" "goldenrod")) (draw-debug q doc "goldenrod" "goldenrod"))
(draw-page-footer q doc)))) (draw-page-footer q doc))))
(define q:column (q (define-quad column-quad quad)
(define q:column (make-quad
#:type column-quad
#:id 'col #:id 'col
#:from 'ne #:from 'ne
#:to 'nw)) #:to 'nw))
(define-quad column-spacer-quad quad) (define-quad column-spacer-quad quad)
(define q:column-spacer (q #:type column-spacer-quad (define q:column-spacer (make-quad
#:from 'ne #:type column-spacer-quad
#:to 'nw #:from 'ne
#:printable only-prints-in-middle)) #:to 'nw
#:printable only-prints-in-middle))
(define-quad page-quad quad) (define-quad page-quad quad)
(define q:page (q (define q:page (make-quad
#:type page-quad #:type page-quad
#:id 'page #:id 'page
#:from-parent 'nw #:from-parent 'nw
#:draw-start page-draw-start)) #:draw-start page-draw-start))
(define q:doc (q #:draw-start (λ (q doc) (start-doc doc)) (define-quad doc-quad quad)
#:draw-end (λ (q doc) (end-doc doc)))) (define q:doc (make-quad
#:type doc-quad
#:draw-start (λ (q doc) (start-doc doc))
#:draw-end (λ (q doc) (end-doc doc))))
(define q:section (q #:id 'section)) (define-quad section-quad quad)
(define q:section (make-quad #:type section-quad
#:id 'section))
(define ((block-draw-start first-line) q doc) (define ((block-draw-start first-line) q doc)
;; adjust drawing coordinates for border inset ;; adjust drawing coordinates for border inset
@ -794,7 +792,7 @@
(append (append
(match lns (match lns
[(cons line _) [(cons line _)
(list (struct-copy quad col-quad (list (quad-copy col-quad
;; move block attrs up, so they are visible in page wrap ;; move block attrs up, so they are visible in page wrap
[attrs (copy-block-attrs (quad-attrs line) [attrs (copy-block-attrs (quad-attrs line)
(hash-copy (quad-attrs col-quad)))] (hash-copy (quad-attrs col-quad)))]
@ -855,7 +853,8 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96
(when (pair? cols) (when (pair? cols)
(quad-update! (car cols) (quad-update! (car cols)
[elems (append (quad-elems (car cols)) reversed-fn-lines)])) [elems (append (quad-elems (car cols)) reversed-fn-lines)]))
(define col-spacer (struct-copy quad q:column-spacer [size (pt column-gap (and 'arbitrary-irrelevant-value 100))])) (define col-spacer (quad-copy column-spacer-quad q:column-spacer
[size (pt column-gap (and 'arbitrary-irrelevant-value 100))]))
(add-between cols col-spacer)) (add-between cols col-spacer))
(verbose-quad-printing? #t) (verbose-quad-printing? #t)
@ -873,14 +872,14 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96
[(or #false "none") null] [(or #false "none") null]
[_ (list (make-footer-quad q-for-attrs page-idx path))]) [_ (list (make-footer-quad q-for-attrs page-idx path))])
(from-parent cols 'nw))) (from-parent cols 'nw)))
(list (struct-copy page-quad pq (list (quad-update! pq
[elems #:parent quad elems] [elems elems]
[attrs #:parent quad (copy-block-attrs (cond [attrs (copy-block-attrs (cond
[q-for-attrs => quad-attrs] [q-for-attrs => quad-attrs]
[else (hash)]) [else (hash)])
(hash-copy (quad-attrs pq)))]))) (hash-copy (quad-attrs pq)))])))
(define (page-wrap qs width [make-page-quad (λ (x) q:page)]) (define (page-wrap qs width [make-page-quad (λ (x) (quad-copy page-quad q:page))])
(unless (positive? width) (unless (positive? width)
(raise-argument-error 'page-wrap "positive number" width)) (raise-argument-error 'page-wrap "positive number" width))
(wrap qs width (wrap qs width

Write Preview
Loading…
Cancel
Save