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

chunkier

Browse Source
main
Matthew Butterick 6 years ago
parent 0608024893
commit c6e263c176
6 changed files with 362 additions and 299 deletions
Show Stats Download Patch File Download Diff File

41
quad/quad/atomize.rkt
Unescape Escape View File

@ -40,13 +40,13 @@
(define atomic-quads (define atomic-quads
(let loop ([x (if (string? qx) (q qx) qx)][attrs (current-default-attrs)]) (let loop ([x (if (string? qx) (q qx) qx)][attrs (current-default-attrs)])
(match x (match x
[(? char? c) (list (q (hash-set attrs 'id (gensym)) c))] [(? char? c) (list (q attrs c))]
[(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded [(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded
(loop c attrs)))] (loop c attrs)))]
[($quad this-attrs elems) ;; qexprs with attributes are recursed [($quad this-attrs elems) ;; qexprs with attributes are recursed
(define merged-attrs (attrs . update-with . this-attrs)) (define merged-attrs (attrs . update-with . this-attrs))
(append* (for/list ([elem (in-list elems)]) (append* (for/list ([elem (in-list elems)])
(loop elem merged-attrs)))] (loop elem merged-attrs)))]
[else (raise-argument-error 'atomize "valid item" x)]))) [else (raise-argument-error 'atomize "valid item" x)])))
(merge-whitespace atomic-quads)) (merge-whitespace atomic-quads))
@ -76,3 +76,38 @@
($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\Y)) ($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\Y))
($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\o)) ($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\o))
($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\u))))) ($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\u)))))
(define whitespace-pat #px"\\s+")
(define (merge-white str) (regexp-replace* whitespace-pat str " "))
(define (isolate-white str)
(for/list ([m (in-list (regexp-match* " " str #:gap-select? #t))]
#:when (positive? (string-length m)))
m))
(define (merge-adjacent-strings xs [acc null])
(match xs
[(== empty) (reverse acc)]
[(list (? string? strs) ..1 others ...)
(merge-adjacent-strings others (append (reverse (isolate-white (merge-white (apply string-append strs)))) acc))]
[(cons x others) (merge-adjacent-strings others (cons x acc))]))
(define (runify qx)
;; runify a quad by reducing it to a series of "runs",
;; which are multi-character quads with the same formatting.
(dropf
(let loop ([x (if (string? qx) (q qx) qx)][attrs (current-default-attrs)])
(match x
[($quad this-attrs elems) ;; qexprs with attributes are recursed
(define merged-attrs (attrs . update-with . this-attrs))
(append* (for/list ([elem (in-list (merge-adjacent-strings elems))])
(if (string? elem)
(list (q merged-attrs elem))
(loop elem merged-attrs))))]))
(λ (q) (string=? " " (car (elems q))))))
(module+ test
(check-equal?
(runify (q (hasheq 'foo 42) (q "Hi" " idiot" (q (hasheq 'bar 84) "There") "Eve" "ry" "one")))
(list (q (hasheq 'foo 42) "Hi") (q (hasheq 'foo 42) " ") (q (hasheq 'foo 42) "idiot") (q (hasheq 'foo 42 'bar 84) "There") (q (hasheq 'foo 42) "Everyone"))))

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

@ -114,282 +114,298 @@
(define last-wrap (wrap-append #false (wrap-append next-wrap-tail next-wrap-head))) (define last-wrap (wrap-append #false (wrap-append next-wrap-tail next-wrap-head)))
(define finished-wraps (define finished-wraps
(for/list ([wrap (in-list (cons last-wrap wraps))]) (for/list ([wrap (in-list (cons last-wrap wraps))])
(match wrap (match wrap
[(list (? nonprinting-at-end?)) wrap] ; matches break signals [(list (? nonprinting-at-end?)) wrap] ; matches break signals
;; pieces will have been accumulated in reverse order ;; pieces will have been accumulated in reverse order
;; thus beginning of list represents the end of the wrap ;; thus beginning of list represents the end of the wrap
[(list (? (conjoin soft-break? nonprinting-at-end?)) ... rest ...) [(list (? (conjoin soft-break? nonprinting-at-end?)) ... rest ...)
(finish-wrap-proc (reverse rest))]))) (finish-wrap-proc (reverse rest))])))
(add-between finished-wraps (list break-val)))) (add-between finished-wraps (list break-val))))
([i (in-naturals)] ([i (in-naturals)]
#:break (empty? qs)) #:break (empty? qs))
(match-define (cons q other-qs) qs) (match-define (cons q other-qs) qs)
(debug-report q 'next-q) (debug-report q 'next-q)
(define at-start? (not current-dist)) (define at-start? (not current-dist))
(define dist (if (and (quad? q) (printable? q)) (distance q) 0)) (define dist (if (and (quad? q) (printable? q)) (distance q) 0))
(define would-overflow? (and current-dist (> (+ dist current-dist) target-size))) (define would-overflow? (and current-dist (> (+ dist current-dist) target-size)))
(cond (cond
[(and at-start? (soft-break? q) (nonprinting-at-start? q)) [(and at-start? (soft-break? q) (nonprinting-at-start? q))
(debug-report q 'skipping-soft-break-at-beginning) (debug-report q 'skipping-soft-break-at-beginning)
(values wraps (values wraps
next-wrap-head next-wrap-head
next-wrap-tail next-wrap-tail
current-dist current-dist
other-qs)] other-qs)]
[at-start? [at-start?
(debug-report 'hard-quad-at-start) (debug-report 'hard-quad-at-start)
(values wraps (values wraps
next-wrap-head next-wrap-head
(list q) (list q)
(distance q) (distance q)
other-qs)] other-qs)]
[(and would-overflow? (soft-break? q) (nonprinting-at-end? q)) [(and would-overflow? (soft-break? q) (nonprinting-at-end? q))
(debug-report 'would-overflow-soft-nonprinting) (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 ;; 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 ;; but we can move the current-partial into the current-wrap
(values wraps (values wraps
(wrap-append (cons q next-wrap-tail) next-wrap-head) (wrap-append (cons q next-wrap-tail) next-wrap-head)
null null
(+ dist current-dist) (+ dist current-dist)
other-qs)] other-qs)]
[(and would-overflow? (empty? next-wrap-head)) [(and would-overflow? (empty? next-wrap-head))
(debug-report 'would-overflow-hard-without-captured-break) (debug-report 'would-overflow-hard-without-captured-break)
(values (cons next-wrap-tail wraps) (values (cons next-wrap-tail wraps)
null null
null null
#false #false
qs)] qs)]
[would-overflow? ; finish the wrap & reset the line without consuming a quad [would-overflow? ; finish the wrap & reset the line without consuming a quad
(values (cons next-wrap-head wraps) (values (cons next-wrap-head wraps)
null null
next-wrap-tail next-wrap-tail
(apply + (map distance next-wrap-tail)) (apply + (map distance next-wrap-tail))
qs)] qs)]
[(soft-break? q) ; printing soft break, like a hyphen [(soft-break? q) ; printing soft break, like a hyphen
(debug-report 'would-not-overflow-soft) (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 ;; a soft break that fits, so move it on top of the next-wrap-head with the next-wrap-tail
(values wraps (values wraps
(wrap-append (cons q next-wrap-tail) next-wrap-head) (wrap-append (cons q next-wrap-tail) next-wrap-head)
null null
(+ dist current-dist) (+ dist current-dist)
other-qs)] other-qs)]
[else [else
(debug-report 'would-not-overflow) (debug-report 'would-not-overflow)
;; add to partial ;; add to partial
(values wraps (values wraps
next-wrap-head next-wrap-head
(cons q next-wrap-tail) (cons q next-wrap-tail)
(+ dist current-dist) (+ dist current-dist)
other-qs)]))) other-qs)])))
(define x (q (list 'size (pt 1 1)) #\x)) (require "subsequence.rkt")
(define zwx (q (list 'size (pt 0 0)) #\z)) (define (break-softs1 qs
(define hyph (q (list 'size (pt 1 1)) #\-)) target-size
(define shy (q (list 'size (pt 1 1) 'printable? (λ (sig) debug
(case sig break-val
[(end) #t] soft-break?
[else #f]))) #\-)) finish-wrap-proc)
(define a (q (list 'size (pt 1 1)) #\a)) (define finished-wraps
(define b (q (list 'size (pt 1 1)) #\b)) (for/list ([wrap (in-list (greedy-split qs target-size #:key distance))])
(define c (q (list 'size (pt 1 1)) #\c)) (match wrap
(define d (q (list 'size (pt 1 1)) #\d)) [(list (? nonprinting-at-end?)) wrap] ; matches break signals
(define sp (q (list 'size (pt 1 1) 'printable? (λ (sig) [(list (? soft-break?) ... rest ... (? (conjoin soft-break? nonprinting-at-end?)) ...)
(case sig (finish-wrap-proc rest)])))
[(start end) #f] (reverse (add-between finished-wraps (list break-val))))
[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 x (q (list 'size (pt 1 1)) #\x))
(define zwx (q (list 'size (pt 0 0)) #\z))
(define (linewrap xs size [debug #f]) (define hyph (q (list 'size (pt 1 1)) #\-))
(break xs size debug (define shy (q (list 'size (pt 1 1) 'printable? (λ (sig)
#:break-val 'lb (case sig
#:hard-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) [(end) #t]
#:soft-break-proc soft-break?)) [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))
(require rackunit) (define d (q (list 'size (pt 1 1)) #\d))
(define sp (q (list 'size (pt 1 1) 'printable? (λ (sig)
(module+ test (case sig
(test-case [(start end) #f]
"chars" [else #t]))) #\space))
(check-equal? (linewrap (list) 1) null) (define br (q (list 'size (pt 0 0) 'printable? #f) #\newline))
(check-equal? (linewrap (list a) 1) (list a)) (define soft-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space #\-)))))
(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)) (define (linewrap xs size [debug #f])
(check-equal? (linewrap (list a b c) 2) (list a b 'lb c)) (break xs size debug
(check-equal? (linewrap (list x x x x) 2) (list x x 'lb x x)) #:break-val 'lb
(check-equal? (linewrap (list x x x x x) 3) (list x x x 'lb x x)) #:hard-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline))))
(check-equal? (linewrap (list x x x x x) 1) (list x 'lb x 'lb x 'lb x 'lb x)) #:soft-break-proc soft-break?))
(check-equal? (linewrap (list x x x x x) 10) (list x x x x x))))
(module+ test
(test-case (require rackunit)
"chars and spaces"
(check-equal? (linewrap (list a sp b) 1) (list a 'lb b)) (module+ test
(check-equal? (linewrap (list a b sp c) 2) (list a b 'lb c)) (test-case
(check-equal? (linewrap (list a sp b) 3) (list a sp b)) "chars"
(check-equal? (linewrap (list a sp b c) 3) (list a 'lb b c)))) (check-equal? (linewrap (list) 1) null)
(check-equal? (linewrap (list a) 1) (list a))
(module+ test (check-equal? (linewrap (list a b) 1) (list a 'lb b))
(test-case (check-equal? (linewrap (list a b c) 1) (list a 'lb b 'lb c))
"leading & trailing spaces" (check-equal? (linewrap (list a b c) 2) (list a b 'lb c))
(check-equal? (linewrap (list sp x) 2) (list x)) (check-equal? (linewrap (list x x x x) 2) (list x x 'lb x x))
(check-equal? (linewrap (list x sp) 2) (list x)) (check-equal? (linewrap (list x x x x x) 3) (list x x x 'lb x x))
(check-equal? (linewrap (list sp x sp) 2) (list 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 sp sp x sp sp) 2) (list x)) (check-equal? (linewrap (list x x x x x) 10) (list x x x x x))))
(check-equal? (linewrap (list sp sp x sp sp x sp) 1) (list x 'lb x))))
(module+ test
(module+ test (test-case
(test-case "chars and spaces"
"hard hyphens" (check-equal? (linewrap (list a sp b) 1) (list a 'lb b))
(check-equal? (linewrap (list hyph) 1) (list hyph)) (check-equal? (linewrap (list a b sp c) 2) (list a b 'lb c))
(check-equal? (linewrap (list hyph hyph) 1) (list hyph 'lb hyph)) (check-equal? (linewrap (list a sp b) 3) (list a sp b))
(check-equal? (linewrap (list hyph hyph) 2) (list hyph hyph)) (check-equal? (linewrap (list a sp b c) 3) (list a 'lb b c))))
(check-equal? (linewrap (list hyph hyph hyph) 2) (list hyph hyph 'lb hyph))
(check-equal? (linewrap (list x hyph) 1) (list x 'lb hyph)) (module+ test
(check-equal? (linewrap (list a b hyph c d) 1) (list a 'lb b 'lb hyph 'lb c 'lb d)) (test-case
(check-equal? (linewrap (list a b hyph c d) 2) (list a b 'lb hyph c 'lb d)) "leading & trailing spaces"
(check-equal? (linewrap (list a b hyph c d) 3) (list a b hyph 'lb c d)) (check-equal? (linewrap (list sp x) 2) (list x))
(check-equal? (linewrap (list x x hyph x x) 4) (list x x hyph 'lb x x)) (check-equal? (linewrap (list x sp) 2) (list x))
(check-equal? (linewrap (list x x hyph x x) 5) (list x x hyph x x)))) (check-equal? (linewrap (list sp x sp) 2) (list x))
(check-equal? (linewrap (list sp sp x sp sp) 2) (list x))
(module+ test (check-equal? (linewrap (list sp sp x sp sp x sp) 1) (list x 'lb x))))
(test-case
"soft hyphens" (module+ test
(check-equal? (linewrap (list shy) 1) (list)) (test-case
(check-equal? (linewrap (list shy shy) 2) (list)) "hard hyphens"
(check-equal? (linewrap (list shy shy shy) 2) (list)) (check-equal? (linewrap (list hyph) 1) (list hyph))
(check-equal? (linewrap (list x shy) 1) (list x)) (check-equal? (linewrap (list hyph hyph) 1) (list hyph 'lb hyph))
(check-equal? (linewrap (list x shy shy shy shy) 1) (list x)) (check-equal? (linewrap (list hyph hyph) 2) (list hyph hyph))
;; todo: degenerate cases (check-equal? (linewrap (list hyph hyph hyph) 2) (list hyph hyph 'lb hyph))
;(check-equal? (linewrap (list x x shy x x) 1) (list x 'lb x 'lb x 'lb x)) (check-equal? (linewrap (list x hyph) 1) (list x 'lb hyph))
;(check-equal? (linewrap (list x x shy x x) 2) (list x x 'lb x x)) (check-equal? (linewrap (list a b hyph c d) 1) (list a 'lb b 'lb hyph 'lb c 'lb d))
(check-equal? (linewrap (list x x shy x x) 3) (list x x shy 'lb x x)) (check-equal? (linewrap (list a b hyph c d) 2) (list a b 'lb hyph c 'lb d))
(check-equal? (linewrap (list x x shy x x) 4) (list x x x x)) (check-equal? (linewrap (list a b hyph c d) 3) (list a b hyph 'lb c d))
(check-equal? (linewrap (list x x shy x x) 5) (list x x x x)) (check-equal? (linewrap (list x x hyph x x) 4) (list x x hyph 'lb x x))
(check-equal? (linewrap (list x x shy x sp x) 4) (list x x x 'lb x)) (check-equal? (linewrap (list x x hyph x x) 5) (list x x hyph x x))))
))
(module+ test
(module+ test (test-case
(test-case "soft hyphens"
"zero width nonbreakers" (check-equal? (linewrap (list shy) 1) (list))
(check-equal? (linewrap (list sp zwx) 2) (list zwx)) (check-equal? (linewrap (list shy shy) 2) (list))
(check-equal? (linewrap (list zwx sp) 2) (list zwx)) (check-equal? (linewrap (list shy shy shy) 2) (list))
(check-equal? (linewrap (list sp zwx sp) 2) (list zwx)) (check-equal? (linewrap (list x shy) 1) (list x))
(check-equal? (linewrap (list sp sp zwx sp sp) 2) (list zwx)) (check-equal? (linewrap (list x shy shy shy shy) 1) (list x))
(check-equal? (linewrap (list sp sp zwx sp sp zwx sp) 2) (list zwx sp sp zwx)))) ;; todo: degenerate cases
;(check-equal? (linewrap (list x x shy x x) 1) (list x 'lb x 'lb x 'lb x))
(module+ test ;(check-equal? (linewrap (list x x shy x x) 2) (list x x 'lb x x))
(test-case (check-equal? (linewrap (list x x shy x x) 3) (list x x shy 'lb x x))
"hard breaks" (check-equal? (linewrap (list x x shy x x) 4) (list x x x x))
(check-equal? (linewrap (list br) 2) (list)) ;; only insert a break if it's between things (check-equal? (linewrap (list x x shy x x) 5) (list x x x x))
(check-equal? (linewrap (list a br b) 2) (list a 'lb b)) (check-equal? (linewrap (list x x shy x sp x) 4) (list x x x 'lb x))
(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)) (module+ test
(check-equal? (linewrap (list x x br x) 3) (list x x 'lb x)) (test-case
(check-equal? (linewrap (list x x x x) 3) (list x x x 'lb x)) "zero width nonbreakers"
(check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x)) (check-equal? (linewrap (list sp zwx) 2) (list zwx))
(check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x)))) (check-equal? (linewrap (list zwx sp) 2) (list zwx))
(check-equal? (linewrap (list sp zwx sp) 2) (list zwx))
(module+ test (check-equal? (linewrap (list sp sp zwx sp sp) 2) (list zwx))
(test-case (check-equal? (linewrap (list sp sp zwx sp sp zwx sp) 2) (list zwx sp sp zwx))))
"hard breaks and spurious spaces"
(check-equal? (linewrap (list a sp sp sp br b) 2) (list a 'lb b)) (module+ test
(check-equal? (linewrap (list x sp br sp sp x x sp) 3) (list x 'lb x x)) (test-case
(check-equal? (linewrap (list sp sp x x sp sp br sp sp sp x) 3) (list x x 'lb x)) "hard breaks"
(check-equal? (linewrap (list a sp b sp sp br sp c) 3) (list a sp b 'lb c)) (check-equal? (linewrap (list br) 2) (list)) ;; only insert a break if it's between things
(check-equal? (linewrap (list x x x x) 3) (list x x x 'lb x)) (check-equal? (linewrap (list a br b) 2) (list a 'lb b))
(check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x)) (check-equal? (linewrap (list a b br) 2) (list a b))
(check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x)))) (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))
(define (visual-wrap str int [debug #f]) (check-equal? (linewrap (list x x br x) 3) (list x x 'lb x))
(apply string (for/list ([b (in-list (linewrap (for/list ([atom (atomize str)]) (check-equal? (linewrap (list x x x x) 3) (list x x x 'lb x))
($quad (hash-set (attrs atom) 'size '(1 1)) (check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x))
(elems atom))) int debug))]) (check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x))))
(cond
[(quad? b) (car (elems b))] (module+ test
[else #\|])))) (test-case
"hard breaks and spurious spaces"
(module+ test (check-equal? (linewrap (list a sp sp sp br b) 2) (list a 'lb b))
(test-case (check-equal? (linewrap (list x sp br sp sp x x sp) 3) (list x 'lb x x))
"visual breaks" (check-equal? (linewrap (list sp sp x x sp sp br sp sp sp x) 3) (list x x 'lb x))
(check-equal? (visual-wrap "My dog has fleas" 1) "M|y|d|o|g|h|a|s|f|l|e|a|s") (check-equal? (linewrap (list a sp b sp sp br sp c) 3) (list a sp b 'lb c))
(check-equal? (visual-wrap "My dog has fleas" 2) "My|do|g|ha|s|fl|ea|s") (check-equal? (linewrap (list x x x x) 3) (list x x x 'lb x))
(check-equal? (visual-wrap "My dog has fleas" 3) "My|dog|has|fle|as") (check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x))
(check-equal? (visual-wrap "My dog has fleas" 4) "My|dog|has|flea|s") (check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x))))
(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") (define (visual-wrap str int [debug #f])
(check-equal? (visual-wrap "My dog has fleas" 7) "My dog|has|fleas") (apply string (for/list ([b (in-list (linewrap (for/list ([atom (atomize str)])
(check-equal? (visual-wrap "My dog has fleas" 8) "My dog|has|fleas") ($quad (hash-set (attrs atom) 'size '(1 1))
(check-equal? (visual-wrap "My dog has fleas" 9) "My dog|has fleas") (elems atom))) int debug))])
(check-equal? (visual-wrap "My dog has fleas" 10) "My dog has|fleas") (cond
(check-equal? (visual-wrap "My dog has fleas" 11) "My dog has|fleas") [(quad? b) (car (elems b))]
(check-equal? (visual-wrap "My dog has fleas" 12) "My dog has|fleas") [else #\|]))))
(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") (module+ test
(check-equal? (visual-wrap "My dog has fleas" 15) "My dog has|fleas") (test-case
(check-equal? (visual-wrap "My dog has fleas" 16) "My dog has fleas"))) "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")
(define (pagewrap xs size [debug #f]) (check-equal? (visual-wrap "My dog has fleas" 3) "My|dog|has|fle|as")
(break xs size debug (check-equal? (visual-wrap "My dog has fleas" 4) "My|dog|has|flea|s")
#:break-val 'pb (check-equal? (visual-wrap "My dog has fleas" 5) "My|dog|has|fleas")
#:break-before? #t (check-equal? (visual-wrap "My dog has fleas" 6) "My dog|has|fleas")
#:hard-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page)))) (check-equal? (visual-wrap "My dog has fleas" 7) "My dog|has|fleas")
#:soft-break-proc (λ (x) (eq? x 'lb)))) (check-equal? (visual-wrap "My dog has fleas" 8) "My dog|has|fleas")
(define pbr (q '(size #f) #\page)) (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")
(module+ test (check-equal? (visual-wrap "My dog has fleas" 11) "My dog has|fleas")
(test-case (check-equal? (visual-wrap "My dog has fleas" 12) "My dog has|fleas")
"soft page breaks" (check-equal? (visual-wrap "My dog has fleas" 13) "My dog has|fleas")
(check-equal? (pagewrap null 2) '(pb)) (check-equal? (visual-wrap "My dog has fleas" 14) "My dog has|fleas")
(check-equal? (pagewrap (list x) 2) (list 'pb x)) (check-equal? (visual-wrap "My dog has fleas" 15) "My dog has|fleas")
(check-equal? (pagewrap (list x x) 2) (list 'pb x x)) (check-equal? (visual-wrap "My dog has fleas" 16) "My dog has fleas")))
(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)) (define (pagewrap xs size [debug #f])
(check-equal? (pagewrap (list x x x) 4) (list 'pb x x x)) (break xs size debug
(check-equal? (pagewrap (list x 'lb x x) 2) (list 'pb x 'pb x x)))) #:break-val 'pb
#:break-before? #t
(module+ test #:hard-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page))))
(test-case #:soft-break-proc (λ (x) (eq? x 'lb))))
"hard page breaks" (define pbr (q '(size #f) #\page))
(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)) (module+ test
(check-equal? (pagewrap (list x pbr pbr x x) 1) (list 'pb x 'pb 'pb x 'pb x)) (test-case
(check-equal? (pagewrap (list x pbr pbr x x) 2) (list 'pb x 'pb 'pb x x)) "soft page breaks"
(check-equal? (pagewrap (list 'lb x 'lb 'lb pbr 'lb x x 'lb) 2) (list 'pb x 'pb x x)))) (check-equal? (pagewrap null 2) '(pb))
(check-equal? (pagewrap (list x) 2) (list 'pb x))
(module+ test (check-equal? (pagewrap (list x x) 2) (list 'pb x x))
(test-case (check-equal? (pagewrap (list x x x) 1) (list 'pb x 'pb x 'pb x))
"composed line breaks and page breaks" (check-equal? (pagewrap (list x x x) 2) (list 'pb x x 'pb x))
(check-equal? (pagewrap (linewrap null 1) 2) '(pb) ) (check-equal? (pagewrap (list x x x) 3) (list 'pb x x x))
(check-equal? (pagewrap (linewrap (list x) 1) 2) (list 'pb x)) (check-equal? (pagewrap (list x x x) 4) (list 'pb x x x))
(check-equal? (pagewrap (linewrap (list x x x) 1) 2) (list 'pb x 'lb x 'pb x)) (check-equal? (pagewrap (list x 'lb x x) 2) (list 'pb x 'pb x 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)))) (module+ test
(test-case
(struct $slug $quad () #:transparent) "hard page breaks"
(define (slug . xs) ($slug #f xs)) (check-equal? (pagewrap (list x pbr x x) 2) (list 'pb x 'pb x x))
(define (linewrap2 xs size [debug #f]) (check-equal? (pagewrap (list x pbr x x) 1) (list 'pb x 'pb x 'pb x))
(break xs size debug (check-equal? (pagewrap (list x pbr pbr x x) 1) (list 'pb x 'pb 'pb x 'pb x))
#:break-val 'lb (check-equal? (pagewrap (list x pbr pbr x x) 2) (list 'pb x 'pb 'pb x x))
#:hard-break-proc (λ (q) (and (quad? q) (memv (car (elems q)) '(#\newline)))) (check-equal? (pagewrap (list 'lb x 'lb 'lb pbr 'lb x x 'lb) 2) (list 'pb x 'pb x x))))
#:soft-break-proc soft-break?
#:finish-wrap-proc (λ (pcs) (list ($slug #f pcs))))) (module+ test
(test-case
(module+ test "composed line breaks and page breaks"
(test-case (check-equal? (pagewrap (linewrap null 1) 2) '(pb) )
"hard breaks and spurious spaces with slugs" (check-equal? (pagewrap (linewrap (list x) 1) 2) (list 'pb x))
(check-equal? (linewrap2 (list a sp sp sp br b) 2) (list (slug a) 'lb (slug b))) (check-equal? (pagewrap (linewrap (list x x x) 1) 2) (list 'pb x 'lb x 'pb x))
(check-equal? (linewrap2 (list x sp br sp sp x x sp) 3) (list (slug x) 'lb (slug x x))) (check-equal? (pagewrap (linewrap (list x x x) 2) 2) (list 'pb x x 'pb 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? (pagewrap (linewrap (list x x x) 2) 1) (list 'pb x 'pb x 'pb 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))) (struct $slug $quad () #:transparent)
(check-equal? (linewrap2 (list x x x sp x x) 2) (list (slug x x) 'lb (slug x) 'lb (slug x x))) (define (slug . xs) ($slug #f xs))
(check-equal? (linewrap2 (list x x x sp x x) 3) (list (slug x x x) 'lb (slug x x))))) (define (linewrap2 xs size [debug #f])
(break xs size debug
#;(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))) #: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)))

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

@ -1,5 +1,6 @@
#lang debug racket #lang debug racket
(require sugar/debug) (require sugar/debug)
(provide (all-defined-out))
(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 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.")
@ -8,21 +9,16 @@
(define wws (string->widths words)) (define wws (string->widths words))
(define (greedy-split xs width) (define (greedy-split xs width #:key [keyproc values])
(for/fold ([xss null] (for/fold ([xss null]
[xs null] [xs null]
#:result (reverse (cons xs xss))) #:result (reverse (cons (reverse xs) xss)))
([x (in-list xs)]) ([x (in-list xs)])
(define next-xs (cons x xs)) (define next-xs (cons x xs))
(if (<= (apply + next-xs) width) (if (<= (apply + (map keyproc next-xs)) width)
(values xss next-xs) (values xss next-xs)
(values (cons (reverse xs) xss) (list x))))) (values (cons (reverse xs) xss) (list x)))))
wws
(require rackunit)
(define width 30)
(greedy-split wws width)
(define (optimal-score xs width) (define (optimal-score xs width)
(cond (cond
[(empty? xs) 0] [(empty? xs) 0]
@ -41,7 +37,13 @@ wws
(cons next-xscore xscores) (cons next-xscore xscores)
(cons next-width widths)))])) (cons next-width widths)))]))
(optimal-score wws width) (module+ test
(require rackunit)
(define width 30)
(greedy-split wws width)
#;(optimal-score wws width)
#;(time-avg 100 (void (check-equal? (greedy-split (string->widths #;(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) "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)
@ -128,4 +130,4 @@ wws
(9 1 3 1 2 1 6 1 2 1) (9 1 3 1 2 1 6 1 2 1)
(4 1 2 1 3 1 6 1 2 1 8) (4 1 2 1 3 1 6 1 2 1 8)
(1 3 1 10 1 2 1 7 1 2 1) (1 3 1 10 1 2 1 7 1 2 1)
(3 1 8 1 2 1 14))))) (3 1 8 1 2 1 14))))))

12
quad/quad/test-glyph-layout.rkt
Unescape Escape View File

@ -0,0 +1,12 @@
#lang br
(require fontkit/font)
(define f (openSync "fira.ttf"))
(define gr (time (layout f "fifl")))
(get-field glyphs gr)
(get-field positions gr)
(send gr advanceWidth)

5
quad/quad/typewriter-test.rkt
Unescape Escape View File

@ -1,8 +1,3 @@
#lang quad/typewriter #lang quad/typewriter
◊;quad[#:fontsize "11"]{Hello world}
◊;quad[#:fontsize "11"]{◊quad[#:link "http://beautifulracket.com"]{An expression that} is not a value can ◊quad[#:fontsize "22"]{always} ◊quad[#:fontsize "7"]{be partitioned} into}
◊quad[#:fontsize "11"]{◊quad[#:link "http://beautifulracket.com"]{An expression that} is not a value can ◊quad[#:fontsize "22"]{always} ◊quad[#:fontsize "7"]{be partitioned} into two parts: a redex, which is the part that changed in a single-step simplification (highlighted), and the continuation, which is the evaluation context surrounding an expression. In (- 4 (+ 1 1)), the redex is (+ 1 1), and the continuation is (- 4 []), where [] takes the place of the redex. That is, the continuation says how to "continue" after the redex is reduced to a value.} ◊quad[#:fontsize "11"]{◊quad[#:link "http://beautifulracket.com"]{An expression that} is not a value can ◊quad[#:fontsize "22"]{always} ◊quad[#:fontsize "7"]{be partitioned} into two parts: a redex, which is the part that changed in a single-step simplification (highlighted), and the continuation, which is the evaluation context surrounding an expression. In (- 4 (+ 1 1)), the redex is (+ 1 1), and the continuation is (- 4 []), where [] takes the place of the redex. That is, the continuation says how to "continue" after the redex is reduced to a value.}

9
quad/quad/typewriter.rkt
Unescape Escape View File

@ -32,7 +32,8 @@
'size 'size
(delay (delay
(define fontsize (string->number (hash-ref (attrs q) 'fontsize "12"))) (define fontsize (string->number (hash-ref (attrs q) 'fontsize "12")))
(define str (apply string (elems q))) (define str (car (elems q)))
#R str
(send* (current-doc) (send* (current-doc)
[fontSize fontsize] [fontSize fontsize]
[font (path->string charter)]) [font (path->string charter)])
@ -46,7 +47,7 @@
'draw (λ (q doc) 'draw (λ (q doc)
(draw-debug q doc) (draw-debug q doc)
(send doc fontSize (string->number (hash-ref (attrs q) 'fontsize "12"))) (send doc fontSize (string->number (hash-ref (attrs q) 'fontsize "12")))
(let ([str (apply string (elems q))]) (let ([str (car (elems q))])
(cond (cond
[(hash-ref (attrs q) 'link #f) [(hash-ref (attrs q) 'link #f)
=> =>
@ -124,7 +125,9 @@
(define chars 25) (define chars 25)
(define line-width (* 7.2 chars)) (define line-width (* 7.2 chars))
(define lines-per-page (* 4 line-height)) (define lines-per-page (* 4 line-height))
(let* ([x (time-name line-wrap (line-wrap (map charify (atomize qarg)) line-width))] (let* ([x (time-name runify #R (runify qarg))]
[x (time-name charify (map charify x))]
[x (time-name line-wrap (line-wrap x line-width))]
[x (time-name page-wrap (page-wrap x lines-per-page))] [x (time-name page-wrap (page-wrap x lines-per-page))]
[x (time-name position (position ($doc (hasheq) x)))]) [x (time-name position (position ($doc (hasheq) x)))])
x)) x))

Write Preview
Loading…
Cancel
Save