add wrap-anywhere option

main
Matthew Butterick 6 years ago
parent eeaddc0b77
commit ed82c7455c

@ -6,7 +6,7 @@ A simple _hyphenation engine_ that uses the KnuthLiang hyphenation algorithm
I **have added little** to their work. Accordingly, I take no credit, except a spoonful of *snako-bits.* 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 ## 1. Installation
@ -25,4 +25,31 @@ 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 Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their 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. text.

@ -140,31 +140,31 @@
(define (line-wrap xs size) (define (line-wrap xs size)
(break xs size (wrap xs size
#:hard-break (λ (q) (equal? "" (car (quad-elems q)))) #:hard-break (λ (q) (equal? "" (car (quad-elems q))))
#:soft-break soft-break-for-line? #:soft-break soft-break-for-line?
#:finish-wrap (λ (pcs q idx) #:finish-wrap (λ (pcs q idx)
(define new-elems (consolidate-runs pcs)) (define new-elems (consolidate-runs pcs))
(append (append
(if (= idx 1) (list q:line-spacer) null) (if (= idx 1) (list q:line-spacer) null)
(list (struct-copy quad q:line (list (struct-copy quad q:line
[attrs (let ([attrs (hash-copy (quad-attrs q:line))]) [attrs (let ([attrs (hash-copy (quad-attrs q:line))])
(define container-val (hash-ref (quad-attrs (car new-elems)) 'container #f)) (define container-val (hash-ref (quad-attrs (car new-elems)) 'container #f))
(when (and container-val (when (and container-val
(for/and ([elem (in-list (cdr new-elems))]) (for/and ([elem (in-list (cdr new-elems))])
(equal? (hash-ref (quad-attrs elem) 'container #f) (equal? (hash-ref (quad-attrs elem) 'container #f)
container-val))) container-val)))
(hash-set! attrs 'container container-val)) (hash-set! attrs 'container container-val))
attrs)] attrs)]
[size (let () [size (let ()
(define line-heights (define line-heights
(filter-map (filter-map
(λ (q) (string->number (hash-ref (quad-attrs q) 'line-height "NaN"))) (λ (q) (string->number (hash-ref (quad-attrs q) 'line-height "NaN")))
pcs)) pcs))
(match-define (list w h) (quad-size q:line)) (match-define (list w h) (quad-size q:line))
;; when `line-heights` is empty, this is just h ;; when `line-heights` is empty, this is just h
(pt w (apply max (cons h line-heights))))] (pt w (apply max (cons h line-heights))))]
[elems new-elems])))))) [elems new-elems]))))))
(define top-margin 60) (define top-margin 60)
(define bottom-margin 120) (define bottom-margin 120)
@ -174,12 +174,12 @@
(define q:page (q #:offset page-offset (define q:page (q #:offset page-offset
#:draw-start (λ (q doc) (add-page doc)) #:draw-start (λ (q doc) (add-page doc))
#:draw-end (λ (q doc) #:draw-end (λ (q doc)
(font-size doc 10) (font-size doc 10)
(text doc (format "~a · ~a at ~a" (hash-ref (quad-attrs q) 'page-number) (text doc (format "~a · ~a at ~a" (hash-ref (quad-attrs q) 'page-number)
(hash-ref (quad-attrs q) 'doc-title) (hash-ref (quad-attrs q) 'doc-title)
(date->string (current-date) #t)) (date->string (current-date) #t))
side-margin side-margin
(- (pdf-height doc) bottom-margin))))) (+ (- (pdf-height doc) bottom-margin) 20)))))
(define q:doc (q #:draw-start (λ (q doc) (start-doc doc)) (define q:doc (q #:draw-start (λ (q doc) (start-doc doc))
#:draw-end (λ (q doc) (end-doc doc)))) #:draw-end (λ (q doc) (end-doc doc))))
@ -193,13 +193,13 @@
(for/sum ([pc (in-list pcs)]) (for/sum ([pc (in-list pcs)])
(pt-y (size pc))))) (pt-y (size pc)))))
#:draw-start (λ (q doc) #:draw-start (λ (q doc)
(save doc) (save doc)
(match-define (list left top) (quad-origin q)) (match-define (list left top) (quad-origin q))
(match-define (list right bottom) (size q)) (match-define (list right bottom) (size q))
(rect doc (- left 4) (+ top 6) right (+ bottom 2)) (rect doc (- left 4) (+ top 6) right (+ bottom 2))
(line-width doc 1) (line-width doc 1)
(fill-and-stroke doc "#eee" "#999") (fill-and-stroke doc "#eee" "#999")
(restore doc)))) (restore doc))))
(define (contiguous-group-by pred xs) (define (contiguous-group-by pred xs)
;; like `group-by`, but only groups together contiguous xs with the same pred value. ;; 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)))) '((1 1) (2 2 2) (3) (4) (5 5) (6 6) (7) (8) (9))))
(define (page-wrap xs vertical-height path) (define (page-wrap xs vertical-height path)
(break xs vertical-height (wrap xs vertical-height
#:finish-wrap (λ (lns q idx) #:soft-break line-spacer?
(list (struct-copy quad q:page #:wrap-anywhere? #t
[attrs (let ([page-number idx] #:finish-wrap (λ (lns q idx)
[h (hash-copy (quad-attrs q:page))]) (list (struct-copy quad q:page
(hash-set! h 'page-number page-number) [attrs (let ([page-number idx]
(define-values (dir name _) [h (hash-copy (quad-attrs q:page))])
(split-path (path-replace-extension path #""))) (hash-set! h 'page-number page-number)
(hash-set! h 'doc-title (string-titlecase (path->string name))) (define-values (dir name _)
h)] (split-path (path-replace-extension path #"")))
[elems lns]))))) (hash-set! h 'doc-title (string-titlecase (path->string name)))
h)]
[elems lns])))))
(define (insert-containers pages) (define (insert-containers pages)
;; container recomposition happens after page composition because page breaks can happen between lines. ;; container recomposition happens after page composition because page breaks can happen between lines.

@ -38,7 +38,8 @@
[(hash-has-key? (quad-attrs q) 'link) [(hash-has-key? (quad-attrs q) 'link)
(save doc) (save doc)
(fill-color doc "blue") (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)] (restore doc)]
[else [else
#;(println str) #;(println str)
@ -66,15 +67,15 @@
(define $page (q #:attrs (hasheq 'type "page") (define $page (q #:attrs (hasheq 'type "page")
#:offset '(36 36) #:offset '(36 36)
#:draw-start (λ (q doc) #:draw-start (λ (q doc)
(add-page doc) (add-page doc)
(font-size doc 10) (font-size doc 10)
(define str (string-append "page " (number->string page-count))) (define str (string-append "page " (number->string page-count)))
;; page number ;; page number
(save doc) (save doc)
(fill-color doc "blue") (fill-color doc "blue")
(text doc str 10 10 (hasheq 'link "https://practicaltypography.com")) (text doc str 10 10 #:link "https://practicaltypography.com")
(restore doc) (restore doc)
(set! page-count (add1 page-count))))) (set! page-count (add1 page-count)))))
(define $doc (q #:draw-start (λ (q doc) (start-doc doc)) (define $doc (q #:draw-start (λ (q doc) (start-doc doc))
#:draw-end (λ (q doc) (end-doc doc)))) #:draw-end (λ (q doc) (end-doc doc))))
(struct $break quad ()) (struct $break quad ())
@ -96,29 +97,29 @@
[elems (merge-adjacent-strings (apply append (for/list ([pc (in-list run-pcs)]) [elems (merge-adjacent-strings (apply append (for/list ([pc (in-list run-pcs)])
(quad-elems pc))))] (quad-elems pc))))]
[size (delay (pt (for/sum ([pc (in-list run-pcs)]) [size (delay (pt (for/sum ([pc (in-list run-pcs)])
(pt-x (size pc))) (pt-x (size pc)))
(pt-y (size (car pcs)))))])) (pt-y (size (car pcs)))))]))
(values (cons new-run runs) rest))) (values (cons new-run runs) rest)))
(define consolidate-into-runs? #t) (define consolidate-into-runs? #t)
(define (line-wrap xs size [debug #f]) (define (line-wrap xs size [debug #f])
(break xs size debug (wrap xs size debug
#:soft-break soft-break? #:soft-break soft-break?
#:finish-wrap (λ (pcs q idx) (list (struct-copy quad $line #:finish-wrap (λ (pcs q idx) (list (struct-copy quad $line
[elems [elems
;; consolidate chars into a single run (naively) ;; consolidate chars into a single run (naively)
;; by taking attributes from first (including origin) ;; by taking attributes from first (including origin)
;; this only works because there's only one run per line ;; this only works because there's only one run per line
;; that is, it suffices to position the first letter ;; that is, it suffices to position the first letter
(if consolidate-into-runs? (if consolidate-into-runs?
(consolidate-runs pcs) (consolidate-runs pcs)
pcs)]))))) pcs)])))))
(define (page-wrap xs size [debug #f]) (define (page-wrap xs size [debug #f])
(break xs size debug (wrap xs size debug
#:finish-wrap (λ (pcs q idx) (list (struct-copy quad $page #:finish-wrap (λ (pcs q idx) (list (struct-copy quad $page
[elems pcs]))))) [elems pcs])))))
(define (typeset pdf qarg) (define (typeset pdf qarg)
(define chars 65) (define chars 65)

@ -3,13 +3,13 @@
(require "atomize.rkt" (require "atomize.rkt"
"quad.rkt" "quad.rkt"
"qexpr.rkt" "qexpr.rkt"
"break.rkt" "wrap.rkt"
"position.rkt" "position.rkt"
"param.rkt") "param.rkt")
(provide (all-from-out "atomize.rkt" (provide (all-from-out "atomize.rkt"
"quad.rkt" "quad.rkt"
"qexpr.rkt" "qexpr.rkt"
"break.rkt" "wrap.rkt"
"position.rkt" "position.rkt"
"param.rkt")) "param.rkt"))

@ -57,7 +57,7 @@
(define (hash-proc h recur) (equal-hash-code h)) (define (hash-proc h recur) (equal-hash-code h))
(define (hash2-proc h recur) (equal-secondary-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) (define (default-draw q surface)
(for-each (λ (qi) (draw qi surface)) (quad-elems q))) (for-each (λ (qi) (draw qi surface)) (quad-elems q)))

@ -1,31 +1,30 @@
#lang debug racket #lang debug racket
(require racket/list racket/match sugar/debug (require racket/list racket/match sugar/debug
"param.rkt" "quad.rkt" "atomize.rkt" "position.rkt") "param.rkt" "quad.rkt" "atomize.rkt" "position.rkt")
(provide break) (provide wrap)
(define-syntax (debug-report stx) (define-syntax (debug-report stx)
(syntax-case stx () (syntax-case stx ()
[(_ EXPR ...) (with-syntax ([debug (datum->syntax stx 'debug)]) [(_ EXPR ...) (with-syntax ([debug (datum->syntax stx 'debug)])
#'(when debug (report EXPR ...)))])) #'(when debug (report EXPR ...)))]))
(define (break xs (define (wrap xs
[target-size (current-wrap-distance)] [target-size (current-wrap-distance)]
[debug #f] [debug #f]
#:hard-break [hard-break? (λ (x) #f)] #:hard-break [hard-break? (λ (x) #f)]
#:soft-break [soft-break? (λ (x) #f)] #:soft-break [soft-break? (λ (x) #f)]
#:finish-wrap [finish-wrap-proc (λ (xs q idx) (list xs))]) #:wrap-anywhere? [wrap-anywhere? #f]
#:finish-wrap [finish-wrap-proc (λ (xs q idx) (list xs))])
#;((listof quad?) #;((listof quad?)
(real? (real?
any/c any/c
#:hard-break (quad? . -> . any/c) #:hard-break (quad? . -> . any/c)
#:soft-break (quad? . -> . any/c) #:soft-break (quad? . -> . any/c)
#:finish-wrap ((listof any/c) quad? natural? . -> . (listof any/c))) . ->* . (listof 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 ;; the hard breaks are used to divide the wrap territory into smaller chunks
;; that can be cached, parallelized, etc. ;; 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 xs])
(let loop ([wraps null][qs qs])
(match qs (match qs
;; ignore a trailing hard break ;; ignore a trailing hard break
[(or (? null?) (list (? hard-break?))) (append* (reverse wraps))] [(or (? null?) (list (? hard-break?))) (append* (reverse wraps))]
@ -33,7 +32,7 @@
(define-values (head tail) (splitf-at rest (λ (x) (not (hard-break? x))))) (define-values (head tail) (splitf-at rest (λ (x) (not (hard-break? x)))))
;; head will be empty (intentionally) if qs starts with two hard breaks ;; head will be empty (intentionally) if qs starts with two hard breaks
;; because there should be a blank wrap in between ;; 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) (debug-report next-wrap)
(loop (cons next-wrap wraps) tail)]))) (loop (cons next-wrap wraps) tail)])))
@ -46,11 +45,12 @@
;; thus beginning of list represents the end of the wrap ;; thus beginning of list represents the end of the wrap
(append partial (dropf wrap nonprinting-soft-break-in-middle?))) (append partial (dropf wrap nonprinting-soft-break-in-middle?)))
(define (break-softs qs (define (wrap-soft-breaks qs
target-size target-size
debug debug
soft-break? soft-break?
finish-wrap-proc) ; takes quads in wrap, triggering quad, and wrap idx; returns list containing wrap (and maybe other things) 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)]) (define (finish-wrap qs wrap-idx [wrap-triggering-q (car qs)])
;; reverse because quads accumulated in reverse ;; reverse because quads accumulated in reverse
;; wrap-triggering-q is ordinarily the last accumulated q ;; wrap-triggering-q is ordinarily the last accumulated q
@ -95,8 +95,16 @@
(define would-overflow? (and current-dist (> (+ dist current-dist) target-size))) (define would-overflow? (and current-dist (> (+ dist current-dist) target-size)))
(cond (cond
[would-overflow? [would-overflow?
(match q (cond
[(and (? soft-break?) (? nonprinting-at-end?)) [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) (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 ;; 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 ;; but we can move the current-partial into the current-wrap
@ -106,22 +114,22 @@
null null
(+ dist current-dist) (+ dist current-dist)
other-qs)] other-qs)]
[_ #:when (empty? next-wrap-head) [(empty? next-wrap-head)
(debug-report 'would-overflow-hard-without-captured-break) (debug-report 'would-overflow-hard-without-captured-break)
(loop (cons (finish-wrap next-wrap-tail wrap-idx) wraps) (loop (cons (finish-wrap next-wrap-tail wrap-idx) wraps)
(add1 wrap-idx) (add1 wrap-idx)
null null
null null
#false #false
qs)] qs)]
[_ ; finish the wrap & reset the line without consuming a quad [else ; finish the wrap & reset the line without consuming a quad
(loop (cons (finish-wrap next-wrap-head wrap-idx) wraps) (loop (cons (finish-wrap next-wrap-head wrap-idx) wraps)
(add1 wrap-idx) (add1 wrap-idx)
null null
next-wrap-tail next-wrap-tail
(apply + (map distance next-wrap-tail)) (apply + (map distance next-wrap-tail))
qs)])] qs)])]
[(soft-break? q) ; printing soft break, like a hyphen [(soft-break? q)
(debug-report 'would-not-overflow-soft) (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 ;; a soft break that fits, so move it on top of the next-wrap-head with the next-wrap-tail
(loop wraps (loop wraps
@ -178,10 +186,10 @@
(define soft-break? (λ (q) (memv (car (quad-elems q)) '(#\space #\-)))) (define soft-break? (λ (q) (memv (car (quad-elems q)) '(#\space #\-))))
(define (linewrap xs size [debug #f]) (define (linewrap xs size [debug #f])
(add-between (break xs size debug (add-between (wrap xs size debug
#:finish-wrap (λ (xs . _) (list xs)) #:finish-wrap (λ (xs . _) (list xs))
#:hard-break (λ (q) (char=? (car (quad-elems q)) #\newline)) #:hard-break (λ (q) (char=? (car (quad-elems q)) #\newline))
#:soft-break soft-break?) lbr)) #:soft-break soft-break?) lbr))
(module+ test (module+ test
(require rackunit)) (require rackunit))
@ -284,13 +292,13 @@
(define (visual-wrap str int [debug #f]) (define (visual-wrap str int [debug #f])
(string-join (string-join
(for/list ([x (in-list (linewrap (for/list ([atom (atomize str)]) (for/list ([x (in-list (linewrap (for/list ([atom (atomize str)])
(if (equal? (quad-elems atom) '(#\space)) (if (equal? (quad-elems atom) '(#\space))
(struct-copy quad sp) (struct-copy quad sp)
(struct-copy quad q-one (struct-copy quad q-one
[attrs (quad-attrs atom)] [attrs (quad-attrs atom)]
[elems (quad-elems atom)]))) int debug))] [elems (quad-elems atom)]))) int debug))]
#:when (and (list? x) (andmap quad? x))) #: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 (module+ test
@ -315,9 +323,9 @@
(define (pagewrap xs size [debug #f]) (define (pagewrap xs size [debug #f])
(add-between (add-between
(break (flatten xs) size debug (wrap (flatten xs) size debug
#:hard-break (λ (x) (and (quad? x) (memv (car (quad-elems x)) '(#\page)))) #:hard-break (λ (x) (and (quad? x) (memv (car (quad-elems x)) '(#\page))))
#:soft-break (λ (x) (and (quad? x) (eq? x lbr)))) pbr)) #:soft-break (λ (x) (and (quad? x) (eq? x lbr)))) pbr))
(define pbr (q #:size #false #:elems '(#\page))) (define pbr (q #:size #false #:elems '(#\page)))
(module+ test (module+ test
@ -353,10 +361,10 @@
(define (linewrap2 xs size [debug #f]) (define (linewrap2 xs size [debug #f])
(add-between (add-between
(break xs size debug (wrap xs size debug
#:hard-break (λ (q) (memv (car (quad-elems q)) '(#\newline))) #:hard-break (λ (q) (memv (car (quad-elems q)) '(#\newline)))
#:soft-break soft-break? #:soft-break soft-break?
#:finish-wrap (λ (pcs . _) (list (apply q pcs)))) #:finish-wrap (λ (pcs . _) (list (apply q pcs))))
lbr)) lbr))
(module+ test (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 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) 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))))) (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))))))
Loading…
Cancel
Save