From 5d0ae09c3a6ceb849382f641881bf89ec21887da Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 23 Jan 2019 18:29:10 -0800 Subject: [PATCH] to be surprised --- quad/qtest/fark.rkt | 14 +++++------ quad/qtest/markdown.rkt | 49 ++++++++++++++++++--------------------- quad/qtest/typewriter.rkt | 4 ++-- quad/quad/wrap.rkt | 34 ++++++++++++++------------- 4 files changed, 48 insertions(+), 53 deletions(-) diff --git a/quad/qtest/fark.rkt b/quad/qtest/fark.rkt index a642f511..2f4e7296 100644 --- a/quad/qtest/fark.rkt +++ b/quad/qtest/fark.rkt @@ -20,23 +20,21 @@ it's a codeblock! ``` -``` -it's a -codeblock! -``` +> A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm originally developed for TeX. A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm originally developed for TeX. + ``` it's a codeblock! ``` -enated. To hyphenate words of -any length, use `#:min-length` `#f`. -A [list of web colors](https://en.wikipedia.org/wiki/Web_colors). +> A [list of web colors](https://en.wikipedia.org/wiki/Web_colors). Certain word processors allow users to [insert soft hyphens](http://practicaltypography.com/optional-hyphens.html) in their -text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors). +text. + +A [list of web colors](https://en.wikipedia.org/wiki/Web_colors). Certain word processors allow users to [insert soft hyphens](http://practicaltypography.com/optional-hyphens.html) in their text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors). diff --git a/quad/qtest/markdown.rkt b/quad/qtest/markdown.rkt index 3e844217..72c5efd4 100644 --- a/quad/qtest/markdown.rkt +++ b/quad/qtest/markdown.rkt @@ -24,7 +24,7 @@ (define-tag-function (blockquote attrs exprs) (qexpr (list* '(display "block") - '(background-color "#eee") + '(background-color "#eee") '(font "fira") '(fontsize "10") '(line-height "15") '(border-width-top "0.5") '(border-color-top "gray") '(border-inset-top "8") '(border-width-left "3") '(border-color-left "gray") '(border-inset-left "20") @@ -73,7 +73,7 @@ '(border-inset-top "10") '(border-width-left "2") '(border-color-left "#669") '(border-inset-left "0") '(border-inset-right "10") '(border-inset-bottom "-4") - '(inset-left "12") '(inset-right "12") '(inset-top "12") '(inset-bottom "24") + '(inset-left "12") '(inset-right "12") '(inset-top "12") '(inset-bottom "12") attrs) new-exprs)) (define (list-base attrs exprs [bullet-val #f]) @@ -313,14 +313,11 @@ #:out 'sw #:offset (pt 0 (+ (quad-ref first-line 'inset-top 0))) #:elems lines - ;; this sizing approach doesn't work. - ;; can't add inset-top and inset-bottom here because page composition has already happened. - ;; therefore, resizing the block quads now will throw off the calculated page breaks. - #:size (pt (pt-x (size first-line)) ; - (+ (for/sum ([line (in-list lines)]) - (pt-y (size line))) - (quad-ref first-line 'inset-top 0) - (quad-ref first-line 'inset-bottom 0))) + #:size (delay (pt (pt-x (size first-line)) ; + (+ (for/sum ([line (in-list lines)]) + (pt-y (size line))) + (quad-ref first-line 'inset-top 0) + (quad-ref first-line 'inset-bottom 0)))) #:draw-start (λ (q doc) ;; adjust drawing coordinates for border inset (match-define (list bil bit bir bib) @@ -357,7 +354,8 @@ (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)))) + (quad-ref first-line 'border-color-left) bw-left)) + #:draw-end (λ (q doc) (draw-debug q doc "#6c6" "#9c9")))) (define (contiguous-group-by pred xs) @@ -381,6 +379,10 @@ (wrap xs vertical-height #:soft-break line-spacer? #:wrap-anywhere? #t + #:distance (λ (q dist-so-far wrap-qs) + ;; do trial block insertions + (for/sum ([x (in-list (insert-blocks wrap-qs))]) + (pt-y (size x)))) #:finish-wrap (λ (lns q idx) (list (struct-copy quad q:page [attrs (let ([page-number idx] @@ -390,21 +392,15 @@ (split-path (path-replace-extension path #""))) (hash-set! h 'doc-title (string-titlecase (path->string name))) h)] - [elems lns]))))) - -(define (insert-blocks pages) - ;; block recomposition happens after page composition because page breaks can happen between lines. - ;; iow, the lines within a block may be split over multiple pages, each of which should be drawn - ;; as a separate block - (for/list ([page (in-list pages)]) - (define lines (quad-elems page)) - (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x 'display)) lines)) - (define lines-and-blocks - (append* (for/list ([lines (in-list groups-of-lines)]) - (match (quad-ref (car lines) 'display) - ["block" (list (block-wrap lines))] - [_ lines])))) - (struct-copy quad page [elems lines-and-blocks]))) + [elems (insert-blocks lns)]))))) + +(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)]) + (match (quad-ref (car line-group) 'display) + ["block" (list (block-wrap line-group))] + [_ line-group])))) + (define (run xs path) (define pdf (time-name make-pdf (make-pdf #:compress #t @@ -418,7 +414,6 @@ [x (time-name ->string-quad (map (λ (x) (->string-quad pdf x)) x))] [x (time-name line-wrap (line-wrap x line-width))] [x (time-name page-wrap (page-wrap x vertical-height path))] - [x (time-name insert-containers (insert-blocks x))] [x (time-name position (position (struct-copy quad q:doc [elems x])))]) (time-name draw (draw x pdf)))) diff --git a/quad/qtest/typewriter.rkt b/quad/qtest/typewriter.rkt index 4aa377ca..c39c3245 100644 --- a/quad/qtest/typewriter.rkt +++ b/quad/qtest/typewriter.rkt @@ -32,7 +32,7 @@ [else #true])) #:draw (λ (q doc) (set! draw-counter (add1 draw-counter )) - (font-size doc (string->number (hash-ref (quad-attrs q) 'fontsize "12"))) + (font-size doc (hash-ref (quad-attrs q) 'fontsize 12)) (let ([str (car (quad-elems q))]) (cond [(hash-has-key? (quad-attrs q) 'link) @@ -51,7 +51,7 @@ [attrs (let ([h (quad-attrs q)]) (hash-set! h 'font charter) h)] [elems (quad-elems q)] [size (delay - (define fontsize (string->number (hash-ref (quad-attrs q) 'fontsize "12"))) + (define fontsize (hash-ref (quad-attrs q) 'fontsize 12)) (define str (car (quad-elems q))) (font-size doc fontsize) (font doc (path->string charter)) diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt index 9f24c1db..8532b5dc 100644 --- a/quad/quad/wrap.rkt +++ b/quad/quad/wrap.rkt @@ -23,7 +23,9 @@ #:hard-break [hard-break? (λ (x) #f)] #:soft-break [soft-break? (λ (x) #f)] #:wrap-anywhere? [wrap-anywhere? #f] - #:finish-wrap [finish-wrap-proc (λ (xs q idx) (list xs))]) + #:distance [distance-func (λ (q last-dist wrap-qs) + (+ last-dist (if (printable? q) (distance q) 0)))] + #:finish-wrap [finish-wrap-func (λ (xs q idx) (list xs))]) (define target-size-proc (match target-size-proc-arg [(? procedure? proc) proc] @@ -36,7 +38,7 @@ ;; but we capture it separately because it's likely to get trimmed away by `nonprinting-at-end?` ;; note: we don't trim `soft-break?` or `hard-break?` because that's an orthogonal consideration ;; for instance, a hyphen is `soft-break?` but shouldn't be trimmed. - (finish-wrap-proc (reverse (dropf qs nonprinting-at-end?)) wrap-triggering-q wrap-idx)) + (finish-wrap-func (reverse (dropf qs nonprinting-at-end?)) wrap-triggering-q wrap-idx)) (let loop ([wraps null] ; list of (list of quads) [wrap-idx 1] ; wrap count (could be (length wraps) but we'd rather avoid `length`) [next-wrap-head null] ; list of quads ending in previous `soft-break?` or `hard-break?` @@ -55,12 +57,12 @@ [(cons q other-qs) (debug-report q 'next-q) (debug-report (quad-elems q) 'next-q-elems) + (define would-be-wrap-qs (wrap-append (cons q next-wrap-tail) next-wrap-head)) (cond [(hard-break? q) (debug-report 'found-hard-break) ;; put hard break onto next-wrap-tail, and finish the wrap - (define wrap-qs (wrap-append (cons q next-wrap-tail) next-wrap-head)) - (loop (cons (finish-wrap wrap-qs wrap-idx) wraps) + (loop (cons (finish-wrap would-be-wrap-qs wrap-idx) wraps) (add1 wrap-idx) null null @@ -84,8 +86,8 @@ (distance q) other-qs)])] [else ; cases that require computing distance - (define dist (if (printable? q) (distance q) 0)) - (define would-overflow? (and current-dist (> (+ dist current-dist) (target-size-proc q wrap-idx)))) + (define cumulative-dist (distance-func q current-dist would-be-wrap-qs)) + (define would-overflow? (> cumulative-dist (target-size-proc q wrap-idx))) (cond [would-overflow? (cond @@ -105,7 +107,7 @@ wrap-idx (wrap-append (cons q next-wrap-tail) next-wrap-head) null - (+ dist current-dist) + cumulative-dist other-qs)] [(empty? next-wrap-head) (debug-report 'would-overflow-hard-without-captured-break) @@ -129,7 +131,7 @@ wrap-idx (wrap-append (cons q next-wrap-tail) next-wrap-head) null - (+ dist current-dist) + cumulative-dist other-qs)] [else (debug-report 'would-not-overflow) @@ -138,7 +140,7 @@ wrap-idx next-wrap-head (cons q next-wrap-tail) - (+ dist current-dist) + cumulative-dist other-qs)])])]))) (define q-zero (q #:size (pt 0 0))) @@ -285,14 +287,14 @@ (define (visual-wrap str int [debug #f]) (string-join (for/list ([x (in-list (linewrap (for/list ([c (in-string str)]) - (define atom (q c)) - (if (equal? (quad-elems atom) '(#\space)) - (struct-copy quad sp) - (struct-copy quad q-one - [attrs (quad-attrs atom)] - [elems (quad-elems atom)]))) int debug))] + (define atom (q c)) + (if (equal? (quad-elems atom) '(#\space)) + (struct-copy quad sp) + (struct-copy quad q-one + [attrs (quad-attrs atom)] + [elems (quad-elems atom)]))) int debug))] #:when (and (list? x) (andmap quad? x))) - (list->string (map car (map quad-elems x)))) + (list->string (map car (map quad-elems x)))) "|")) (module+ test