530 lines
17 KiB
Scheme
530 lines
17 KiB
Scheme
#lang scheme/base
|
|
(provide draw-honu)
|
|
|
|
(require scheme/class
|
|
scheme/gui/base
|
|
"palaka.ss")
|
|
|
|
(define pi (atan 0 -1))
|
|
|
|
(define body-path (make-object dc-path%))
|
|
|
|
(define (find-arc-spot x y w h end)
|
|
(let ([ce (cos end)]
|
|
[se (- (sin end))])
|
|
(values (+ x (* w 1/2) (* w 1/2 ce))
|
|
(+ y (* h 1/2) (* h 1/2 se)))))
|
|
|
|
(define weighted-arc
|
|
(lambda (path x y w h start end ccw? [dx1 0.0] [dy1 0.2] [dx2 dx1] [dy2 (- dy1)])
|
|
(let ([sweep (let loop ([s (if ccw? (- end start) (- start end))])
|
|
(if (< s 0)
|
|
(loop (+ s (* 2 pi)))
|
|
s))])
|
|
(if (> sweep pi)
|
|
(let ([halfway ((if ccw? + -) start (/ sweep 2))])
|
|
(weighted-arc path x y w h start halfway ccw? dx1 dy1 dx2 dy2)
|
|
(weighted-arc path x y w h halfway end ccw? dx2 (- dy2) dx1 (- dy1)))
|
|
(let ([p (new dc-path%)])
|
|
;; Set p to be the arc for a unit circle,
|
|
;; centered on the X-axis:
|
|
(let* ([x0 (cos (/ sweep 2))]
|
|
[y0 (sin (/ sweep 2))]
|
|
[x1 (/ (- 4 x0) 3)]
|
|
[y1 (/ (* (- 1 x0) (- 3 x0)) (* 3 y0))]
|
|
[x2 x1]
|
|
[y2 (- y1)]
|
|
[x3 x0]
|
|
[y3 (- y0)]
|
|
[sw (/ w 2)]
|
|
[sh (/ h 2)])
|
|
(send p move-to x0 y0)
|
|
(send p curve-to
|
|
(+ x1 dx1) (+ y1 dy1)
|
|
(+ x2 dx2) (+ y2 dy2)
|
|
x3 y3)
|
|
;; Rotate to match start:
|
|
(send p rotate (+ (if ccw? start end) (/ sweep 2)))
|
|
;; Scale to match width and height:
|
|
(send p scale (/ w 2) (/ h 2))
|
|
;; Translate to match x and y
|
|
(send p translate (+ x (/ w 2)) (+ y (/ h 2)))
|
|
(unless ccw?
|
|
(send p reverse)))
|
|
(send path append p))))))
|
|
|
|
(define overall-rotation (- (* pi 1/2 3/8)))
|
|
|
|
(define body-width 100)
|
|
(define body-height 110)
|
|
(define body-thickness 12)
|
|
(define angle-offset (* pi 1/10))
|
|
|
|
(define big-fin-curve-top-offset 0)
|
|
(define big-fin-curve-bottom-offset 4)
|
|
(define big-fin-top-angle (* pi 3/12))
|
|
(define big-fin-bottom-angle (* pi 2/12))
|
|
(define big-fin-size 60)
|
|
(define big-fin-right-edge (+ body-width big-fin-size))
|
|
|
|
(define little-fin-top-angle (- (* pi (/ 3.5 12))))
|
|
(define little-fin-bottom-angle (- (* pi (/ 4.5 12))))
|
|
(define little-fin-size 20)
|
|
(define little-fin-far-y (+ body-height little-fin-size))
|
|
|
|
(define pointy-tip-offset 8)
|
|
|
|
(define head-angle-span (* pi 1/6))
|
|
|
|
(define head-cx (/ body-width 2))
|
|
(define head-cy -8)
|
|
|
|
(define head-width 30)
|
|
(define head-height 40)
|
|
|
|
(define acos-arg
|
|
(* (/ 2 head-width) (- (* (cos (- (/ pi 2) (/ head-angle-span 2)))
|
|
(/ body-width 2)))))
|
|
|
|
(define head-theta-start (- (acos acos-arg)))
|
|
(define head-theta-end (- pi head-theta-start))
|
|
|
|
(define-values (head-attach-left-x head-attach-left-y)
|
|
(find-arc-spot 0 0 body-width body-height (+ (/ pi 2) (/ head-angle-span 2))))
|
|
(define-values (head-attach-right-x head-attach-right-y)
|
|
(find-arc-spot 0 0 body-width body-height (- (/ pi 2) (/ head-angle-span 2))))
|
|
|
|
(define right-edge-of-center-line (+ (/ body-width 2) (/ body-thickness 2)))
|
|
(define left-edge-of-center-line (- (/ body-width 2) (/ body-thickness 2)))
|
|
|
|
(define-values (big-fin-top-x big-fin-top-y)
|
|
(find-arc-spot 0 0 body-width body-height big-fin-top-angle))
|
|
(define-values (big-fin-bottom-x big-fin-bottom-y)
|
|
(find-arc-spot 0 0 body-width body-height big-fin-bottom-angle))
|
|
|
|
(define-values (left-little-fin-top-x left-little-fin-top-y)
|
|
(find-arc-spot 0 0 body-width body-height (- pi little-fin-top-angle)))
|
|
(define-values (left-little-fin-bottom-x left-little-fin-bottom-y)
|
|
(find-arc-spot 0 0 body-width body-height (- pi little-fin-bottom-angle)))
|
|
|
|
(define-values (little-fin-top-x little-fin-top-y)
|
|
(find-arc-spot 0 0 body-width body-height little-fin-top-angle))
|
|
(define-values (little-fin-bottom-x little-fin-bottom-y)
|
|
(find-arc-spot 0 0 body-width body-height little-fin-bottom-angle))
|
|
|
|
(define-values (inner-right-arc-top-x inner-right-arc-top-y)
|
|
(find-arc-spot
|
|
body-thickness
|
|
body-thickness
|
|
(- body-width body-thickness body-thickness)
|
|
(- body-height body-thickness body-thickness)
|
|
(- (* pi 1/2) angle-offset)))
|
|
|
|
(define-values (inner-right-arc-bottom-x inner-right-arc-bottom-y)
|
|
(find-arc-spot
|
|
body-thickness
|
|
body-thickness
|
|
(- body-width body-thickness body-thickness)
|
|
(- body-height body-thickness body-thickness)
|
|
(+ (* pi 3/2) angle-offset)))
|
|
|
|
(define (add-big-fin-top add)
|
|
(let ([fin-width (- big-fin-right-edge big-fin-top-x)])
|
|
(add big-fin-top-x
|
|
big-fin-top-y
|
|
|
|
(+ big-fin-top-x (* 1/3 fin-width))
|
|
big-fin-curve-top-offset
|
|
|
|
(+ big-fin-top-x (* 2/3 fin-width))
|
|
big-fin-curve-top-offset
|
|
|
|
big-fin-right-edge
|
|
(+ big-fin-bottom-y 10))))
|
|
|
|
(define (add-big-fin-bottom add)
|
|
(let ([fin-width (- big-fin-right-edge big-fin-bottom-x)])
|
|
(add
|
|
(+ big-fin-bottom-x fin-width)
|
|
(+ big-fin-bottom-y 10)
|
|
|
|
(+ big-fin-bottom-x (* 1/3 fin-width))
|
|
(- (/ (+ big-fin-bottom-y big-fin-top-y) 2)
|
|
big-fin-curve-bottom-offset)
|
|
|
|
(+ big-fin-bottom-x (* 1/5 fin-width))
|
|
(/ (+ big-fin-bottom-y big-fin-top-y) 2)
|
|
|
|
big-fin-bottom-x
|
|
big-fin-bottom-y)))
|
|
|
|
(define (add-little-fin-top add)
|
|
(add
|
|
little-fin-top-x
|
|
little-fin-top-y
|
|
|
|
(+ little-fin-top-x (* (- little-fin-top-x little-fin-bottom-x) 2/3))
|
|
(+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 1/3))
|
|
|
|
(+ little-fin-top-x (* (- little-fin-top-x little-fin-bottom-x) 1/3))
|
|
(+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 2/3))
|
|
|
|
little-fin-top-x
|
|
little-fin-far-y))
|
|
|
|
(define (add-little-fin-bottom add)
|
|
(add
|
|
little-fin-top-x
|
|
little-fin-far-y
|
|
|
|
(+ little-fin-top-x (* (- little-fin-bottom-x little-fin-top-x) 2/3))
|
|
(+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 1/3))
|
|
|
|
(+ little-fin-top-x (* (- little-fin-bottom-x little-fin-top-x) 2/3))
|
|
(+ little-fin-top-y (* (- little-fin-far-y little-fin-top-y) 1/3))
|
|
|
|
little-fin-bottom-x
|
|
little-fin-bottom-y))
|
|
|
|
(define (add-dot path x y)
|
|
(let ([p (new dc-path%)])
|
|
(send p ellipse (- x 2) (- y 2) 4 4)
|
|
(send path append p)))
|
|
|
|
(define (same-side-add x1 y1 x2 y2 x3 y3 x4 y4)
|
|
(send body-path curve-to x2 y2 x3 y3 x4 y4))
|
|
|
|
(define (same-side-add/dot x1 y1 x2 y2 x3 y3 x4 y4)
|
|
(send body-path line-to x1 y1)
|
|
(add-dot body-path x1 y1)
|
|
(send body-path line-to x2 y2)
|
|
(add-dot body-path x2 y2)
|
|
(send body-path line-to x3 y3)
|
|
(add-dot body-path x3 y3))
|
|
|
|
(define (opposite-side-add x1 y1 x2 y2 x3 y3 x4 y4)
|
|
(let ([conv (lambda (x y) (values (+ (- x) body-width) y))])
|
|
(let-values ([(cx1 cy1) (conv x1 y1)]
|
|
[(cx2 cy2) (conv x2 y2)]
|
|
[(cx3 cy3) (conv x3 y3)])
|
|
(send body-path curve-to cx3 cy3 cx2 cy2 cx1 cy1))))
|
|
|
|
(define (opposite-side-add/dot x1 y1 x2 y2 x3 y3 x4 y4)
|
|
(let ([conv (lambda (x y) (values (+ (- x) body-width) y))])
|
|
(let-values ([(cx1 cy1) (conv x1 y1)]
|
|
[(cx2 cy2) (conv x2 y2)]
|
|
[(cx3 cy3) (conv x3 y3)])
|
|
(send body-path line-to cx3 cy3)
|
|
(add-dot body-path cx3 cy3)
|
|
(send body-path line-to cx2 cy2)
|
|
(add-dot body-path cx2 cy2)
|
|
(send body-path line-to cx1 cy1)
|
|
(add-dot body-path cx1 cy1))))
|
|
|
|
(define side-perturb-y 0.0)
|
|
(define side-perturb-x -0.1)
|
|
|
|
(weighted-arc body-path 0 0 body-width body-height big-fin-bottom-angle little-fin-top-angle #f
|
|
side-perturb-x side-perturb-y)
|
|
(add-little-fin-top same-side-add)
|
|
(add-little-fin-bottom same-side-add)
|
|
|
|
(send body-path line-to
|
|
little-fin-bottom-x
|
|
little-fin-bottom-y)
|
|
|
|
(send body-path line-to
|
|
(/ body-width 2)
|
|
(+ body-height pointy-tip-offset))
|
|
|
|
(send body-path line-to
|
|
left-little-fin-bottom-x
|
|
left-little-fin-bottom-y)
|
|
|
|
(add-little-fin-bottom opposite-side-add)
|
|
(add-little-fin-top opposite-side-add)
|
|
|
|
(weighted-arc body-path 0 0 body-width body-height
|
|
(- pi little-fin-top-angle)
|
|
(- pi big-fin-bottom-angle)
|
|
#f
|
|
side-perturb-x side-perturb-y)
|
|
|
|
(add-big-fin-bottom opposite-side-add)
|
|
(add-big-fin-top opposite-side-add)
|
|
|
|
(weighted-arc body-path 0 0 body-width body-height (- pi big-fin-top-angle) (+ (/ pi 2) (/ head-angle-span 2)) #f 0 0)
|
|
|
|
|
|
(weighted-arc body-path
|
|
(- head-cx (/ head-width 2))
|
|
(- head-cy (/ head-height 2))
|
|
head-width
|
|
head-height
|
|
head-theta-start
|
|
head-theta-end
|
|
#f 0 0 0 -0.2)
|
|
|
|
(weighted-arc body-path 0 0 body-width body-height (- (/ pi 2) (/ head-angle-span 2)) big-fin-top-angle #f 0 0)
|
|
|
|
(add-big-fin-top same-side-add)
|
|
(add-big-fin-bottom same-side-add)
|
|
(send body-path close)
|
|
|
|
(define (make-right-hole-path)
|
|
(let ([right-hole-path (make-object dc-path%)])
|
|
|
|
(define arc/end
|
|
(lambda (x y w h start end [cc? #t] [dx1 0] [dy1 0.2] [dx2 0] [dy2 -0.2])
|
|
(weighted-arc right-hole-path x y w h start end cc? dx1 dy1 dx2 dy2)
|
|
(find-arc-spot x y w h end)))
|
|
|
|
(define-values (arc1x arc1y)
|
|
(arc/end body-thickness
|
|
body-thickness
|
|
(- body-width body-thickness body-thickness)
|
|
(- body-height body-thickness body-thickness)
|
|
(- (* pi 1/2) angle-offset)
|
|
(+ (* pi 3/2) angle-offset)
|
|
#f -0.2 0.2 0 -0.2))
|
|
|
|
(define little-arc-size (* 2 (- inner-right-arc-bottom-x right-edge-of-center-line)))
|
|
|
|
(define-values (arc2x arc2y)
|
|
(arc/end
|
|
right-edge-of-center-line
|
|
(- inner-right-arc-bottom-y little-arc-size)
|
|
little-arc-size
|
|
little-arc-size
|
|
(* 3/2 pi)
|
|
pi
|
|
#f
|
|
0 0 0 0))
|
|
|
|
(let ([arc2y (- body-height arc2y)])
|
|
(send right-hole-path curve-to
|
|
|
|
(+ (/ (+ (* 2 arc1x) (* 1 arc2x)) 3) -4)
|
|
(/ (+ (* 2 arc1y) (* 1 arc2y)) 3)
|
|
|
|
(+ (/ (+ (* 1 arc1x) (* 2 arc2x)) 3) -4)
|
|
(/ (+ (* 1 arc1y) (* 2 arc2y)) 3)
|
|
|
|
arc2x arc2y))
|
|
|
|
(weighted-arc right-hole-path
|
|
right-edge-of-center-line
|
|
inner-right-arc-top-y
|
|
little-arc-size
|
|
little-arc-size
|
|
pi
|
|
(* 1/2 pi)
|
|
#f
|
|
0 0 0 0)
|
|
|
|
(send right-hole-path close)
|
|
|
|
right-hole-path))
|
|
|
|
(define (make-left-hole-path)
|
|
(let ([left-hole-path (make-right-hole-path)])
|
|
(send left-hole-path scale -1 1)
|
|
(send left-hole-path translate
|
|
(+ right-edge-of-center-line left-edge-of-center-line) 0)
|
|
left-hole-path))
|
|
|
|
(define right-hole-path (make-right-hole-path))
|
|
(define left-hole-path (make-left-hole-path))
|
|
|
|
(define (adjust-path path)
|
|
(send path translate (+ (- big-fin-right-edge body-width) 1) (+ (- head-cy) (/ head-height 2) 2))
|
|
(send path rotate overall-rotation))
|
|
|
|
(adjust-path body-path)
|
|
(adjust-path left-hole-path)
|
|
(adjust-path right-hole-path)
|
|
|
|
(define pale-red-color (make-object color% 242 183 183))
|
|
(define pale-blue-color (make-object color% 183 202 242))
|
|
(define pale-background-color (make-object color% 209 220 248))
|
|
|
|
(define current-body-path body-path)
|
|
(define current-left-hole-path left-hole-path)
|
|
(define current-right-hole-path right-hole-path)
|
|
|
|
(define (draw dc main-pen-color main-color left-pen-color left-color right-pen-color right-color dx dy)
|
|
(send dc set-brush main-color 'solid)
|
|
(send dc set-pen main-pen-color 1 'solid)
|
|
(send dc draw-path current-body-path dx dy)
|
|
(draw-holes dc left-pen-color left-color right-pen-color right-color dx dy))
|
|
|
|
(define (draw-holes dc left-pen-color left-color right-pen-color right-color dx dy)
|
|
(send dc set-brush left-color 'solid)
|
|
(send dc set-pen left-pen-color 1 'solid)
|
|
(send dc draw-path current-left-hole-path dx dy)
|
|
(send dc set-brush right-color 'solid)
|
|
(send dc set-pen right-pen-color 1 'solid)
|
|
(send dc draw-path current-right-hole-path dx dy))
|
|
|
|
(define base-width 260)
|
|
(define base-height 240)
|
|
|
|
(define dark-x 80)
|
|
(define dark-y -20)
|
|
(define current-dark-x dark-x)
|
|
(define current-dark-y dark-y)
|
|
|
|
(define light-x 350)
|
|
(define light-y dark-y)
|
|
(define current-light-x light-x)
|
|
(define current-light-y light-y)
|
|
|
|
(define (rescale w h)
|
|
(let ([scale (min (/ w base-width) (/ h base-height))])
|
|
(set! current-body-path (new dc-path%))
|
|
(send current-body-path append body-path)
|
|
(send current-body-path scale scale scale)
|
|
(set! current-left-hole-path (new dc-path%))
|
|
(send current-left-hole-path append left-hole-path)
|
|
(send current-left-hole-path scale scale scale)
|
|
(set! current-right-hole-path (new dc-path%))
|
|
(send current-right-hole-path append right-hole-path)
|
|
(send current-right-hole-path scale scale scale)
|
|
(set! current-light-x (* light-x scale))
|
|
(set! current-light-y (* light-y scale))
|
|
(set! current-dark-x (* dark-x scale))
|
|
(set! current-dark-y (* dark-y scale))))
|
|
|
|
(define my-canvas%
|
|
(class canvas%
|
|
(define/override (on-size w h)
|
|
(rescale w h))
|
|
(super-new)))
|
|
|
|
|
|
(define (vector-map f v)
|
|
(build-vector (vector-length v)
|
|
(λ (i) (f (vector-ref v i)))))
|
|
|
|
(define color-series
|
|
(vector-map (λ (l) (vector-map (λ (x) (send the-color-database find-color x)) l))
|
|
'#(#("red" "blue")
|
|
#("red" "blue")
|
|
#("Magenta" "MediumOrchid")
|
|
#("MediumOrchid" "Magenta")
|
|
#("blue" "red"))))
|
|
|
|
|
|
(define black-honu-bitmap 'not-yet-the-bitmap)
|
|
(define black-honu-bdc (make-object bitmap-dc%))
|
|
|
|
(define (do-draw dc left-body-color right-body-color)
|
|
(send dc draw-bitmap black-honu-bitmap 0 0)
|
|
(send dc set-smoothing 'aligned)
|
|
(draw-holes dc left-body-color left-body-color right-body-color right-body-color
|
|
current-dark-x
|
|
current-dark-y))
|
|
|
|
(define (set-size w h)
|
|
;; update the bitmap if the size has changed
|
|
(unless (and (is-a? black-honu-bitmap bitmap%)
|
|
(equal? w (send black-honu-bitmap get-width))
|
|
(equal? h (send black-honu-bitmap get-height)))
|
|
(rescale w h)
|
|
(set! black-honu-bitmap (make-object bitmap% w h))
|
|
(recalc-bitmap)))
|
|
|
|
(define (recalc-bitmap)
|
|
(send black-honu-bdc set-bitmap black-honu-bitmap)
|
|
(send black-honu-bdc set-smoothing 'aligned)
|
|
(draw-palaka black-honu-bdc (send black-honu-bitmap get-width) (send black-honu-bitmap get-height))
|
|
(draw black-honu-bdc
|
|
"black" "black" "black" "black" "black" "black"
|
|
current-dark-x
|
|
current-dark-y)
|
|
(send black-honu-bdc set-bitmap #f))
|
|
|
|
(define (set-val val left-body-color right-body-color)
|
|
(cond
|
|
[(and (<= 0 val)
|
|
(< val 1))
|
|
(let* ([scaled-val (* val (- (vector-length color-series) 1))]
|
|
[set (floor scaled-val)]
|
|
[in-set-val (- scaled-val set)]
|
|
[before-colors (vector-ref color-series set)]
|
|
[after-colors (vector-ref color-series (+ set 1))])
|
|
(linear-color-combination (vector-ref before-colors 0)
|
|
(vector-ref after-colors 0)
|
|
in-set-val
|
|
left-body-color)
|
|
(linear-color-combination (vector-ref before-colors 1)
|
|
(vector-ref after-colors 1)
|
|
in-set-val
|
|
right-body-color))]
|
|
[else
|
|
(let ([set (vector-ref color-series (- (vector-length color-series) 1))])
|
|
(send left-body-color copy-from (vector-ref set 0))
|
|
(send right-body-color copy-from (vector-ref set 1)))]))
|
|
|
|
(define (linear-color-combination xc yc val uc)
|
|
(send uc set
|
|
(linear-combination (send xc red) (send yc red) val)
|
|
(linear-combination (send xc green) (send yc green) val)
|
|
(linear-combination (send xc blue) (send yc blue) val)))
|
|
|
|
(define (linear-combination x y val)
|
|
(floor (+ x (* val (- y x)))))
|
|
|
|
(define draw-honu
|
|
(let ()
|
|
;; colors
|
|
(define left-body-color (make-object color% 0 0 0))
|
|
(define right-body-color (make-object color% 0 0 0))
|
|
|
|
(λ (dc val range w h)
|
|
(set-size w h)
|
|
(set-val (/ val range) left-body-color right-body-color)
|
|
(do-draw dc left-body-color right-body-color))))
|
|
|
|
#;
|
|
(let ()
|
|
(define f (new frame% (label "")))
|
|
(define c2 (new canvas% [parent f]
|
|
[min-width 200]
|
|
[min-height 200]
|
|
[style '(no-autoclear)]
|
|
[paint-callback
|
|
(λ (c dc)
|
|
(let-values ([(w h) (send c get-client-size)])
|
|
(draw-honu dc
|
|
(send slider get-value)
|
|
100
|
|
w
|
|
h)))]))
|
|
(define slider (new slider%
|
|
[label #f]
|
|
[min-value 0]
|
|
[max-value 100]
|
|
[parent f]
|
|
[callback
|
|
(λ (a b)
|
|
(send c2 refresh))]))
|
|
(define b (new button%
|
|
[label "animate"]
|
|
[parent f]
|
|
[callback
|
|
(λ (x y)
|
|
(thread
|
|
(λ ()
|
|
(let loop ([i 0])
|
|
(queue-callback
|
|
(λ ()
|
|
(send slider set-value i)
|
|
(send c2 refresh)))
|
|
(unless (= i 100)
|
|
(sleep 1/20)
|
|
(loop (+ i 1)))))))]))
|
|
|
|
(send f show #t))
|
|
|