diff --git a/quad/qtest/hyphenate.rkt b/quad/qtest/hyphenate.rkt index 69bb71a1..a1bec69a 100644 --- a/quad/qtest/hyphenate.rkt +++ b/quad/qtest/hyphenate.rkt @@ -6,7 +6,7 @@ A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm I **have added little** to their work. Accordingly, I take no credit, except a spoonful of *snako-bits.* -And now, for something __altogether__ the same. +And now, for something __altogether__ the same. Yes! No?!ß ## 1. Installation @@ -25,4 +25,31 @@ any length, use `#:min-length` `#f`. 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). +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). +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). +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). +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). +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). +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). +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). +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). +Certain word processors allow users to [insert soft +hyphens](http://practicaltypography.com/optional-hyphens.html) in their text. \ No newline at end of file diff --git a/quad/qtest/markdown.rkt b/quad/qtest/markdown.rkt index c01aa442..86c34da1 100644 --- a/quad/qtest/markdown.rkt +++ b/quad/qtest/markdown.rkt @@ -140,31 +140,31 @@ (define (line-wrap xs size) - (break xs size - #:hard-break (λ (q) (equal? "¶" (car (quad-elems q)))) - #:soft-break soft-break-for-line? - #:finish-wrap (λ (pcs q idx) - (define new-elems (consolidate-runs pcs)) - (append - (if (= idx 1) (list q:line-spacer) null) - (list (struct-copy quad q:line - [attrs (let ([attrs (hash-copy (quad-attrs q:line))]) - (define container-val (hash-ref (quad-attrs (car new-elems)) 'container #f)) - (when (and container-val - (for/and ([elem (in-list (cdr new-elems))]) - (equal? (hash-ref (quad-attrs elem) 'container #f) - container-val))) - (hash-set! attrs 'container container-val)) - attrs)] - [size (let () - (define line-heights - (filter-map - (λ (q) (string->number (hash-ref (quad-attrs q) 'line-height "NaN"))) - pcs)) - (match-define (list w h) (quad-size q:line)) - ;; when `line-heights` is empty, this is just h - (pt w (apply max (cons h line-heights))))] - [elems new-elems])))))) + (wrap xs size + #:hard-break (λ (q) (equal? "¶" (car (quad-elems q)))) + #:soft-break soft-break-for-line? + #:finish-wrap (λ (pcs q idx) + (define new-elems (consolidate-runs pcs)) + (append + (if (= idx 1) (list q:line-spacer) null) + (list (struct-copy quad q:line + [attrs (let ([attrs (hash-copy (quad-attrs q:line))]) + (define container-val (hash-ref (quad-attrs (car new-elems)) 'container #f)) + (when (and container-val + (for/and ([elem (in-list (cdr new-elems))]) + (equal? (hash-ref (quad-attrs elem) 'container #f) + container-val))) + (hash-set! attrs 'container container-val)) + attrs)] + [size (let () + (define line-heights + (filter-map + (λ (q) (string->number (hash-ref (quad-attrs q) 'line-height "NaN"))) + pcs)) + (match-define (list w h) (quad-size q:line)) + ;; when `line-heights` is empty, this is just h + (pt w (apply max (cons h line-heights))))] + [elems new-elems])))))) (define top-margin 60) (define bottom-margin 120) @@ -174,12 +174,12 @@ (define q:page (q #:offset page-offset #:draw-start (λ (q doc) (add-page doc)) #:draw-end (λ (q doc) - (font-size doc 10) - (text doc (format "~a · ~a at ~a" (hash-ref (quad-attrs q) 'page-number) - (hash-ref (quad-attrs q) 'doc-title) - (date->string (current-date) #t)) - side-margin - (- (pdf-height doc) bottom-margin))))) + (font-size doc 10) + (text doc (format "~a · ~a at ~a" (hash-ref (quad-attrs q) 'page-number) + (hash-ref (quad-attrs q) 'doc-title) + (date->string (current-date) #t)) + side-margin + (+ (- (pdf-height doc) bottom-margin) 20))))) (define q:doc (q #:draw-start (λ (q doc) (start-doc doc)) #:draw-end (λ (q doc) (end-doc doc)))) @@ -193,13 +193,13 @@ (for/sum ([pc (in-list pcs)]) (pt-y (size pc))))) #:draw-start (λ (q doc) - (save doc) - (match-define (list left top) (quad-origin q)) - (match-define (list right bottom) (size q)) - (rect doc (- left 4) (+ top 6) right (+ bottom 2)) - (line-width doc 1) - (fill-and-stroke doc "#eee" "#999") - (restore doc)))) + (save doc) + (match-define (list left top) (quad-origin q)) + (match-define (list right bottom) (size q)) + (rect doc (- left 4) (+ top 6) right (+ bottom 2)) + (line-width doc 1) + (fill-and-stroke doc "#eee" "#999") + (restore doc)))) (define (contiguous-group-by pred xs) ;; like `group-by`, but only groups together contiguous xs with the same pred value. @@ -219,17 +219,19 @@ '((1 1) (2 2 2) (3) (4) (5 5) (6 6) (7) (8) (9)))) (define (page-wrap xs vertical-height path) - (break xs vertical-height - #:finish-wrap (λ (lns q idx) - (list (struct-copy quad q:page - [attrs (let ([page-number idx] - [h (hash-copy (quad-attrs q:page))]) - (hash-set! h 'page-number page-number) - (define-values (dir name _) - (split-path (path-replace-extension path #""))) - (hash-set! h 'doc-title (string-titlecase (path->string name))) - h)] - [elems lns]))))) + (wrap xs vertical-height + #:soft-break line-spacer? + #:wrap-anywhere? #t + #:finish-wrap (λ (lns q idx) + (list (struct-copy quad q:page + [attrs (let ([page-number idx] + [h (hash-copy (quad-attrs q:page))]) + (hash-set! h 'page-number page-number) + (define-values (dir name _) + (split-path (path-replace-extension path #""))) + (hash-set! h 'doc-title (string-titlecase (path->string name))) + h)] + [elems lns]))))) (define (insert-containers pages) ;; container recomposition happens after page composition because page breaks can happen between lines. diff --git a/quad/qtest/typewriter.rkt b/quad/qtest/typewriter.rkt index 1b92b1d9..f91550cb 100644 --- a/quad/qtest/typewriter.rkt +++ b/quad/qtest/typewriter.rkt @@ -38,7 +38,8 @@ [(hash-has-key? (quad-attrs q) 'link) (save doc) (fill-color doc "blue") - (text doc str (first (quad-origin q)) (second (quad-origin q)) (hasheq 'link (hash-ref (quad-attrs q) 'link))) + (text doc str (first (quad-origin q)) (second (quad-origin q)) + #:link (hash-ref (quad-attrs q) 'link)) (restore doc)] [else #;(println str) @@ -66,15 +67,15 @@ (define $page (q #:attrs (hasheq 'type "page") #:offset '(36 36) #:draw-start (λ (q doc) - (add-page doc) - (font-size doc 10) - (define str (string-append "page " (number->string page-count))) - ;; page number - (save doc) - (fill-color doc "blue") - (text doc str 10 10 (hasheq 'link "https://practicaltypography.com")) - (restore doc) - (set! page-count (add1 page-count))))) + (add-page doc) + (font-size doc 10) + (define str (string-append "page " (number->string page-count))) + ;; page number + (save doc) + (fill-color doc "blue") + (text doc str 10 10 #:link "https://practicaltypography.com") + (restore doc) + (set! page-count (add1 page-count))))) (define $doc (q #:draw-start (λ (q doc) (start-doc doc)) #:draw-end (λ (q doc) (end-doc doc)))) (struct $break quad ()) @@ -96,29 +97,29 @@ [elems (merge-adjacent-strings (apply append (for/list ([pc (in-list run-pcs)]) (quad-elems pc))))] [size (delay (pt (for/sum ([pc (in-list run-pcs)]) - (pt-x (size pc))) - (pt-y (size (car pcs)))))])) + (pt-x (size pc))) + (pt-y (size (car pcs)))))])) (values (cons new-run runs) rest))) (define consolidate-into-runs? #t) (define (line-wrap xs size [debug #f]) - (break xs size debug - #:soft-break soft-break? - #:finish-wrap (λ (pcs q idx) (list (struct-copy quad $line - [elems - ;; consolidate chars into a single run (naively) - ;; by taking attributes from first (including origin) - ;; this only works because there's only one run per line - ;; that is, it suffices to position the first letter - (if consolidate-into-runs? - (consolidate-runs pcs) - pcs)]))))) + (wrap xs size debug + #:soft-break soft-break? + #:finish-wrap (λ (pcs q idx) (list (struct-copy quad $line + [elems + ;; consolidate chars into a single run (naively) + ;; by taking attributes from first (including origin) + ;; this only works because there's only one run per line + ;; that is, it suffices to position the first letter + (if consolidate-into-runs? + (consolidate-runs pcs) + pcs)]))))) (define (page-wrap xs size [debug #f]) - (break xs size debug - #:finish-wrap (λ (pcs q idx) (list (struct-copy quad $page - [elems pcs]))))) + (wrap xs size debug + #:finish-wrap (λ (pcs q idx) (list (struct-copy quad $page + [elems pcs]))))) (define (typeset pdf qarg) (define chars 65) diff --git a/quad/quad/main.rkt b/quad/quad/main.rkt index eb1cc047..4e4c457c 100644 --- a/quad/quad/main.rkt +++ b/quad/quad/main.rkt @@ -3,13 +3,13 @@ (require "atomize.rkt" "quad.rkt" "qexpr.rkt" -"break.rkt" +"wrap.rkt" "position.rkt" "param.rkt") (provide (all-from-out "atomize.rkt" "quad.rkt" "qexpr.rkt" -"break.rkt" +"wrap.rkt" "position.rkt" "param.rkt")) \ No newline at end of file diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 590c7c24..1869e48e 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -57,7 +57,7 @@ (define (hash-proc h recur) (equal-hash-code h)) (define (hash2-proc h recur) (equal-secondary-hash-code h))]) -(define (default-printable q [sig #f]) #f) +(define (default-printable q [sig #f]) #t) (define (default-draw q surface) (for-each (λ (qi) (draw qi surface)) (quad-elems q))) diff --git a/quad/quad/break.rkt b/quad/quad/wrap.rkt similarity index 81% rename from quad/quad/break.rkt rename to quad/quad/wrap.rkt index 035053af..16b4676e 100644 --- a/quad/quad/break.rkt +++ b/quad/quad/wrap.rkt @@ -1,31 +1,30 @@ #lang debug racket (require racket/list racket/match sugar/debug "param.rkt" "quad.rkt" "atomize.rkt" "position.rkt") -(provide break) +(provide wrap) (define-syntax (debug-report stx) (syntax-case stx () [(_ EXPR ...) (with-syntax ([debug (datum->syntax stx 'debug)]) #'(when debug (report EXPR ...)))])) -(define (break xs - [target-size (current-wrap-distance)] - [debug #f] - #:hard-break [hard-break? (λ (x) #f)] - #:soft-break [soft-break? (λ (x) #f)] - #:finish-wrap [finish-wrap-proc (λ (xs q idx) (list xs))]) +(define (wrap xs + [target-size (current-wrap-distance)] + [debug #f] + #: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))]) #;((listof quad?) (real? any/c #:hard-break (quad? . -> . any/c) #:soft-break (quad? . -> . any/c) #:finish-wrap ((listof any/c) quad? natural? . -> . (listof any/c))) . ->* . (listof any/c)) - (break-hards xs target-size debug hard-break? soft-break? finish-wrap-proc)) -;; the hard breaks are used to divide the wrap territory into smaller chunks -;; that can be cached, parallelized, etc. -(define (break-hards qs target-size debug hard-break? soft-break? finish-wrap-proc) - (let loop ([wraps null][qs qs]) + ;; the hard breaks are used to divide the wrap territory into smaller chunks + ;; that can be cached, parallelized, etc. + (let loop ([wraps null][qs xs]) (match qs ;; ignore a trailing hard break [(or (? null?) (list (? hard-break?))) (append* (reverse wraps))] @@ -33,7 +32,7 @@ (define-values (head tail) (splitf-at rest (λ (x) (not (hard-break? x))))) ;; head will be empty (intentionally) if qs starts with two hard breaks ;; because there should be a blank wrap in between - (define next-wrap (break-softs head target-size debug soft-break? finish-wrap-proc)) + (define next-wrap (wrap-soft-breaks head target-size debug soft-break? wrap-anywhere? finish-wrap-proc)) (debug-report next-wrap) (loop (cons next-wrap wraps) tail)]))) @@ -46,11 +45,12 @@ ;; thus beginning of list represents the end of the wrap (append partial (dropf wrap nonprinting-soft-break-in-middle?))) -(define (break-softs qs - target-size - debug - soft-break? - finish-wrap-proc) ; takes quads in wrap, triggering quad, and wrap idx; returns list containing wrap (and maybe other things) +(define (wrap-soft-breaks qs + target-size + debug + soft-break? + wrap-anywhere? + finish-wrap-proc) ; takes quads in wrap, triggering quad, and wrap idx; returns list containing wrap (and maybe other things) (define (finish-wrap qs wrap-idx [wrap-triggering-q (car qs)]) ;; reverse because quads accumulated in reverse ;; wrap-triggering-q is ordinarily the last accumulated q @@ -95,8 +95,16 @@ (define would-overflow? (and current-dist (> (+ dist current-dist) target-size))) (cond [would-overflow? - (match q - [(and (? soft-break?) (? nonprinting-at-end?)) + (cond + [wrap-anywhere? + (debug-report 'we-can-wrap-anywhere-so-why-not-here) + (loop (cons (finish-wrap (wrap-append next-wrap-tail next-wrap-head) wrap-idx) wraps) + (add1 wrap-idx) + null + null + #false + qs)] + [(and (soft-break? q) (nonprinting-at-end? q)) (debug-report 'would-overflow-soft-nonprinting) ;; a break is inevitable but we want to wait to finish the wrap until we see a hard quad ;; but we can move the current-partial into the current-wrap @@ -106,22 +114,22 @@ null (+ dist current-dist) other-qs)] - [_ #:when (empty? next-wrap-head) - (debug-report 'would-overflow-hard-without-captured-break) - (loop (cons (finish-wrap next-wrap-tail wrap-idx) wraps) - (add1 wrap-idx) - null - null - #false - qs)] - [_ ; finish the wrap & reset the line without consuming a quad + [(empty? next-wrap-head) + (debug-report 'would-overflow-hard-without-captured-break) + (loop (cons (finish-wrap next-wrap-tail wrap-idx) wraps) + (add1 wrap-idx) + null + null + #false + qs)] + [else ; finish the wrap & reset the line without consuming a quad (loop (cons (finish-wrap next-wrap-head wrap-idx) wraps) (add1 wrap-idx) null next-wrap-tail (apply + (map distance next-wrap-tail)) qs)])] - [(soft-break? q) ; printing soft break, like a hyphen + [(soft-break? q) (debug-report 'would-not-overflow-soft) ;; a soft break that fits, so move it on top of the next-wrap-head with the next-wrap-tail (loop wraps @@ -178,10 +186,10 @@ (define soft-break? (λ (q) (memv (car (quad-elems q)) '(#\space #\-)))) (define (linewrap xs size [debug #f]) - (add-between (break xs size debug - #:finish-wrap (λ (xs . _) (list xs)) - #:hard-break (λ (q) (char=? (car (quad-elems q)) #\newline)) - #:soft-break soft-break?) lbr)) + (add-between (wrap xs size debug + #:finish-wrap (λ (xs . _) (list xs)) + #:hard-break (λ (q) (char=? (car (quad-elems q)) #\newline)) + #:soft-break soft-break?) lbr)) (module+ test (require rackunit)) @@ -284,13 +292,13 @@ (define (visual-wrap str int [debug #f]) (string-join (for/list ([x (in-list (linewrap (for/list ([atom (atomize str)]) - (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))] + (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 @@ -315,9 +323,9 @@ (define (pagewrap xs size [debug #f]) (add-between - (break (flatten xs) size debug - #:hard-break (λ (x) (and (quad? x) (memv (car (quad-elems x)) '(#\page)))) - #:soft-break (λ (x) (and (quad? x) (eq? x lbr)))) pbr)) + (wrap (flatten xs) size debug + #:hard-break (λ (x) (and (quad? x) (memv (car (quad-elems x)) '(#\page)))) + #:soft-break (λ (x) (and (quad? x) (eq? x lbr)))) pbr)) (define pbr (q #:size #false #:elems '(#\page))) (module+ test @@ -353,10 +361,10 @@ (define (linewrap2 xs size [debug #f]) (add-between - (break xs size debug - #:hard-break (λ (q) (memv (car (quad-elems q)) '(#\newline))) - #:soft-break soft-break? - #:finish-wrap (λ (pcs . _) (list (apply q pcs)))) + (wrap xs size debug + #:hard-break (λ (q) (memv (car (quad-elems q)) '(#\newline))) + #:soft-break soft-break? + #:finish-wrap (λ (pcs . _) (list (apply q pcs)))) lbr)) (module+ test @@ -369,3 +377,18 @@ (check-equal? (linewrap2 (list x x x x) 3) (list (q x x x) lbr (q x))) (check-equal? (linewrap2 (list x x x sp x x) 2) (list (q x x) lbr (q x) lbr (q x x))) (check-equal? (linewrap2 (list x x x sp x x) 3) (list (q x x x) lbr (q x x))))) + +(module+ test + (test-case + "wrap anywhere behavior" + (struct sp quad ()) + (define (qsoft) + (q #:type sp + #:printable (λ (q sig) (not (memq sig '(start end)))) + #:size (pt 1 1))) + (define (qhard) (q #:attrs (hasheq 'q 1) #:size (pt 1 1))) + (define qs (list (qhard) (qsoft) (qhard) (qhard))) + ;; only wraps on soft break, so two qhards go in second wrap + (check-equal? (wrap qs 3 #:soft-break sp?) (list (list (qhard)) (list (qhard) (qhard)))) + ;; wraps anywhere, so two qhards fit onto first wrap with space + (check-equal? (wrap qs 3 #:soft-break sp? #:wrap-anywhere? #t) (list (list (qhard) (qsoft) (qhard)) (list (qhard))))))