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

type harder

Browse Source
main
Matthew Butterick 4 years ago
parent eeec8d03cf
commit 3114290280
5 changed files with 72 additions and 65 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
(quad-copy q (quad-copy quad 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 (quad-copy positioned-q (let ([parent-q (quad-copy quad 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

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

@ -112,8 +112,6 @@
(define-syntax (quad-copy stx) (define-syntax (quad-copy stx)
(syntax-case stx () (syntax-case stx ()
[(_ ID [K V] ...)
#'(quad-copy quad ID [K V] ...)]
[(_ QUAD-TYPE ID [K V] ...) [(_ QUAD-TYPE ID [K V] ...)
(if (free-identifier=? #'quad #'QUAD-TYPE) (if (free-identifier=? #'quad #'QUAD-TYPE)
#'(struct-copy QUAD-TYPE ID #'(struct-copy QUAD-TYPE ID

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

@ -230,7 +230,8 @@
[else convert-string-quad])) [else convert-string-quad]))
(converter q)) (converter q))
(define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"] [stroke-width 0.5]) (define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"] . _)
(define stroke-width 0.5)
(when (draw-debug?) (when (draw-debug?)
(save doc) (save doc)
;; draw layout box ;; draw layout box
@ -248,27 +249,29 @@
(restore doc))) (restore doc)))
(define-quad line-quad quad)
(define q:line (q #:size (pt 0 default-line-height) (define q:line (make-quad
#:from 'sw #:type line-quad
#:to 'nw #:size (pt 0 default-line-height)
#:printable #true #:from 'sw
#:id 'line #:to 'nw
#:draw-start (if draw-debug-line? draw-debug void))) #:printable #true
#:id 'line
#:draw-start (if draw-debug-line? draw-debug void)))
(define-quad line-spacer-quad line-break-quad) (define-quad line-spacer-quad line-break-quad)
(define only-prints-in-middle (λ (q sig) (not (memq sig '(start end))))) (define only-prints-in-middle (λ (q sig) (not (memq sig '(start end)))))
(define (make-paragraph-spacer maybe-first-line-q key default-val) (define (make-paragraph-spacer maybe-first-line-q key default-val)
(define arbitrary-width 20) (define arbitrary-width 20)
(q #:type line-spacer-quad (make-quad #:type line-spacer-quad
#:size (pt arbitrary-width (cond #:size (pt arbitrary-width (cond
[(and maybe-first-line-q (quad-ref maybe-first-line-q key))] [(and maybe-first-line-q (quad-ref maybe-first-line-q key))]
[else default-val])) [else default-val]))
#:from 'sw #:from 'sw
#:to 'nw #:to 'nw
#:printable only-prints-in-middle #:printable only-prints-in-middle
#:draw-start (if (draw-debug-line?) draw-debug void))) #:draw-start (if (draw-debug-line?) draw-debug void)))
(define softies (map string '(#\space #\- #\u00AD))) (define softies (map string '(#\space #\- #\u00AD)))
@ -436,7 +439,7 @@
(restore doc)) (restore doc))
(define (make-hr-quad line-q) (define (make-hr-quad line-q)
(quad-copy line-q [draw-start hr-draw])) (quad-copy line-quad 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
@ -459,7 +462,7 @@
[(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
(quad-copy line-prototype-q (quad-copy line-quad 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
@ -519,7 +522,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 (quad-copy q:line [size (pt wrap-size (quad-ref q :line-height default-line-height))])) (define line-q (quad-copy line-quad 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,
@ -654,17 +657,17 @@
:font-family "text") :font-family "text")
(resolve-font-path! attrs) (resolve-font-path! attrs)
attrs)) attrs))
(q #:size (pt 50 default-line-height) (make-quad #:size (pt 50 default-line-height)
#:attrs attrs #:attrs attrs
#:from-parent 'sw #:from-parent 'sw
#:to 'nw #:to 'nw
#:elems (or null (hash-ref (current-named-quads) "foo")) #:elems (or null (hash-ref (current-named-quads) "foo"))
#:shift (pt 0 (* 1.5 default-line-height)) #:shift (pt 0 (* 1.5 default-line-height))
#:printable #true #:printable #true
#:draw-start (λ (q doc) #:draw-start (λ (q doc)
(when draw-debug-line? (when draw-debug-line?
(draw-debug q doc "goldenrod" "goldenrod")) (draw-debug q doc "goldenrod" "goldenrod"))
(draw-page-footer q doc)))) (draw-page-footer q doc))))
(define-quad column-quad quad) (define-quad column-quad quad)
(define q:column (make-quad (define q:column (make-quad
@ -757,21 +760,24 @@
(when (draw-debug-block?) (when (draw-debug-block?)
(draw-debug q doc "#6c6" "#9c9"))) (draw-debug q doc "#6c6" "#9c9")))
(define-quad block-quad quad)
(define (lines->block lines) (define (lines->block lines)
(match lines (match lines
[(cons line _) [(cons line _)
(q #:from 'sw (make-quad
#:to 'nw #:type block-quad
#:elems (from-parent lines 'nw) #:from 'sw
#:id 'block #:to 'nw
#:attrs (quad-attrs line) #:elems (from-parent lines 'nw)
#:size (delay (pt (pt-x (size line)) ; #:id 'block
(+ (sum-y lines) #:attrs (quad-attrs line)
(quad-ref line :inset-top 0) #:size (delay (pt (pt-x (size line)) ;
(quad-ref line :inset-bottom 0)))) (+ (sum-y lines)
#:shift-elems (pt 0 (quad-ref line :inset-top 0)) (quad-ref line :inset-top 0)
#:draw-start (block-draw-start line) (quad-ref line :inset-bottom 0))))
#:draw-end (block-draw-end line))])) #:shift-elems (pt 0 (quad-ref line :inset-top 0))
#:draw-start (block-draw-start line)
#:draw-end (block-draw-end line))]))
(define/match (from-parent qs [where #f]) (define/match (from-parent qs [where #f])
;; doesn't change any positioning. doesn't depend on state. can happen anytime. ;; doesn't change any positioning. doesn't depend on state. can happen anytime.
@ -792,7 +798,7 @@
(append (append
(match lns (match lns
[(cons line _) [(cons line _)
(list (quad-copy col-quad (list (quad-copy column-quad 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)))]
@ -807,7 +813,7 @@ constraint wrapping example
https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d9656046b/pdf/directory-require.rkt#L51 https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d9656046b/pdf/directory-require.rkt#L51
|# |#
;; ;;
(define (column-wrap lines fn-lines vertical-height column-gap [column-quad q:column]) (define (column-wrap lines fn-lines vertical-height column-gap [col-quad-proto q:column])
(unless (positive? vertical-height) (unless (positive? vertical-height)
(raise-argument-error 'column-wrap "positive number" vertical-height)) (raise-argument-error 'column-wrap "positive number" vertical-height))
@ -824,7 +830,7 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96
#:distance (λ (q dist-so-far wrap-qs) #:distance (λ (q dist-so-far wrap-qs)
;; do trial block insertions ;; do trial block insertions
(sum-y (insert-blocks (reverse wrap-qs)))) (sum-y (insert-blocks (reverse wrap-qs))))
#:finish-wrap (column-wrap-finish column-quad) #:finish-wrap (column-wrap-finish col-quad-proto)
#:footnote-qs fn-lines #:footnote-qs fn-lines
#:footnote-leftover-proc (λ (ymax leftover-qs fn-qs) #:footnote-leftover-proc (λ (ymax leftover-qs fn-qs)
(let loop ([ymax ymax][leftover-qs leftover-qs][fn-qs fn-qs]) (let loop ([ymax ymax][leftover-qs leftover-qs][fn-qs fn-qs])

4
quad/quadwriter/param.rkt
Unescape Escape View File

@ -17,9 +17,9 @@
(define draw-debug? (make-parameter #true)) (define draw-debug? (make-parameter #true))
(define draw-debug-line? (make-parameter #true)) (define draw-debug-line? (make-parameter #true))
(define draw-debug-block? (make-parameter #true)) (define draw-debug-block? (make-parameter #false))
(define draw-debug-string? (make-parameter #true)) (define draw-debug-string? (make-parameter #true))
(define draw-debug-image? (make-parameter #true)) (define draw-debug-image? (make-parameter #false))
(define debug-page-width (make-parameter 400)) (define debug-page-width (make-parameter 400))
(define debug-page-height (make-parameter 400)) (define debug-page-height (make-parameter 400))

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

@ -246,7 +246,7 @@
(values line-qs fn-line-qs)) (values line-qs fn-line-qs))
(define (make-columns line-qs fn-line-qs line-wrap-size printable-height column-gap) (define (make-columns line-qs fn-line-qs line-wrap-size printable-height column-gap)
(define col-quad-prototype (quad-copy quad q:column (define col-quad-prototype (quad-copy column-quad q:column
[size (pt line-wrap-size printable-height)])) [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))) (time-log column-wrap (column-wrap line-qs fn-line-qs printable-height column-gap col-quad-prototype)))
@ -276,10 +276,9 @@
(for/list ([repeater (in-list repeaters)] (for/list ([repeater (in-list repeaters)]
#:when (let* ([val (quad-ref repeater :page-repeat)] #:when (let* ([val (quad-ref repeater :page-repeat)]
[sym (string->symbol val)]) [sym (string->symbol val)])
(memq sym (list (or (eq? sym 'all)
(if (= page-num 1) 'first 'rest) (eq? sym page-side)
page-side (eq? sym (if (= page-num 1) 'first 'rest)))))
'all))))
repeater)) repeater))
(when (pair? repeaters-for-this-page) (when (pair? repeaters-for-this-page)
(set-quad-elems! page (append repeaters-for-this-page (quad-elems page))))) (set-quad-elems! page (append repeaters-for-this-page (quad-elems page)))))
@ -337,16 +336,16 @@
(for/list ([repeater (in-list section-repeaters)] (for/list ([repeater (in-list section-repeaters)]
#:when (let* ([val (quad-ref repeater :page-repeat)] #:when (let* ([val (quad-ref repeater :page-repeat)]
[sym (string->symbol (string-trim val #px"section\\s"))]) [sym (string->symbol (string-trim val #px"section\\s"))])
(memq sym (list* (or (eq? sym 'section)
(if (= page-num 1) 'first 'rest) (eq? sym 'all)
page-side (eq? sym page-side)
'(section all))))) (eq? sym (if (= page-num 1) 'first 'rest)))))
repeater)) repeater))
(cond (cond
[(null? section-repeaters-for-this-page) page] [(null? section-repeaters-for-this-page) page]
[else [else
(quad-copy page-quad page (quad-copy page-quad page
[elems (append section-repeaters-for-this-page (quad-elems page))])]))) [elems (append section-repeaters-for-this-page (quad-elems page))])])))
(begin0 (begin0
(cond (cond
@ -358,11 +357,11 @@
;; blank page goes at beginning of current section ;; blank page goes at beginning of current section
(define page-from-current-section (car section-pages)) (define page-from-current-section (car section-pages))
(define blank-page (quad-copy page-quad page-from-current-section [elems null])) (define blank-page (quad-copy page-quad page-from-current-section [elems null]))
(define new-section (quad-copy quad q:section [elems (cons blank-page section-pages)])) (define new-section (quad-copy section-quad q:section [elems (cons blank-page section-pages)]))
(cons new-section sections-acc)] (cons new-section sections-acc)]
[_ ;; must be 'right [_ ;; must be 'right
;; blank page goes at end of previous section (if it exists) ;; blank page goes at end of previous section (if it exists)
(define new-section (quad-copy quad q:section [elems section-pages])) (define new-section (quad-copy section-quad q:section [elems section-pages]))
(match sections-acc (match sections-acc
[(cons previous-section other-sections) [(cons previous-section other-sections)
(define previous-section-pages (quad-elems previous-section)) (define previous-section-pages (quad-elems previous-section))
@ -374,7 +373,7 @@
[elems (append previous-section-pages (list blank-page))])) [elems (append previous-section-pages (list blank-page))]))
(list* new-section updated-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 section-quad q:section [elems section-pages]) )
(cons new-section sections-acc)]) (cons new-section sections-acc)])
(section-pages-used (+ (section-pages-used) (length section-pages)))))) (section-pages-used (+ (section-pages-used) (length section-pages))))))
@ -383,11 +382,15 @@
(for* ([(page page-idx) (in-indexed (for*/list ([section (in-list (quad-elems doc))] (for* ([(page page-idx) (in-indexed (for*/list ([section (in-list (quad-elems doc))]
[page (in-list (quad-elems section))]) [page (in-list (quad-elems section))])
page))] page))]
#:when (page-quad? page)
;; all inner / outer lines are initially filled as if they were right-aligned ;; all inner / outer lines are initially filled as if they were right-aligned
[zero-filler-side (in-value (if (odd? (add1 page-idx)) "inner" "outer"))] [zero-filler-side (in-value (if (odd? (add1 page-idx)) "inner" "outer"))]
[col (in-list (quad-elems page))] [col (in-list (quad-elems page))]
#:when (column-quad? col)
[block (in-list (quad-elems col))] [block (in-list (quad-elems col))]
[line (in-list (quad-elems block))]) #:when (block-quad? block)
[line (in-list (quad-elems block))]
#:when (line-quad? line))
(when (equal? zero-filler-side (quad-ref line :line-align)) (when (equal? zero-filler-side (quad-ref line :line-align))
(match (quad-elems line) (match (quad-elems line)
;; collapse the filler quad by setting size to 0 ;; collapse the filler quad by setting size to 0

Write Preview
Loading…
Cancel
Save