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

refac

Browse Source
main
Matthew Butterick 6 years ago
parent 59ffecf689
commit 1d09780840
1 changed files with 100 additions and 97 deletions
Show Stats Download Patch File Download Diff File

197
quad/quad/break.rkt
Unescape Escape View File

@ -19,9 +19,15 @@
(define (break xs (define (break xs
[target-size (current-wrap-distance)] [target-size (current-wrap-distance)]
[debug #f] [debug #f]
#:hard-break-proc [hard-break? (λ xs #f)] #:hard-break-proc [hard-break? (λ (x) #f)]
#:soft-break-proc [soft-break? (λ xs #f)] #:soft-break-proc [soft-break? (λ (x) #f)]
#:finish-wrap-proc [finish-wrap-proc list]) #:finish-wrap-proc [finish-wrap-proc list])
#;((listof quad?)
(real?
any/c
#:hard-break-proc (any/c . -> . any/c)
#:soft-break-proc (any/c . -> . any/c)
#:finish-wrap-proc ((listof any/c) . -> . (listof any/c))) . ->* . (listof any/c))
(break-hards xs (break-hards xs
target-size target-size
debug debug
@ -37,26 +43,26 @@
hard-break? hard-break?
soft-break? soft-break?
finish-wrap-proc) finish-wrap-proc)
(define (cleanup-wraplist xs) (define (cleanup-wraplist xs) (append* (reverse xs)))
(append* (reverse xs))) (let loop ([wraps null][xs xs])
(define wraps (match xs
(let loop ([wraps null][xs xs]) [(? null?) (cleanup-wraplist wraps)]
(match xs [(cons (? hard-break?) rest)
[(? null?) wraps] (debug-report x 'hard-break)
[(cons (? hard-break?) rest) (loop wraps rest)]
(debug-report x 'hard-break) [_ (define-values (head tail) (splitf-at xs (λ (x) (not (hard-break? x)))))
(loop wraps rest)] (loop (cons (cleanup-wraplist (break-softs head
[_ (define-values (head tail) (splitf-at xs (λ (x) (not (hard-break? x))))) target-size
(loop (cons (cleanup-wraplist (break-softs head debug
target-size soft-break?
debug finish-wrap-proc)) wraps) tail)])))
soft-break?
finish-wrap-proc)) wraps) tail)]))) (define (nonprinting-at-start? x)
(cleanup-wraplist wraps)) (not (printable? x 'start)))
(define (nonprinting-at-end? x)
(define (nonprinting-at-start? x) (if (quad? x) (not (printable? x 'start)) #t)) (not (printable? x 'end)))
(define (nonprinting-at-end? x) (if (quad? x) (not (printable? x 'end)) #t)) (define (nonprinting-in-middle-soft-break? x)
(define (nonprinting-in-middle-soft-break? x) (and (quad? x) (not (printable? x)) (soft-break? x))) (and (not (printable? x)) (soft-break? x)))
(define (wrap-append partial wrap) (define (wrap-append partial wrap)
(match/values (match/values
@ -64,89 +70,86 @@
[((== empty) _) wrap] [((== empty) _) wrap]
[(partial (list (? nonprinting-in-middle-soft-break?) ... rest ...)) (append (or partial null) rest)])) [(partial (list (? nonprinting-in-middle-soft-break?) ... rest ...)) (append (or partial null) rest)]))
(define (break-softs qs (define (break-softs qs
target-size target-size
debug debug
soft-break? soft-break?
finish-wrap-proc) finish-wrap-proc)
(for/fold ([wraps null] ; list of (list of quads) (let loop ([wraps null] ; list of (list of quads)
[next-wrap-head null] ; list of quads ending in previous `soft-break?` [next-wrap-head null] ; list of quads ending in previous `soft-break?`
[next-wrap-tail null] ; list of unbreakable quads [next-wrap-tail null] ; list of unbreakable quads
[current-dist #false] ; #false (to indicate start) or integer [current-dist #false] ; #false (to indicate start) or integer
[qs qs] ; list of quads [qs qs]) ; list of quads
#:result (let () (match qs
(define last-wrap (wrap-append #false (wrap-append next-wrap-tail next-wrap-head))) [(== empty) (define last-wrap (wrap-append #false (wrap-append next-wrap-tail next-wrap-head)))
(define finished-wraps (for/list ([wrap (in-list (cons last-wrap wraps))])
(for/list ([wrap (in-list (cons last-wrap wraps))]) ;; pieces will have been accumulated in reverse order
(match wrap ;; thus beginning of list represents the end of the wrap
[(list (? nonprinting-at-end?)) wrap] ; matches break signals (match wrap
;; pieces will have been accumulated in reverse order [(list (and (? soft-break?) (? nonprinting-at-end?)) ... rest ...)
;; thus beginning of list represents the end of the wrap (finish-wrap-proc (reverse rest))]))]
[(list (and (? soft-break?) (? nonprinting-at-end?)) ... rest ...) [(cons q other-qs)
(finish-wrap-proc (reverse rest))]))) (debug-report q 'next-q)
finished-wraps)) (debug-report (quad-elems q) 'next-q-elems)
([i (in-naturals)] (define at-start? (not current-dist))
#:break (empty? qs)) (define dist (if (and (quad? q) (printable? q)) (distance q) 0))
(match-define (cons q other-qs) qs) (define would-overflow? (and current-dist (> (+ dist current-dist) target-size)))
(debug-report q 'next-q) (cond
(debug-report (quad-elems q) 'next-q-elems) [at-start?
(define at-start? (not current-dist)) (cond
(define dist (if (and (quad? q) (printable? q)) (distance q) 0)) [(and (soft-break? q) (nonprinting-at-start? q))
(define would-overflow? (and current-dist (> (+ dist current-dist) target-size))) (debug-report q 'skipping-soft-break-at-beginning)
(cond (loop wraps
[(and at-start? (soft-break? q) (nonprinting-at-start? q)) next-wrap-head
(debug-report q 'skipping-soft-break-at-beginning) next-wrap-tail
(values wraps current-dist
next-wrap-head other-qs)]
next-wrap-tail [else (debug-report 'hard-quad-at-start)
current-dist (loop wraps
other-qs)] next-wrap-head
[at-start? (list q)
(debug-report 'hard-quad-at-start) (distance q)
(values wraps other-qs)])]
next-wrap-head [would-overflow?
(list q) (cond
(distance q) [(and (soft-break? q) (nonprinting-at-end? q))
other-qs)] (debug-report 'would-overflow-soft-nonprinting)
[(and would-overflow? (soft-break? q) (nonprinting-at-end? q)) ;; a break is inevitable but we want to wait to finish the wrap until we see a hard quad
(debug-report 'would-overflow-soft-nonprinting) ;; but we can move the current-partial into the current-wrap
;; a break is inevitable but we want to wait to finish the wrap until we see a hard quad (loop wraps
;; but we can move the current-partial into the current-wrap (wrap-append (cons q next-wrap-tail) next-wrap-head)
(values wraps null
(wrap-append (cons q next-wrap-tail) next-wrap-head) (+ dist current-dist)
null other-qs)]
(+ dist current-dist) [(empty? next-wrap-head)
other-qs)] (debug-report 'would-overflow-hard-without-captured-break)
[(and would-overflow? (empty? next-wrap-head)) (loop (cons next-wrap-tail wraps)
(debug-report 'would-overflow-hard-without-captured-break) null
(values (cons next-wrap-tail wraps) null
null #false
null qs)]
#false [else ; finish the wrap & reset the line without consuming a quad
qs)] (loop (cons next-wrap-head wraps)
[would-overflow? ; finish the wrap & reset the line without consuming a quad null
(values (cons next-wrap-head wraps) next-wrap-tail
null (apply + (map distance next-wrap-tail))
next-wrap-tail qs)])]
(apply + (map distance next-wrap-tail)) [(soft-break? q) ; printing soft break, like a hyphen
qs)] (debug-report 'would-not-overflow-soft)
[(soft-break? q) ; printing soft break, like a hyphen ;; a soft break that fits, so move it on top of the next-wrap-head with the next-wrap-tail
(debug-report 'would-not-overflow-soft) (loop wraps
;; a soft break that fits, so move it on top of the next-wrap-head with the next-wrap-tail (wrap-append (cons q next-wrap-tail) next-wrap-head)
(values wraps null
(wrap-append (cons q next-wrap-tail) next-wrap-head) (+ dist current-dist)
null other-qs)]
(+ dist current-dist) [else
other-qs)] (debug-report 'would-not-overflow)
[else ;; add to partial
(debug-report 'would-not-overflow) (loop wraps
;; add to partial next-wrap-head
(values wraps (cons q next-wrap-tail)
next-wrap-head (+ dist current-dist)
(cons q next-wrap-tail) other-qs)])])))
(+ dist current-dist)
other-qs)])))
(define q-zero (q #:size (pt 0 0))) (define q-zero (q #:size (pt 0 0)))

Write Preview
Loading…
Cancel
Save