mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

keep hope alive

Browse Source
main
Matthew Butterick 5 years ago
parent f2d29257d5
commit 9f6e45553f
1 changed files with 84 additions and 70 deletions
Show Stats Download Patch File Download Diff File

154
quad/quad/wrap.rkt
Unescape Escape View File

@ -183,64 +183,78 @@
(define last-line-can-be-short? #t) (define last-line-can-be-short? #t)
(define mega-penalty 1e8) (define mega-penalty 1e8)
(define (pieces-sublist pieces 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))])
(if (= n j) (dropf-right pcs nonprinting-at-end?) pcs))))
(define (wrap-best qs max-distance-proc debug hard-break? soft-break? finish-wrap wrap-count distance-func initial-wrap-idx) (define (wrap-best qs max-distance-proc debug hard-break? soft-break? finish-wrap wrap-count distance-func initial-wrap-idx)
(struct $penalty (val idx) #:transparent)
(define (penalty i j) (define (wrap-pieces pieces starting-wrap-idx previous-last-q)
(match-define ($penalty last-val last-idx) (ocm-min-value ocm i)) (struct $penalty (val idx last) #:transparent)
(cond (define (penalty i j)
[(or (= i j) (> j (vector-length pieces))) (cond
(define out-of-bounds-signal (- i)) [(or (= i j) (> j (vector-length pieces)))
($penalty out-of-bounds-signal last-idx)] (define out-of-bounds-signal (- i))
[else ($penalty out-of-bounds-signal #f #f)]
(define last-q (last (vector-ref pieces (sub1 j)))) [else
(define wrap-idx (wrap-count last-idx last-q)) (match-define ($penalty last-val starting-idx last-q) (ocm-min-value ocm i))
(define would-be-wrap-qs (pieces-sublist i j)) (define next-idx (wrap-count starting-idx last-q))
(define wrap-distance (for/fold ([last-dist 0]) (define would-be-wrap-qs (reverse (pieces-sublist pieces i j))) ; `reverse` to track ordinary wrap logic
([q (in-list would-be-wrap-qs)]) (define wrap-distance (for/fold ([last-dist 0])
(distance-func q last-dist would-be-wrap-qs))) ([q (in-list would-be-wrap-qs)])
(define measure (max-distance-proc (car would-be-wrap-qs) wrap-idx)) (distance-func q last-dist would-be-wrap-qs)))
(define underflow (- measure wrap-distance)) (define underflow (- (max-distance-proc (car would-be-wrap-qs) starting-idx) wrap-distance))
($penalty ($penalty
(+ last-val ; include penalty so far (+ last-val ; include penalty so far
(* (sub1 wrap-idx) mega-penalty) ; new line penalty (* (sub1 starting-idx) mega-penalty) ; new line penalty
(cond (cond
;; overfull line: huge penalty prevents break; multiplier is essential for monotonicity. [(negative? underflow)
[(negative? underflow) (* mega-penalty (- underflow))] ;; overfull line: huge penalty prevents break; multiplier is essential for monotonicity.
;; standard penalty (* mega-penalty (- underflow))]
[((if last-line-can-be-short? < <=) j (vector-length pieces)) (expt underflow 2)] [((if last-line-can-be-short? < <=) j (vector-length pieces))
[else 0])) ;; standard penalty
wrap-idx)])) (expt underflow 2)]
[else 0]))
(define ocm (make-ocm penalty ($penalty 0 (sub1 initial-wrap-idx)) $penalty-val)) next-idx
;; starting from last position, ask ocm for position of row minimum (= new-pos) (car would-be-wrap-qs))]))
;; collect this value, and use it as the input next time
;; until you reach first position. (define ocm (make-ocm penalty ($penalty 0 starting-wrap-idx previous-last-q) $penalty-val))
(define pieces (list->vector (slicef-after qs (λ (q) (or (hard-break? q) (soft-break? q)) )))) ;; starting from last position, ask ocm for position of row minimum (= new-pos)
(define (pieces-sublist i j) ;; collect this value, and use it as the input next time
;; nonprinting-soft-break-in-middle? is soft hyphen. ;; until you reach first position.
;; 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. (define breakpoints
;; and the last can drop the nonprinting-at-end? (let ([last-j (vector-length pieces)])
(apply append (for*/list ([n (in-range i j)] (let loop ([j last-j][bps (list last-j)]) ; start from end
[pcs (in-value (vector-ref pieces n))]) (define min-i (ocm-min-index ocm j)) ; look to the previous line
(if (= n j) (dropf-right pcs nonprinting-at-end?) pcs)))) (if (zero? min-i) ; zero means we're at first position, and therefore done
(define last-j (vector-length pieces)) (cons min-i bps)
(define bps (loop min-i (cons min-i bps))))))
(let loop ([j last-j][bps (list last-j)]) ; start from end (for/fold ([wraps null]
(define min-i (ocm-min-index ocm j)) ; look to the previous line [wrap-idx starting-wrap-idx]
(if (zero? min-i) ; zero means we're at first position, and therefore done [previous-wrap-ender previous-last-q])
(cons min-i bps) ([i (in-list breakpoints)]
(loop min-i (cons min-i bps))))) [j (in-list (cdr breakpoints))])
(for/fold ([wraps null] (define wrap-qs (reverse (pieces-sublist pieces i j))) ; first-fit gets wrap-qs in reverse, so be consistent
[wrap-idx initial-wrap-idx] (values (cons (finish-wrap wrap-qs previous-wrap-ender wrap-idx) wraps)
#:result (finalize-reversed-wraps wraps)) (wrap-count wrap-idx (car wrap-qs))
([i (in-list bps)] (car wrap-qs))))
[j (in-list (cdr bps))])
(define wrap-qs (reverse (pieces-sublist i j))) ; first-fit gets wrap-qs in reverse, so be consistent (for*/fold ([wrapss null]
(define previous-wrap-ender (and (not (zero? i)) (last (vector-ref pieces (sub1 i))))) [wrap-idx initial-wrap-idx]
(define wrap-triggering-q (and (not (= j (vector-length pieces))) (car wrap-qs))) [previous-wrap-ender #f]
(values (cons (finish-wrap wrap-qs previous-wrap-ender wrap-idx wrap-triggering-q) wraps) #:result (finalize-reversed-wraps (apply append wrapss)))
(wrap-count wrap-idx (car wrap-qs))))) ([pieces-ending-in-hard-break (in-list (slicef-after qs hard-break?))])
(define piece-vec (list->vector (slicef-after pieces-ending-in-hard-break soft-break?)))
(define-values (wraps idx ender)
(wrap-pieces piece-vec wrap-idx previous-wrap-ender))
(values (cons wraps wrapss) idx ender)))
(module+ test (module+ test
(define q-zero (q #:size (pt 0 0))) (define q-zero (q #:size (pt 0 0)))
@ -315,19 +329,19 @@
(module+ test (require rackunit)) (module+ test (require rackunit))
(module+ test (module+ test
(test-case (test-case
"kp linebreaking" "kp linebreaking"
(define meg-is-an-ally (list a b c sp a b sp c d sp a b c d x)) ; "Meg is an ally." (define meg-is-an-ally (list a b c sp a b sp c d sp a b c d x)) ; "Meg is an ally."
(check-equal? (linewrap meg-is-an-ally 6) (check-equal? (linewrap meg-is-an-ally 6)
;; Meg is ;; Meg is
;; an ;; an
;; ally. ;; ally.
(list (list a b c sp a b) lbr (list c d) lbr (list a b c d x))) (list (list a b c sp a b) lbr (list c d) lbr (list a b c d x)))
(check-equal? (linewrap meg-is-an-ally 6 #:nicely #t) (check-equal? (linewrap meg-is-an-ally 6 #:nicely #t)
;; Meg ;; Meg
;; is an ;; is an
;; ally. ;; ally.
(list (list a b c) lbr (list a b sp c d) lbr (list a b c d x))))) (list (list a b c) lbr (list a b sp c d) lbr (list a b c d x)))))
(module+ test (module+ test
(test-begin (test-begin

Write Preview
Loading…
Cancel
Save