You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
95 lines
3.8 KiB
Racket
95 lines
3.8 KiB
Racket
#lang debug racket
|
|
(require "attrs.rkt"
|
|
"param.rkt"
|
|
"log.rkt"
|
|
"debug.rkt"
|
|
"struct.rkt"
|
|
quad/base
|
|
pitfall)
|
|
(provide (all-defined-out))
|
|
|
|
|
|
(define ((block-draw-start first-line) q doc)
|
|
;; adjust drawing coordinates for border inset
|
|
(match-define (list bil bit bir bib)
|
|
(for/list ([k (in-list (list :border-inset-left :border-inset-top :border-inset-right :border-inset-bottom))])
|
|
(quad-ref first-line k 0)))
|
|
(match-define (list left top) (pt+ (quad-origin q) (list bil bit)))
|
|
(match-define (list width height) (pt- (size q) (list (+ bil bir) (+ bit bib))))
|
|
;; fill rect
|
|
(let ([bgc (quad-ref first-line :background-color)])
|
|
(when bgc
|
|
(rect doc left top width height)
|
|
(fill doc bgc)))
|
|
;; draw border
|
|
(match-define (list bw-left bw-top bw-right bw-bottom)
|
|
(map (λ (k) (max 0 (quad-ref first-line k 0)))
|
|
(list
|
|
:border-width-left
|
|
:border-width-top
|
|
:border-width-right
|
|
:border-width-bottom)))
|
|
;; adjust start and end points based on adjacent border width
|
|
;; so all borders overlap rectangularly
|
|
(define (half x) (/ x 2.0))
|
|
(define right (+ left width))
|
|
(define bottom (+ top height))
|
|
(define (box-side x1 y1 x2 y2 color stroke-width)
|
|
(when (positive? stroke-width)
|
|
(move-to doc x1 y1)
|
|
(line-to doc x2 y2)
|
|
(stroke doc (or color "black") stroke-width)))
|
|
(box-side (- left (half bw-left)) top (+ right (half bw-right)) top
|
|
(quad-ref first-line :border-color-top) bw-top)
|
|
(box-side right (- top (half bw-top)) right (+ bottom (half bw-bottom))
|
|
(quad-ref first-line :border-color-right) bw-right)
|
|
(box-side (+ right (half bw-right)) bottom (- left (half bw-left)) bottom
|
|
(quad-ref first-line :border-color-bottom) bw-bottom)
|
|
(box-side left (+ bottom (half bw-bottom)) left (- top (half bw-top))
|
|
(quad-ref first-line :border-color-left) bw-left)
|
|
(case (quad-ref first-line :block-clip)
|
|
[(#true)
|
|
(when (eq? (log-clipping?) 'warn)
|
|
(for ([line (in-list (quad-elems q))])
|
|
(define line-width (pt-x (size line)))
|
|
(define line-elem-width (sum-x (quad-elems line)))
|
|
(when (< line-width line-elem-width)
|
|
(define error-str (apply string-append (for/list ([q (in-list (quad-elems line))])
|
|
(match (quad-elems q)
|
|
[(list (? string? str)) str]
|
|
[_ ""]))))
|
|
(log-quadwriter-warning (format "clipping overfull line: ~v" error-str)))))
|
|
(save doc)
|
|
(rect doc left top width height)
|
|
(clip doc)]))
|
|
|
|
(define ((block-draw-end first-line) q doc)
|
|
(case (quad-ref first-line :block-clip)
|
|
[(#true) (restore doc)])
|
|
(when (draw-debug-block?)
|
|
(draw-debug q doc "#6c6" "#9c9")))
|
|
|
|
(define (insert-blocks lines)
|
|
(define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x :display)) lines))
|
|
(append* (for/list ([line-group (in-list groups-of-lines)])
|
|
(if (quad-ref (car line-group) :display)
|
|
(list (lines->block line-group))
|
|
line-group))))
|
|
|
|
(define (lines->block lines)
|
|
(match lines
|
|
[(cons line _)
|
|
(make-quad
|
|
#:type block-quad
|
|
#:from 'sw
|
|
#:to 'nw
|
|
#:elems (from-parent lines 'nw)
|
|
#:tag 'block
|
|
#:attrs (quad-attrs line)
|
|
#:size (delay (pt (pt-x (size line)) ;
|
|
(+ (sum-y lines)
|
|
(quad-ref line :inset-top 0)
|
|
(quad-ref line :inset-bottom 0))))
|
|
#:shift-elems (pt 0 (quad-ref line :inset-top 0))
|
|
#:draw-start (block-draw-start line)
|
|
#:draw-end (block-draw-end line))])) |