From 41a9522e28b3aa1f5e4341646adce25d09213849 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 10 Feb 2020 14:47:05 -0800 Subject: [PATCH] refaction --- quad/quad/base.rkt | 12 +++++++ quad/quad/quad.rkt | 10 ++++++ quad/quadwriter/block.rkt | 5 +-- quad/quadwriter/column.rkt | 55 ++++++++++++++++---------------- quad/quadwriter/debug.rkt | 42 +++++++++++++++++++++++-- quad/quadwriter/line.rkt | 14 +-------- quad/quadwriter/param.rkt | 64 ++++++-------------------------------- quad/quadwriter/render.rkt | 3 +- 8 files changed, 103 insertions(+), 102 deletions(-) create mode 100644 quad/quad/base.rkt diff --git a/quad/quad/base.rkt b/quad/quad/base.rkt new file mode 100644 index 00000000..d8ab042a --- /dev/null +++ b/quad/quad/base.rkt @@ -0,0 +1,12 @@ +#lang racket/base + +(require + "quad.rkt" + "position.rkt" + "param.rkt" + "util.rkt") + +(provide (all-from-out "quad.rkt" + "position.rkt" + "param.rkt" + "util.rkt")) \ No newline at end of file diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 1e2bbb99..a77ded81 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -201,6 +201,16 @@ (define q make-quad) +(define only-prints-in-middle (λ (q sig) (not (memq sig '(start end))))) + +(define/match (from-parent qs [where #f]) + ;; doesn't change any positioning. doesn't depend on state. can happen anytime. + ;; can be repeated without damage. + [((? null?) _) null] + [((cons q rest) where) + (quad-update! q [from-parent (or where (quad-from q))]) + (cons q rest)]) + (module+ test (require racket/port) (define q1 (q #f #\H #\e #\l #\o)) diff --git a/quad/quadwriter/block.rkt b/quad/quadwriter/block.rkt index a0239355..7494e229 100644 --- a/quad/quadwriter/block.rkt +++ b/quad/quadwriter/block.rkt @@ -4,10 +4,7 @@ "log.rkt" "debug.rkt" "struct.rkt" - "line.rkt" - quad/quad - quad/util - quad/position + quad/base pitfall) (provide (all-defined-out)) diff --git a/quad/quadwriter/column.rkt b/quad/quadwriter/column.rkt index 9143fb8c..18f509a5 100644 --- a/quad/quadwriter/column.rkt +++ b/quad/quadwriter/column.rkt @@ -1,15 +1,11 @@ #lang debug racket (require "attrs.rkt" "struct.rkt" - "line.rkt" "block.rkt" - quad/quad - quad/wrap - quad/position) + quad/base + quad/wrap) (provide (all-defined-out)) - - (define q:column (make-quad #:type column-quad #:id 'col @@ -47,7 +43,31 @@ constraint wrapping example https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d9656046b/pdf/directory-require.rkt#L51 |# -;; +;; + + +(define (footnote-start? fnq) (quad-ref fnq :fn-text-start)) + +(define (handle-leftover-footnote ymax leftover-qs fn-qs) + (let loop ([ymax ymax][leftover-qs leftover-qs][fn-qs fn-qs]) + (define ydist (and (pair? fn-qs) (pt-y (size (car fn-qs))))) + ;; take all fn lines that are not footnote-start? + ;; and that fit within ymax remaining + (if (and ydist (not (footnote-start? (car fn-qs))) (<= ydist ymax)) + (loop (- ymax ydist) (cons (car fn-qs) leftover-qs) (cdr fn-qs)) + (values ymax leftover-qs fn-qs)))) + +(define (handle-new-footnote ymax leftover-qs fn-qs fn-ref-q) + (define ydist-fn (and (pair? fn-qs) + (footnote-start? (car fn-qs)) + (pt-y (size (car fn-qs))))) + (define ydist-ref (pt-y (size fn-ref-q))) + ;; only accept the footnote if both the first line of footnote + ;; and the line containing the ref will fit. + (if (and ydist-fn (<= (+ ydist-fn ydist-ref) ymax)) + (values (- ymax ydist-fn) (cons (car fn-qs) leftover-qs) (cdr fn-qs)) + (raise 'boom))) + (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)) @@ -57,7 +77,6 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96 ;; could do it after, but it would require going back inside each col quad ;; which seems overly interdependent, because `insert-blocks` is used to determine break locations. ;; `col-wrap` should emit quads that are complete. - (define (footnote-start? fnq) (quad-ref fnq :fn-text-start)) (define cols (wrap lines vertical-height #:soft-break #true #:hard-break column-break-quad? @@ -67,24 +86,8 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96 (sum-y (insert-blocks (reverse wrap-qs)))) #: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]) - (define ydist (and (pair? fn-qs) (pt-y (size (car fn-qs))))) - ;; take all fn lines that are not footnote-start? - ;; and that fit within ymax remaining - (if (and ydist (not (footnote-start? (car fn-qs))) (<= ydist ymax)) - (loop (- ymax ydist) (cons (car fn-qs) leftover-qs) (cdr fn-qs)) - (values ymax leftover-qs fn-qs)))) - #:footnote-new-proc (λ (ymax leftover-qs fn-qs fn-ref-q) - (define ydist-fn (and (pair? fn-qs) - (footnote-start? (car fn-qs)) - (pt-y (size (car fn-qs))))) - (define ydist-ref (pt-y (size fn-ref-q))) - ;; only accept the footnote if both the first line of footnote - ;; and the line containing the ref will fit. - (if (and ydist-fn (<= (+ ydist-fn ydist-ref) ymax)) - (values (- ymax ydist-fn) (cons (car fn-qs) leftover-qs) (cdr fn-qs)) - (raise 'boom))))) + #:footnote-leftover-proc handle-leftover-footnote + #:footnote-new-proc handle-new-footnote)) (define reversed-fn-lines (from-parent (for/list ([fn-line (in-list (reverse fn-lines))]) ;; position bottom to top, in reverse diff --git a/quad/quadwriter/debug.rkt b/quad/quadwriter/debug.rkt index 5df8fbf6..9821d089 100644 --- a/quad/quadwriter/debug.rkt +++ b/quad/quadwriter/debug.rkt @@ -1,10 +1,46 @@ #lang debug racket -(require "param.rkt" - pitfall +(require pitfall quad/position quad/quad) (provide (all-defined-out)) +(define-for-syntax debug-mode #false) + +(define-syntax (go stx) + (datum->syntax stx + (cond + [debug-mode + '(begin + (define draw-debug? (make-parameter #true)) + (define draw-debug-line? (make-parameter #true)) + (define draw-debug-block? (make-parameter #false)) + (define draw-debug-string? (make-parameter #true)) + (define draw-debug-image? (make-parameter #false)) + + (define debug-page-width (make-parameter 400)) + (define debug-page-height (make-parameter 400)) + (define debug-x-margin (make-parameter 50)) + (define debug-y-margin (make-parameter 50)) + (define debug-column-count (make-parameter 1)) + (define debug-column-gap (make-parameter 36)))] + [else + '(begin + (define draw-debug? (make-parameter #false)) + (define draw-debug-line? (make-parameter #true)) + (define draw-debug-block? (make-parameter #true)) + (define draw-debug-string? (make-parameter #true)) + (define draw-debug-image? (make-parameter #true)) + + (define debug-page-width (make-parameter #f)) + (define debug-page-height (make-parameter #f)) + (define debug-x-margin (make-parameter #f)) + (define debug-y-margin (make-parameter #f)) + (define debug-column-count (make-parameter #f)) + (define debug-column-gap (make-parameter #f)))]))) + + +(go) + (define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"] . _) (define stroke-width 0.5) @@ -22,4 +58,4 @@ (restore doc) (apply rect doc (append (pt+ (quad-origin q)) (map (λ (x) (- x stroke-width)) (size q)))) (stroke doc stroke-color) - (restore doc))) \ No newline at end of file + (restore doc))) diff --git a/quad/quadwriter/line.rkt b/quad/quadwriter/line.rkt index efc7d52c..67f1e7c8 100644 --- a/quad/quadwriter/line.rkt +++ b/quad/quadwriter/line.rkt @@ -6,8 +6,7 @@ "font.rkt" "string.rkt" "attrs.rkt" - quad/position - quad/quad + quad/base quad/wrap sugar/list pitfall @@ -57,7 +56,6 @@ (define (space-quad? q) (equal? (quad-elems q) (list " "))) - (define (hang-punctuation nonspacess) (match nonspacess [(list sublists ... (list prev-qs ... last-q)) @@ -160,16 +158,6 @@ ;; ok to put back absolute quads at end, because it doesn't affect their layout (append other-qs absolute-qs))])])) -(define/match (from-parent qs [where #f]) - ;; doesn't change any positioning. doesn't depend on state. can happen anytime. - ;; can be repeated without damage. - [((? null?) _) null] - [((cons q rest) where) - (quad-update! q [from-parent (or where (quad-from q))]) - (cons q rest)]) - - -(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) (make-quad #:type line-spacer-quad diff --git a/quad/quadwriter/param.rkt b/quad/quadwriter/param.rkt index fe13b0fe..7132d5b1 100644 --- a/quad/quadwriter/param.rkt +++ b/quad/quadwriter/param.rkt @@ -1,58 +1,12 @@ #lang debug racket -(define-for-syntax debug-mode #false) - -(define-syntax (go stx) - (syntax-case stx () - [_ - debug-mode - #'(begin - (provide (all-defined-out)) - (define current-doc (make-parameter #false)) - (define current-pdf (make-parameter #false)) - (define current-line-wrap (make-parameter #f)) ; because kp is slow and maybe we want to disable for "draft" mode - (define section-pages-used (make-parameter 0)) - (define current-named-quads (make-parameter #false)) - - (define quadwriter-test-mode (make-parameter #f)) ; used during rackunit to suppress nondeterministic elements, like timestamp in header - - (define draw-debug? (make-parameter #true)) - (define draw-debug-line? (make-parameter #true)) - (define draw-debug-block? (make-parameter #false)) - (define draw-debug-string? (make-parameter #true)) - (define draw-debug-image? (make-parameter #false)) - - (define debug-page-width (make-parameter 400)) - (define debug-page-height (make-parameter 400)) - (define debug-x-margin (make-parameter 50)) - (define debug-y-margin (make-parameter 50)) - (define debug-column-count (make-parameter 1)) - (define debug-column-gap (make-parameter 36)) - (define zoom-factor (make-parameter 1)) - (define log-clipping? (make-parameter 'warn)))] - [_ - #'(begin - (provide (all-defined-out)) - (define current-doc (make-parameter #false)) - (define current-pdf (make-parameter #false)) - (define current-line-wrap (make-parameter #f)) - (define section-pages-used (make-parameter 0)) - (define current-named-quads (make-parameter #false)) +(provide (all-defined-out)) +(define current-doc (make-parameter #false)) +(define current-pdf (make-parameter #false)) +(define current-line-wrap (make-parameter #f)) ; because kp is slow and maybe we want to disable for "draft" mode +(define section-pages-used (make-parameter 0)) +(define current-named-quads (make-parameter #false)) - (define quadwriter-test-mode (make-parameter #f)) - - (define draw-debug? (make-parameter #false)) - (define draw-debug-line? (make-parameter #true)) - (define draw-debug-block? (make-parameter #true)) - (define draw-debug-string? (make-parameter #true)) - (define draw-debug-image? (make-parameter #true)) - - (define debug-page-width (make-parameter #f)) - (define debug-page-height (make-parameter #f)) - (define debug-x-margin (make-parameter #f)) - (define debug-y-margin (make-parameter #f)) - (define debug-column-count (make-parameter #f)) - (define debug-column-gap (make-parameter #f)) - (define zoom-factor (make-parameter 1)) - (define log-clipping? (make-parameter 'warn)))])) +(define quadwriter-test-mode (make-parameter #f)) ; used during rackunit to suppress nondeterministic elements, like timestamp in header -(go) \ No newline at end of file +(define zoom-factor (make-parameter 1)) +(define log-clipping? (make-parameter 'warn)) \ No newline at end of file diff --git a/quad/quadwriter/render.rkt b/quad/quadwriter/render.rkt index d9444e48..e3e6bfe2 100644 --- a/quad/quadwriter/render.rkt +++ b/quad/quadwriter/render.rkt @@ -27,7 +27,8 @@ "section.rkt" "doc.rkt" "column.rkt" - "keep.rkt") + "keep.rkt" + "debug.rkt") (provide (all-defined-out))