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.
typesetting/quad/quadwriter/debug.rkt

64 lines
2.6 KiB
Racket

#lang debug racket
5 years ago
(require pitfall
quad/position
quad/quad)
(provide (all-defined-out))
5 years ago
(define-for-syntax debug-mode #false)
(define-syntax (go stx)
(datum->syntax stx
(cond
[debug-mode
'(begin
(define draw-debug? (make-parameter #true))
(define draw-debug-line? (make-parameter #true))
(define draw-debug-block? (make-parameter #false))
(define draw-debug-string? (make-parameter #true))
(define draw-debug-image? (make-parameter #false))
5 years ago
(define draw-debug-draw? (make-parameter #false))
5 years ago
(define debug-page-width (make-parameter 400))
(define debug-page-height (make-parameter 400))
(define debug-x-margin (make-parameter 50))
(define debug-y-margin (make-parameter 50))
(define debug-column-count (make-parameter 1))
(define debug-column-gap (make-parameter 36)))]
[else
'(begin
(define draw-debug? (make-parameter #false))
(define draw-debug-line? (make-parameter #true))
(define draw-debug-block? (make-parameter #true))
(define draw-debug-string? (make-parameter #true))
(define draw-debug-image? (make-parameter #true))
5 years ago
(define draw-debug-draw? (make-parameter #true))
5 years ago
(define debug-page-width (make-parameter #f))
(define debug-page-height (make-parameter #f))
(define debug-x-margin (make-parameter #f))
(define debug-y-margin (make-parameter #f))
(define debug-column-count (make-parameter #f))
(define debug-column-gap (make-parameter #f)))])))
(go)
(define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"] . _)
(define stroke-width 0.5)
(when (draw-debug?)
(save doc)
;; draw layout box
(line-width doc stroke-width)
; subtracting stroke-width keeps adjacent boxes from overlapping
(save doc)
(apply rect doc (append (pt+ (quad-origin q)) (map (λ (x) (- x stroke-width)) (size q))))
(clip doc)
(define pt (to-point q))
(circle doc (pt-x pt) (pt-y pt) (+ 3 stroke-width))
(fill doc fill-color)
(restore doc)
(apply rect doc (append (pt+ (quad-origin q)) (map (λ (x) (- x stroke-width)) (size q))))
(stroke doc stroke-color)
5 years ago
(restore doc)))