From cbc82ee174551c4db7f7515f5b64656028c1c0fb Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 17 Feb 2018 14:28:04 -0800 Subject: [PATCH] add position module --- quad/quad/generic.rkt | 19 +++- quad/quad/position.rkt | 115 +++++++++++++++++++ quad/quad/quad.rkt | 13 ++- quad/quad/typewriter.rkt | 30 ++--- quad/quad/{break.rkt => wrap.rkt} | 180 +++++++++++++++--------------- 5 files changed, 241 insertions(+), 116 deletions(-) create mode 100644 quad/quad/position.rkt rename quad/quad/{break.rkt => wrap.rkt} (53%) diff --git a/quad/quad/generic.rkt b/quad/quad/generic.rkt index cd1ea66c..d90e58f5 100644 --- a/quad/quad/generic.rkt +++ b/quad/quad/generic.rkt @@ -3,10 +3,17 @@ (provide (all-defined-out)) (define-generics quad - (elems quad) - (attrs quad) - (entrance-point quad) - (exit-point quad) - (inner-point quad) + (start quad) + (end quad) + (inner quad) + (size quad [condition]) - (draw quad [surface] [origin])) \ No newline at end of file + (offset quad [condition]) + + (origin quad) + (set-origin! quad where) + + (draw quad [surface]) + + (elems quad) + (attrs quad)) \ No newline at end of file diff --git a/quad/quad/position.rkt b/quad/quad/position.rkt new file mode 100644 index 00000000..56061dd2 --- /dev/null +++ b/quad/quad/position.rkt @@ -0,0 +1,115 @@ +#lang debug br +(require racket/contract "quad.rkt" "generic.rkt") +(provide (all-defined-out)) + +(define pt-x real-part) +(define pt-y imag-part) +(define (pt x y) (+ x (* y +i))) +(define point? number?) + +(define (valid-anchor? anchor) + (define valid-anchors '(nw n ne e se s sw w)) + (and (memq anchor valid-anchors) #t)) + +(define (coerce-int x) (if (integer? x) (inexact->exact x) x)) + +(define/contract (relative-anchor-pt q anchor) + (quad? symbol? . -> . point?) + (unless (valid-anchor? anchor) + (raise-argument-error 'anchor-adjustment "valid anchor" anchor)) + (define-values (xfac yfac) + (case anchor + [(nw) (values 0 0)] + [(n) (values 0.5 0)] + [(ne) (values 1 0)] + [(e) (values 1 0.5)] + [(se) (values 1 1)] + [(s) (values 0.5 1)] + [(sw) (values 0 1)] + [(w) (values 0 0.5)])) + (pt (coerce-int (* (pt-x (size q)) xfac)) + (coerce-int (* (pt-y (size q)) yfac)))) + + +(define/contract (inner-point q) + (quad? . -> . point?) + (+ (origin q) (relative-anchor-pt q (inner q)) (offset q))) + + +(define/contract (end-point q) + (quad? . -> . point?) + ;; no offset because end-point is "pre-padding" + (+ (origin q) (relative-anchor-pt q (end q)))) + + +(define/contract (align! q where) + (quad? point? . -> . quad?) + (set-origin! q (- where (relative-anchor-pt q (start q)))) + q) + +(define/contract (position q [where 0]) + ((quad?) (point?) . ->* . quad?) + (align! q where) + (fold-positions (elems q) (inner-point q)) + q) + +(define/contract (fold-positions qs [start-pt 0]) + (((listof quad?)) (point?) . ->* . point?) + (foldl (λ (q pt) (end-point (position q pt))) start-pt qs)) + + + +(module+ test + (require rackunit) + (test-case + "origins" + (define size 10+10i) + (define orig 5+5i) + (check-equal? (origin (position (quad (hasheq 'start 'nw 'size size)) orig)) 5+5i) + (check-equal? (origin (position (quad (hasheq 'start 'n 'size size)) orig)) +5i) + (check-equal? (origin (position (quad (hasheq 'start 'ne 'size size)) orig)) -5+5i) + (check-equal? (origin (position (quad (hasheq 'start 'e 'size size)) orig)) -5) + (check-equal? (origin (position (quad (hasheq 'start 'se 'size size)) orig)) -5-5i) + (check-equal? (origin (position (quad (hasheq 'start 's 'size size)) orig)) -5i) + (check-equal? (origin (position (quad (hasheq 'start 'sw 'size size)) orig)) 5-5i) + (check-equal? (origin (position (quad (hasheq 'start 'w 'size size)) orig)) 5)) + + (test-case + "inner points" + (define size 10+10i) + (define orig 0) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'nw)) orig)) 0) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'n)) orig)) 5) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'ne)) orig)) 10) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'e)) orig)) 10+5i) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'se)) orig)) 10+10i) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 's)) orig)) 5+10i) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'sw)) orig)) +10i) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'w)) orig)) +5i)) + + (test-case + "inner points with offsets" + (define size 10+10i) + (define orig 0) + (define off (pt (random 100) (random 100))) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'nw 'offset off)) orig)) (+ 0 off)) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'n 'offset off)) orig)) (+ 5 off)) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'ne 'offset off)) orig)) (+ 10 off)) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'e 'offset off)) orig)) (+ 10+5i off)) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'se 'offset off)) orig)) (+ 10+10i off)) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 's 'offset off)) orig)) (+ 5+10i off)) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'sw 'offset off)) orig)) (+ +10i off)) + (check-equal? (inner-point (position (quad (hasheq 'size size 'inner 'w 'offset off)) orig)) (+ +5i off))) + + (test-case + "folding positions" + (check-equal? (position (quad (quad (hasheq 'size +i 'end 'se) (quad) (quad) (quad)) + (quad (hasheq 'size +i 'end 'se) (quad) (quad) (quad)) + (quad (hasheq 'size +i 'end 'se) (quad) (quad) (quad)))) + + (position (quad (quad (hasheq 'size +i 'end 'se 'origin 0) (quad (hasheq 'origin 0)) + (quad (hasheq 'origin 1)) (quad (hasheq 'origin 2))) + (quad (hasheq 'size +i 'end 'se 'origin +i) (quad (hasheq 'origin +i)) + (quad (hasheq 'origin 1+i)) (quad (hasheq 'origin 2+i))) + (quad (hasheq 'size +i 'end 'se 'origin +2i) (quad (hasheq 'origin +2i)) + (quad (hasheq 'origin 1+2i)) (quad (hasheq 'origin 2+2i)))))))) \ No newline at end of file diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 9133b6c1..b0d2de6f 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -3,14 +3,17 @@ (provide (all-defined-out)) (module+ test (require rackunit)) -(struct $quad (attrs elems) #:transparent +(struct $quad (attrs elems) #:transparent #:mutable #:methods gen:quad [(define (elems q) ($quad-elems q)) (define (attrs q) ($quad-attrs q)) - (define (entrance-point q) (hash-ref (attrs q) 'entrance 'entrance)) - (define (exit-point q) (hash-ref (attrs q) 'exit 'exit)) - (define (inner-point q) (hash-ref (attrs q) 'inner 'inner)) - (define (size q [condition #f]) (hash-ref (attrs q) 'size (λ () (length (elems q))))) + (define (start q) (hash-ref (attrs q) 'start 'nw)) + (define (end q) (hash-ref (attrs q) 'end 'ne)) + (define (inner q) (hash-ref (attrs q) 'inner (λ () (start q)))) + (define (size q [condition #f]) (hash-ref (attrs q) 'size 1)) + (define (offset q [condition #f]) (hash-ref (attrs q) 'offset 0)) + (define (origin q) (hash-ref (attrs q) 'origin 0)) + (define (set-origin! q val) (set-$quad-attrs! q (hash-set (attrs q) 'origin val))) (define (draw q [surface #f] [origin #f]) ((hash-ref (attrs q) 'draw (λ () (λ () (println ""))))))]) (define (quad-attrs? x) (and (hash? x) (hash-eq? x))) diff --git a/quad/quad/typewriter.rkt b/quad/quad/typewriter.rkt index e825cc59..ac44527b 100644 --- a/quad/quad/typewriter.rkt +++ b/quad/quad/typewriter.rkt @@ -1,5 +1,5 @@ #lang debug br/quicklang -(require racket/promise racket/list "quad.rkt" "atomize.rkt" "break.rkt" "qexpr.rkt" "generic.rkt") +(require racket/promise racket/list "quad.rkt" "atomize.rkt" "wrap.rkt" "qexpr.rkt" "generic.rkt") (provide (rename-out [mb #%module-begin])) (define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space))))) @@ -17,22 +17,22 @@ (struct $break $quad () #:transparent) (define (break . xs) ($break (hasheq 'size (delay (values 0 0 0))) xs)) (define (lbs xs size [debug #f]) - (insert-breaks xs size debug - #:break-val (break #\newline) - #:optional-break-proc optional-break? - #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ () - (if (memv (car (elems q)) '(#\space)) - (delay (values 0 1 0)) - (delay (values 1 1 1)))))]) - (if (promise? val) (force val) (val)))) - #:finish-segment-proc (λ (pcs) (list ($line (hasheq) (map charify pcs)))))) + (wrap xs size debug + #:break-val (break #\newline) + #:optional-break-proc optional-break? + #:size-proc (λ (q) (let ([val (hash-ref (attrs q) 'size (λ () + (if (memv (car (elems q)) '(#\space)) + (delay (values 0 1 0)) + (delay (values 1 1 1)))))]) + (if (promise? val) (force val) (val)))) + #:finish-segment-proc (λ (pcs) (list ($line (hasheq) (map charify pcs)))))) (define (pbs xs size [debug #f]) - (insert-breaks xs size debug - #:break-val (break #\page) - #:optional-break-proc $break? - #:size-proc (λ (q) (force (hash-ref (attrs q) 'size (λ () (delay (values 1 1 1)))))) - #:finish-segment-proc (λ (pcs) (list ($page (hasheq) (filter-not $break? pcs)))))) + (wrap xs size debug + #:break-val (break #\page) + #:optional-break-proc $break? + #:size-proc (λ (q) (force (hash-ref (attrs q) 'size (λ () (delay (values 1 1 1)))))) + #:finish-segment-proc (λ (pcs) (list ($page (hasheq) (filter-not $break? pcs)))))) (define (typeset args) (quad->qexpr ($doc (hasheq) (filter-not $break? (pbs (lbs (atomize (apply quad #f args)) 3) 2))))) diff --git a/quad/quad/break.rkt b/quad/quad/wrap.rkt similarity index 53% rename from quad/quad/break.rkt rename to quad/quad/wrap.rkt index 146a3815..cd2b2150 100644 --- a/quad/quad/break.rkt +++ b/quad/quad/wrap.rkt @@ -2,7 +2,7 @@ (require racket/contract racket/list racket/match txexpr sugar/debug sugar/define sugar/list racket/promise racket/function (only-in racket/control call/prompt) "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt") -(define+provide/contract (insert-breaks xs +(define+provide/contract (wrap xs [target-size (current-line-width)] [debug #f] #:break-val [break-val 'break] @@ -67,8 +67,8 @@ (define br (q (hasheq 'size (delay (values 0 0 0))) #\newline)) (define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space))))) -(define (lbs xs size [debug #f]) - (insert-breaks xs size debug +(define (linewrap xs size [debug #f]) + (wrap xs size debug #:break-val 'lb #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) #:optional-break-proc optional-break? @@ -83,89 +83,89 @@ (test-case "chars" - (check-equal? (lbs (list) 1) null) - (check-equal? (lbs (list x) 1) (list x)) - (check-equal? (lbs (list x x) 1) (list x 'lb x)) - (check-equal? (lbs (list x x x) 1) (list x 'lb x 'lb x)) - (check-equal? (lbs (list x x x) 2) (list x x 'lb x)) - (check-equal? (lbs (list x x x x) 2) (list x x 'lb x x)) - (check-equal? (lbs (list x x x x x) 3) (list x x x 'lb x x)) - (check-equal? (lbs (list x x x x x) 1) (list x 'lb x 'lb x 'lb x 'lb x)) - (check-equal? (lbs (list x x x x x) 10) (list x x x x x))) + (check-equal? (linewrap (list) 1) null) + (check-equal? (linewrap (list x) 1) (list x)) + (check-equal? (linewrap (list x x) 1) (list x 'lb x)) + (check-equal? (linewrap (list x x x) 1) (list x 'lb x 'lb x)) + (check-equal? (linewrap (list x x x) 2) (list x x 'lb x)) + (check-equal? (linewrap (list x x x x) 2) (list x x 'lb x x)) + (check-equal? (linewrap (list x x x x x) 3) (list x x x 'lb x x)) + (check-equal? (linewrap (list x x x x x) 1) (list x 'lb x 'lb x 'lb x 'lb x)) + (check-equal? (linewrap (list x x x x x) 10) (list x x x x x))) (test-case "chars and spaces" - (check-equal? (lbs (list x sp x) 1) (list x 'lb x)) - (check-equal? (lbs (list x x sp x) 2) (list x x 'lb x)) - (check-equal? (lbs (list a sp b) 3) (list a sp b)) - (check-equal? (lbs (list x sp x x) 3) (list x 'lb x x))) + (check-equal? (linewrap (list x sp x) 1) (list x 'lb x)) + (check-equal? (linewrap (list x x sp x) 2) (list x x 'lb x)) + (check-equal? (linewrap (list a sp b) 3) (list a sp b)) + (check-equal? (linewrap (list x sp x x) 3) (list x 'lb x x))) (test-case "leading & trailing spaces" - (check-equal? (lbs (list sp x) 2) (list x)) - (check-equal? (lbs (list x sp) 2) (list x)) - (check-equal? (lbs (list sp x sp) 2) (list x)) - (check-equal? (lbs (list sp sp x sp sp) 2) (list x)) - (check-equal? (lbs (list sp sp x sp sp x sp) 1) (list x 'lb x))) + (check-equal? (linewrap (list sp x) 2) (list x)) + (check-equal? (linewrap (list x sp) 2) (list x)) + (check-equal? (linewrap (list sp x sp) 2) (list x)) + (check-equal? (linewrap (list sp sp x sp sp) 2) (list x)) + (check-equal? (linewrap (list sp sp x sp sp x sp) 1) (list x 'lb x))) (test-case "zero width nonbreakers" - (check-equal? (lbs (list sp zwx) 2) (list zwx)) - (check-equal? (lbs (list zwx sp) 2) (list zwx)) - (check-equal? (lbs (list sp zwx sp) 2) (list zwx)) - (check-equal? (lbs (list sp sp zwx sp sp) 2) (list zwx)) - (check-equal? (lbs (list sp sp zwx sp sp zwx sp) 2) (list zwx sp sp zwx))) + (check-equal? (linewrap (list sp zwx) 2) (list zwx)) + (check-equal? (linewrap (list zwx sp) 2) (list zwx)) + (check-equal? (linewrap (list sp zwx sp) 2) (list zwx)) + (check-equal? (linewrap (list sp sp zwx sp sp) 2) (list zwx)) + (check-equal? (linewrap (list sp sp zwx sp sp zwx sp) 2) (list zwx sp sp zwx))) (test-case "mandatory breaks" - (check-equal? (lbs (list br) 2) (list 'lb)) - (check-equal? (lbs (list a br b) 2) (list a 'lb b)) - (check-equal? (lbs (list a b br) 2) (list a b 'lb)) - (check-equal? (lbs (list a b br br) 2) (list a b 'lb 'lb)) - (check-equal? (lbs (list x br x x) 3) (list x 'lb x x)) - (check-equal? (lbs (list x x br x) 3) (list x x 'lb x)) - (check-equal? (lbs (list x x x x) 3) (list x x x 'lb x)) - (check-equal? (lbs (list x x x sp x x) 2) (list x x 'lb x 'lb x x)) - (check-equal? (lbs (list x x x sp x x) 3) (list x x x 'lb x x))) + (check-equal? (linewrap (list br) 2) (list 'lb)) + (check-equal? (linewrap (list a br b) 2) (list a 'lb b)) + (check-equal? (linewrap (list a b br) 2) (list a b 'lb)) + (check-equal? (linewrap (list a b br br) 2) (list a b 'lb 'lb)) + (check-equal? (linewrap (list x br x x) 3) (list x 'lb x x)) + (check-equal? (linewrap (list x x br x) 3) (list x x 'lb x)) + (check-equal? (linewrap (list x x x x) 3) (list x x x 'lb x)) + (check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x)) + (check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x))) (test-case "mandatory breaks and spurious spaces" - (check-equal? (lbs (list a sp sp sp br b) 2) (list a 'lb b)) - (check-equal? (lbs (list x sp br sp sp x x sp) 3) (list x 'lb x x)) - (check-equal? (lbs (list sp sp x x sp sp br sp sp sp x) 3) (list x x 'lb x)) - (check-equal? (lbs (list a sp b sp sp br sp c) 3) (list a sp b 'lb c)) - (check-equal? (lbs (list x x x x) 3) (list x x x 'lb x)) - (check-equal? (lbs (list x x x sp x x) 2) (list x x 'lb x 'lb x x)) - (check-equal? (lbs (list x x x sp x x) 3) (list x x x 'lb x x))) - - (define (visual-breaks str int) - (apply string (for/list ([b (in-list (lbs (atomize str) int))]) + (check-equal? (linewrap (list a sp sp sp br b) 2) (list a 'lb b)) + (check-equal? (linewrap (list x sp br sp sp x x sp) 3) (list x 'lb x x)) + (check-equal? (linewrap (list sp sp x x sp sp br sp sp sp x) 3) (list x x 'lb x)) + (check-equal? (linewrap (list a sp b sp sp br sp c) 3) (list a sp b 'lb c)) + (check-equal? (linewrap (list x x x x) 3) (list x x x 'lb x)) + (check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x)) + (check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x))) + + (define (visual-wrap str int) + (apply string (for/list ([b (in-list (linewrap (atomize str) int))]) (cond [(quad? b) (car (elems b))] [else #\|])))) (test-case "visual breaks" - (check-equal? (visual-breaks "My dog has fleas" 1) "M|y|d|o|g|h|a|s|f|l|e|a|s") - (check-equal? (visual-breaks "My dog has fleas" 2) "My|do|g|ha|s|fl|ea|s") - (check-equal? (visual-breaks "My dog has fleas" 3) "My|dog|has|fle|as") - (check-equal? (visual-breaks "My dog has fleas" 4) "My|dog|has|flea|s") - (check-equal? (visual-breaks "My dog has fleas" 5) "My|dog|has|fleas") - (check-equal? (visual-breaks "My dog has fleas" 6) "My dog|has|fleas") - (check-equal? (visual-breaks "My dog has fleas" 7) "My dog|has|fleas") - (check-equal? (visual-breaks "My dog has fleas" 8) "My dog|has|fleas") - (check-equal? (visual-breaks "My dog has fleas" 9) "My dog|has fleas") - (check-equal? (visual-breaks "My dog has fleas" 10) "My dog has|fleas") - (check-equal? (visual-breaks "My dog has fleas" 11) "My dog has|fleas") - (check-equal? (visual-breaks "My dog has fleas" 12) "My dog has|fleas") - (check-equal? (visual-breaks "My dog has fleas" 13) "My dog has|fleas") - (check-equal? (visual-breaks "My dog has fleas" 14) "My dog has|fleas") - (check-equal? (visual-breaks "My dog has fleas" 15) "My dog has|fleas") - (check-equal? (visual-breaks "My dog has fleas" 16) "My dog has fleas")) + (check-equal? (visual-wrap "My dog has fleas" 1) "M|y|d|o|g|h|a|s|f|l|e|a|s") + (check-equal? (visual-wrap "My dog has fleas" 2) "My|do|g|ha|s|fl|ea|s") + (check-equal? (visual-wrap "My dog has fleas" 3) "My|dog|has|fle|as") + (check-equal? (visual-wrap "My dog has fleas" 4) "My|dog|has|flea|s") + (check-equal? (visual-wrap "My dog has fleas" 5) "My|dog|has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 6) "My dog|has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 7) "My dog|has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 8) "My dog|has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 9) "My dog|has fleas") + (check-equal? (visual-wrap "My dog has fleas" 10) "My dog has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 11) "My dog has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 12) "My dog has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 13) "My dog has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 14) "My dog has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 15) "My dog has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 16) "My dog has fleas")) - (define (pbs xs size [debug #f]) - (insert-breaks xs size debug + (define (pagewrap xs size [debug #f]) + (wrap xs size debug #:break-val 'pb #:mandatory-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page)))) #:optional-break-proc (λ (x) (eq? x 'lb)) @@ -176,35 +176,35 @@ (test-case "soft page breaks" - (check-equal? (pbs null 2) null) - (check-equal? (pbs (list x) 2) (list x)) - (check-equal? (pbs (list x x) 2) (list x x)) - (check-equal? (pbs (list x x x) 1) (list x 'pb x 'pb x)) - (check-equal? (pbs (list x x x) 2) (list x x 'pb x)) - (check-equal? (pbs (list x x x) 3) (list x x x)) - (check-equal? (pbs (list x x x) 4) (list x x x)) - (check-equal? (pbs (list x 'lb x x) 2) (list x 'pb x x))) + (check-equal? (pagewrap null 2) null) + (check-equal? (pagewrap (list x) 2) (list x)) + (check-equal? (pagewrap (list x x) 2) (list x x)) + (check-equal? (pagewrap (list x x x) 1) (list x 'pb x 'pb x)) + (check-equal? (pagewrap (list x x x) 2) (list x x 'pb x)) + (check-equal? (pagewrap (list x x x) 3) (list x x x)) + (check-equal? (pagewrap (list x x x) 4) (list x x x)) + (check-equal? (pagewrap (list x 'lb x x) 2) (list x 'pb x x))) (test-case "hard page breaks" - (check-equal? (pbs (list x pbr x x) 2) (list x 'pb x x)) - (check-equal? (pbs (list x pbr x x) 1) (list x 'pb x 'pb x)) - (check-equal? (pbs (list x pbr pbr x x) 1) (list x 'pb 'pb x 'pb x)) - (check-equal? (pbs (list x pbr pbr x x) 2) (list x 'pb 'pb x x)) - (check-equal? (pbs (list 'lb x 'lb 'lb pbr 'lb x x 'lb) 2) (list x 'pb x x))) + (check-equal? (pagewrap (list x pbr x x) 2) (list x 'pb x x)) + (check-equal? (pagewrap (list x pbr x x) 1) (list x 'pb x 'pb x)) + (check-equal? (pagewrap (list x pbr pbr x x) 1) (list x 'pb 'pb x 'pb x)) + (check-equal? (pagewrap (list x pbr pbr x x) 2) (list x 'pb 'pb x x)) + (check-equal? (pagewrap (list 'lb x 'lb 'lb pbr 'lb x x 'lb) 2) (list x 'pb x x))) (test-case "composed line breaks and page breaks" - (check-equal? (pbs (lbs null 1) 2) null) - (check-equal? (pbs (lbs (list x) 1) 2) (list x)) - (check-equal? (pbs (lbs (list x x x) 1) 2) (list x 'lb x 'pb x)) - (check-equal? (pbs (lbs (list x x x) 2) 2) (list x x 'pb x)) - (check-equal? (pbs (lbs (list x x x) 2) 1) (list x 'pb x 'pb x)))) + (check-equal? (pagewrap (linewrap null 1) 2) null) + (check-equal? (pagewrap (linewrap (list x) 1) 2) (list x)) + (check-equal? (pagewrap (linewrap (list x x x) 1) 2) (list x 'lb x 'pb x)) + (check-equal? (pagewrap (linewrap (list x x x) 2) 2) (list x x 'pb x)) + (check-equal? (pagewrap (linewrap (list x x x) 2) 1) (list x 'pb x 'pb x)))) (struct $slug $quad () #:transparent) (define (slug . xs) ($slug #f xs)) -(define (lbs2 xs size [debug #f]) - (insert-breaks xs size debug +(define (linewrap2 xs size [debug #f]) + (wrap xs size debug #:break-val 'lb #:mandatory-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) #:optional-break-proc optional-break? @@ -218,10 +218,10 @@ (module+ test (test-case "mandatory breaks and spurious spaces with slugs" - (check-equal? (lbs2 (list a sp sp sp br b) 2) (list (slug a) 'lb (slug b))) - (check-equal? (lbs2 (list x sp br sp sp x x sp) 3) (list (slug x) 'lb (slug x x))) - (check-equal? (lbs2 (list sp sp x x sp sp br sp sp sp x) 3) (list (slug x x) 'lb (slug x))) - (check-equal? (lbs2 (list a sp b sp sp br sp c) 3) (list (slug a sp b) 'lb (slug c))) - (check-equal? (lbs2 (list x x x x) 3) (list (slug x x x) 'lb (slug x))) - (check-equal? (lbs2 (list x x x sp x x) 2) (list (slug x x) 'lb (slug x) 'lb (slug x x))) - (check-equal? (lbs2 (list x x x sp x x) 3) (list (slug x x x) 'lb (slug x x))))) \ No newline at end of file + (check-equal? (linewrap2 (list a sp sp sp br b) 2) (list (slug a) 'lb (slug b))) + (check-equal? (linewrap2 (list x sp br sp sp x x sp) 3) (list (slug x) 'lb (slug x x))) + (check-equal? (linewrap2 (list sp sp x x sp sp br sp sp sp x) 3) (list (slug x x) 'lb (slug x))) + (check-equal? (linewrap2 (list a sp b sp sp br sp c) 3) (list (slug a sp b) 'lb (slug c))) + (check-equal? (linewrap2 (list x x x x) 3) (list (slug x x x) 'lb (slug x))) + (check-equal? (linewrap2 (list x x x sp x x) 2) (list (slug x x) 'lb (slug x) 'lb (slug x x))) + (check-equal? (linewrap2 (list x x x sp x x) 3) (list (slug x x x) 'lb (slug x x))))) \ No newline at end of file