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

change

Browse Source
main
Matthew Butterick 6 years ago
parent 9f6e45553f
commit 49c9197715
1 changed files with 65 additions and 78 deletions
Show Stats Download Patch File Download Diff File

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

@ -51,7 +51,6 @@
(define wrap-proc (if nicely? wrap-best wrap-first))
(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 max-distance-proc (match max-distance-proc-arg
[(? procedure? proc) proc]
[val (λ (q idx) val)]))
@ -64,7 +63,6 @@
;; note: we don't trim `soft-break?` or `hard-break?` because that's an orthogonal consideration
;; 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))
(wrap-proc qs max-distance-proc debug hard-break? soft-break? finish-wrap wrap-count distance-func initial-wrap-idx))
(define (wrap-first qs max-distance-proc debug hard-break? soft-break? finish-wrap wrap-count distance-func initial-wrap-idx)
@ -75,7 +73,6 @@
[current-dist #false] ; #false (to indicate start) or integer
[previous-wrap-ender #f]
[qs qs]) ; list of quads
(match qs
[(or (== empty) (list (? hard-break?))) ; ignore single trailing hard break
(define last-wrap (finish-wrap (append next-wrap-tail next-wrap-head) previous-wrap-ender wrap-idx #f))
@ -184,77 +181,67 @@
(define last-line-can-be-short? #t)
(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))))
(reverse (apply append (for/list ([n (in-range i j)])
(vector-ref pieces n)))))
(define (wrap-best qs max-distance-proc debug hard-break? soft-break? finish-wrap wrap-count distance-func initial-wrap-idx)
(define (wrap-pieces pieces starting-wrap-idx previous-last-q)
(struct $penalty (val idx last) #:transparent)
(define (penalty i j)
(cond
[(or (= i j) (> j (vector-length pieces)))
(define out-of-bounds-signal (- i))
($penalty out-of-bounds-signal #f #f)]
[else
(match-define ($penalty last-val starting-idx last-q) (ocm-min-value ocm i))
(define next-idx (wrap-count starting-idx last-q))
(define would-be-wrap-qs (reverse (pieces-sublist pieces i j))) ; `reverse` to track ordinary wrap logic
(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 underflow (- (max-distance-proc (car would-be-wrap-qs) starting-idx) wrap-distance))
($penalty
(+ last-val ; include penalty so far
(* (sub1 starting-idx) mega-penalty) ; new line penalty
(cond
[(negative? underflow)
;; overfull line: huge penalty prevents break; multiplier is essential for monotonicity.
(* mega-penalty (- underflow))]
[((if last-line-can-be-short? < <=) j (vector-length pieces))
;; standard penalty
(expt underflow 2)]
[else 0]))
next-idx
(car would-be-wrap-qs))]))
(define ocm (make-ocm penalty ($penalty 0 starting-wrap-idx previous-last-q) $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 breakpoints
(let ([last-j (vector-length pieces)])
(let loop ([j last-j][bps (list last-j)]) ; start from end
(define min-i (ocm-min-index ocm j)) ; look to the previous line
(if (zero? min-i) ; zero means we're at first position, and therefore done
(cons min-i bps)
(loop min-i (cons min-i bps))))))
(for/fold ([wraps null]
[wrap-idx starting-wrap-idx]
[previous-wrap-ender previous-last-q])
([i (in-list breakpoints)]
[j (in-list (cdr breakpoints))])
(define wrap-qs (reverse (pieces-sublist pieces i j))) ; first-fit gets wrap-qs in reverse, so be consistent
(values (cons (finish-wrap wrap-qs previous-wrap-ender wrap-idx) wraps)
(wrap-count wrap-idx (car wrap-qs))
(car wrap-qs))))
(for*/fold ([wrapss null]
[wrap-idx initial-wrap-idx]
[previous-wrap-ender #f]
#:result (finalize-reversed-wraps (apply append wrapss)))
([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 pieces-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))
(wrap-pieces-best pieces-vec wrap-idx previous-wrap-ender wrap-count distance-func max-distance-proc finish-wrap))
(values (cons wraps wrapss) idx ender)))
(struct penalty-rec (val idx) #:transparent)
(define (wrap-pieces-best pieces-vec starting-wrap-idx previous-last-q wrap-count distance-func max-distance-proc finish-wrap)
(define (penalty i j)
(cond
[(or (= i j) (> j (vector-length pieces-vec)))
(define out-of-bounds-signal (- i))
(penalty-rec out-of-bounds-signal #f)]
[else
(match-define (penalty-rec last-val starting-idx) (ocm-min-value ocm i))
(define would-be-wrap-qs (pieces-sublist pieces-vec i j)) ; `reverse` to track ordinary wrap logic
(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 underflow (- (max-distance-proc (car would-be-wrap-qs) starting-idx) wrap-distance))
(penalty-rec
(+ last-val ; include penalty so far
(* starting-idx mega-penalty) ; new line penalty
(cond
[(negative? underflow)
;; overfull line: huge penalty prevents break; multiplier is essential for monotonicity.
(* mega-penalty (- underflow))]
[((if last-line-can-be-short? < <=) j (vector-length pieces-vec))
;; standard penalty
(expt underflow 2)]
[else 0]))
(wrap-count starting-idx (car would-be-wrap-qs)))]))
;; 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 ocm (make-ocm penalty (penalty-rec 0 starting-wrap-idx) penalty-rec-val))
(define breakpoints
(let ([last-j (vector-length pieces-vec)])
(let loop ([bps (list last-j)]) ; start from end
(match (ocm-min-index ocm (car bps)) ; look to the previous line
[0 (cons 0 bps)]; zero means we're at first position, and therefore done
[min-i (loop (cons min-i bps))]))))
(for/fold ([wraps null]
[wrap-idx starting-wrap-idx]
[previous-wrap-ender previous-last-q])
([i (in-list breakpoints)]
[j (in-list (cdr breakpoints))])
(define wrap-qs (pieces-sublist pieces-vec i j)) ; first-fit gets wrap-qs in reverse, so be consistent
(values (cons (finish-wrap wrap-qs previous-wrap-ender wrap-idx) wraps)
(wrap-count wrap-idx (car wrap-qs))
(car wrap-qs))))
(module+ test
(define q-zero (q #:size (pt 0 0)))
@ -328,20 +315,20 @@
(module+ test (require rackunit))
(module+ test
(test-case
"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."
(check-equal? (linewrap meg-is-an-ally 6)
;; Meg is
;; an
;; ally.
(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)
;; Meg
;; is an
;; ally.
(list (list a b c) lbr (list a b sp c d) lbr (list a b c d x)))))
#;(module+ test
(test-case
"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."
(check-equal? (linewrap meg-is-an-ally 6)
;; Meg is
;; an
;; ally.
(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)
;; Meg
;; is an
;; ally.
(list (list a b c) lbr (list a b sp c d) lbr (list a b c d x)))))
(module+ test
(test-begin

Write Preview
Loading…
Cancel
Save