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

subseq

Browse Source
main
Matthew Butterick 6 years ago
parent 24208e3e24
commit 0608024893
2 changed files with 411 additions and 279 deletions
Show Stats Download Patch File Download Diff File

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

@ -99,15 +99,6 @@
[(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
@ -121,274 +112,284 @@
[qs qs] ; list of quads
#:result (let ()
(define last-wrap (wrap-append #false (wrap-append next-wrap-tail next-wrap-head)))
(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
next-wrap-head
next-wrap-tail
current-dist
other-qs)]
[at-start?
(debug-report 'hard-quad-at-start)
(values wraps
next-wrap-head
(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
(wrap-append (cons q next-wrap-tail) next-wrap-head)
null
(+ dist current-dist)
other-qs)]
[(and would-overflow? (empty? next-wrap-head))
(debug-report 'would-overflow-hard-without-captured-break)
(values (list* (list break-val) next-wrap-tail wraps)
null
null
#false
qs)]
[would-overflow? ; finish the wrap & reset the line without consuming a quad
(values (list* (list break-val) next-wrap-head wraps)
null
next-wrap-tail
(apply + (map distance next-wrap-tail))
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 next-wrap-head with the next-wrap-tail
(values wraps
(wrap-append (cons q next-wrap-tail) next-wrap-head)
null
(+ dist current-dist)
other-qs)]
[else
(debug-report 'would-not-overflow)
;; add to partial
(values wraps
next-wrap-head
(cons q next-wrap-tail)
(+ dist current-dist)
other-qs)])))
(define x (q (list 'size (pt 1 1)) #\x))
(define zwx (q (list 'size (pt 0 0)) #\z))
(define hyph (q (list 'size (pt 1 1)) #\-))
(define shy (q (list 'size (pt 1 1) 'printable? (λ (sig)
(case sig
[(end) #t]
[else #f]))) #\-))
(define a (q (list 'size (pt 1 1)) #\a))
(define b (q (list 'size (pt 1 1)) #\b))
(define c (q (list 'size (pt 1 1)) #\c))
(define d (q (list 'size (pt 1 1)) #\d))
(define sp (q (list 'size (pt 1 1) 'printable? (λ (sig)
(case sig
[(start end) #f]
[else #t]))) #\space))
(define br (q (list 'size (pt 0 0) 'printable? #f) #\newline))
(define soft-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space #\-)))))
(define (linewrap xs size [debug #f])
(break xs size debug
#:break-val 'lb
#:hard-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
#:soft-break-proc soft-break?))
(require rackunit)
(module+ test
(test-case
"chars"
(check-equal? (linewrap (list) 1) null)
(check-equal? (linewrap (list a) 1) (list a))
(check-equal? (linewrap (list a b) 1) (list a 'lb b))
(check-equal? (linewrap (list a b c) 1) (list a 'lb b 'lb c))
(check-equal? (linewrap (list a b c) 2) (list a b 'lb c))
(check-equal? (linewrap (list x x x x) 2) (list x x 'lb x x))
(check-equal? (linewrap (list x x x x x) 3) (list x x x 'lb x x))
(check-equal? (linewrap (list x x x x x) 1) (list x 'lb x 'lb x 'lb x 'lb x))
(check-equal? (linewrap (list x x x x x) 10) (list x x x x x))))
(module+ test
(test-case
"chars and spaces"
(check-equal? (linewrap (list a sp b) 1) (list a 'lb b))
(check-equal? (linewrap (list a b sp c) 2) (list a b 'lb c))
(check-equal? (linewrap (list a sp b) 3) (list a sp b))
(check-equal? (linewrap (list a sp b c) 3) (list a 'lb b c))))
(define finished-wraps
(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 ...)
(finish-wrap-proc (reverse rest))])))
(add-between finished-wraps (list break-val))))
([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
next-wrap-head
next-wrap-tail
current-dist
other-qs)]
[at-start?
(debug-report 'hard-quad-at-start)
(values wraps
next-wrap-head
(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
(wrap-append (cons q next-wrap-tail) next-wrap-head)
null
(+ dist current-dist)
other-qs)]
[(and would-overflow? (empty? next-wrap-head))
(debug-report 'would-overflow-hard-without-captured-break)
(values (cons next-wrap-tail wraps)
null
null
#false
qs)]
[would-overflow? ; finish the wrap & reset the line without consuming a quad
(values (cons next-wrap-head wraps)
null
next-wrap-tail
(apply + (map distance next-wrap-tail))
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 next-wrap-head with the next-wrap-tail
(values wraps
(wrap-append (cons q next-wrap-tail) next-wrap-head)
null
(+ dist current-dist)
other-qs)]
[else
(debug-report 'would-not-overflow)
;; add to partial
(values wraps
next-wrap-head
(cons q next-wrap-tail)
(+ dist current-dist)
other-qs)])))
(define x (q (list 'size (pt 1 1)) #\x))
(define zwx (q (list 'size (pt 0 0)) #\z))
(define hyph (q (list 'size (pt 1 1)) #\-))
(define shy (q (list 'size (pt 1 1) 'printable? (λ (sig)
(case sig
[(end) #t]
[else #f]))) #\-))
(define a (q (list 'size (pt 1 1)) #\a))
(define b (q (list 'size (pt 1 1)) #\b))
(define c (q (list 'size (pt 1 1)) #\c))
(define d (q (list 'size (pt 1 1)) #\d))
(define sp (q (list 'size (pt 1 1) 'printable? (λ (sig)
(case sig
[(start end) #f]
[else #t]))) #\space))
(define br (q (list 'size (pt 0 0) 'printable? #f) #\newline))
(define soft-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space #\-)))))
(define (linewrap xs size [debug #f])
(break xs size debug
#:break-val 'lb
#:hard-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
#:soft-break-proc soft-break?))
(require rackunit)
(module+ test
(test-case
"chars"
(check-equal? (linewrap (list) 1) null)
(check-equal? (linewrap (list a) 1) (list a))
(check-equal? (linewrap (list a b) 1) (list a 'lb b))
(check-equal? (linewrap (list a b c) 1) (list a 'lb b 'lb c))
(check-equal? (linewrap (list a b c) 2) (list a b 'lb c))
(check-equal? (linewrap (list x x x x) 2) (list x x 'lb x x))
(check-equal? (linewrap (list x x x x x) 3) (list x x x 'lb x x))
(check-equal? (linewrap (list x x x x x) 1) (list x 'lb x 'lb x 'lb x 'lb x))
(check-equal? (linewrap (list x x x x x) 10) (list x x x x x))))
(module+ test
(test-case
"chars and spaces"
(check-equal? (linewrap (list a sp b) 1) (list a 'lb b))
(check-equal? (linewrap (list a b sp c) 2) (list a b 'lb c))
(check-equal? (linewrap (list a sp b) 3) (list a sp b))
(check-equal? (linewrap (list a sp b c) 3) (list a 'lb b c))))
(module+ test
(test-case
"leading & trailing spaces"
(check-equal? (linewrap (list sp x) 2) (list x))
(check-equal? (linewrap (list x sp) 2) (list x))
(check-equal? (linewrap (list sp x sp) 2) (list x))
(check-equal? (linewrap (list sp sp x sp sp) 2) (list x))
(check-equal? (linewrap (list sp sp x sp sp x sp) 1) (list x 'lb x))))
(module+ test
(test-case
"hard hyphens"
(check-equal? (linewrap (list hyph) 1) (list hyph))
(check-equal? (linewrap (list hyph hyph) 1) (list hyph 'lb hyph))
(check-equal? (linewrap (list hyph hyph) 2) (list hyph hyph))
(check-equal? (linewrap (list hyph hyph hyph) 2) (list hyph hyph 'lb hyph))
(check-equal? (linewrap (list x hyph) 1) (list x 'lb hyph))
(check-equal? (linewrap (list a b hyph c d) 1) (list a 'lb b 'lb hyph 'lb c 'lb d))
(check-equal? (linewrap (list a b hyph c d) 2) (list a b 'lb hyph c 'lb d))
(check-equal? (linewrap (list a b hyph c d) 3) (list a b hyph 'lb c d))
(check-equal? (linewrap (list x x hyph x x) 4) (list x x hyph 'lb x x))
(check-equal? (linewrap (list x x hyph x x) 5) (list x x hyph x x))))
(module+ test
(test-case
"soft hyphens"
(check-equal? (linewrap (list shy) 1) (list))
(check-equal? (linewrap (list shy shy) 2) (list))
(check-equal? (linewrap (list shy shy shy) 2) (list))
(check-equal? (linewrap (list x shy) 1) (list x))
(check-equal? (linewrap (list x shy shy shy shy) 1) (list x))
;; todo: degenerate cases
;(check-equal? (linewrap (list x x shy x x) 1) (list x 'lb x 'lb x 'lb x))
;(check-equal? (linewrap (list x x shy x x) 2) (list x x 'lb x x))
(check-equal? (linewrap (list x x shy x x) 3) (list x x shy 'lb x x))
(check-equal? (linewrap (list x x shy x x) 4) (list x x x x))
(check-equal? (linewrap (list x x shy x x) 5) (list x x x x))
(check-equal? (linewrap (list x x shy x sp x) 4) (list x x x 'lb x))
))
(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))))
(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))))
(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))))
(define (visual-wrap str int [debug #f])
(apply string (for/list ([b (in-list (linewrap (for/list ([atom (atomize str)])
($quad (hash-set (attrs atom) 'size '(1 1))
(elems atom))) int debug))])
(cond
[(quad? b) (car (elems b))]
[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")))
(define (pagewrap xs size [debug #f])
(break xs size debug
#:break-val 'pb
#:break-before? #t
#:hard-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page))))
#:soft-break-proc (λ (x) (eq? x 'lb))))
(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))))
(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))))
(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))))
(struct $slug $quad () #:transparent)
(define (slug . xs) ($slug #f xs))
(define (linewrap2 xs size [debug #f])
(break xs size debug
#:break-val 'lb
#:hard-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
#:soft-break-proc soft-break?
#: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)))))
(module+ test
(test-case
"leading & trailing spaces"
(check-equal? (linewrap (list sp x) 2) (list x))
(check-equal? (linewrap (list x sp) 2) (list x))
(check-equal? (linewrap (list sp x sp) 2) (list x))
(check-equal? (linewrap (list sp sp x sp sp) 2) (list x))
(check-equal? (linewrap (list sp sp x sp sp x sp) 1) (list x 'lb x))))
(module+ test
(test-case
"hard hyphens"
(check-equal? (linewrap (list hyph) 1) (list hyph))
(check-equal? (linewrap (list hyph hyph) 1) (list hyph 'lb hyph))
(check-equal? (linewrap (list hyph hyph) 2) (list hyph hyph))
(check-equal? (linewrap (list hyph hyph hyph) 2) (list hyph hyph 'lb hyph))
(check-equal? (linewrap (list x hyph) 1) (list x 'lb hyph))
(check-equal? (linewrap (list a b hyph c d) 1) (list a 'lb b 'lb hyph 'lb c 'lb d))
(check-equal? (linewrap (list a b hyph c d) 2) (list a b 'lb hyph c 'lb d))
(check-equal? (linewrap (list a b hyph c d) 3) (list a b hyph 'lb c d))
(check-equal? (linewrap (list x x hyph x x) 4) (list x x hyph 'lb x x))
(check-equal? (linewrap (list x x hyph x x) 5) (list x x hyph x x))))
(module+ test
(test-case
"soft hyphens"
(check-equal? (linewrap (list shy) 1) (list))
(check-equal? (linewrap (list shy shy) 2) (list))
(check-equal? (linewrap (list shy shy shy) 2) (list))
(check-equal? (linewrap (list x shy) 1) (list x))
(check-equal? (linewrap (list x shy shy shy shy) 1) (list x))
;; todo: degenerate cases
;(check-equal? (linewrap (list x x shy x x) 1) (list x 'lb x 'lb x 'lb x))
;(check-equal? (linewrap (list x x shy x x) 2) (list x x 'lb x x))
(check-equal? (linewrap (list x x shy x x) 3) (list x x shy 'lb x x))
(check-equal? (linewrap (list x x shy x x) 4) (list x x x x))
(check-equal? (linewrap (list x x shy x x) 5) (list x x x x))
(check-equal? (linewrap (list x x shy x sp x) 4) (list x x x 'lb x))
))
(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))))
(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))))
(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))))
(define (visual-wrap str int [debug #f])
(apply string (for/list ([b (in-list (linewrap (for/list ([atom (atomize str)])
($quad (hash-set (attrs atom) 'size '(1 1))
(elems atom))) int debug))])
(cond
[(quad? b) (car (elems b))]
[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")))
(define (pagewrap xs size [debug #f])
(break xs size debug
#:break-val 'pb
#:break-before? #t
#:hard-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page))))
#:soft-break-proc (λ (x) (eq? x 'lb))))
(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))))
(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))))
(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))))
(struct $slug $quad () #:transparent)
(define (slug . xs) ($slug #f xs))
(define (linewrap2 xs size [debug #f])
(break xs size debug
#:break-val 'lb
#:hard-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
#:soft-break-proc soft-break?
#: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)))))
#;(time-avg 100 (void (visual-wrap "The make-object procedure creates a new object with by-position initialization arguments, the new form creates a new object with by-name initialization arguments, and the instantiate form creates a new object with both by-position and by-name initialization arguments. All fields in the newly created object are initially bound to the special #<undefined> value (see Void). Initialization variables with default value expressions (and no provided value) are also initialized to #<undefined>. After argument values are assigned to initialization variables, expressions in field clauses, init-field clauses with no provided argument, init clauses with no provided argument, private field definitions, and other expressions are evaluated. Those expressions are evaluated as they appear in the class expression, from left to right. Sometime during the evaluation of the expressions, superclass-declared initializations must be evaluated once by using the super-make-object procedure, super-new form, or super-instantiate form. By-name initialization arguments to a class that have no matching initialization variable are implicitly added as by-name arguments to a super-make-object, super-new, or super-instantiate invocation, after the explicit arguments. If multiple initialization arguments are provided for the same name, the first (if any) is used, and the unused arguments are propagated to the superclass. (Note that converted by-position arguments are always placed before explicit by-name arguments.) The initialization procedure for the object% class accepts zero initialization arguments; if it receives any by-name initialization arguments, then exn:fail:object exception is raised. If the end of initialization is reached for any class in the hierarchy without invoking the superclass’s initialization, the exn:fail:object exception is raised. Also, if superclass initialization is invoked more than once, the exn:fail:object exception is raised. Fields inherited from a superclass are not initialized until the superclass’s initialization procedure is invoked. In contrast, all methods are available for an object as soon as the object is created; the overriding of methods is not affected by initialization (unlike objects in C++)." 35)))

131
quad/quad/subsequence.rkt
Unescape Escape View File

@ -0,0 +1,131 @@
#lang debug racket
(require sugar/debug)
(define words "This tutorial provides a brief introduction to the Racket programming language by using one of its picture-drawing libraries. Even if you don’t intend to use Racket for your artistic endeavours, the picture library supports interesting and enlightening examples. After all, a picture is worth five hundred “hello world”s.")
(define (string->widths words)
(add-between (map string-length (string-split words)) 1))
(define wws (string->widths words))
(define (greedy-split xs width)
(for/fold ([xss null]
[xs null]
#:result (reverse (cons xs xss)))
([x (in-list xs)])
(define next-xs (cons x xs))
(if (<= (apply + next-xs) width)
(values xss next-xs)
(values (cons (reverse xs) xss) (list x)))))
wws
(require rackunit)
(define width 30)
(greedy-split wws width)
(define (optimal-score xs width)
(cond
[(empty? xs) 0]
[(= (length xs) 1) (car xs)]
[else
(for/fold ([scores null]
[xscores null]
[widths (list 0)]
#:result (cadr scores))
([(x idx) (in-indexed xs)]
#:break (and (pair? xscores) (negative? (car xscores))))
(define next-width (+ x (car widths)))
(define next-xscore (- width next-width))
(define next-score (+ next-xscore (optimal-score (drop xs (add1 idx)) width)))
(values (cons next-score scores)
(cons next-xscore xscores)
(cons next-width widths)))]))
(optimal-score wws width)
#;(time-avg 100 (void (check-equal? (greedy-split (string->widths
"The make-object procedure creates a new object with by-position initialization arguments, the new form creates a new object with by-name initialization arguments, and the instantiate form creates a new object with both by-position and by-name initialization arguments. All fields in the newly created object are initially bound to the special #<undefined> value (see Void). Initialization variables with default value expressions (and no provided value) are also initialized to #<undefined>. After argument values are assigned to initialization variables, expressions in field clauses, init-field clauses with no provided argument, init clauses with no provided argument, private field definitions, and other expressions are evaluated. Those expressions are evaluated as they appear in the class expression, from left to right. Sometime during the evaluation of the expressions, superclass-declared initializations must be evaluated once by using the super-make-object procedure, super-new form, or super-instantiate form. By-name initialization arguments to a class that have no matching initialization variable are implicitly added as by-name arguments to a super-make-object, super-new, or super-instantiate invocation, after the explicit arguments. If multiple initialization arguments are provided for the same name, the first (if any) is used, and the unused arguments are propagated to the superclass. (Note that converted by-position arguments are always placed before explicit by-name arguments.) The initialization procedure for the object% class accepts zero initialization arguments; if it receives any by-name initialization arguments, then exn:fail:object exception is raised. If the end of initialization is reached for any class in the hierarchy without invoking the superclass’s initialization, the exn:fail:object exception is raised. Also, if superclass initialization is invoked more than once, the exn:fail:object exception is raised. Fields inherited from a superclass are not initialized until the superclass’s initialization procedure is invoked. In contrast, all methods are available for an object as soon as the object is created; the overriding of methods is not affected by initialization (unlike objects in C++).") 30)
'((3 1 11 1 9 1)
(7 1 1 1 3 1 6 1 4 1)
(11 1 14 1)
(10 1 3 1 3 1 4 1)
(7 1 1 1 3 1 6 1 4 1)
(7 1 14 1)
(10 1 3 1 3 1 11)
(1 4 1 7 1 1 1 3 1 6 1)
(4 1 4 1 11 1 3 1)
(7 1 14 1)
(10 1 3 1 6 1 2 1 3 1)
(5 1 7 1 6 1 3 1)
(9 1 5 1 2 1 3 1 7)
(1 12 1 5 1 4 1)
(6 1 14 1)
(9 1 4 1 7 1 5 1)
(11 1 4 1 2 1 8 1)
(6 1 3 1 4 1 11 1 2)
(1 13 1 5 1 8 1)
(6 1 3 1 8 1 2 1)
(14 1 10 1)
(11 1 2 1 5 1 8 1)
(10 1 7 1 4 1 2 1)
(8 1 9 1 4 1)
(7 1 4 1 2 1 8 1)
(9 1 7 1 5 1)
(12 1 3 1 5 1)
(11 1 3 1 10 1)
(5 1 11 1 3 1)
(9 1 2 1 4 1 6 1 2 1)
(3 1 5 1 11 1 4 1)
(4 1 2 1 6 1 8 1 6)
(1 3 1 10 1 2 1 3 1)
(12 1)
(19 1)
(15 1 4 1 2 1)
(9 1 4 1 2 1 5 1 3 1)
(17 1 10 1)
(9 1 5 1 2 1)
(17 1 5 1)
(7 1 14 1)
(9 1 2 1 1 1 5 1 4 1 4)
(1 2 1 8 1 14 1)
(8 1 3 1 10 1 5 1)
(2 1 7 1 9 1 2 1 1 1)
(18 1 10 1)
(2 1 17 1)
(11 1 5 1 3 1 8)
(1 10 1 2 1 8 1)
(14 1 9 1 3 1)
(8 1 3 1 3 1 4 1 5 1)
(3 1 5 1 3 1 4 1 2 1 5 1)
(3 1 3 1 6 1 9 1 3 1)
(10 1 2 1 3 1 11 1)
(5 1 4 1 9 1)
(11 1 9 1 3 1)
(6 1 6 1 6 1 8 1)
(7 1 11 1 3 1)
(14 1 9 1 3 1)
(3 1 7 1 5 1 7 1 4)
(1 14 1 10 1 2 1)
(2 1 8 1 3 1 7 1)
(14 1 10 1 4)
(1 15 1 9 1 2 1)
(7 1 2 1 3 1 3 1 2 1)
(14 1 2 1 7 1 3 1)
(3 1 5 1 2 1 3 1 9 1)
(7 1 8 1 3 1)
(12 1 15 1)
(3 1 15 1 9 1)
(2 1 7 1 5 1 2 1 10)
(1 14 1 2 1 7 1)
(4 1 4 1 5 1 3 1)
(15 1 9 1 2 1)
(7 1 6 1 9 1 4 1)
(1 1 10 1 3 1 3 1)
(11 1 5 1 3 1)
(12 1 14 1)
(9 1 2 1 8 1 2 1)
(9 1 3 1 7 1 3 1)
(9 1 3 1 2 1 6 1 2 1)
(4 1 2 1 3 1 6 1 2 1 8)
(1 3 1 10 1 2 1 7 1 2 1)
(3 1 8 1 2 1 14)))))
Write Preview
Loading…
Cancel
Save