178 lines
7.1 KiB
Scheme
178 lines
7.1 KiB
Scheme
(module balloon mzscheme
|
|
(require "mrpict.ss"
|
|
"utils.ss"
|
|
mred
|
|
mzlib/class
|
|
mzlib/etc
|
|
mzlib/math)
|
|
|
|
(provide wrap-balloon pip-wrap-balloon
|
|
place-balloon
|
|
pin-balloon
|
|
(rename mk-balloon balloon)
|
|
make-balloon
|
|
balloon?
|
|
balloon-pict
|
|
balloon-point-x
|
|
balloon-point-y
|
|
balloon-color)
|
|
|
|
(define-struct balloon (pict point-x point-y))
|
|
|
|
(define no-pen (find-pen "white" 1 'transparent))
|
|
(define no-brush (find-brush "white" 'transparent))
|
|
(define black-pen (find-pen "black"))
|
|
|
|
(define (series dc steps start-c end-c f pen? brush?)
|
|
(color-series dc steps #e0.5 start-c end-c f pen? brush?))
|
|
|
|
(define (mk-balloon w h corner-radius spike-pos dx dy color)
|
|
(let ([dw (if (< corner-radius 1)
|
|
(* corner-radius w)
|
|
corner-radius)]
|
|
[dh (if (< corner-radius 1)
|
|
(* corner-radius h)
|
|
corner-radius)]
|
|
[dxbig (lambda (v) (if (> (abs dx) (abs dy))
|
|
v
|
|
0))]
|
|
[dybig (lambda (v) (if (<= (abs dx) (abs dy))
|
|
v
|
|
0))])
|
|
(let-values ([(bx0 by0 bx1 by1 x0 y0 x1 y1 xc yc mx0 mx1 my0 my1 mfx mfy)
|
|
(case spike-pos
|
|
[(w) (values -1 -0.5 -1 0.5
|
|
1 (/ (- h dh) 2)
|
|
1 (/ (+ h dh) 2)
|
|
1 (/ h 2)
|
|
0.5 1 0.5 -1
|
|
1 0)]
|
|
[(nw) (values 0 0 0 0
|
|
0 dh
|
|
dw 0
|
|
0 0
|
|
1 -0.5 -1 0.5
|
|
(dxbig 1) (dybig 1))]
|
|
[(e) (values 1 -0.5 1 0.5
|
|
(sub1 w) (/ (- h dh) 2)
|
|
(sub1 w) (/ (+ h dh) 2)
|
|
(sub1 w) (/ h 2)
|
|
-1 -1 1 -1
|
|
-1 0)]
|
|
[(ne) (values 0 0 0 0
|
|
(- w dw) 0
|
|
w dh
|
|
w 0
|
|
0.5 -1 0.5 -1
|
|
(dxbig -1) (dybig 1))]
|
|
[(s) (values -0.5 1 0.5 1
|
|
(/ (- w dw) 2) (sub1 h)
|
|
(/ (+ w dw) 2) (sub1 h)
|
|
(/ w 2) (sub1 h)
|
|
1 -1 -1 -1
|
|
0 -1)]
|
|
[(n) (values -0.5 -1 0.5 -1
|
|
(/ (- w dw) 2) 1
|
|
(/ (+ w dw) 2) 1
|
|
(/ w 2) 1
|
|
1 -1 1 1
|
|
0 1)]
|
|
[(sw) (values 0 0 0 0
|
|
0 (- (sub1 h) dh)
|
|
dw (sub1 h)
|
|
0 (sub1 h)
|
|
0.5 -1 0.5 -1
|
|
(dxbig 1) (dybig -1))]
|
|
[(se) (values 0 1 0 1
|
|
(- w dw) (sub1 h)
|
|
w (- (sub1 h) dh)
|
|
w (sub1 h)
|
|
0.5 -1 -1 0.5
|
|
(dxbig -1) (dybig -1))])])
|
|
(let ([xf (+ xc dx)]
|
|
[yf (+ yc dy)]
|
|
[dark-color (scale-color #e0.6 color)])
|
|
(make-balloon
|
|
(dc (lambda (dc x y)
|
|
(let ([b (send dc get-brush)]
|
|
[p (send dc get-pen)]
|
|
[draw-once
|
|
(lambda (i rr?)
|
|
(when rr?
|
|
(send dc draw-rounded-rectangle
|
|
(+ x (/ i 2)) (+ y (/ i 2))
|
|
(- w i) (- h i)
|
|
(if (and (< (* 2 corner-radius) (- w i))
|
|
(< (* 2 corner-radius) (- h i)))
|
|
corner-radius
|
|
(/ (min (- w i) (- h i)) 2)))
|
|
(let ([p (send dc get-pen)])
|
|
(send dc set-pen no-pen)
|
|
(send dc draw-polygon (list (make-object point% (+ x0 (* i mx0)) (+ y0 (* i my0)))
|
|
(make-object point% (+ xf (* i mfx)) (+ yf (* i mfy)))
|
|
(make-object point% (+ x1 (* i mx1)) (+ y1 (* i my1))))
|
|
x y)
|
|
(send dc set-pen p)))
|
|
(send dc draw-line (+ x x0 bx0 (* i mx0)) (+ y y0 by0 (* i my0))
|
|
(+ x xf (* i mfx)) (+ y yf (* i mfy)))
|
|
(send dc draw-line (+ x x1 bx1 (* i mx1)) (+ y y1 by1 (* i my1))
|
|
(+ x xf (* i mfx)) (+ y yf (* i mfy))))])
|
|
(series dc 5
|
|
dark-color
|
|
(if (string? color) (make-object color% color) color)
|
|
(lambda (i) (draw-once i #t))
|
|
#t #t)
|
|
(send dc set-brush no-brush)
|
|
(send dc set-pen (find-pen dark-color 0.5))
|
|
(draw-once 0 #f)
|
|
|
|
(send dc set-pen p)
|
|
(send dc set-brush b)))
|
|
w h 0 0)
|
|
xf yf)))))
|
|
|
|
(define balloon-color (make-object color% 255 255 170))
|
|
|
|
(define corner-size 32)
|
|
|
|
(define wrap-balloon
|
|
(opt-lambda (p corner dx dy [color balloon-color][c-rad corner-size])
|
|
(let ([b (mk-balloon (+ (pict-width p) (* 2 c-rad))
|
|
(+ (pict-height p) c-rad)
|
|
c-rad
|
|
corner dx dy
|
|
color)])
|
|
(make-balloon
|
|
(cc-superimpose
|
|
(balloon-pict b)
|
|
p)
|
|
(balloon-point-x b)
|
|
(balloon-point-y b)))))
|
|
|
|
(define pip-wrap-balloon
|
|
(opt-lambda (p corner dx dy [color balloon-color][c-rad corner-size])
|
|
(pin-balloon (wrap-balloon p corner dx dy color c-rad) (blank 0) 0 0)))
|
|
|
|
(define (do-place-balloon flip-proc? balloon p to find-to)
|
|
(let-values ([(x y) (if (and (number? to)
|
|
(number? find-to))
|
|
(values to (- (pict-height p)
|
|
find-to))
|
|
(if flip-proc?
|
|
(let-values ([(x y) (find-to p to)])
|
|
(values x (- (pict-height p) y)))
|
|
(find-to p to)))])
|
|
(cons-picture
|
|
p
|
|
`((place ,(- x (balloon-point-x balloon))
|
|
,(- y ; up-side down!
|
|
(- (pict-height (balloon-pict balloon))
|
|
(balloon-point-y balloon)))
|
|
,(balloon-pict balloon))))))
|
|
|
|
(define (place-balloon balloon p to find-to)
|
|
(do-place-balloon #f balloon p to find-to))
|
|
|
|
(define (pin-balloon balloon p to find-to)
|
|
(do-place-balloon #t balloon p to find-to)))
|