428 lines
15 KiB
Racket
428 lines
15 KiB
Racket
(module honu-bitmaps mzscheme
|
|
(require mzlib/math
|
|
mzlib/etc
|
|
mred
|
|
mzlib/class)
|
|
|
|
(provide honu-bitmap honu-down-bitmap
|
|
honu-rotation honu-down-rotation)
|
|
|
|
(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
|
|
(opt-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 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
|
|
(opt-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)))
|
|
|
|
(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 bitmap-size 128)
|
|
|
|
(define (make-honu-bitmap main-color left-color right-color rot)
|
|
(let ([main-bm (make-single-bitmap main-color main-color left-color right-color rot)])
|
|
(send main-bm set-loaded-mask (make-single-bitmap "white" "black" "black" "black" rot))
|
|
main-bm))
|
|
|
|
(define (make-single-bitmap bgcolor main-color left-color right-color rot)
|
|
(let* ([bitmap (make-object bitmap% bitmap-size bitmap-size)]
|
|
[dc (make-object bitmap-dc% bitmap)]
|
|
[path (rotate-path body-path rot)]
|
|
[left-hole-path (rotate-path left-hole-path rot)]
|
|
[right-hole-path (rotate-path right-hole-path rot)]
|
|
[scale 1/2])
|
|
(send dc set-smoothing 'aligned)
|
|
(send dc set-pen "white" 1 'transparent)
|
|
(send dc set-brush bgcolor 'solid)
|
|
(send dc draw-rectangle 0 0 bitmap-size bitmap-size)
|
|
(send dc set-scale scale scale)
|
|
|
|
(let-values ([(x y w h) (send path get-bounding-box)])
|
|
(let ([dx (- (/ (/ bitmap-size scale) 2) (/ w 2))]
|
|
[dy (- (/ (/ bitmap-size scale) 2) (/ h 2))])
|
|
(send path translate (- x) (- y))
|
|
(send left-hole-path translate (- x) (- y))
|
|
(send right-hole-path translate (- x) (- y))
|
|
|
|
(send dc set-brush main-color 'solid)
|
|
(send dc set-pen main-color 1 'solid)
|
|
(send dc draw-path path dx dy)
|
|
|
|
(send dc set-pen left-color 1 'solid)
|
|
(send dc set-brush left-color 'solid)
|
|
(send dc draw-path left-hole-path dx dy)
|
|
|
|
(send dc set-brush right-color 'solid)
|
|
(send dc set-pen right-color 1 'solid)
|
|
(send dc draw-path right-hole-path dx dy)))
|
|
|
|
(send dc set-bitmap #f)
|
|
bitmap))
|
|
|
|
(define (rotate-path path rot)
|
|
(let ([pth (new dc-path%)])
|
|
(send pth append path)
|
|
(send pth rotate rot)
|
|
pth))
|
|
|
|
(define honu-rotation (* pi 1/4))
|
|
(define honu-down-rotation (* pi (+ 1 1/4)))
|
|
|
|
(define honu-bitmap (make-honu-bitmap (make-object color% 150 150 150) "red" "blue" honu-rotation))
|
|
(define honu-down-bitmap (make-honu-bitmap "black" "orangered" "blue" honu-down-rotation))
|
|
#|
|
|
(define dx 0)
|
|
(define dy 0)
|
|
(define f (new frame% (label "")))
|
|
(define c (new canvas%
|
|
(parent f)
|
|
(paint-callback
|
|
(lambda (c dc)
|
|
(send dc draw-bitmap honu-bitmap dx dy)
|
|
(send dc draw-line
|
|
(/ bitmap-size 2)
|
|
(/ bitmap-size 2)
|
|
(+ (/ bitmap-size 2) (* 100 (cos (+ (/ pi 2) honu-down-rotation))))
|
|
(+ (/ bitmap-size 2) (* 100 (- (sin (+ (/ pi 2) honu-down-rotation))))))))))
|
|
(send c min-width bitmap-size)
|
|
(send c min-height bitmap-size)
|
|
(define b+ (new button%
|
|
(label "+1")
|
|
(parent f)
|
|
(callback (lambda (x y) (set! dy (+ dy 1)) (send c refresh)))))
|
|
(define b- (new button%
|
|
(label "-1")
|
|
(parent f)
|
|
(callback (lambda (x y) (set! dy (- dy 1)) (send c refresh)))))
|
|
(send f show #t)
|
|
|#
|
|
)
|