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

better blockage

Browse Source
main
Matthew Butterick 6 years ago
parent 3febe20e5b
commit 519ee64115
1 changed files with 82 additions and 63 deletions
Show Stats Download Patch File Download Diff File

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

@ -23,10 +23,15 @@
hrbr) hrbr)
(define-tag-function (blockquote attrs exprs) (define-tag-function (blockquote attrs exprs)
(qexpr (list* '(container "bq") (qexpr (list* '(display "block")
'(font "fira") '(fontsize "10") '(line-height "13.5") '(background-color "#eee")
'(inset-top "1") '(inset-bottom "7") '(inset-left "8") '(font "fira") '(fontsize "10") '(line-height "15")
attrs) exprs)) '(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-bottom "0.5") '(border-color-bottom "gray") '(border-inset-bottom "-2")
'(border-width-right "0.5") '(border-color-right "gray") '(border-inset-right "20")
'(inset-top "10") '(inset-bottom "8") '(inset-left "30") '(inset-right "30")
attrs) exprs))
(define id (default-tag-function 'id)) (define id (default-tag-function 'id))
(define class (default-tag-function 'class)) (define class (default-tag-function 'class))
@ -63,7 +68,13 @@
[str (in-list (string-split (string-join (get-elements expr) "") "\n"))]) [str (in-list (string-split (string-join (get-elements expr) "") "\n"))])
`(,(get-tag expr) ,(get-attrs expr) ,str)) `(,(get-tag expr) ,(get-attrs expr) ,str))
lbr)) lbr))
(qexpr (list* '(container "codeblock") '(line-height "13") '(inset-left "12") '(inset-right "12") attrs) new-exprs)) (qexpr (list* '(display "block") '(background-color "aliceblue")
'(font "fira-mono") '(fontsize "11") '(line-height "14")
'(border-inset-top "10")
'(border-width-left "2") '(border-color-left "#669") '(border-inset-left "0")
'(border-inset-right "10") '(border-inset-bottom "-4")
'(inset-left "12") '(inset-right "12") '(inset-top "12") '(inset-bottom "6")
attrs) new-exprs))
(define (list-base attrs exprs [bullet-val #f]) (define (list-base attrs exprs [bullet-val #f])
(qexpr (list* '(inset-left "20") attrs) (qexpr (list* '(inset-left "20") attrs)
@ -145,7 +156,7 @@
[else (current-line-height doc)])) [else (current-line-height doc)]))
(pt (string-width doc str) line-height))])])) (pt (string-width doc str) line-height))])]))
(define draw-debug? #t) (define draw-debug? #f)
(define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"]) (define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"])
(when draw-debug? (when draw-debug?
(save doc) (save doc)
@ -209,7 +220,12 @@
(check-true (line-break? (second (atomize (q "foo" pbr "bar")))))) (check-true (line-break? (second (atomize (q "foo" pbr "bar"))))))
(define (copy-block-attrs source-hash dest-hash) (define (copy-block-attrs source-hash dest-hash)
(define block-attrs '(container inset-top inset-bottom)) (define block-attrs '(display
inset-top inset-bottom inset-left inset-right
border-inset-top border-inset-bottom border-inset-left border-inset-right
border-width-left border-width-right border-width-top border-width-bottom
border-color-left border-color-right border-color-top border-color-bottom
background-color))
(for ([k (in-list block-attrs)]) (for ([k (in-list block-attrs)])
(cond (cond
[(hash-ref source-hash k #f) => (λ (val) (hash-set! dest-hash k val))])) [(hash-ref source-hash k #f) => (λ (val) (hash-set! dest-hash k val))]))
@ -268,14 +284,16 @@
(list q:line-spacer) (list q:line-spacer)
null))))) null)))))
(define zoom-mode? #f)
(define top-margin 60) (define top-margin 60)
(define bottom-margin 120) (define bottom-margin 120)
(define side-margin 120) (define side-margin 120)
(define page-offset (pt (/ side-margin 4) (/ top-margin 3))) (define page-offset (pt (/ side-margin (if zoom-mode? 3 1))
(/ top-margin (if zoom-mode? 3 1))))
(require racket/date) (require racket/date)
(define q:page (q #:offset page-offset (define q:page (q #:offset page-offset
#:draw-start (λ (q doc) (add-page doc) #:draw-start (λ (q doc) (add-page doc)
(scale doc 3 3)) (scale doc (if zoom-mode? 3 1) (if zoom-mode? 3 1)))
#:draw-end (λ (q doc) #:draw-end (λ (q doc)
(font-size doc 10) (font-size doc 10)
(font doc charter) (font doc charter)
@ -289,12 +307,11 @@
(define q:doc (q #:draw-start (λ (q doc) (start-doc doc)) (define q:doc (q #:draw-start (λ (q doc) (start-doc doc))
#:draw-end (λ (q doc) (end-doc doc)))) #:draw-end (λ (q doc) (end-doc doc))))
(define (make-blockquote lines) (define (block-wrap lines)
(define first-line (car lines)) (define first-line (car lines))
(q #:attrs (hasheq 'type "bq") (q #:in 'nw
#:in 'nw
#: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
#:size (delay (pt (pt-x (size first-line)) ; #:size (delay (pt (pt-x (size first-line)) ;
(+ (for/sum ([line (in-list lines)]) (+ (for/sum ([line (in-list lines)])
@ -302,41 +319,43 @@
(quad-ref first-line 'inset-top 0) (quad-ref first-line 'inset-top 0)
(quad-ref first-line 'inset-bottom 0)))) (quad-ref first-line 'inset-bottom 0))))
#:draw-start (λ (q doc) #:draw-start (λ (q doc)
(match-define (list left top) (quad-origin q)) ;; adjust drawing coordinates for border inset
(match-define (list right bottom) (size q)) (match-define (list bil bit bir bib)
#;(rect doc (- left 4) (+ top 6) right (+ bottom 2)) (map (λ (k) (quad-ref first-line k 0))
(rect doc left top right bottom) '(border-inset-left border-inset-top border-inset-right border-inset-bottom)))
(line-width doc 1) (match-define (list left top) (map + (quad-origin q) (list bil bit)))
(fill-and-stroke doc "#eee" "#999")))) (match-define (list width height) (map - (size q) (list (+ bil bir) (+ bit bib))))
;; fill rect
(define (make-codeblock pcs) (cond
(q #:attrs (hasheq 'type "codeblock") [(quad-ref first-line 'background-color)
#:in 'nw => (λ (bgcolor)
#:out 'sw (rect doc left top width height)
#:elems pcs (fill doc bgcolor))])
#:size (delay (pt (pt-x (size (car pcs))) ;; draw border
(for/sum ([pc (in-list pcs)]) (match-define (list bw-left bw-top bw-right bw-bottom)
(pt-y (size pc))))) (map (λ (k) (max 0 (quad-ref first-line k 0))) '(border-width-left
#:draw-start (λ (q doc) border-width-top
(save doc) border-width-right
(match-define (list left top) (quad-origin q)) border-width-bottom)))
(match-define (list right bottom) (size q)) ;; adjust start and end points based on adjacent border width
(translate doc (- left 4) (+ top 6)) ; reset origin to top left of quad ;; so all borders overlap rectangularly
(rect doc 0 0 right (+ bottom 2)) (define (half x) (/ x 2.0))
(fill doc "aliceblue") (define right (+ left width))
(define vert-line-width 6) (define bottom (+ top height))
(move-to doc (/ vert-line-width 2) 0) ; affirmatively move cursor (define (box-side x1 y1 x2 y2 color stroke-width)
(line-to doc (/ vert-line-width 2) bottom) ; strictly vert line (when (positive? stroke-width)
(line-width doc vert-line-width) (move-to doc x1 y1)
(stroke doc "#669") (line-to doc x2 y2)
#;(move-to doc 0 0) ; affirmatively move cursor (stroke doc (or color "black") stroke-width)))
#;(line-to doc 0 bottom) ; strictly horiz line (box-side (- left (half bw-left)) top (+ right (half bw-right)) top
#;(stroke doc "gray") (quad-ref first-line 'border-color-top) bw-top)
#;(translate doc 0 (+ bottom 2)) ; reset origin (box-side right (- top (half bw-top)) right (+ bottom (half bw-bottom))
#;(move-to doc 0 0) ; move again (quad-ref first-line 'border-color-right) bw-right)
#;(line-to doc right 0) ; same line, translated (box-side (+ right (half bw-right)) bottom (- left (half bw-left)) bottom
(stroke doc "gray") (quad-ref first-line 'border-color-bottom) bw-bottom)
(restore doc)))) (box-side left (+ bottom (half bw-bottom)) left (- top (half bw-top))
(quad-ref first-line 'border-color-left) bw-left))))
(define (contiguous-group-by pred xs) (define (contiguous-group-by pred xs)
;; like `group-by`, but only groups together contiguous xs with the same pred value. ;; like `group-by`, but only groups together contiguous xs with the same pred value.
@ -370,33 +389,33 @@
h)] h)]
[elems lns]))))) [elems lns])))))
(define (insert-containers pages) (define (insert-blocks pages)
;; container recomposition happens after page composition because page breaks can happen between lines. ;; block recomposition happens after page composition because page breaks can happen between lines.
;; iow, the lines within a container may be split over multiple pages, each of which should be drawn ;; iow, the lines within a block may be split over multiple pages, each of which should be drawn
;; as a separate container ;; as a separate block
(for/list ([page (in-list pages)]) (for/list ([page (in-list pages)])
(define lns (quad-elems page)) (define lines (quad-elems page))
(define groups (contiguous-group-by (λ (x) (hash-ref (quad-attrs x) 'container #f)) lns)) (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x 'display)) lines))
(define lns-and-containers (append* (for/list ([grp (in-list groups)]) (define lines-and-blocks
(match (hash-ref (quad-attrs (car grp)) 'container #f) (append* (for/list ([lines (in-list groups-of-lines)])
["bq" (list (make-blockquote grp))] (match (quad-ref (car lines) 'display)
["codeblock" (list (make-codeblock grp))] ["block" (list (block-wrap lines))]
[_ grp])))) [_ lines]))))
(struct-copy quad page [elems lns-and-containers]))) (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
#:auto-first-page #f #:auto-first-page #f
#:output-path path #:output-path path
#:width 350 #:width (if zoom-mode? 350 612)
#:height 400))) #:height (if zoom-mode? 400 792))))
(define line-width (- (pdf-width pdf) (* 2 side-margin))) (define line-width (- (pdf-width pdf) (* 2 side-margin)))
(define vertical-height (- (pdf-height pdf) top-margin bottom-margin)) (define vertical-height (- (pdf-height pdf) top-margin bottom-margin))
(let* ([x (time-name atomize (atomize (qexpr->quad xs)))] (let* ([x (time-name atomize (atomize (qexpr->quad xs)))]
[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-containers x))] [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))))

Write Preview
Loading…
Cancel
Save