From 3114290280812c517bd8f3dce117079c98fb61bb Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 8 Feb 2020 08:33:42 -0800 Subject: [PATCH] type harder --- quad/quad/position.rkt | 4 +- quad/quad/quad.rkt | 2 - quad/quadwriter/layout.rkt | 96 ++++++++++++++++++++------------------ quad/quadwriter/param.rkt | 4 +- quad/quadwriter/render.rkt | 31 ++++++------ 5 files changed, 72 insertions(+), 65 deletions(-) diff --git a/quad/quad/position.rkt b/quad/quad/position.rkt index ae421719..8ce69aa1 100644 --- a/quad/quad/position.rkt +++ b/quad/quad/position.rkt @@ -92,7 +92,7 @@ ;; recursively calculates coordinates for quad & subquads ;; need to position before recurring, so subquads have accurate reference point (define positioned-q - (quad-copy q + (quad-copy quad q [origin (let* ([ref-pt (cond [(quad? ref-src) (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 ;; 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 + (let ([parent-q (quad-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 diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 0b0752c3..b77631c3 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -112,8 +112,6 @@ (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 diff --git a/quad/quadwriter/layout.rkt b/quad/quadwriter/layout.rkt index aa79f6ce..3b89c3d8 100644 --- a/quad/quadwriter/layout.rkt +++ b/quad/quadwriter/layout.rkt @@ -230,7 +230,8 @@ [else convert-string-quad])) (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?) (save doc) ;; draw layout box @@ -248,27 +249,29 @@ (restore doc))) - -(define q:line (q #:size (pt 0 default-line-height) - #:from 'sw - #:to 'nw - #:printable #true - #:id 'line - #:draw-start (if draw-debug-line? draw-debug void))) +(define-quad line-quad quad) +(define q:line (make-quad + #:type line-quad + #:size (pt 0 default-line-height) + #:from 'sw + #:to 'nw + #:printable #true + #:id 'line + #:draw-start (if draw-debug-line? draw-debug void))) (define-quad line-spacer-quad line-break-quad) (define only-prints-in-middle (λ (q sig) (not (memq sig '(start end))))) (define (make-paragraph-spacer maybe-first-line-q key default-val) (define arbitrary-width 20) - (q #:type line-spacer-quad - #:size (pt arbitrary-width (cond - [(and maybe-first-line-q (quad-ref maybe-first-line-q key))] - [else default-val])) - #:from 'sw - #:to 'nw - #:printable only-prints-in-middle - #:draw-start (if (draw-debug-line?) draw-debug void))) + (make-quad #:type line-spacer-quad + #:size (pt arbitrary-width (cond + [(and maybe-first-line-q (quad-ref maybe-first-line-q key))] + [else default-val])) + #:from 'sw + #:to 'nw + #:printable only-prints-in-middle + #:draw-start (if (draw-debug-line?) draw-debug void))) (define softies (map string '(#\space #\- #\u00AD))) @@ -436,7 +439,7 @@ (restore doc)) (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) ;; we curry line-q so that the wrap size can be communicated to this operation @@ -459,7 +462,7 @@ [(and (cons elem-first _) elems) (match-define (list line-width line-height) (quad-size line-prototype-q)) (list - (quad-copy line-prototype-q + (quad-copy line-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)))]) ;; 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)) (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 (quad-copy line-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, @@ -654,17 +657,17 @@ :font-family "text") (resolve-font-path! attrs) attrs)) - (q #:size (pt 50 default-line-height) - #:attrs attrs - #:from-parent 'sw - #:to 'nw - #:elems (or null (hash-ref (current-named-quads) "foo")) - #:shift (pt 0 (* 1.5 default-line-height)) - #:printable #true - #:draw-start (λ (q doc) - (when draw-debug-line? - (draw-debug q doc "goldenrod" "goldenrod")) - (draw-page-footer q doc)))) + (make-quad #:size (pt 50 default-line-height) + #:attrs attrs + #:from-parent 'sw + #:to 'nw + #:elems (or null (hash-ref (current-named-quads) "foo")) + #:shift (pt 0 (* 1.5 default-line-height)) + #:printable #true + #:draw-start (λ (q doc) + (when draw-debug-line? + (draw-debug q doc "goldenrod" "goldenrod")) + (draw-page-footer q doc)))) (define-quad column-quad quad) (define q:column (make-quad @@ -757,21 +760,24 @@ (when (draw-debug-block?) (draw-debug q doc "#6c6" "#9c9"))) +(define-quad block-quad quad) (define (lines->block lines) (match lines [(cons line _) - (q #:from 'sw - #:to 'nw - #:elems (from-parent lines 'nw) - #:id 'block - #:attrs (quad-attrs line) - #:size (delay (pt (pt-x (size line)) ; - (+ (sum-y lines) - (quad-ref line :inset-top 0) - (quad-ref line :inset-bottom 0)))) - #:shift-elems (pt 0 (quad-ref line :inset-top 0)) - #:draw-start (block-draw-start line) - #:draw-end (block-draw-end line))])) + (make-quad + #:type block-quad + #:from 'sw + #:to 'nw + #:elems (from-parent lines 'nw) + #:id 'block + #:attrs (quad-attrs line) + #:size (delay (pt (pt-x (size line)) ; + (+ (sum-y lines) + (quad-ref line :inset-top 0) + (quad-ref line :inset-bottom 0)))) + #: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]) ;; doesn't change any positioning. doesn't depend on state. can happen anytime. @@ -792,7 +798,7 @@ (append (match lns [(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 [attrs (copy-block-attrs (quad-attrs line) (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 |# ;; -(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) (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) ;; do trial block insertions (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-leftover-proc (λ (ymax leftover-qs fn-qs) (let loop ([ymax ymax][leftover-qs leftover-qs][fn-qs fn-qs]) diff --git a/quad/quadwriter/param.rkt b/quad/quadwriter/param.rkt index fd188bd2..fe13b0fe 100644 --- a/quad/quadwriter/param.rkt +++ b/quad/quadwriter/param.rkt @@ -17,9 +17,9 @@ (define draw-debug? (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-image? (make-parameter #true)) + (define draw-debug-image? (make-parameter #false)) (define debug-page-width (make-parameter 400)) (define debug-page-height (make-parameter 400)) diff --git a/quad/quadwriter/render.rkt b/quad/quadwriter/render.rkt index 364f61a5..51c25022 100644 --- a/quad/quadwriter/render.rkt +++ b/quad/quadwriter/render.rkt @@ -246,7 +246,7 @@ (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 quad q:column + (define col-quad-prototype (quad-copy column-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))) @@ -276,10 +276,9 @@ (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)))) + (or (eq? sym 'all) + (eq? sym page-side) + (eq? sym (if (= page-num 1) 'first 'rest))))) repeater)) (when (pair? repeaters-for-this-page) (set-quad-elems! page (append repeaters-for-this-page (quad-elems page))))) @@ -337,16 +336,16 @@ (for/list ([repeater (in-list section-repeaters)] #:when (let* ([val (quad-ref repeater :page-repeat)] [sym (string->symbol (string-trim val #px"section\\s"))]) - (memq sym (list* - (if (= page-num 1) 'first 'rest) - page-side - '(section all))))) + (or (eq? sym 'section) + (eq? sym 'all) + (eq? sym page-side) + (eq? sym (if (= page-num 1) 'first 'rest))))) repeater)) (cond [(null? section-repeaters-for-this-page) page] [else (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 (cond @@ -358,11 +357,11 @@ ;; blank page goes at beginning of current section (define page-from-current-section (car section-pages)) (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)] [_ ;; must be 'right ;; 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 [(cons previous-section other-sections) (define previous-section-pages (quad-elems previous-section)) @@ -374,7 +373,7 @@ [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 (quad-copy section-quad q:section [elems section-pages]) ) (cons new-section sections-acc)]) (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))] [page (in-list (quad-elems section))]) page))] + #:when (page-quad? page) ;; 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"))] [col (in-list (quad-elems page))] + #:when (column-quad? 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)) (match (quad-elems line) ;; collapse the filler quad by setting size to 0