From ae5c5eeb1a1c758e045be8d9ae121e6ff7003146 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 19 Mar 2019 16:16:04 -0700 Subject: [PATCH] perhaps --- quad/quad/wrap.rkt | 80 +++++++++++++++++++++++++++++----------------- 1 file changed, 51 insertions(+), 29 deletions(-) diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt index c1c6dc05..d8f209f2 100644 --- a/quad/quad/wrap.rkt +++ b/quad/quad/wrap.rkt @@ -28,13 +28,24 @@ ;; for instance, a hyphen is `soft-break?` but shouldn't be trimmed. (finish-wrap-func (reverse (dropf qs nonprinting-at-end?)) previous-wrap-ender wrap-triggering-q wrap-idx)) +(define (make-max-distance-proc max-distance-proc-arg) + (match max-distance-proc-arg + [(? procedure? proc) proc] + [val (λ (q idx) val)])) + (define (finalize-reversed-wraps wraps) (match (append* (reverse wraps)) [(list (list)) (list)] [wraps wraps])) +(define ((make-hard-break-pred hard-break-func no-break-func) x) + (and (hard-break-func x) (or (not no-break-func) (not (no-break-func x))))) + +(define ((make-soft-break-pred soft-break-func no-break-func) x) + (and (soft-break-func x) (or (not no-break-func) (not (no-break-func x))))) + (define (wrap qs - [target-size-proc-arg (current-wrap-distance)] + [max-distance-proc-arg (current-wrap-distance)] [debug #f] ;; hard break: must wrap #:hard-break [hard-break-func (λ (x) #f)] @@ -60,11 +71,9 @@ ;; (q0 is not part of this wrap, but q is) ;; idx is current wrap-count value. #:finish-wrap [finish-wrap-func default-finish-wrap-func]) - (define (hard-break? x) (and (hard-break-func x) (or (not no-break-func) (not (no-break-func x))))) - (define (soft-break? x) (and (soft-break-func x) (or (not no-break-func) (not (no-break-func x))))) - (define target-size-proc (match target-size-proc-arg - [(? procedure? proc) proc] - [val (λ (q idx) val)])) + (define hard-break? (make-hard-break-pred hard-break-func no-break-func)) + (define soft-break? (make-soft-break-pred soft-break-func no-break-func)) + (define max-distance-proc (make-max-distance-proc max-distance-proc-arg)) ; takes quads in wrap, triggering quad, and wrap idx; returns list containing wrap (and maybe other things) (define finish-wrap (make-finish-wrap finish-wrap-func)) (let loop ([wraps null] ; list of (list of quads) @@ -116,8 +125,9 @@ previous-wrap-ender other-qs)])] [else ; cases that require computing distance - (define cumulative-dist (distance-func q current-dist would-be-wrap-qs)) - (define would-overflow? (> cumulative-dist (target-size-proc q wrap-idx))) + (define wrap-distance (distance-func q current-dist would-be-wrap-qs)) + (define max-distance (max-distance-proc q wrap-idx)) + (define would-overflow? (> wrap-distance max-distance)) (cond [would-overflow? (cond @@ -129,7 +139,7 @@ wrap-idx (wrap-append (cons q next-wrap-tail) next-wrap-head) null - cumulative-dist + wrap-distance previous-wrap-ender other-qs)] [(empty? next-wrap-head) @@ -167,7 +177,7 @@ wrap-idx (wrap-append (cons q next-wrap-tail) next-wrap-head) null - cumulative-dist + wrap-distance previous-wrap-ender other-qs)] [else @@ -177,12 +187,12 @@ wrap-idx next-wrap-head (cons q next-wrap-tail) - cumulative-dist + wrap-distance previous-wrap-ender other-qs)])])]))) (define (wrap-best qs - [target-size-proc-arg (current-wrap-distance)] + [max-distance-proc-arg (current-wrap-distance)] [debug #f] ;; hard break: must wrap #:hard-break [hard-break-func (λ (x) #f)] @@ -208,37 +218,49 @@ ;; (q0 is not part of this wrap, but q is) ;; idx is current wrap-count value. #:finish-wrap [finish-wrap-func default-finish-wrap-func]) - (define (hard-break? x) (and (hard-break-func x) (or (not no-break-func) (not (no-break-func x))))) - (define (soft-break? x) (and (soft-break-func x) (or (not no-break-func) (not (no-break-func x))))) + (define hard-break? (make-hard-break-pred hard-break-func no-break-func)) + (define soft-break? (make-soft-break-pred soft-break-func no-break-func)) + (define max-distance-proc (make-max-distance-proc max-distance-proc-arg)) (define finish-wrap (make-finish-wrap finish-wrap-func)) - (define measure target-size-proc-arg) (struct $penalty (val idx) #:transparent) (define (penalty i j) (match-define ($penalty last-val last-idx) (ocm-min-value ocm i)) (cond - [(> j (vector-length pieces)) ($penalty (- i) last-idx)] + [(> j (vector-length pieces)) + (define out-of-bounds-signal (- i)) + ($penalty out-of-bounds-signal last-idx)] [else + (define would-be-wrap-qs (pieces-sublist i j)) (define last-q (vector-ref pieces (sub1 j))) - (define wrap-qs (pieces-sublist i j)) - (define this-idx (wrap-count last-idx last-q)) - (define line-width (length wrap-qs)) - (define underflow (- measure line-width)) + (define wrap-idx (wrap-count last-idx last-q)) + (define wrap-distance (for/fold ([last-dist 0]) + ([q (in-list would-be-wrap-qs)]) + (distance-func q last-dist would-be-wrap-qs))) + (define measure (max-distance-proc (car would-be-wrap-qs) wrap-idx)) + (define underflow (- measure wrap-distance)) ($penalty - (+ last-val ; include penalty so far - (if (negative? underflow) - ;; overfull line: huge penalty prevents break; multiplier is essential for monotonicity. - (* 1e8 (- underflow)) - ;; standard penalty - (expt underflow 2))) - this-idx)])) + (+ last-val ; include penalty so far + (if (negative? underflow) + ;; overfull line: huge penalty prevents break; multiplier is essential for monotonicity. + (* 1e8 (- underflow)) + ;; standard penalty + (expt underflow 2))) + wrap-idx)])) (define ocm (make-ocm penalty ($penalty 0 (sub1 initial-wrap-idx)) $penalty-val)) ;; starting from last position, ask ocm for position of row minimum (= new-pos) ;; collect this value, and use it as the input next time ;; until you reach first position. (define pieces (list->vector (slicef-after qs (λ (q) (or (hard-break? q) (soft-break? q)) )))) - (define (pieces-sublist i j) (apply append (vector->list (vector-copy pieces i j)))) + (define (pieces-sublist i j) + ;; nonprinting-soft-break-in-middle? is soft hyphen. + ;; if a soft hyphen is in the middle of a pieces-sublist, it's superfluous. + ;; the ones that will end up in the middle are the ones at the end of every piece except the last. + ;; and the last can drop the nonprinting-at-end? + (apply append (for*/list ([n (in-range i j)] + [pcs (in-value (vector-ref pieces n))]) + (dropf-right pcs (if (= n j) nonprinting-at-end? nonprinting-soft-break-in-middle?))))) (define last-j (vector-length pieces)) (define bps (let loop ([j last-j][bps (list last-j)]) ; start from end @@ -252,7 +274,7 @@ ([i (in-list bps)] [j (in-list (cdr bps))]) (define wrap-qs (reverse (pieces-sublist i j))) ; first-fit gets wrap-qs in reverse, so be consistent - (define previous-wrap-ender (and (positive? i) (vector-ref pieces (sub1 i)))) + (define previous-wrap-ender (and (not (zero? i)) (vector-ref pieces (sub1 i)))) (define wrap-triggering-q (and (not (= j (vector-length pieces))) (car wrap-qs))) (values (cons (finish-wrap wrap-qs previous-wrap-ender wrap-idx wrap-triggering-q) wraps) (wrap-count wrap-idx (car wrap-qs)))))