From b507a26a4b02ca3c42810bc0c564e277eaacafbc Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 10 Feb 2020 14:22:46 -0800 Subject: [PATCH] refac layout module into pieces --- quad/quad/quad.rkt | 1 + quad/quadwriter/block.rkt | 98 ++++ quad/quadwriter/break.rkt | 51 ++ quad/quadwriter/column.rkt | 99 ++++ quad/quadwriter/core.rkt | 26 +- quad/quadwriter/debug.rkt | 25 + quad/quadwriter/doc.rkt | 10 + quad/quadwriter/draw.rkt | 38 ++ quad/quadwriter/image.rkt | 57 +++ quad/quadwriter/keep.rkt | 48 ++ quad/quadwriter/layout.rkt | 934 ------------------------------------ quad/quadwriter/line.rkt | 315 ++++++++++++ quad/quadwriter/page.rkt | 110 +++++ quad/quadwriter/para.rkt | 31 ++ quad/quadwriter/render.rkt | 29 +- quad/quadwriter/section.rkt | 7 + quad/quadwriter/string.rkt | 124 +++++ quad/quadwriter/struct.rkt | 34 ++ 18 files changed, 1078 insertions(+), 959 deletions(-) create mode 100644 quad/quadwriter/block.rkt create mode 100644 quad/quadwriter/break.rkt create mode 100644 quad/quadwriter/column.rkt create mode 100644 quad/quadwriter/debug.rkt create mode 100644 quad/quadwriter/doc.rkt create mode 100644 quad/quadwriter/draw.rkt create mode 100644 quad/quadwriter/image.rkt create mode 100644 quad/quadwriter/keep.rkt delete mode 100644 quad/quadwriter/layout.rkt create mode 100644 quad/quadwriter/line.rkt create mode 100644 quad/quadwriter/page.rkt create mode 100644 quad/quadwriter/para.rkt create mode 100644 quad/quadwriter/section.rkt create mode 100644 quad/quadwriter/string.rkt create mode 100644 quad/quadwriter/struct.rkt diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index b77631c3..1e2bbb99 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -191,6 +191,7 @@ (define-syntax (define-quad stx) (syntax-case stx () + [(M ID) #'(M ID quad)] [(_ ID SUPER) (with-syntax ([MAKE-ID (format-id #'ID "make-~a" (syntax-e #'ID))]) #'(begin diff --git a/quad/quadwriter/block.rkt b/quad/quadwriter/block.rkt new file mode 100644 index 00000000..a0239355 --- /dev/null +++ b/quad/quadwriter/block.rkt @@ -0,0 +1,98 @@ +#lang debug racket +(require "attrs.rkt" + "param.rkt" + "log.rkt" + "debug.rkt" + "struct.rkt" + "line.rkt" + quad/quad + quad/util + quad/position + pitfall) +(provide (all-defined-out)) + + +(define ((block-draw-start first-line) q doc) + ;; adjust drawing coordinates for border inset + (match-define (list bil bit bir bib) + (for/list ([k (in-list (list :border-inset-left :border-inset-top :border-inset-right :border-inset-bottom))]) + (quad-ref first-line k 0))) + (match-define (list left top) (pt+ (quad-origin q) (list bil bit))) + (match-define (list width height) (pt- (size q) (list (+ bil bir) (+ bit bib)))) + ;; fill rect + (let ([bgc (quad-ref first-line :background-color)]) + (when bgc + (rect doc left top width height) + (fill doc bgc))) + ;; draw border + (match-define (list bw-left bw-top bw-right bw-bottom) + (map (λ (k) (max 0 (quad-ref first-line k 0))) + (list + :border-width-left + :border-width-top + :border-width-right + :border-width-bottom))) + ;; adjust start and end points based on adjacent border width + ;; so all borders overlap rectangularly + (define (half x) (/ x 2.0)) + (define right (+ left width)) + (define bottom (+ top height)) + (define (box-side x1 y1 x2 y2 color stroke-width) + (when (positive? stroke-width) + (move-to doc x1 y1) + (line-to doc x2 y2) + (stroke doc (or color "black") stroke-width))) + (box-side (- left (half bw-left)) top (+ right (half bw-right)) top + (quad-ref first-line :border-color-top) bw-top) + (box-side right (- top (half bw-top)) right (+ bottom (half bw-bottom)) + (quad-ref first-line :border-color-right) bw-right) + (box-side (+ right (half bw-right)) bottom (- left (half bw-left)) bottom + (quad-ref first-line :border-color-bottom) bw-bottom) + (box-side left (+ bottom (half bw-bottom)) left (- top (half bw-top)) + (quad-ref first-line :border-color-left) bw-left) + (case (quad-ref first-line :block-clip) + [(#true) + (when (eq? (log-clipping?) 'warn) + (for ([line (in-list (quad-elems q))]) + (define line-width (pt-x (size line))) + (define line-elem-width (sum-x (quad-elems line))) + (when (< line-width line-elem-width) + (define error-str (apply string-append (for/list ([q (in-list (quad-elems line))]) + (match (quad-elems q) + [(list (? string? str)) str] + [_ ""])))) + (log-quadwriter-warning (format "clipping overfull line: ~v" error-str))))) + (save doc) + (rect doc left top width height) + (clip doc)])) + +(define ((block-draw-end first-line) q doc) + (case (quad-ref first-line :block-clip) + [(#true) (restore doc)]) + (when (draw-debug-block?) + (draw-debug q doc "#6c6" "#9c9"))) + +(define (insert-blocks lines) + (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x :display)) lines)) + (append* (for/list ([line-group (in-list groups-of-lines)]) + (if (quad-ref (car line-group) :display) + (list (lines->block line-group)) + line-group)))) + +(define (lines->block lines) + (match lines + [(cons 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))])) \ No newline at end of file diff --git a/quad/quadwriter/break.rkt b/quad/quadwriter/break.rkt new file mode 100644 index 00000000..4f9e1dc2 --- /dev/null +++ b/quad/quadwriter/break.rkt @@ -0,0 +1,51 @@ +#lang debug racket +(require "struct.rkt" + "attrs.rkt" + quad/quad) +(provide (all-defined-out)) + + +(define (convert-break-quad q) + ;; this is verbose & ugly because `struct-copy` is a macro + ;; we want to use break prototypes but also preserve their type + (match (quad-ref q :break) + ["para" (quad-copy para-break-quad q:para-break [attrs (quad-attrs q)])] + ["line" (quad-copy line-break-quad q:line-break [attrs (quad-attrs q)])] + ["page" (quad-copy page-break-quad q:page-break [attrs (quad-attrs q)])] + ["column" (quad-copy column-break-quad q:column-break [attrs (quad-attrs q)])] + ["hr" (quad-copy hr-break-quad q:hr-break [attrs (quad-attrs q)])] + ["section" (quad-copy section-break-quad q:section-break [attrs (quad-attrs q)])] + [_ q])) + + +(module+ test + (require rackunit quad/qexpr) + (check-equal? (quad-ref (convert-break-quad (qexpr->quad '(q ((break "page") (foo "bar"))))) 'foo) "bar")) + + +(define q:line-break (make-line-break-quad #:printable #f + #:id 'line-break)) +(define q:para-break (make-para-break-quad #:printable #f + #:id 'para-break)) +(define q:hr-break (make-hr-break-quad #:printable #t + #:id 'hr-break)) +(define q:column-break (make-column-break-quad #:printable #f + #:id 'column-break)) + +(define q:page-break (make-page-break-quad #:printable #f + #:id 'page-break)) + +(define q:section-break (make-section-break-quad #:printable #f + #:id 'section-break)) + +(define para-break '(q ((break "para")))) +(define line-break '(q ((break "line")))) +(define page-break '(q ((break "page")))) +(define column-break '(q ((break "column")))) +(define hr-break '(q ((break "hr")))) +(define section-break '(q ((break "section")))) + +(module+ test + (require rackunit quad/atomize) + (check-true (line-break-quad? (second (quad-elems (q "foo" q:page-break "bar"))))) + (check-true (line-break-quad? (second (atomize (q "foo" q:page-break "bar")))))) diff --git a/quad/quadwriter/column.rkt b/quad/quadwriter/column.rkt new file mode 100644 index 00000000..9143fb8c --- /dev/null +++ b/quad/quadwriter/column.rkt @@ -0,0 +1,99 @@ +#lang debug racket +(require "attrs.rkt" + "struct.rkt" + "line.rkt" + "block.rkt" + quad/quad + quad/wrap + quad/position) +(provide (all-defined-out)) + + + +(define q:column (make-quad + #:type column-quad + #:id 'col + #:from 'ne + #:to 'nw)) + +(define q:column-spacer (make-quad + #:type column-spacer-quad + #:from 'ne + #:to 'nw + #:printable only-prints-in-middle)) + +(define ((column-wrap-finish col-quad) lns q0 ending-q idx [reversed-fn-lines null]) + (define fn-lines + (from-parent (for/list ([fn-line (in-list reversed-fn-lines)]) + ;; position bottom to top, in reverse + (quad-update! fn-line + [from 'nw] + [to 'sw])) 'sw)) + + (append + (match lns + [(cons line _) + (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)))] + [elems (append (from-parent (insert-blocks lns) 'nw) fn-lines)]))] + [_ null]) + (match ending-q + [(? page-break-quad? page-break) (list page-break)] ; hard page (or section) break + [_ null]))) + +#| +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 [col-quad-proto q:column]) + (unless (positive? vertical-height) + (raise-argument-error 'column-wrap "positive number" vertical-height)) + + ;; on timing of `insert-blocks`: + ;; can't do it before because it depends on where columns are broken. + ;; 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? + #:no-break (λ (q) (quad-ref q :no-colbr)) ; cooperates with make-nobreak + #:distance (λ (q dist-so-far wrap-qs) + ;; do trial block insertions + (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))))) + (define reversed-fn-lines + (from-parent (for/list ([fn-line (in-list (reverse fn-lines))]) + ;; position bottom to top, in reverse + (quad-update! fn-line + [from 'nw] + [to 'sw])) 'sw)) + (when (pair? cols) + (quad-update! (car cols) + [elems (append (quad-elems (car cols)) reversed-fn-lines)])) + (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)) diff --git a/quad/quadwriter/core.rkt b/quad/quadwriter/core.rkt index 93d77d42..357dbc7e 100644 --- a/quad/quadwriter/core.rkt +++ b/quad/quadwriter/core.rkt @@ -1,23 +1,5 @@ #lang debug racket/base -(require "layout.rkt" - "render.rkt" - "param.rkt") -(provide render-pdf - para-break - line-break - page-break - column-break - hr-break - section-break - q:para-break - q:line-break - q:page-break - q:hr-break - (all-from-out "param.rkt")) - -(define para-break '(q ((break "para")))) -(define line-break '(q ((break "line")))) -(define page-break '(q ((break "page")))) -(define column-break '(q ((break "column")))) -(define hr-break '(q ((break "hr")))) -(define section-break '(q ((break "section")))) +(require "render.rkt" + "param.rkt" + "break.rkt") +(provide render-pdf (all-from-out "param.rkt" "break.rkt")) diff --git a/quad/quadwriter/debug.rkt b/quad/quadwriter/debug.rkt new file mode 100644 index 00000000..5df8fbf6 --- /dev/null +++ b/quad/quadwriter/debug.rkt @@ -0,0 +1,25 @@ +#lang debug racket +(require "param.rkt" + pitfall + quad/position + quad/quad) +(provide (all-defined-out)) + + +(define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"] . _) + (define stroke-width 0.5) + (when (draw-debug?) + (save doc) + ;; draw layout box + (line-width doc stroke-width) + ; subtracting stroke-width keeps adjacent boxes from overlapping + (save doc) + (apply rect doc (append (pt+ (quad-origin q)) (map (λ (x) (- x stroke-width)) (size q)))) + (clip doc) + (define pt (to-point q)) + (circle doc (pt-x pt) (pt-y pt) (+ 3 stroke-width)) + (fill doc fill-color) + (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 diff --git a/quad/quadwriter/doc.rkt b/quad/quadwriter/doc.rkt new file mode 100644 index 00000000..d6707b4f --- /dev/null +++ b/quad/quadwriter/doc.rkt @@ -0,0 +1,10 @@ +#lang debug racket +(require "struct.rkt" + quad/quad + pitfall) +(provide (all-defined-out)) + +(define q:doc (make-quad + #:type doc-quad + #:draw-start (λ (q doc) (start-doc doc)) + #:draw-end (λ (q doc) (end-doc doc)))) diff --git a/quad/quadwriter/draw.rkt b/quad/quadwriter/draw.rkt new file mode 100644 index 00000000..5d5e79ab --- /dev/null +++ b/quad/quadwriter/draw.rkt @@ -0,0 +1,38 @@ +#lang debug racket +(require "struct.rkt" + "string.rkt" + "debug.rkt" + "param.rkt" + "attrs.rkt" + quad/quad + quad/position + pitfall) +(provide (all-defined-out)) + +(define (convert-draw-quad q) + (quad-copy draw-quad q:draw + [attrs (quad-attrs q)] + [size (pt (quad-ref q :width 0) (quad-ref q :height 0))])) + +(define q:draw (make-quad #:type draw-quad + #:from 'bo + #:to 'bi + #:draw (λ (q doc) + (save doc) + (apply translate doc (if (equal? (quad-ref q :position) "absolute") + (list 0 0) + (quad-origin q))) + (match (quad-ref q :draw) + ["line" + (define x0 (quad-ref q :x 0)) + (define y0 (quad-ref q :y 0)) + (move-to doc x0 y0) + (line-to doc (quad-ref q :x2 x0) (quad-ref q :y2 y0)) + (line-width doc (quad-ref q :stroke 1)) + (stroke doc (quad-ref q :color "black"))] + ["text" (move-to doc 0 0) + (q:string-draw q doc + #:origin (pt (quad-ref q :x 0) (quad-ref q :y 0)) + #:text (quad-ref q :text))] + [_ (void)]) + (restore doc)))) \ No newline at end of file diff --git a/quad/quadwriter/image.rkt b/quad/quadwriter/image.rkt new file mode 100644 index 00000000..671f181a --- /dev/null +++ b/quad/quadwriter/image.rkt @@ -0,0 +1,57 @@ +#lang debug racket +(require "struct.rkt" + "attrs.rkt" + "param.rkt" + "debug.rkt" + quad/position + pitfall + quad/quad) +(provide (all-defined-out)) + + + +(define (convert-image-quad q) + (define path-string (quad-ref q :image-file)) + (unless (file-exists? path-string) + (raise-argument-error 'create-image-quad "image path that exists" path-string)) + (define img-obj (open-image (current-pdf) path-string)) + (define img-width ($img-width img-obj)) + (define img-height ($img-height img-obj)) + (match-define (list layout-width layout-height) + (match (list (quad-ref q :image-width) (quad-ref q :image-height)) + [(list (? number? w) (? number? h)) (list w h)] + [(list #false (? number? h)) + (define ratio (/ h img-height)) + (list (* ratio img-width) h)] + [(list (? number? w) #false) + (define ratio (/ w img-width)) + (list w (* ratio img-height))] + [(list #false #false) (list img-width img-height)])) + (quad-copy image-quad q:image + [attrs (let ([h (hash-copy (quad-attrs q))]) + ;; defeat 'bi 'bo positioning by removing font reference + (hash-set! h font-path-key #false) + ;; save the img-obj for later + (hash-set! h :image-object img-obj) + h)] + [size (pt layout-width layout-height)])) + +(define (q:image-draw q doc) + (define img (quad-ref q :image-object)) + (match-define (list x y) (quad-origin q)) + (match-define (list w h) (size q)) + (image doc img x y + #:width w + #:height h)) + +(define (q:image-draw-end q doc) + (when (draw-debug-image?) + (draw-debug q doc "orange" "orange"))) + +(define q:image (q #:type image-quad + #:from 'bo + #:to 'bi + #:id 'image + #:printable #true + #:draw q:image-draw + #:draw-end q:image-draw-end)) \ No newline at end of file diff --git a/quad/quadwriter/keep.rkt b/quad/quadwriter/keep.rkt new file mode 100644 index 00000000..415d6819 --- /dev/null +++ b/quad/quadwriter/keep.rkt @@ -0,0 +1,48 @@ +#lang debug racket +(require quad/quad + quad/util + "attrs.rkt" + "struct.rkt") +(provide (all-defined-out)) + + + +(define (make-nobreak! q) (quad-set! q :no-colbr #true)) ; scooperates with col-wrap + +(define (do-keep-with-next! reversed-lines) + ;; paints nobreak onto the kwn line itself, + ;; and any line spacers that follow (could be one or more) + ;; (we are iterating backward, so the geometrically previous ln follows the spacer) + (define (is-kwn-line? ln) (quad-ref ln :keep-with-next)) + (let loop ([lines (reverse reversed-lines)]) + (unless (null? lines) + (match lines + [(list* (? is-kwn-line? kwn) (? line-spacer-quad? lsqs) ..1 rest) + (for-each make-nobreak! (cons kwn lsqs)) + (loop rest)] + [(cons ln rest) (loop rest)])))) + +(define (apply-keeps lines) + (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x :display)) lines)) + (for*/fold ([reversed-lines null] + #:result (begin + (do-keep-with-next! reversed-lines) + (reverse reversed-lines))) + ([group (in-list groups-of-lines)] + [group-len (in-value (length group))] + [(ln idx0) (in-indexed group)]) + (define idx (add1 idx0)) + ;; always catch last line of block in this case + ;; so later cases are guaranteed to have earlier lines. + (define keep-first (quad-ref ln :keep-first-lines)) + (define keep-last (quad-ref ln :keep-last-lines)) + (unless (eq? idx group-len) + (when (or + ;; if we have keep all we can skip :keep-first and :keep-last cases + (or (equal? keep-first "all") (equal? keep-last "all")) + ;; to keep n lines, we only paint the first n - 1 + ;; (because each nobr line sticks to the next) + (and (number? keep-first) (< idx keep-first)) + (and (number? keep-last) (< (- group-len keep-last) idx))) + (make-nobreak! ln))) + (cons ln reversed-lines))) \ No newline at end of file diff --git a/quad/quadwriter/layout.rkt b/quad/quadwriter/layout.rkt deleted file mode 100644 index e96c8b3e..00000000 --- a/quad/quadwriter/layout.rkt +++ /dev/null @@ -1,934 +0,0 @@ -#lang debug racket/base -(require (for-syntax racket/base racket/syntax) - racket/promise - racket/match - racket/list - sugar/list - txexpr/base - racket/date - pitfall - quad - racket/unsafe/ops - "attrs.rkt" - "param.rkt" - "font.rkt" - "log.rkt") -(provide (all-defined-out)) - - -(define-quad break-quad quad) - -(define-quad line-break-quad break-quad) -(define q:line-break (make-line-break-quad #:printable #f - #:id 'line-break)) -(define-quad para-break-quad line-break-quad) -(define q:para-break (make-para-break-quad #:printable #f - #:id 'para-break)) -(define-quad hr-break-quad line-break-quad) -(define q:hr-break (make-hr-break-quad #:printable #t - #:id 'hr-break)) -(define-quad column-break-quad line-break-quad) -(define q:column-break (make-column-break-quad #:printable #f - #:id 'column-break)) -(define-quad page-break-quad column-break-quad) -(define q:page-break (make-page-break-quad #:printable #f - #:id 'page-break)) - -(define-quad section-break-quad page-break-quad) -(define q:section-break (make-section-break-quad #:printable #f - #:id 'section-break)) - -(define-quad string-quad quad) - -(define (q:string-draw q doc - #:origin [origin-in #f] - #:text [str-in #f]) - (match (or str-in (and (pair? (quad-elems q)) (unsafe-car (quad-elems q)))) - [#false (void)] - [str - (font doc (path->string (quad-ref q font-path-key default-font-face))) - (font-size doc (quad-ref q :font-size default-font-size)) - (fill-color doc (quad-ref q :font-color default-font-color)) - (match-define (list x y) (or origin-in (quad-origin q))) - (define tracking (quad-ref q :font-tracking 0)) - ;; we adjust x by half tracking because by convention, string quads have half tracking at beginning & end - ;; whereas PDF drawing only puts tracking between the glyphs. - (text doc str (+ x (/ tracking 2.0)) (- y (quad-ref q :font-baseline-shift 0)) - #:tracking tracking - #:bg (quad-ref q :bg) - #:features (quad-ref q :font-features default-font-features) - #:link (quad-ref q :link))])) - -(define (q:string-draw-end q doc) - (when (draw-debug-string?) - (draw-debug q doc "#99f" "#ccf"))) - -(define (q:string-printable? q [sig #f]) - ;; printable unless single space, which is not printable at start or end - (match (quad-elems q) - [(cons elem _) - (case elem - [(" " #\space) (not (memq sig '(start end)))] - [else #true])] - [_ #true])) - -(define q:string (q #:type string-quad - #:from 'bo - #:to 'bi - #:id 'str - #:printable q:string-printable? - #:draw q:string-draw - #:draw-end q:string-draw-end)) - -(define-quad image-quad quad) - -(define (q:image-draw q doc) - (define img (quad-ref q :image-object)) - (match-define (list x y) (quad-origin q)) - (match-define (list w h) (size q)) - (image doc img x y - #:width w - #:height h)) - -(define (q:image-draw-end q doc) - (when (draw-debug-image?) - (draw-debug q doc "orange" "orange"))) - -(define q:image (q #:type image-quad - #:from 'bo - #:to 'bi - #:id 'image - #:printable #true - #:draw q:image-draw - #:draw-end q:image-draw-end)) - -(define soft-hyphen-string "\u00AD") - -(define (make-size-promise-for-string q [str-arg #f]) - ;; we know sensible defaults for all text properties have been set up during atomization. - (delay - (define q-string-width - (let ([str (cond - [str-arg] - [else (match (quad-elems q) - [(cons q _) q] - [_ #false])])]) - (cond - [(positive? (string-length str)) - (define pdf (current-pdf)) - (font-size pdf (quad-ref q :font-size)) - (font pdf (path->string (quad-ref q font-path-key))) - (define tracking-val (quad-ref q :font-tracking 0)) - (cond - [(equal? str soft-hyphen-string) tracking-val] - [else ;; `string-width` only applies tracking between glyphs. - ;; we add an extra tracking-val because we want to count tracking on every glyph. - ;; because at this stage, we don't know whether the quad will be freestanding or adjacent to another - ;; probably adjacent. And if so, it should have half tracking on the ends, full tracking in between - (+ (string-width pdf str - #:tracking tracking-val - #:features (quad-ref q :font-features)) - tracking-val)])] - [else 0]))) - (list q-string-width (quad-ref q :line-height)))) - -(define (convert-break-quad q) - ;; this is verbose & ugly because `struct-copy` is a macro - ;; we want to use break prototypes but also preserve their type - (match (quad-ref q :break) - ["para" (quad-copy para-break-quad q:para-break [attrs (quad-attrs q)])] - ["line" (quad-copy line-break-quad q:line-break [attrs (quad-attrs q)])] - ["page" (quad-copy page-break-quad q:page-break [attrs (quad-attrs q)])] - ["column" (quad-copy column-break-quad q:column-break [attrs (quad-attrs q)])] - ["hr" (quad-copy hr-break-quad q:hr-break [attrs (quad-attrs q)])] - ["section" (quad-copy section-break-quad q:section-break [attrs (quad-attrs q)])] - [_ q])) - -(module+ test - (check-equal? (quad-ref (convert-break-quad (qexpr->quad '(q ((break "page") (foo "bar"))))) 'foo) "bar")) - -(define-quad draw-quad quad) -(define q:draw (q #:type draw-quad - #:from 'bo - #:to 'bi)) - -(define (convert-draw-quad q) - (quad-copy draw-quad q:draw - [attrs (quad-attrs q)] - [draw (λ (q doc) - (save doc) - (apply translate doc (if (equal? (quad-ref q :position) "absolute") - (list 0 0) - (quad-origin q))) - (match (quad-ref q :draw) - ["line" - (define x0 (quad-ref q :x 0)) - (define y0 (quad-ref q :y 0)) - (move-to doc x0 y0) - (line-to doc (quad-ref q :x2 x0) (quad-ref q :y2 y0)) - (line-width doc (quad-ref q :stroke 1)) - (stroke doc (quad-ref q :color "black"))] - ["text" (move-to doc 0 0) - (q:string-draw q doc - #:origin (pt (quad-ref q :x 0) (quad-ref q :y 0)) - #:text (quad-ref q :text))] - [_ (void)]) - (restore doc))] - [size (pt (quad-ref q :width 0) (quad-ref q :height 0))])) - -(define (convert-image-quad q) - (define path-string (quad-ref q :image-file)) - (unless (file-exists? path-string) - (raise-argument-error 'create-image-quad "image path that exists" path-string)) - (define img-obj (open-image (current-pdf) path-string)) - (define img-width ($img-width img-obj)) - (define img-height ($img-height img-obj)) - (match-define (list layout-width layout-height) - (match (list (quad-ref q :image-width) (quad-ref q :image-height)) - [(list (? number? w) (? number? h)) (list w h)] - [(list #false (? number? h)) - (define ratio (/ h img-height)) - (list (* ratio img-width) h)] - [(list (? number? w) #false) - (define ratio (/ w img-width)) - (list w (* ratio img-height))] - [(list #false #false) (list img-width img-height)])) - (quad-copy image-quad q:image - [attrs (let ([h (hash-copy (quad-attrs q))]) - ;; defeat 'bi 'bo positioning by removing font reference - (hash-set! h font-path-key #false) - ;; save the img-obj for later - (hash-set! h :image-object img-obj) - h)] - [size (pt layout-width layout-height)])) - -(define (convert-string-quad q) - ;; need to handle casing here so that it's reflected in subsequent sizing ops - (define cased-str (match (quad-elems q) - [(cons str _) - (define proc (match (quad-ref q :font-case) - [(or "upper" "uppercase") string-upcase] - [(or "lower" "lowercase" "down" "downcase") string-downcase] - [(or "title" "titlecase") string-titlecase] - [_ values])) - (proc str)] - [_ ""])) ; a string quad should always contain a string - (quad-copy string-quad q:string - [attrs (let ([attrs (quad-attrs q)]) - (hash-ref! attrs :font-size default-font-size) - attrs)] - [elems (list cased-str)] - [size (make-size-promise-for-string q cased-str)])) - -(define (generic->typed-quad q) - ;; replaces quads representing certain things - ;; with special typed quads representing those things. - ;; Because typed quads have their own predicates, - ;; it's faster to find them in wrapping operations - (define converter (cond - [(quad-ref q :break) convert-break-quad] - [(quad-ref q :draw) convert-draw-quad] - [(quad-ref q :image-file) convert-image-quad] - [else convert-string-quad])) - (converter q)) - -(define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"] . _) - (define stroke-width 0.5) - (when (draw-debug?) - (save doc) - ;; draw layout box - (line-width doc stroke-width) - ; subtracting stroke-width keeps adjacent boxes from overlapping - (save doc) - (apply rect doc (append (pt+ (quad-origin q)) (map (λ (x) (- x stroke-width)) (size q)))) - (clip doc) - (define pt (to-point q)) - (circle doc (pt-x pt) (pt-y pt) (+ 3 stroke-width)) - (fill doc fill-color) - (restore doc) - (apply rect doc (append (pt+ (quad-origin q)) (map (λ (x) (- x stroke-width)) (size q)))) - (stroke doc stroke-color) - (restore doc))) - - -(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) - (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))) - -(define (soft-break-for-line? q) - (and (pair? (quad-elems q)) - (member (unsafe-car (quad-elems q)) softies))) - -(define (consolidate-runs pcs) - (let loop ([runs empty][pcs pcs]) - (match pcs - [(cons (? string-quad? strq) rest) - (define-values (run-pcs rest) (splitf-at pcs (λ (p) (same-run? strq p)))) - ;; run-pcs has at least one element (strq) - ;; and the other members are part of the same run. - ;; meaning, they share the same formatting, including character tracking. - - ;; we add a tracking adjustment because it only "appears" - ;; once characters are consolidated - (define tracking-adjustment - (* (sub1 (length run-pcs)) (quad-ref (car run-pcs) :font-tracking 0))) - (define new-run - (quad-copy string-quad q:string - [attrs (quad-attrs strq)] - [elems (merge-adjacent-strings (apply append (map quad-elems run-pcs)))] - [size (delay (pt (sum-x run-pcs) (pt-y (size strq))))])) - (loop (cons new-run runs) rest)] - [(cons first rest) (loop (cons first runs) rest)] - [_ (reverse runs)]))) - -(define (render-hyphen qs ending-q) - ;; naive handling of soft hyphen: - ;; if soft hyphen cause the break, then append a printing hyphen to the end of the run. - ;; this assumes that there is room for the hyphen on the line - ;; and does not take into account hyphen-break transformations found in other languages. - ;; However we do want the hyphen joined into the string so the final shaping / positioning is correct - ;; for instance, kerning between last letter and hyphen. - (match (and ending-q (equal? (quad-elems ending-q) '("\u00AD")) qs) - [(list head ... last-q) - (define str (car (quad-elems last-q))) - (define str+hyphen (string-append str "-")) - (append head - (list (quad-update! last-q - [elems (list str+hyphen)] - [size (make-size-promise-for-string last-q str+hyphen)])))] - [_ qs])) - - -(module+ test - (require rackunit) - (check-true (line-break-quad? (second (quad-elems (q "foo" q:page-break "bar"))))) - (check-true (line-break-quad? (second (atomize (q "foo" q:page-break "bar")))))) - -(define-quad filler-quad quad) - -(define (space-quad? q) (equal? (quad-elems q) (list " "))) - -(define (hang-punctuation nonspacess) - (match nonspacess - [(list sublists ... (list prev-qs ... last-q)) - #:when (pair? (quad-elems last-q)) - (match (regexp-match #rx"[.,:;’-]$" (car (quad-elems last-q))) - [#false nonspacess] - [last-char-str - (define hanger-q (quad-copy string-quad last-q - [elems null] - [size (let ([p (make-size-promise-for-string last-q (car last-char-str))]) - (delay - (match-define (list x y) (force p)) - (pt (- x) y)))])) - (define last-sublist (append prev-qs (list last-q hanger-q))) - (append sublists (list last-sublist))])] - [_ nonspacess])) - -(define (sum-sum-x qss) - (for/sum ([qs (in-list qss)]) - (sum-x qs))) - -(define (tracking-adjustment q) - (match q - [(? string-quad?) (/ (quad-ref q :font-tracking 0) 2.0)] - [_ 0])) - -(define (fill-line-wrap all-qs line-prototype last-line-in-paragraph?) - ;; happens during the finish of a line wrap, before consolidation of runs - (unless (pair? all-qs) - (raise-argument-error 'fill-line-wrap "nonempty list of quads" all-qs)) - - ;; remove absolute position quads because they don't affect line layout - (define-values (absolute-qs qs) (partition (λ (q) (equal? (quad-ref q :position) "absolute")) all-qs)) - - (match-define (and (cons q-first other-qs) (list _ ... q-last)) qs) - (define align-value (quad-ref q-first :line-align "left")) - - ;; words may still be in hyphenated fragments - ;; (though soft hyphens would have been removed) - ;; so group them (but no need to consolidate — that happens elsewhere) - (define-values (spacess nonspacess) (partition* space-quad? qs)) - (match (length nonspacess) - [1 #:when (equal? align-value "justify") qs] ; can't justify single word - [nonspacess-count - (match-define (list line-prototype-width line-prototype-height) (quad-size line-prototype)) - (define hung-nonspacess (hang-punctuation nonspacess)) - (define left-tracking-adjustment (tracking-adjustment q-first)) - (define right-tracking-adjustment (tracking-adjustment q-last)) - (define nonspace-total-width - (- (sum-sum-x hung-nonspacess) left-tracking-adjustment right-tracking-adjustment)) - (define space-total-width (sum-sum-x spacess)) - (define empty-hspace (- line-prototype-width - (quad-ref q-first :inset-left 0) - nonspace-total-width - (quad-ref q-first :inset-right 0))) - - (define (make-left-edge-filler [width 0]) - (make-quad #:type filler-quad - #:id 'line-filler - #:from-parent (quad-from-parent q-first) - #:from 'bo - #:to 'bi - #:shift (pt (- left-tracking-adjustment) 0) - #:size (pt width 0) - #:attrs (quad-attrs q-first))) - - (cond - [(or - (and (equal? align-value "justify") (or (not last-line-in-paragraph?) - ;; don't justify the last line in a paragraph - ;; unless empty space is less than 17% of width (an arbitrary visual threshold) - (< (/ empty-hspace line-prototype-width 1.0) .17))) - (let ([line-overfull? (negative? (- empty-hspace space-total-width))]) - ;; force justification upon overfull lines, - ;; which amounts to shrinking the word spaces till the line fits - (and line-overfull? (> nonspacess-count 1)))) - (define justified-space-width (/ empty-hspace (sub1 nonspacess-count))) - (cons (make-left-edge-filler) - (apply append (add-between hung-nonspacess (list (make-quad - #:from 'bo - #:to 'bi - #:draw-end q:string-draw-end - #:size (pt justified-space-width line-prototype-height))))))] - [else - (define space-multiplier (match align-value - ["center" 0.5] - ;; fill inner & outer as if they were right, - ;; they will be corrected later, when pagination is known. - [(or "right" "inner" "outer") 1] - ;; "left" and "justify" are handled here - [_ 0])) - ;; subtact space-width because that appears between words - ;; we only care about redistributing the space on the ends - (define end-hspace (- empty-hspace space-total-width)) - ;; make filler a leading quad, not a parent / grouping quad, - ;; so that elements can still be reached by consolidate-runs - (list* (make-left-edge-filler (* end-hspace space-multiplier)) - (quad-update! q-first [from-parent #f]) - ;; ok to put back absolute quads at end, because it doesn't affect their layout - (append other-qs absolute-qs))])])) - -(define-quad offsetter-quad quad) - -(define (hr-draw dq doc) - (match-define (list left top) (quad-origin dq)) - (match-define (list right bottom) (size dq)) - (save doc) - (translate doc left (+ top (/ bottom 2.0))) - (move-to doc 0 0) - (line-to doc right 0) - (line-width doc 0.5) - (stroke doc "black") - (restore doc)) - -(define (make-hr-quad line-q) - (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 - ;; remove unused soft hyphens so they don't affect final shaping - (define wrap-qs-printing (for/list ([wq (in-list wrap-qs)] - #:unless (equal? (quad-elems wq) '("\u00AD"))) - wq)) - (define new-lines - (cond - [(empty? wrap-qs-printing) null] - [(hr-break-quad? q-after) (list (make-hr-quad line-prototype-q))] - [else - ;; render hyphen first so that all printable characters are available for size-dependent ops. - (define pcs-with-hyphen (render-hyphen wrap-qs-printing q-after)) - ;; fill wrap so that consolidate-runs works properly - ;; (justified lines won't be totally consolidated) - (define last-line-in-paragraph? (not q-after)) - (define pcs (fill-line-wrap pcs-with-hyphen line-prototype-q last-line-in-paragraph?)) - (match (consolidate-runs pcs) - [(and (cons elem-first _) elems) - (match-define (list line-width line-height) (quad-size line-prototype-q)) - (list - (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 - ;; so that it will be wrapped as a block later. - ;; we only set this if there is no value for :display. - (hash-ref! h :display default-block-id) - h)] - ;; line width is static - ;; 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) - [(? null?) line-height] - [line-heights (apply max line-heights)]))] - ;; handle list indexes. drop new quad into line to hold list index - ;; could also use this for line numbers - [elems - ;; we assume here that a list item has already had extra inset-left - ;; with room for a bullet - ;; which we just insert at the front. - ;; this is safe because line has already been filled. - (append - ;; 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)) - [#false null] - [bullet - (define bq (quad-copy string-quad q:string ;; copy q:string to get draw routine - ;; borrow attrs from elem - [attrs (quad-attrs elem-first)] - ;; use bullet as elems - [elems (list (if (number? bullet) (format "~a." bullet) bullet))] - ;; size doesn't matter because nothing refers to this quad - ;; just for debugging box - [size (pt 15 (pt-y (size line-prototype-q)))])) - (from-parent (list bq) 'sw)]) - (from-parent - (match (quad-ref elem-first :inset-left 0) - [0 elems] - [inset-val (cons (make-quad - #:draw-end q:string-draw-end - #:to 'sw - #:size (pt inset-val 5) - #:type offsetter-quad) - elems)]) 'sw))]))] - [_ null])])) - (define maybe-first-line (and (pair? new-lines) (car new-lines))) - (append (match q-before - [#false (list (make-paragraph-spacer maybe-first-line :space-before 0))] ; paragraph break - [_ null]) - new-lines - (match q-after - [(? column-break-quad? column-break) (list column-break)] ; hard column (or section or page) break - [#false (list (make-paragraph-spacer maybe-first-line :space-after (* default-line-height 0.6)))] ; paragraph break - [_ null]))) ; hard line break - - -(define (line-wrap qs wrap-size [debug #false]) - (unless (positive? wrap-size) - (raise-argument-error 'line-wrap "positive number" wrap-size)) - (match qs - [(cons q _) - (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, - ;; and then fill-wrap will tighten thes word spaces - ;; this makes justified paragraphs more even, becuase - ;; some lines are a little tight, as opposed to all of them being loose - ["justify" 1.04] - [_ 1])) - ;; group lines into sublists separated by para-breaks, but then omit the para-breaks themselves - ;; because they've served their purpose (leave the others, to be expressed later) - ;; however, leave line-breaks in, because they will be handled by wrap. - (define para-qss (let loop ([qs qs][acc null]) - (match qs - [(? null?) (reverse acc)] - [(cons (? para-break-quad?) rest) - (loop rest acc)] - [(cons (? column-break-quad? bq) rest) - (loop rest (cons bq acc))] - [(list* (and (not (? para-break-quad?)) nbqs) ... rest) - (loop rest (cons nbqs acc))]))) - (define res - (apply append - (for/list ([para-qs (in-list para-qss)]) - (define block-id (gensym)) - (match para-qs - [(? break-quad? bq) (list bq)] - [(cons pq _) - (wrap para-qs - (* (- wrap-size - (quad-ref pq :inset-left 0) - (quad-ref pq :inset-right 0)) - permitted-justify-overfill) - debug - #:nicely (match (or (current-line-wrap) (quad-ref pq :line-wrap)) - [(or "best" "kp") #true] - [_ #false]) - #:hard-break line-break-quad? - #:soft-break soft-break-for-line? - #:finish-wrap (line-wrap-finish line-q block-id))])))) - res] - [_ null])) - -#;(module+ test - (line-wrap (list (make-quad "foo" #:type string-quad) - (make-quad #:type column-break-quad) - (make-quad "foo2" #:type string-quad) ) 10 #t) - - (line-wrap (list (make-quad "foo" #:type string-quad) - (make-quad #:type column-break-quad)) 10 #t)) - -(define (make-nobreak! q) (quad-set! q :no-colbr #true)) ; scooperates with col-wrap - -(define (do-keep-with-next! reversed-lines) - ;; paints nobreak onto the kwn line itself, - ;; and any line spacers that follow (could be one or more) - ;; (we are iterating backward, so the geometrically previous ln follows the spacer) - (define (is-kwn-line? ln) (quad-ref ln :keep-with-next)) - (let loop ([lines (reverse reversed-lines)]) - (unless (null? lines) - (match lines - [(list* (? is-kwn-line? kwn) (? line-spacer-quad? lsqs) ..1 rest) - (for-each make-nobreak! (cons kwn lsqs)) - (loop rest)] - [(cons ln rest) (loop rest)])))) - -(define (apply-keeps lines) - (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x :display)) lines)) - (for*/fold ([reversed-lines null] - #:result (begin - (do-keep-with-next! reversed-lines) - (reverse reversed-lines))) - ([group (in-list groups-of-lines)] - [group-len (in-value (length group))] - [(ln idx0) (in-indexed group)]) - (define idx (add1 idx0)) - ;; always catch last line of block in this case - ;; so later cases are guaranteed to have earlier lines. - (define keep-first (quad-ref ln :keep-first-lines)) - (define keep-last (quad-ref ln :keep-last-lines)) - (unless (eq? idx group-len) - (when (or - ;; if we have keep all we can skip :keep-first and :keep-last cases - (or (equal? keep-first "all") (equal? keep-last "all")) - ;; to keep n lines, we only paint the first n - 1 - ;; (because each nobr line sticks to the next) - (and (number? keep-first) (< idx keep-first)) - (and (number? keep-last) (< (- group-len keep-last) idx))) - (make-nobreak! ln))) - (cons ln reversed-lines))) - - -(define default-page-size "letter") -(define default-page-orientation "tall") -(define (parse-page-size q) - ;; page size can be specified by name, or measurements. - ;; explicit measurements from page-height and page-width supersede those from page-size. - (match-define (list page-width page-height) - (for/list ([k (list :page-width :page-height)]) - (and (quad? q) (match (quad-ref q k) - [#false #false] - [val (inexact->exact (floor val))])))) - (resolve-page-size - (or (debug-page-width) page-width) - (or (debug-page-height) page-height) - (quad-ref q :page-size default-page-size) - (quad-ref q :page-orientation default-page-orientation))) - -(define (page-draw-start q doc) - (match-define (list page-width page-height) (parse-page-size q)) - (add-page doc page-width page-height) - (scale doc (zoom-factor) (zoom-factor)) - (draw-debug q doc "aliceblue" "aliceblue" 3)) - -(define (draw-page-footer q doc) - (match-define (list x y) (quad-origin q)) - (font-size doc (* .8 default-font-size)) - (font doc (path->string (quad-ref q font-path-key default-font-face))) - (fill-color doc default-font-color) - (text doc (or (quad-ref q :footer-text) - (format "~a · ~a at ~a" (quad-ref q :page-number 0) - (if (quadwriter-test-mode) "test" (quad-ref q :doc-title "untitled")) - (date->string (if (quadwriter-test-mode) (seconds->date 0 #f) (current-date)) #t))) - x y)) - -(define (make-footer-quad col-q page-idx path) - (define-values (dir name _) (split-path (path-replace-extension path #""))) - (define attrs (let ([attrs (make-hasheq)]) - (hash-set*! attrs - :footer-text (quad-ref col-q :footer-text) - :page-number (+ (quad-ref col-q :page-number-start (add1 (section-pages-used))) (sub1 page-idx)) - :doc-title (string-titlecase (path->string name)) - :font-family "text") - (resolve-font-path! attrs) - attrs)) - (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 - #:type column-quad - #:id 'col - #:from 'ne - #:to 'nw)) - -(define-quad column-spacer-quad quad) -(define q:column-spacer (make-quad - #:type column-spacer-quad - #:from 'ne - #:to 'nw - #:printable only-prints-in-middle)) - -(define-quad page-quad quad) -(define q:page (make-quad - #:type page-quad - #:id 'page - #:from-parent 'nw - #:draw-start page-draw-start)) - -(define-quad doc-quad quad) -(define q:doc (make-quad - #:type doc-quad - #:draw-start (λ (q doc) (start-doc doc)) - #:draw-end (λ (q doc) (end-doc doc)))) - -(define-quad section-quad quad) -(define q:section (make-quad #:type section-quad - #:id 'section)) - -(define ((block-draw-start first-line) q doc) - ;; adjust drawing coordinates for border inset - (match-define (list bil bit bir bib) - (for/list ([k (in-list (list :border-inset-left :border-inset-top :border-inset-right :border-inset-bottom))]) - (quad-ref first-line k 0))) - (match-define (list left top) (pt+ (quad-origin q) (list bil bit))) - (match-define (list width height) (pt- (size q) (list (+ bil bir) (+ bit bib)))) - ;; fill rect - (let ([bgc (quad-ref first-line :background-color)]) - (when bgc - (rect doc left top width height) - (fill doc bgc))) - ;; draw border - (match-define (list bw-left bw-top bw-right bw-bottom) - (map (λ (k) (max 0 (quad-ref first-line k 0))) - (list - :border-width-left - :border-width-top - :border-width-right - :border-width-bottom))) - ;; adjust start and end points based on adjacent border width - ;; so all borders overlap rectangularly - (define (half x) (/ x 2.0)) - (define right (+ left width)) - (define bottom (+ top height)) - (define (box-side x1 y1 x2 y2 color stroke-width) - (when (positive? stroke-width) - (move-to doc x1 y1) - (line-to doc x2 y2) - (stroke doc (or color "black") stroke-width))) - (box-side (- left (half bw-left)) top (+ right (half bw-right)) top - (quad-ref first-line :border-color-top) bw-top) - (box-side right (- top (half bw-top)) right (+ bottom (half bw-bottom)) - (quad-ref first-line :border-color-right) bw-right) - (box-side (+ right (half bw-right)) bottom (- left (half bw-left)) bottom - (quad-ref first-line :border-color-bottom) bw-bottom) - (box-side left (+ bottom (half bw-bottom)) left (- top (half bw-top)) - (quad-ref first-line :border-color-left) bw-left) - (case (quad-ref first-line :block-clip) - [(#true) - (when (eq? (log-clipping?) 'warn) - (for ([line (in-list (quad-elems q))]) - (define line-width (pt-x (size line))) - (define line-elem-width (sum-x (quad-elems line))) - (when (< line-width line-elem-width) - (define error-str (apply string-append (for/list ([q (in-list (quad-elems line))]) - (match (quad-elems q) - [(list (? string? str)) str] - [_ ""])))) - (log-quadwriter-warning (format "clipping overfull line: ~v" error-str))))) - (save doc) - (rect doc left top width height) - (clip doc)])) - -(define ((block-draw-end first-line) q doc) - (case (quad-ref first-line :block-clip) - [(#true) (restore doc)]) - (when (draw-debug-block?) - (draw-debug q doc "#6c6" "#9c9"))) - -(define-quad block-quad quad) -(define (lines->block lines) - (match lines - [(cons 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. - ;; 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 ((column-wrap-finish col-quad) lns q0 ending-q idx [reversed-fn-lines null]) - (define fn-lines - (from-parent (for/list ([fn-line (in-list reversed-fn-lines)]) - ;; position bottom to top, in reverse - (quad-update! fn-line - [from 'nw] - [to 'sw])) 'sw)) - - (append - (match lns - [(cons line _) - (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)))] - [elems (append (from-parent (insert-blocks lns) 'nw) fn-lines)]))] - [_ null]) - (match ending-q - [(? page-break-quad? page-break) (list page-break)] ; hard page (or section) break - [_ null]))) - -#| -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 [col-quad-proto q:column]) - (unless (positive? vertical-height) - (raise-argument-error 'column-wrap "positive number" vertical-height)) - - ;; on timing of `insert-blocks`: - ;; can't do it before because it depends on where columns are broken. - ;; 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? - #:no-break (λ (q) (quad-ref q :no-colbr)) ; cooperates with make-nobreak - #:distance (λ (q dist-so-far wrap-qs) - ;; do trial block insertions - (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))))) - (define reversed-fn-lines - (from-parent (for/list ([fn-line (in-list (reverse fn-lines))]) - ;; position bottom to top, in reverse - (quad-update! fn-line - [from 'nw] - [to 'sw])) 'sw)) - (when (pair? cols) - (quad-update! (car cols) - [elems (append (quad-elems (car cols)) reversed-fn-lines)])) - (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)) - -(verbose-quad-printing? #t) -(define ((page-wrap-finish make-page-quad path) cols q-before q-after page-idx) - (define pq (make-page-quad (+ (section-pages-used) page-idx))) - ;; get attrs from cols if we can, otherwise try q-after or q-before - (define q-for-attrs (cond - [(pair? cols) (car cols)] - [q-after] - [q-before] - [else (raise-argument-error 'page-wrap-finish "quad with attrs" (list cols q-after q-before))])) - (define elems - (append - (match (quad-ref q-for-attrs :footer-display #true) - [(or #false "none") null] - [_ (list (make-footer-quad q-for-attrs page-idx path))]) - (from-parent cols 'nw))) - (list (quad-update! pq - [elems elems] - [attrs (copy-block-attrs (cond - [q-for-attrs => quad-attrs] - [else (hash)]) - (hash-copy (quad-attrs pq)))]))) - -(define (page-wrap qs width [make-page-quad (λ (x) (quad-copy page-quad q:page))]) - (unless (positive? width) - (raise-argument-error 'page-wrap "positive number" width)) - (wrap qs width - #:soft-break #true - #:hard-break page-break-quad? - #:no-break (λ (q) (quad-ref q :no-pbr)) - #:distance (λ (q dist-so-far wrap-qs) (sum-x wrap-qs)) - #:finish-wrap (page-wrap-finish make-page-quad (pdf-output-path (current-pdf))))) - -(define (insert-blocks lines) - (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x :display)) lines)) - (append* (for/list ([line-group (in-list groups-of-lines)]) - (if (quad-ref (car line-group) :display) - (list (lines->block line-group)) - line-group)))) - -(define-quad first-line-indent-quad quad) - -(define (insert-first-line-indents qs-in) - ;; first line indents are quads inserted at the beginning of a paragraph - ;; (that is, just after a paragraph break) - ;; they need to be installed before line wrap - ;; to be compatible with first-fit and best-fit. - - ;; stick a pbr on the front if there isn't one already - ;; because of the "lookahead" style of iteration - (define qs (match qs-in - [(cons (? para-break-quad?) _) qs-in] - [_ (cons q:page-break qs-in)])) - (apply append - (for/list ([q (in-list qs)] - [next-q (in-list (cdr qs))]) - (match (and (para-break-quad? q) (quad-ref next-q :first-line-indent 0)) - [(or #false 0) (list next-q)] - [indent-val (list (make-quad #:from 'bo - #:to 'bi - #:draw-end q:string-draw-end - #:type first-line-indent-quad - #:attrs (quad-attrs next-q) - #:size (pt indent-val 10)) next-q)])))) diff --git a/quad/quadwriter/line.rkt b/quad/quadwriter/line.rkt new file mode 100644 index 00000000..efc7d52c --- /dev/null +++ b/quad/quadwriter/line.rkt @@ -0,0 +1,315 @@ +#lang debug racket +(require quad/quad + "struct.rkt" + "param.rkt" + "debug.rkt" + "font.rkt" + "string.rkt" + "attrs.rkt" + quad/position + quad/quad + quad/wrap + sugar/list + pitfall + racket/unsafe/ops) +(provide (all-defined-out)) + +(define (hr-draw dq doc) + (match-define (list left top) (quad-origin dq)) + (match-define (list right bottom) (size dq)) + (save doc) + (translate doc left (+ top (/ bottom 2.0))) + (move-to doc 0 0) + (line-to doc right 0) + (line-width doc 0.5) + (stroke doc "black") + (restore doc)) + +(define (make-hr-quad line-q) + (quad-copy line-quad line-q [draw-start hr-draw])) + +(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 (render-hyphen qs ending-q) + ;; naive handling of soft hyphen: + ;; if soft hyphen cause the break, then append a printing hyphen to the end of the run. + ;; this assumes that there is room for the hyphen on the line + ;; and does not take into account hyphen-break transformations found in other languages. + ;; However we do want the hyphen joined into the string so the final shaping / positioning is correct + ;; for instance, kerning between last letter and hyphen. + (match (and ending-q (equal? (quad-elems ending-q) '("\u00AD")) qs) + [(list head ... last-q) + (define str (car (quad-elems last-q))) + (define str+hyphen (string-append str "-")) + (append head + (list (quad-update! last-q + [elems (list str+hyphen)] + [size (make-size-promise-for-string last-q str+hyphen)])))] + [_ qs])) + + +(define (space-quad? q) (equal? (quad-elems q) (list " "))) + + +(define (hang-punctuation nonspacess) + (match nonspacess + [(list sublists ... (list prev-qs ... last-q)) + #:when (pair? (quad-elems last-q)) + (match (regexp-match #rx"[.,:;’-]$" (car (quad-elems last-q))) + [#false nonspacess] + [last-char-str + (define hanger-q (quad-copy string-quad last-q + [elems null] + [size (let ([p (make-size-promise-for-string last-q (car last-char-str))]) + (delay + (match-define (list x y) (force p)) + (pt (- x) y)))])) + (define last-sublist (append prev-qs (list last-q hanger-q))) + (append sublists (list last-sublist))])] + [_ nonspacess])) + + +(define (sum-sum-x qss) + (for/sum ([qs (in-list qss)]) + (sum-x qs))) + +(define (tracking-adjustment q) + (match q + [(? string-quad?) (/ (quad-ref q :font-tracking 0) 2.0)] + [_ 0])) + +(define (fill-line-wrap all-qs line-prototype last-line-in-paragraph?) + ;; happens during the finish of a line wrap, before consolidation of runs + (unless (pair? all-qs) + (raise-argument-error 'fill-line-wrap "nonempty list of quads" all-qs)) + + ;; remove absolute position quads because they don't affect line layout + (define-values (absolute-qs qs) (partition (λ (q) (equal? (quad-ref q :position) "absolute")) all-qs)) + + (match-define (and (cons q-first other-qs) (list _ ... q-last)) qs) + (define align-value (quad-ref q-first :line-align "left")) + + ;; words may still be in hyphenated fragments + ;; (though soft hyphens would have been removed) + ;; so group them (but no need to consolidate — that happens elsewhere) + (define-values (spacess nonspacess) (partition* space-quad? qs)) + (match (length nonspacess) + [1 #:when (equal? align-value "justify") qs] ; can't justify single word + [nonspacess-count + (match-define (list line-prototype-width line-prototype-height) (quad-size line-prototype)) + (define hung-nonspacess (hang-punctuation nonspacess)) + (define left-tracking-adjustment (tracking-adjustment q-first)) + (define right-tracking-adjustment (tracking-adjustment q-last)) + (define nonspace-total-width + (- (sum-sum-x hung-nonspacess) left-tracking-adjustment right-tracking-adjustment)) + (define space-total-width (sum-sum-x spacess)) + (define empty-hspace (- line-prototype-width + (quad-ref q-first :inset-left 0) + nonspace-total-width + (quad-ref q-first :inset-right 0))) + + (define (make-left-edge-filler [width 0]) + (make-quad #:type filler-quad + #:id 'line-filler + #:from-parent (quad-from-parent q-first) + #:from 'bo + #:to 'bi + #:shift (pt (- left-tracking-adjustment) 0) + #:size (pt width 0) + #:attrs (quad-attrs q-first))) + + (cond + [(or + (and (equal? align-value "justify") (or (not last-line-in-paragraph?) + ;; don't justify the last line in a paragraph + ;; unless empty space is less than 17% of width (an arbitrary visual threshold) + (< (/ empty-hspace line-prototype-width 1.0) .17))) + (let ([line-overfull? (negative? (- empty-hspace space-total-width))]) + ;; force justification upon overfull lines, + ;; which amounts to shrinking the word spaces till the line fits + (and line-overfull? (> nonspacess-count 1)))) + (define justified-space-width (/ empty-hspace (sub1 nonspacess-count))) + (cons (make-left-edge-filler) + (apply append (add-between hung-nonspacess (list (make-quad + #:from 'bo + #:to 'bi + #:draw-end q:string-draw-end + #:size (pt justified-space-width line-prototype-height))))))] + [else + (define space-multiplier (match align-value + ["center" 0.5] + ;; fill inner & outer as if they were right, + ;; they will be corrected later, when pagination is known. + [(or "right" "inner" "outer") 1] + ;; "left" and "justify" are handled here + [_ 0])) + ;; subtact space-width because that appears between words + ;; we only care about redistributing the space on the ends + (define end-hspace (- empty-hspace space-total-width)) + ;; make filler a leading quad, not a parent / grouping quad, + ;; so that elements can still be reached by consolidate-runs + (list* (make-left-edge-filler (* end-hspace space-multiplier)) + (quad-update! q-first [from-parent #f]) + ;; 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 + #: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 ((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 + ;; remove unused soft hyphens so they don't affect final shaping + (define wrap-qs-printing (for/list ([wq (in-list wrap-qs)] + #:unless (equal? (quad-elems wq) '("\u00AD"))) + wq)) + (define new-lines + (cond + [(empty? wrap-qs-printing) null] + [(hr-break-quad? q-after) (list (make-hr-quad line-prototype-q))] + [else + ;; render hyphen first so that all printable characters are available for size-dependent ops. + (define pcs-with-hyphen (render-hyphen wrap-qs-printing q-after)) + ;; fill wrap so that consolidate-runs works properly + ;; (justified lines won't be totally consolidated) + (define last-line-in-paragraph? (not q-after)) + (define pcs (fill-line-wrap pcs-with-hyphen line-prototype-q last-line-in-paragraph?)) + (match (consolidate-runs pcs) + [(and (cons elem-first _) elems) + (match-define (list line-width line-height) (quad-size line-prototype-q)) + (list + (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 + ;; so that it will be wrapped as a block later. + ;; we only set this if there is no value for :display. + (hash-ref! h :display default-block-id) + h)] + ;; line width is static + ;; 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) + [(? null?) line-height] + [line-heights (apply max line-heights)]))] + ;; handle list indexes. drop new quad into line to hold list index + ;; could also use this for line numbers + [elems + ;; we assume here that a list item has already had extra inset-left + ;; with room for a bullet + ;; which we just insert at the front. + ;; this is safe because line has already been filled. + (append + ;; 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)) + [#false null] + [bullet + (define bq (quad-copy string-quad q:string ;; copy q:string to get draw routine + ;; borrow attrs from elem + [attrs (quad-attrs elem-first)] + ;; use bullet as elems + [elems (list (if (number? bullet) (format "~a." bullet) bullet))] + ;; size doesn't matter because nothing refers to this quad + ;; just for debugging box + [size (pt 15 (pt-y (size line-prototype-q)))])) + (from-parent (list bq) 'sw)]) + (from-parent + (match (quad-ref elem-first :inset-left 0) + [0 elems] + [inset-val (cons (make-quad + #:draw-end q:string-draw-end + #:to 'sw + #:size (pt inset-val 5) + #:type offsetter-quad) + elems)]) 'sw))]))] + [_ null])])) + (define maybe-first-line (and (pair? new-lines) (car new-lines))) + (append (match q-before + [#false (list (make-paragraph-spacer maybe-first-line :space-before 0))] ; paragraph break + [_ null]) + new-lines + (match q-after + [(? column-break-quad? column-break) (list column-break)] ; hard column (or section or page) break + [#false (list (make-paragraph-spacer maybe-first-line :space-after (* default-line-height 0.6)))] ; paragraph break + [_ null]))) ; hard line break + + +(define softies (map string '(#\space #\- #\u00AD))) + +(define (soft-break-for-line? q) + (and (pair? (quad-elems q)) + (member (unsafe-car (quad-elems q)) softies))) + + +(define (line-wrap qs wrap-size [debug #false]) + (unless (positive? wrap-size) + (raise-argument-error 'line-wrap "positive number" wrap-size)) + (match qs + [(cons q _) + (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, + ;; and then fill-wrap will tighten thes word spaces + ;; this makes justified paragraphs more even, becuase + ;; some lines are a little tight, as opposed to all of them being loose + ["justify" 1.04] + [_ 1])) + ;; group lines into sublists separated by para-breaks, but then omit the para-breaks themselves + ;; because they've served their purpose (leave the others, to be expressed later) + ;; however, leave line-breaks in, because they will be handled by wrap. + (define para-qss (let loop ([qs qs][acc null]) + (match qs + [(? null?) (reverse acc)] + [(cons (? para-break-quad?) rest) + (loop rest acc)] + [(cons (? column-break-quad? bq) rest) + (loop rest (cons bq acc))] + [(list* (and (not (? para-break-quad?)) nbqs) ... rest) + (loop rest (cons nbqs acc))]))) + (define res + (apply append + (for/list ([para-qs (in-list para-qss)]) + (define block-id (gensym)) + (match para-qs + [(? break-quad? bq) (list bq)] + [(cons pq _) + (wrap para-qs + (* (- wrap-size + (quad-ref pq :inset-left 0) + (quad-ref pq :inset-right 0)) + permitted-justify-overfill) + debug + #:nicely (match (or (current-line-wrap) (quad-ref pq :line-wrap)) + [(or "best" "kp") #true] + [_ #false]) + #:hard-break line-break-quad? + #:soft-break soft-break-for-line? + #:finish-wrap (line-wrap-finish line-q block-id))])))) + res] + [_ null])) + diff --git a/quad/quadwriter/page.rkt b/quad/quadwriter/page.rkt new file mode 100644 index 00000000..fbb4b77c --- /dev/null +++ b/quad/quadwriter/page.rkt @@ -0,0 +1,110 @@ +#lang debug racket +(require "struct.rkt" + "attrs.rkt" + "param.rkt" + "debug.rkt" + "font.rkt" + "line.rkt" + quad/position + quad/quad + quad/wrap + racket/date + pitfall) +(provide (all-defined-out)) + + + +(define default-page-size "letter") +(define default-page-orientation "tall") +(define (page-draw-start q doc) + (match-define (list page-width page-height) (parse-page-size q)) + (add-page doc page-width page-height) + (scale doc (zoom-factor) (zoom-factor)) + (draw-debug q doc "aliceblue" "aliceblue" 3)) + + +(define q:page (make-quad + #:type page-quad + #:id 'page + #:from-parent 'nw + #:draw-start page-draw-start)) + + +(define (parse-page-size q) + ;; page size can be specified by name, or measurements. + ;; explicit measurements from page-height and page-width supersede those from page-size. + (match-define (list page-width page-height) + (for/list ([k (list :page-width :page-height)]) + (and (quad? q) (match (quad-ref q k) + [#false #false] + [val (inexact->exact (floor val))])))) + (resolve-page-size + (or (debug-page-width) page-width) + (or (debug-page-height) page-height) + (quad-ref q :page-size default-page-size) + (quad-ref q :page-orientation default-page-orientation))) + + +(define (draw-page-footer q doc) + (match-define (list x y) (quad-origin q)) + (font-size doc (* .8 default-font-size)) + (font doc (path->string (quad-ref q font-path-key default-font-face))) + (fill-color doc default-font-color) + (text doc (or (quad-ref q :footer-text) + (format "~a · ~a at ~a" (quad-ref q :page-number 0) + (if (quadwriter-test-mode) "test" (quad-ref q :doc-title "untitled")) + (date->string (if (quadwriter-test-mode) (seconds->date 0 #f) (current-date)) #t))) + x y)) + +(define (make-footer-quad col-q page-idx path) + (define-values (dir name _) (split-path (path-replace-extension path #""))) + (define attrs (let ([attrs (make-hasheq)]) + (hash-set*! attrs + :footer-text (quad-ref col-q :footer-text) + :page-number (+ (quad-ref col-q :page-number-start (add1 (section-pages-used))) (sub1 page-idx)) + :doc-title (string-titlecase (path->string name)) + :font-family "text") + (resolve-font-path! attrs) + attrs)) + (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 ((page-wrap-finish make-page-quad path) cols q-before q-after page-idx) + (define pq (make-page-quad (+ (section-pages-used) page-idx))) + ;; get attrs from cols if we can, otherwise try q-after or q-before + (define q-for-attrs (cond + [(pair? cols) (car cols)] + [q-after] + [q-before] + [else (raise-argument-error 'page-wrap-finish "quad with attrs" (list cols q-after q-before))])) + (define elems + (append + (match (quad-ref q-for-attrs :footer-display #true) + [(or #false "none") null] + [_ (list (make-footer-quad q-for-attrs page-idx path))]) + (from-parent cols 'nw))) + (list (quad-update! pq + [elems elems] + [attrs (copy-block-attrs (cond + [q-for-attrs => quad-attrs] + [else (hash)]) + (hash-copy (quad-attrs pq)))]))) + +(define (page-wrap qs width [make-page-quad (λ (x) (quad-copy page-quad q:page))]) + (unless (positive? width) + (raise-argument-error 'page-wrap "positive number" width)) + (wrap qs width + #:soft-break #true + #:hard-break page-break-quad? + #:no-break (λ (q) (quad-ref q :no-pbr)) + #:distance (λ (q dist-so-far wrap-qs) (sum-x wrap-qs)) + #:finish-wrap (page-wrap-finish make-page-quad (pdf-output-path (current-pdf))))) \ No newline at end of file diff --git a/quad/quadwriter/para.rkt b/quad/quadwriter/para.rkt new file mode 100644 index 00000000..9d23e4ff --- /dev/null +++ b/quad/quadwriter/para.rkt @@ -0,0 +1,31 @@ +#lang debug racket +(require "attrs.rkt" + "break.rkt" + "string.rkt" + "struct.rkt" + quad/quad + quad/position) +(provide (all-defined-out)) + +(define (insert-first-line-indents qs-in) + ;; first line indents are quads inserted at the beginning of a paragraph + ;; (that is, just after a paragraph break) + ;; they need to be installed before line wrap + ;; to be compatible with first-fit and best-fit. + + ;; stick a pbr on the front if there isn't one already + ;; because of the "lookahead" style of iteration + (define qs (match qs-in + [(cons (? para-break-quad?) _) qs-in] + [_ (cons q:page-break qs-in)])) + (apply append + (for/list ([q (in-list qs)] + [next-q (in-list (cdr qs))]) + (match (and (para-break-quad? q) (quad-ref next-q :first-line-indent 0)) + [(or #false 0) (list next-q)] + [indent-val (list (make-quad #:from 'bo + #:to 'bi + #:draw-end q:string-draw-end + #:type first-line-indent-quad + #:attrs (quad-attrs next-q) + #:size (pt indent-val 10)) next-q)])))) \ No newline at end of file diff --git a/quad/quadwriter/render.rkt b/quad/quadwriter/render.rkt index 4207b620..d9444e48 100644 --- a/quad/quadwriter/render.rkt +++ b/quad/quadwriter/render.rkt @@ -6,7 +6,6 @@ racket/sequence racket/list racket/dict - racket/generator pitfall quad hyphenate @@ -16,8 +15,19 @@ "attrs.rkt" "param.rkt" "font.rkt" - "layout.rkt" - "log.rkt") + "struct.rkt" + "break.rkt" + "draw.rkt" + "string.rkt" + "image.rkt" + "log.rkt" + "line.rkt" + "page.rkt" + "para.rkt" + "section.rkt" + "doc.rkt" + "column.rkt" + "keep.rkt") (provide (all-defined-out)) @@ -136,6 +146,19 @@ ;; so if we invoke that style first, we will get a page break. (dropf qs break-quad?)) + +(define (generic->typed-quad q) + ;; replaces quads representing certain things + ;; with special typed quads representing those things. + ;; Because typed quads have their own predicates, + ;; it's faster to find them in wrapping operations + (define converter (cond + [(quad-ref q :break) convert-break-quad] + [(quad-ref q :draw) convert-draw-quad] + [(quad-ref q :image-file) convert-image-quad] + [else convert-string-quad])) + (converter q)) + (define (extract-defined-quads qs) (define (get-define-val q) (quad-ref q 'define)) (define-values (dqs not-dqs) (partition get-define-val qs)) diff --git a/quad/quadwriter/section.rkt b/quad/quadwriter/section.rkt new file mode 100644 index 00000000..96db1e62 --- /dev/null +++ b/quad/quadwriter/section.rkt @@ -0,0 +1,7 @@ +#lang debug racket +(require "struct.rkt" + quad/quad) +(provide (all-defined-out)) + +(define q:section (make-quad #:type section-quad + #:id 'section)) diff --git a/quad/quadwriter/string.rkt b/quad/quadwriter/string.rkt new file mode 100644 index 00000000..f938860e --- /dev/null +++ b/quad/quadwriter/string.rkt @@ -0,0 +1,124 @@ +#lang debug racket +(require "struct.rkt" + "font.rkt" + "attrs.rkt" + "param.rkt" + "debug.rkt" + quad/quad + quad/atomize + pitfall + quad/position + racket/unsafe/ops) +(provide (all-defined-out)) + +(define (convert-string-quad q) + ;; need to handle casing here so that it's reflected in subsequent sizing ops + (define cased-str (match (quad-elems q) + [(cons str _) + (define proc (match (quad-ref q :font-case) + [(or "upper" "uppercase") string-upcase] + [(or "lower" "lowercase" "down" "downcase") string-downcase] + [(or "title" "titlecase") string-titlecase] + [_ values])) + (proc str)] + [_ ""])) ; a string quad should always contain a string + (quad-copy string-quad q:string + [attrs (let ([attrs (quad-attrs q)]) + (hash-ref! attrs :font-size default-font-size) + attrs)] + [elems (list cased-str)] + [size (make-size-promise-for-string q cased-str)])) + + +(define soft-hyphen-string "\u00AD") + +(define (make-size-promise-for-string q [str-arg #f]) + ;; we know sensible defaults for all text properties have been set up during atomization. + (delay + (define q-string-width + (let ([str (cond + [str-arg] + [else (match (quad-elems q) + [(cons q _) q] + [_ #false])])]) + (cond + [(positive? (string-length str)) + (define pdf (current-pdf)) + (font-size pdf (quad-ref q :font-size)) + (font pdf (path->string (quad-ref q font-path-key))) + (define tracking-val (quad-ref q :font-tracking 0)) + (cond + [(equal? str soft-hyphen-string) tracking-val] + [else ;; `string-width` only applies tracking between glyphs. + ;; we add an extra tracking-val because we want to count tracking on every glyph. + ;; because at this stage, we don't know whether the quad will be freestanding or adjacent to another + ;; probably adjacent. And if so, it should have half tracking on the ends, full tracking in between + (+ (string-width pdf str + #:tracking tracking-val + #:features (quad-ref q :font-features)) + tracking-val)])] + [else 0]))) + (list q-string-width (quad-ref q :line-height)))) + + +(define (q:string-draw q doc + #:origin [origin-in #f] + #:text [str-in #f]) + (match (or str-in (and (pair? (quad-elems q)) (unsafe-car (quad-elems q)))) + [#false (void)] + [str + (font doc (path->string (quad-ref q font-path-key default-font-face))) + (font-size doc (quad-ref q :font-size default-font-size)) + (fill-color doc (quad-ref q :font-color default-font-color)) + (match-define (list x y) (or origin-in (quad-origin q))) + (define tracking (quad-ref q :font-tracking 0)) + ;; we adjust x by half tracking because by convention, string quads have half tracking at beginning & end + ;; whereas PDF drawing only puts tracking between the glyphs. + (text doc str (+ x (/ tracking 2.0)) (- y (quad-ref q :font-baseline-shift 0)) + #:tracking tracking + #:bg (quad-ref q :bg) + #:features (quad-ref q :font-features default-font-features) + #:link (quad-ref q :link))])) + +(define (q:string-draw-end q doc) + (when (draw-debug-string?) + (draw-debug q doc "#99f" "#ccf"))) + +(define (q:string-printable? q [sig #f]) + ;; printable unless single space, which is not printable at start or end + (match (quad-elems q) + [(cons elem _) + (case elem + [(" " #\space) (not (memq sig '(start end)))] + [else #true])] + [_ #true])) + +(define q:string (q #:type string-quad + #:from 'bo + #:to 'bi + #:id 'str + #:printable q:string-printable? + #:draw q:string-draw + #:draw-end q:string-draw-end)) + +(define (consolidate-runs pcs) + (let loop ([runs empty][pcs pcs]) + (match pcs + [(cons (? string-quad? strq) rest) + (define-values (run-pcs rest) (splitf-at pcs (λ (p) (same-run? strq p)))) + ;; run-pcs has at least one element (strq) + ;; and the other members are part of the same run. + ;; meaning, they share the same formatting, including character tracking. + + ;; we add a tracking adjustment because it only "appears" + ;; once characters are consolidated + (define tracking-adjustment + (* (sub1 (length run-pcs)) (quad-ref (car run-pcs) :font-tracking 0))) + (define new-run + (quad-copy string-quad q:string + [attrs (quad-attrs strq)] + [elems (merge-adjacent-strings (apply append (map quad-elems run-pcs)))] + [size (delay (pt (sum-x run-pcs) (pt-y (size strq))))])) + (loop (cons new-run runs) rest)] + [(cons first rest) (loop (cons first runs) rest)] + [_ (reverse runs)]))) \ No newline at end of file diff --git a/quad/quadwriter/struct.rkt b/quad/quadwriter/struct.rkt new file mode 100644 index 00000000..aabafee0 --- /dev/null +++ b/quad/quadwriter/struct.rkt @@ -0,0 +1,34 @@ +#lang debug racket +(require quad/quad) +(provide (all-defined-out)) + +(define-quad break-quad) +(define-quad line-break-quad break-quad) +(define-quad para-break-quad line-break-quad) +(define-quad hr-break-quad line-break-quad) +(define-quad column-break-quad line-break-quad) +(define-quad page-break-quad column-break-quad) +(define-quad section-break-quad page-break-quad) + +(define-quad line-quad) +(define-quad line-spacer-quad line-break-quad) + +(define-quad filler-quad) +(define-quad offsetter-quad) + +(define-quad column-quad) +(define-quad column-spacer-quad) + +(define-quad page-quad) + +(define-quad doc-quad) + +(define-quad section-quad) + +(define-quad block-quad) + +(define-quad first-line-indent-quad) + +(define-quad string-quad) +(define-quad image-quad) +(define-quad draw-quad)