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

to be surprised

Browse Source
main
Matthew Butterick 6 years ago
parent 1241d97dea
commit 5d0ae09c3a
4 changed files with 48 additions and 53 deletions
Show Stats Download Patch File Download Diff File

14
quad/qtest/fark.rkt
Unescape Escape View File

@ -20,23 +20,21 @@ it's a
codeblock! codeblock!
``` ```
``` > A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm originally developed for TeX. A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm originally developed for TeX.
it's a
codeblock!
```
``` ```
it's a it's a
codeblock! codeblock!
``` ```
enated. To hyphenate words of
any length, use `#:min-length` `#f`.
A [list of web colors](https://en.wikipedia.org/wiki/Web_colors). > A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors). text.
A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors). text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).

49
quad/qtest/markdown.rkt
Unescape Escape View File

@ -24,7 +24,7 @@
(define-tag-function (blockquote attrs exprs) (define-tag-function (blockquote attrs exprs)
(qexpr (list* '(display "block") (qexpr (list* '(display "block")
'(background-color "#eee") '(background-color "#eee")
'(font "fira") '(fontsize "10") '(line-height "15") '(font "fira") '(fontsize "10") '(line-height "15")
'(border-width-top "0.5") '(border-color-top "gray") '(border-inset-top "8") '(border-width-top "0.5") '(border-color-top "gray") '(border-inset-top "8")
'(border-width-left "3") '(border-color-left "gray") '(border-inset-left "20") '(border-width-left "3") '(border-color-left "gray") '(border-inset-left "20")
@ -73,7 +73,7 @@
'(border-inset-top "10") '(border-inset-top "10")
'(border-width-left "2") '(border-color-left "#669") '(border-inset-left "0") '(border-width-left "2") '(border-color-left "#669") '(border-inset-left "0")
'(border-inset-right "10") '(border-inset-bottom "-4") '(border-inset-right "10") '(border-inset-bottom "-4")
'(inset-left "12") '(inset-right "12") '(inset-top "12") '(inset-bottom "24") '(inset-left "12") '(inset-right "12") '(inset-top "12") '(inset-bottom "12")
attrs) new-exprs)) attrs) new-exprs))
(define (list-base attrs exprs [bullet-val #f]) (define (list-base attrs exprs [bullet-val #f])
@ -313,14 +313,11 @@
#:out 'sw #:out 'sw
#:offset (pt 0 (+ (quad-ref first-line 'inset-top 0))) #:offset (pt 0 (+ (quad-ref first-line 'inset-top 0)))
#:elems lines #:elems lines
;; this sizing approach doesn't work. #:size (delay (pt (pt-x (size first-line)) ;
;; can't add inset-top and inset-bottom here because page composition has already happened. (+ (for/sum ([line (in-list lines)])
;; therefore, resizing the block quads now will throw off the calculated page breaks. (pt-y (size line)))
#:size (pt (pt-x (size first-line)) ; (quad-ref first-line 'inset-top 0)
(+ (for/sum ([line (in-list lines)]) (quad-ref first-line 'inset-bottom 0))))
(pt-y (size line)))
(quad-ref first-line 'inset-top 0)
(quad-ref first-line 'inset-bottom 0)))
#:draw-start (λ (q doc) #:draw-start (λ (q doc)
;; adjust drawing coordinates for border inset ;; adjust drawing coordinates for border inset
(match-define (list bil bit bir bib) (match-define (list bil bit bir bib)
@ -357,7 +354,8 @@
(box-side (+ right (half bw-right)) bottom (- left (half bw-left)) bottom (box-side (+ right (half bw-right)) bottom (- left (half bw-left)) bottom
(quad-ref first-line 'border-color-bottom) bw-bottom) (quad-ref first-line 'border-color-bottom) bw-bottom)
(box-side left (+ bottom (half bw-bottom)) left (- top (half bw-top)) (box-side left (+ bottom (half bw-bottom)) left (- top (half bw-top))
(quad-ref first-line 'border-color-left) bw-left)))) (quad-ref first-line 'border-color-left) bw-left))
#:draw-end (λ (q doc) (draw-debug q doc "#6c6" "#9c9"))))
(define (contiguous-group-by pred xs) (define (contiguous-group-by pred xs)
@ -381,6 +379,10 @@
(wrap xs vertical-height (wrap xs vertical-height
#:soft-break line-spacer? #:soft-break line-spacer?
#:wrap-anywhere? #t #:wrap-anywhere? #t
#:distance (λ (q dist-so-far wrap-qs)
;; do trial block insertions
(for/sum ([x (in-list (insert-blocks wrap-qs))])
(pt-y (size x))))
#:finish-wrap (λ (lns q idx) #:finish-wrap (λ (lns q idx)
(list (struct-copy quad q:page (list (struct-copy quad q:page
[attrs (let ([page-number idx] [attrs (let ([page-number idx]
@ -390,21 +392,15 @@
(split-path (path-replace-extension path #""))) (split-path (path-replace-extension path #"")))
(hash-set! h 'doc-title (string-titlecase (path->string name))) (hash-set! h 'doc-title (string-titlecase (path->string name)))
h)] h)]
[elems lns]))))) [elems (insert-blocks lns)])))))
(define (insert-blocks pages) (define (insert-blocks lines)
;; block recomposition happens after page composition because page breaks can happen between lines. (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x 'display)) lines))
;; iow, the lines within a block may be split over multiple pages, each of which should be drawn (append* (for/list ([line-group (in-list groups-of-lines)])
;; as a separate block (match (quad-ref (car line-group) 'display)
(for/list ([page (in-list pages)]) ["block" (list (block-wrap line-group))]
(define lines (quad-elems page)) [_ line-group]))))
(define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x 'display)) lines))
(define lines-and-blocks
(append* (for/list ([lines (in-list groups-of-lines)])
(match (quad-ref (car lines) 'display)
["block" (list (block-wrap lines))]
[_ lines]))))
(struct-copy quad page [elems lines-and-blocks])))
(define (run xs path) (define (run xs path)
(define pdf (time-name make-pdf (make-pdf #:compress #t (define pdf (time-name make-pdf (make-pdf #:compress #t
@ -418,7 +414,6 @@
[x (time-name ->string-quad (map (λ (x) (->string-quad pdf x)) x))] [x (time-name ->string-quad (map (λ (x) (->string-quad pdf x)) x))]
[x (time-name line-wrap (line-wrap x line-width))] [x (time-name line-wrap (line-wrap x line-width))]
[x (time-name page-wrap (page-wrap x vertical-height path))] [x (time-name page-wrap (page-wrap x vertical-height path))]
[x (time-name insert-containers (insert-blocks x))]
[x (time-name position (position (struct-copy quad q:doc [elems x])))]) [x (time-name position (position (struct-copy quad q:doc [elems x])))])
(time-name draw (draw x pdf)))) (time-name draw (draw x pdf))))

4
quad/qtest/typewriter.rkt
Unescape Escape View File

@ -32,7 +32,7 @@
[else #true])) [else #true]))
#:draw (λ (q doc) #:draw (λ (q doc)
(set! draw-counter (add1 draw-counter )) (set! draw-counter (add1 draw-counter ))
(font-size doc (string->number (hash-ref (quad-attrs q) 'fontsize "12"))) (font-size doc (hash-ref (quad-attrs q) 'fontsize 12))
(let ([str (car (quad-elems q))]) (let ([str (car (quad-elems q))])
(cond (cond
[(hash-has-key? (quad-attrs q) 'link) [(hash-has-key? (quad-attrs q) 'link)
@ -51,7 +51,7 @@
[attrs (let ([h (quad-attrs q)]) (hash-set! h 'font charter) h)] [attrs (let ([h (quad-attrs q)]) (hash-set! h 'font charter) h)]
[elems (quad-elems q)] [elems (quad-elems q)]
[size (delay [size (delay
(define fontsize (string->number (hash-ref (quad-attrs q) 'fontsize "12"))) (define fontsize (hash-ref (quad-attrs q) 'fontsize 12))
(define str (car (quad-elems q))) (define str (car (quad-elems q)))
(font-size doc fontsize) (font-size doc fontsize)
(font doc (path->string charter)) (font doc (path->string charter))

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

@ -23,7 +23,9 @@
#:hard-break [hard-break? (λ (x) #f)] #:hard-break [hard-break? (λ (x) #f)]
#:soft-break [soft-break? (λ (x) #f)] #:soft-break [soft-break? (λ (x) #f)]
#:wrap-anywhere? [wrap-anywhere? #f] #:wrap-anywhere? [wrap-anywhere? #f]
#:finish-wrap [finish-wrap-proc (λ (xs q idx) (list xs))]) #:distance [distance-func (λ (q last-dist wrap-qs)
(+ last-dist (if (printable? q) (distance q) 0)))]
#:finish-wrap [finish-wrap-func (λ (xs q idx) (list xs))])
(define target-size-proc (define target-size-proc
(match target-size-proc-arg (match target-size-proc-arg
[(? procedure? proc) proc] [(? procedure? proc) proc]
@ -36,7 +38,7 @@
;; but we capture it separately because it's likely to get trimmed away by `nonprinting-at-end?` ;; but we capture it separately because it's likely to get trimmed away by `nonprinting-at-end?`
;; note: we don't trim `soft-break?` or `hard-break?` because that's an orthogonal consideration ;; 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. ;; for instance, a hyphen is `soft-break?` but shouldn't be trimmed.
(finish-wrap-proc (reverse (dropf qs nonprinting-at-end?)) wrap-triggering-q wrap-idx)) (finish-wrap-func (reverse (dropf qs nonprinting-at-end?)) wrap-triggering-q wrap-idx))
(let loop ([wraps null] ; list of (list of quads) (let loop ([wraps null] ; list of (list of quads)
[wrap-idx 1] ; wrap count (could be (length wraps) but we'd rather avoid `length`) [wrap-idx 1] ; wrap count (could be (length wraps) but we'd rather avoid `length`)
[next-wrap-head null] ; list of quads ending in previous `soft-break?` or `hard-break?` [next-wrap-head null] ; list of quads ending in previous `soft-break?` or `hard-break?`
@ -55,12 +57,12 @@
[(cons q other-qs) [(cons q other-qs)
(debug-report q 'next-q) (debug-report q 'next-q)
(debug-report (quad-elems q) 'next-q-elems) (debug-report (quad-elems q) 'next-q-elems)
(define would-be-wrap-qs (wrap-append (cons q next-wrap-tail) next-wrap-head))
(cond (cond
[(hard-break? q) [(hard-break? q)
(debug-report 'found-hard-break) (debug-report 'found-hard-break)
;; put hard break onto next-wrap-tail, and finish the wrap ;; put hard break onto next-wrap-tail, and finish the wrap
(define wrap-qs (wrap-append (cons q next-wrap-tail) next-wrap-head)) (loop (cons (finish-wrap would-be-wrap-qs wrap-idx) wraps)
(loop (cons (finish-wrap wrap-qs wrap-idx) wraps)
(add1 wrap-idx) (add1 wrap-idx)
null null
null null
@ -84,8 +86,8 @@
(distance q) (distance q)
other-qs)])] other-qs)])]
[else ; cases that require computing distance [else ; cases that require computing distance
(define dist (if (printable? q) (distance q) 0)) (define cumulative-dist (distance-func q current-dist would-be-wrap-qs))
(define would-overflow? (and current-dist (> (+ dist current-dist) (target-size-proc q wrap-idx)))) (define would-overflow? (> cumulative-dist (target-size-proc q wrap-idx)))
(cond (cond
[would-overflow? [would-overflow?
(cond (cond
@ -105,7 +107,7 @@
wrap-idx wrap-idx
(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) cumulative-dist
other-qs)] other-qs)]
[(empty? next-wrap-head) [(empty? next-wrap-head)
(debug-report 'would-overflow-hard-without-captured-break) (debug-report 'would-overflow-hard-without-captured-break)
@ -129,7 +131,7 @@
wrap-idx wrap-idx
(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) cumulative-dist
other-qs)] other-qs)]
[else [else
(debug-report 'would-not-overflow) (debug-report 'would-not-overflow)
@ -138,7 +140,7 @@
wrap-idx wrap-idx
next-wrap-head next-wrap-head
(cons q next-wrap-tail) (cons q next-wrap-tail)
(+ dist current-dist) cumulative-dist
other-qs)])])]))) other-qs)])])])))
(define q-zero (q #:size (pt 0 0))) (define q-zero (q #:size (pt 0 0)))
@ -285,14 +287,14 @@
(define (visual-wrap str int [debug #f]) (define (visual-wrap str int [debug #f])
(string-join (string-join
(for/list ([x (in-list (linewrap (for/list ([c (in-string str)]) (for/list ([x (in-list (linewrap (for/list ([c (in-string str)])
(define atom (q c)) (define atom (q c))
(if (equal? (quad-elems atom) '(#\space)) (if (equal? (quad-elems atom) '(#\space))
(struct-copy quad sp) (struct-copy quad sp)
(struct-copy quad q-one (struct-copy quad q-one
[attrs (quad-attrs atom)] [attrs (quad-attrs atom)]
[elems (quad-elems atom)]))) int debug))] [elems (quad-elems atom)]))) int debug))]
#:when (and (list? x) (andmap quad? x))) #:when (and (list? x) (andmap quad? x)))
(list->string (map car (map quad-elems x)))) (list->string (map car (map quad-elems x))))
"|")) "|"))
(module+ test (module+ test

Write Preview
Loading…
Cancel
Save