107 lines
3.9 KiB
Racket
107 lines
3.9 KiB
Racket
#lang racket/base
|
|
(require slideshow/pict
|
|
"display.rkt"
|
|
"constants.rkt")
|
|
(provide opacity-layer
|
|
circle-pict
|
|
rect-pict
|
|
text-pict
|
|
text-block-pict
|
|
draw-line-onto
|
|
make-stand-out
|
|
at
|
|
draw-stack-onto)
|
|
|
|
;;opacity-layer : float uint uint -> pict
|
|
(define (opacity-layer alpha w h)
|
|
(cellophane (colorize (filled-rectangle w h)
|
|
"white")
|
|
0.6))
|
|
|
|
;;circle-pict : string string uint [uint] -> pict
|
|
(define (circle-pict color stroke-color width #:stroke-width [stroke-width 1])
|
|
(pin-over (colorize (filled-ellipse width width)
|
|
stroke-color)
|
|
(* stroke-width 2)
|
|
(* stroke-width 2)
|
|
(colorize (filled-ellipse (- width (* stroke-width 4))
|
|
(- width (* stroke-width 4)))
|
|
color)))
|
|
|
|
;;rect-pict : string string uint uint [uint] -> pict
|
|
(define (rect-pict color stroke-color width height #:stroke-width [stroke-width 1])
|
|
(pin-over (colorize (filled-rectangle width height)
|
|
stroke-color)
|
|
(* stroke-width 2)
|
|
(* stroke-width 2)
|
|
(colorize (filled-rectangle (- width (* stroke-width 4))
|
|
(- height (* stroke-width 4)))
|
|
color)))
|
|
|
|
;;text-pict : string [string] -> pict
|
|
(define (text-pict t #:color [color "black"])
|
|
(colorize (text t) color))
|
|
|
|
;;text-block-pict : string [string] [string] [uint] [float] [uint] [uint] -> pict
|
|
(define (text-block-pict t #:backcolor [backcolor "white"]
|
|
#:forecolor [forecolor "black"]
|
|
#:padding [padding 10]
|
|
#:opacity [opacity 1.0]
|
|
#:width [width 0]
|
|
#:height [height 0])
|
|
(let* ([textp (colorize (text t) forecolor)]
|
|
[padx2 (* padding 2)]
|
|
[text-cont (pin-over (blank (+ (pict-width textp) padx2)
|
|
(+ (pict-height textp) padx2))
|
|
padding
|
|
padding
|
|
textp)]
|
|
[bg (cellophane (colorize (filled-rectangle (max width (pict-width text-cont))
|
|
(max height (pict-height text-cont)))
|
|
backcolor)
|
|
opacity)])
|
|
(lc-superimpose bg text-cont)))
|
|
|
|
;;draw-line-onto : pict uint uint uint uint string -> pict
|
|
(define (draw-line-onto base
|
|
startx
|
|
starty
|
|
endx
|
|
endy
|
|
color
|
|
#:width [width 1]
|
|
#:with-arrow [with-arrow #f]
|
|
#:arrow-sz [arrow-sz 10]
|
|
#:style [style 'solid])
|
|
(let ([dx (- endx startx)]
|
|
[dy (- endy starty)]
|
|
[line-f (if with-arrow pip-arrow-line pip-line)])
|
|
(pin-over base
|
|
startx
|
|
starty
|
|
(linewidth width
|
|
(linestyle style
|
|
(colorize (line-f dx dy arrow-sz)
|
|
color))))))
|
|
|
|
;;make-stand-out : pict -> pict
|
|
(define (make-stand-out pict)
|
|
(scale pict 2))
|
|
|
|
(struct draw-at (x y p) #:transparent)
|
|
|
|
;;at : uint uint pict -> draw-at
|
|
(define (at x y p)
|
|
(draw-at x y p))
|
|
|
|
;;draw-stack-onto : pict (listof pict) -> pict
|
|
(define (draw-stack-onto base . picts)
|
|
(for/fold ([p base]) ([cur-p (in-list picts)])
|
|
(cond
|
|
[(pict? cur-p) (pin-over p 0 0 cur-p)]
|
|
[(draw-at? cur-p) (pin-over p
|
|
(draw-at-x cur-p)
|
|
(draw-at-y cur-p)
|
|
(draw-at-p cur-p))]
|
|
[else (error 'draw-onto "Invalid argument in 'picts' list.")])))
|