From 527682d62466bf9b343953258f205075c3d03ddc Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 3 Nov 2018 22:24:48 -0700 Subject: [PATCH] refac --- quad/quad/break.rkt | 337 +++++++++++++++++++++----------------------- 1 file changed, 159 insertions(+), 178 deletions(-) diff --git a/quad/quad/break.rkt b/quad/quad/break.rkt index e40e8e5c..eb419d61 100644 --- a/quad/quad/break.rkt +++ b/quad/quad/break.rkt @@ -12,7 +12,7 @@ (any/c . -> . real?) (hash-ref! distance-cache (cond [(quad? q) - (hash-ref (attrs q) 'id q)] + (hash-ref (attrs q) 'id q)] [(symbol? q) q]) (λ () (cond @@ -64,6 +64,8 @@ finish-wrap-proc) (define break-val=? (if (symbol? break-val) eq? equal?)) (define (cleanup-wraplist xs) + ;; combine the segments into a flat list, and drop any trailing breaks + ;; (on the idea that breaks should separate things, and there's nothing left to separate) (dropf-right (append* (reverse xs)) (λ (x) (break-val=? break-val x)))) (define wraps (for/fold ([wraps null] @@ -96,111 +98,90 @@ [((== empty) _) wrap] [(partial (list (? nonprinting-in-middle-soft-break?) ... rest ...)) (append (or partial null) rest)])) + +(define (finish-wraps wraps wrap-proc soft-break?) + (for/list ([wrap (in-list wraps)]) + (match wrap + [(list (? nonprinting-at-end?)) wrap] ; matches break signals + ;; pieces will have been accumulated in reverse order + ;; thus beginning of list represents the end of the wrap + [(list (? (conjoin soft-break? nonprinting-at-end?)) ... rest ...) + (wrap-proc (reverse rest))]))) + (define (break-softs qs target-size debug break-val soft-break? finish-wrap-proc) - (define start-signal (gensym)) - ;; qs = list of quads - ;; current-dist = integer - ;; current-wrap = list of quads ending in previous `soft-break?` - ;; current-partial = list of unbreakable quads - ;; wraps = list of (list of quads) - (let loop ([wraps null][current-wrap null][current-partial null][current-dist start-signal][qs qs]) - (match qs - [(== empty) - (when debug (report 'all-quads-wrapped)) - ;; combine the segments into a flat list, and drop any trailing breaks - ;; (on the idea that breaks should separate things, and there's nothing left to separate) - ;; wraps alternate with breaks - (debug-report wraps) - ;; use false as signal to indicate the end - (define last-wrap (append-to-wrap #false (append-to-wrap current-partial current-wrap))) - (for/list ([wrap (in-list (cons last-wrap wraps))]) - (match wrap - [(list (? nonprinting-at-end?)) wrap] ; matches break signals - ;; pieces will have been accumulated in reverse order - ;; thus beginning of list represents the end of the wrap - [(list (? (conjoin soft-break? nonprinting-at-end?)) ... rest ...) - (debug-report (finish-wrap-proc (reverse rest))) - (finish-wrap-proc (reverse rest))]))] - [(cons q other-qs) - (debug-report q 'next-q) - (define at-start? (eq? current-dist start-signal)) - (cond - [at-start? - (cond - [(and (soft-break? q) (nonprinting-at-start? q)) - (debug-report q 'skipping-soft-break-at-beginning) - ;; skip it - (loop wraps - current-wrap - current-partial - current-dist - other-qs)] - [else ; printing quad - (debug-report 'hard-quad-at-start) - (loop wraps - current-wrap - (cons q current-partial) - (distance q) - other-qs)])] - [else - (define dist (if (and (quad? q) (printable? q)) (distance q) 0)) - (debug-report current-dist) - (debug-report dist) - (define would-overflow? (> (+ dist current-dist) target-size)) - (cond - [would-overflow? - (cond - [(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 - (loop wraps - (append-to-wrap (cons q current-partial) current-wrap) - null - (+ dist current-dist) - other-qs)] - [else - (debug-report 'would-overflow-hard) - (debug-report (empty? current-wrap)) - ;; finish the wrap & reset the line without consuming a quad - (if (empty? current-wrap) ; means we have not captured a soft break - (loop (list* (list break-val) current-partial wraps) - current-wrap ; which is empty - null - start-signal - qs) - (loop (list* (list break-val) current-wrap wraps) - null - current-partial - (apply + (map distance current-partial)) - qs))])] - [else - (cond - [(soft-break? q) ; printing soft break, like a hyphen - (debug-report 'would-not-overflow-soft) - ;; a soft break that fits, so move it on top of the current-wrap with the current-partial - (cond - [else - (loop wraps - (append-to-wrap (cons q current-partial) current-wrap) - null - (+ dist current-dist) - other-qs)])] - [else - (debug-report 'would-not-overflow) - ;; add to partial - (loop wraps - current-wrap - (cons q current-partial) - (+ dist current-dist) - other-qs)])]) - - ])]))) + (for/fold ([wraps null] ; list of (list of quads) + [current-wrap null] ; list of quads ending in previous `soft-break?` + [current-partial null] ; list of unbreakable quads + [current-dist #false] ; #false (to indicate start) or integer + [qs qs] ; list of quads + #:result (let () + (define last-wrap (append-to-wrap #false (append-to-wrap current-partial current-wrap))) + (finish-wraps (cons last-wrap wraps) finish-wrap-proc soft-break?))) + ([i (in-naturals)] + #:break (empty? qs)) + (match-define (cons q other-qs) qs) + (debug-report q 'next-q) + (define at-start? (not current-dist)) + (define dist (if (and (quad? q) (printable? q)) (distance q) 0)) + (define would-overflow? (and current-dist (> (+ dist current-dist) target-size))) + (cond + [(and at-start? (soft-break? q) (nonprinting-at-start? q)) + (debug-report q 'skipping-soft-break-at-beginning) + (values wraps + current-wrap + current-partial + current-dist + other-qs)] + [at-start? + (debug-report 'hard-quad-at-start) + (values wraps + current-wrap + (list q) + (distance q) + other-qs)] + [(and would-overflow? (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 + (values wraps + (append-to-wrap (cons q current-partial) current-wrap) + null + (+ dist current-dist) + other-qs)] + [(and would-overflow? (empty? current-wrap)) + (debug-report 'would-overflow-hard-without-captured-break) + (values (list* (list break-val) current-partial wraps) + null + null + #false + qs)] + [would-overflow? ; finish the wrap & reset the line without consuming a quad + (values (list* (list break-val) current-wrap wraps) + null + current-partial + (apply + (map distance current-partial)) + qs)] + [(soft-break? q) ; printing soft break, like a hyphen + (debug-report 'would-not-overflow-soft) + ;; a soft break that fits, so move it on top of the current-wrap with the current-partial + (values wraps + (append-to-wrap (cons q current-partial) current-wrap) + null + (+ dist current-dist) + other-qs)] + [else + (debug-report 'would-not-overflow) + ;; add to partial + (values wraps + current-wrap + (cons q current-partial) + (+ dist current-dist) + other-qs)]))) (define x (q (list 'size (pt 1 1)) #\x)) @@ -293,37 +274,37 @@ )) (module+ test - (test-case - "zero width nonbreakers" - (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 + "zero width nonbreakers" + (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)))) (module+ test - (test-case - "hard breaks" - (check-equal? (linewrap (list br) 2) (list)) ;; only insert a break if it's between things - (check-equal? (linewrap (list a br b) 2) (list a 'lb b)) - (check-equal? (linewrap (list a b br) 2) (list a b)) - (check-equal? (linewrap (list a b br br) 2) (list a b)) - (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 + "hard breaks" + (check-equal? (linewrap (list br) 2) (list)) ;; only insert a break if it's between things + (check-equal? (linewrap (list a br b) 2) (list a 'lb b)) + (check-equal? (linewrap (list a b br) 2) (list a b)) + (check-equal? (linewrap (list a b br br) 2) (list a b)) + (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)))) (module+ test - (test-case - "hard breaks and spurious spaces" - (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)))) + (test-case + "hard breaks and spurious spaces" + (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 [debug #f]) (apply string (for/list ([b (in-list (linewrap (for/list ([atom (atomize str)]) @@ -334,24 +315,24 @@ [else #\|])))) (module+ test - (test-case - "visual breaks" - (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"))) + (test-case + "visual breaks" + (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 (pagewrap xs size [debug #f]) @@ -363,34 +344,34 @@ (define pbr (q '(size #f) #\page)) (module+ test - (test-case - "soft page breaks" - (check-equal? (pagewrap null 2) '(pb)) - (check-equal? (pagewrap (list x) 2) (list 'pb x)) - (check-equal? (pagewrap (list x x) 2) (list 'pb x x)) - (check-equal? (pagewrap (list x x x) 1) (list 'pb x 'pb x 'pb x)) - (check-equal? (pagewrap (list x x x) 2) (list 'pb x x 'pb x)) - (check-equal? (pagewrap (list x x x) 3) (list 'pb x x x)) - (check-equal? (pagewrap (list x x x) 4) (list 'pb x x x)) - (check-equal? (pagewrap (list x 'lb x x) 2) (list 'pb x 'pb x x)))) + (test-case + "soft page breaks" + (check-equal? (pagewrap null 2) '(pb)) + (check-equal? (pagewrap (list x) 2) (list 'pb x)) + (check-equal? (pagewrap (list x x) 2) (list 'pb x x)) + (check-equal? (pagewrap (list x x x) 1) (list 'pb x 'pb x 'pb x)) + (check-equal? (pagewrap (list x x x) 2) (list 'pb x x 'pb x)) + (check-equal? (pagewrap (list x x x) 3) (list 'pb x x x)) + (check-equal? (pagewrap (list x x x) 4) (list 'pb x x x)) + (check-equal? (pagewrap (list x 'lb x x) 2) (list 'pb x 'pb x x)))) (module+ test - (test-case - "hard page breaks" - (check-equal? (pagewrap (list x pbr x x) 2) (list 'pb x 'pb x x)) - (check-equal? (pagewrap (list x pbr x x) 1) (list 'pb x 'pb x 'pb x)) - (check-equal? (pagewrap (list x pbr pbr x x) 1) (list 'pb x 'pb 'pb x 'pb x)) - (check-equal? (pagewrap (list x pbr pbr x x) 2) (list 'pb x 'pb 'pb x x)) - (check-equal? (pagewrap (list 'lb x 'lb 'lb pbr 'lb x x 'lb) 2) (list 'pb x 'pb x x)))) + (test-case + "hard page breaks" + (check-equal? (pagewrap (list x pbr x x) 2) (list 'pb x 'pb x x)) + (check-equal? (pagewrap (list x pbr x x) 1) (list 'pb x 'pb x 'pb x)) + (check-equal? (pagewrap (list x pbr pbr x x) 1) (list 'pb x 'pb 'pb x 'pb x)) + (check-equal? (pagewrap (list x pbr pbr x x) 2) (list 'pb x 'pb 'pb x x)) + (check-equal? (pagewrap (list 'lb x 'lb 'lb pbr 'lb x x 'lb) 2) (list 'pb x 'pb x x)))) (module+ test - (test-case - "composed line breaks and page breaks" - (check-equal? (pagewrap (linewrap null 1) 2) '(pb) ) - (check-equal? (pagewrap (linewrap (list x) 1) 2) (list 'pb x)) - (check-equal? (pagewrap (linewrap (list x x x) 1) 2) (list 'pb x 'lb x 'pb x)) - (check-equal? (pagewrap (linewrap (list x x x) 2) 2) (list 'pb x x 'pb x)) - (check-equal? (pagewrap (linewrap (list x x x) 2) 1) (list 'pb x 'pb x 'pb x)))) + (test-case + "composed line breaks and page breaks" + (check-equal? (pagewrap (linewrap null 1) 2) '(pb) ) + (check-equal? (pagewrap (linewrap (list x) 1) 2) (list 'pb x)) + (check-equal? (pagewrap (linewrap (list x x x) 1) 2) (list 'pb x 'lb x 'pb x)) + (check-equal? (pagewrap (linewrap (list x x x) 2) 2) (list 'pb x x 'pb x)) + (check-equal? (pagewrap (linewrap (list x x x) 2) 1) (list 'pb x 'pb x 'pb x)))) (struct $slug $quad () #:transparent) (define (slug . xs) ($slug #f xs)) @@ -402,12 +383,12 @@ #:finish-wrap-proc (λ (pcs) (list ($slug #f pcs))))) (module+ test - (test-case - "hard breaks and spurious spaces with slugs" - (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))))) + (test-case + "hard breaks and spurious spaces with slugs" + (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)))))