342 lines
13 KiB
Scheme
342 lines
13 KiB
Scheme
(module stick-figures mzscheme
|
|
(require mzlib/class
|
|
mzlib/pretty
|
|
mred)
|
|
|
|
(define head-size 40)
|
|
(define small-bitmap-factor 1/2)
|
|
(define small-factor 1/5)
|
|
(define line-size 2)
|
|
|
|
(define waiting-points
|
|
'((head 47 2)
|
|
(neck 46 15)
|
|
(shoulders 38 42)
|
|
(left-shoulder 18 39)
|
|
(right-shoulder 65 42)
|
|
(left-elbow 8 74)
|
|
(right-elbow 68 76)
|
|
(left-hand 24 79)
|
|
(right-hand 56 83)
|
|
(waist 37 87)
|
|
(left-knee 23 117)
|
|
(right-knee 57 117)
|
|
(left-ankle 21 149)
|
|
(right-ankle 59 148)
|
|
(left-toe 3 148)
|
|
(right-toe 79 145)))
|
|
|
|
(define waiting-points/2
|
|
'((head 47 2)
|
|
(neck 46 15)
|
|
(shoulders 38 42)
|
|
(left-shoulder 18 39)
|
|
(right-shoulder 65 42)
|
|
(left-elbow 8 74)
|
|
(right-elbow 68 76)
|
|
(left-hand 24 79)
|
|
(right-hand 56 83)
|
|
(waist 37 87)
|
|
(left-knee 23 117)
|
|
(right-knee 57 117)
|
|
(left-ankle 21 149)
|
|
(right-ankle 59 148)
|
|
(left-toe 3 148)
|
|
(right-toe 79 132)))
|
|
|
|
(define waiting-points/old
|
|
'((head 55 0)
|
|
(neck 43 18)
|
|
(shoulders 37 33)
|
|
(left-shoulder 23 34)
|
|
(right-shoulder 50 37)
|
|
(left-elbow 8 74)
|
|
(right-elbow 66 69)
|
|
(left-hand 60 78)
|
|
(right-hand 68 18)
|
|
(waist 37 87)
|
|
(left-knee 19 122)
|
|
(right-knee 57 117)
|
|
(left-ankle 19 154)
|
|
(right-ankle 62 155)
|
|
(left-toe 0 154)
|
|
(right-toe 83 146)))
|
|
|
|
(define waiting-points/2/old
|
|
'((head 55 0)
|
|
(neck 43 18)
|
|
(shoulders 37 33)
|
|
(left-shoulder 23 34)
|
|
(right-shoulder 50 37)
|
|
(left-elbow 8 74)
|
|
(right-elbow 66 69)
|
|
(left-hand 60 78)
|
|
(right-hand 68 18)
|
|
(waist 37 87)
|
|
(left-knee 19 122)
|
|
(right-knee 57 117)
|
|
(left-ankle 19 154)
|
|
(left-toe 0 154)
|
|
(right-ankle 62 155)
|
|
(right-toe 83 154)))
|
|
|
|
(define running-points
|
|
'((head 130 18)
|
|
(neck 114 33)
|
|
(shoulders 105 44)
|
|
(left-shoulder 105 44)
|
|
(right-shoulder 105 44)
|
|
(left-elbow 71 28)
|
|
(right-elbow 115 67)
|
|
(left-hand 50 54)
|
|
(right-hand 148 53)
|
|
(waist 59 78)
|
|
(left-knee 41 112)
|
|
(right-knee 97 93)
|
|
(left-ankle 0 129)
|
|
(right-ankle 89 132)
|
|
(left-toe 14 146)
|
|
(right-toe 109 132)))
|
|
|
|
(define (get-size-parameters)
|
|
(let-values ([(min-rx min-ry) (get-max/min-x/y min running-points)]
|
|
[(max-rx max-ry) (get-max/min-x/y max running-points)]
|
|
[(min-wx min-wy) (get-max/min-x/y min waiting-points)]
|
|
[(max-wx max-wy) (get-max/min-x/y max waiting-points)])
|
|
(let* ([running-w (* small-factor (- max-rx min-rx))]
|
|
[waiting-w (* small-factor (- max-wx min-wx))]
|
|
[running-h (* small-factor (- max-ry min-ry))]
|
|
[waiting-h (* small-factor (- max-wy min-wy))]
|
|
[w (+ 2 (ceiling (max running-w waiting-w)))]
|
|
[h (+ 2 (ceiling (max running-h waiting-h)))]
|
|
[running-dx (+ 1 (- (/ w 2) (/ running-w 2)))]
|
|
[running-dy (+ 1 (- (/ h 2) (/ running-h 2)))]
|
|
[waiting-dx (+ 1 (- (/ w 2) (/ waiting-w 2)))]
|
|
[waiting-dy (+ 1 (- (/ h 2) (/ waiting-h 2)))])
|
|
(values w h running-dx running-dy waiting-dx waiting-dy))))
|
|
|
|
(define (get-bitmap points green)
|
|
(let-values ([(min-rx min-ry) (get-max/min-x/y min points)]
|
|
[(max-rx max-ry) (get-max/min-x/y max points)])
|
|
(let* ([margin 2]
|
|
[bw (+ margin margin (ceiling (* small-factor (- max-rx min-rx))))]
|
|
[bh (+ margin margin (ceiling (* small-factor (- max-ry min-ry))))]
|
|
[w (ceiling (* bw small-bitmap-factor))]
|
|
[h (ceiling (* bh small-bitmap-factor))]
|
|
[bm-big (make-object bitmap% bw bh)]
|
|
[bm-solid (make-object bitmap% w h)]
|
|
[bm-small (make-object bitmap% w h)]
|
|
[bdc-big (make-object bitmap-dc% bm-big)]
|
|
[bdc-solid (make-object bitmap-dc% bm-solid)]
|
|
[bdc-small (make-object bitmap-dc% bm-small)])
|
|
(send bdc-big clear)
|
|
(draw-callback bdc-big small-factor #f points
|
|
(+ margin (- (* small-factor min-rx)))
|
|
(+ margin #;(- (* small-factor min-ry)))
|
|
3)
|
|
|
|
(send bdc-small clear)
|
|
(send bdc-small set-scale small-bitmap-factor small-bitmap-factor)
|
|
(send bdc-small draw-bitmap bm-big 0 0)
|
|
(send bdc-small set-scale 1 1)
|
|
|
|
(send bdc-solid set-brush green 'solid)
|
|
(send bdc-solid set-pen green 1 'solid)
|
|
(send bdc-solid draw-rectangle 0 0 w h)
|
|
|
|
(send bdc-solid set-bitmap #f)
|
|
(send bdc-small set-bitmap #f)
|
|
(send bdc-big set-bitmap #f)
|
|
|
|
(send bm-solid set-loaded-mask bm-small)
|
|
bm-solid)))
|
|
|
|
(define (get-running-bitmap) (get-bitmap running-points (make-object color% 30 100 30)))
|
|
(define (get-waiting-bitmap) (get-bitmap waiting-points (make-object color% 30 100 30)))
|
|
|
|
(define (normalize points)
|
|
(let-values ([(min-x min-y) (get-max/min-x/y min points)])
|
|
(map (λ (x) (list (car x)
|
|
(+ (- (list-ref x 1) min-x))
|
|
(+ (- (list-ref x 2) min-y))))
|
|
points)))
|
|
|
|
(define (get-max/min-x/y choose points)
|
|
(values (apply choose
|
|
(- (list-ref (assoc 'head points) 1) (/ head-size 2))
|
|
(+ (list-ref (assoc 'head points) 1) (/ head-size 2))
|
|
(map (λ (x) (list-ref x 1)) points))
|
|
(apply choose
|
|
(- (list-ref (assoc 'head points) 2) (/ head-size 2))
|
|
(+ (list-ref (assoc 'head points) 2) (/ head-size 2))
|
|
(map (λ (x) (list-ref x 2)) points))))
|
|
|
|
(define show-dots? #t)
|
|
(define (draw-callback dc factor dots? points dx dy line-size)
|
|
(send dc set-smoothing 'aligned)
|
|
(let ([points (normalize points)])
|
|
(send dc set-pen "orange" 1 'solid)
|
|
(send dc set-brush "orange" 'solid)
|
|
(when (and dots? show-dots?)
|
|
(for-each
|
|
(λ (x) (send dc draw-ellipse
|
|
(+ dx (- (list-ref x 1) 4))
|
|
(+ dy (- (list-ref x 2) 4))
|
|
9 9))
|
|
points))
|
|
(send dc set-pen "black" line-size 'solid)
|
|
(send dc set-brush "black" 'transparent)
|
|
(draw-points points dc factor dx dy)
|
|
|
|
(let* ([head (assoc 'head points)]
|
|
[hx (list-ref head 1)]
|
|
[hy (list-ref head 2)])
|
|
(send dc draw-ellipse
|
|
(+ dx (* factor (- hx (/ head-size 2))))
|
|
(+ dy (* factor (- hy (/ head-size 2))))
|
|
(* factor head-size)
|
|
(* factor head-size)))))
|
|
|
|
(define (draw-points points dc factor dx dy)
|
|
(connect 'neck 'shoulders points dc factor dx dy)
|
|
(connect 'shoulders 'left-shoulder points dc factor dx dy)
|
|
(connect 'left-shoulder 'left-elbow points dc factor dx dy)
|
|
(connect 'shoulders 'right-shoulder points dc factor dx dy)
|
|
(connect 'right-shoulder 'right-elbow points dc factor dx dy)
|
|
(connect 'left-elbow 'left-hand points dc factor dx dy)
|
|
(connect 'right-elbow 'right-hand points dc factor dx dy)
|
|
(connect 'shoulders 'waist points dc factor dx dy)
|
|
(connect 'waist 'left-knee points dc factor dx dy)
|
|
(connect 'waist 'right-knee points dc factor dx dy)
|
|
(connect 'left-knee 'left-ankle points dc factor dx dy)
|
|
(connect 'right-knee 'right-ankle points dc factor dx dy)
|
|
(connect 'left-ankle 'left-toe points dc factor dx dy)
|
|
(connect 'right-ankle 'right-toe points dc factor dx dy))
|
|
|
|
(define (connect from to points dc factor dx dy)
|
|
(let ([from-p (assoc from points)]
|
|
[to-p (assoc to points)])
|
|
(when (and from-p to-p)
|
|
(send dc draw-line
|
|
(+ dx (* factor (list-ref from-p 1)))
|
|
(+ dy (* factor (list-ref from-p 2)))
|
|
(+ dx (* factor (list-ref to-p 1)))
|
|
(+ dy (* factor (list-ref to-p 2)))))))
|
|
|
|
;; Use this thunk to edit the points.
|
|
;; Click the 'show' button to print out the points and then
|
|
;; copy and paste them back into this file.
|
|
(define (edit-points points)
|
|
(define c%
|
|
(class canvas%
|
|
(inherit get-client-size refresh get-dc)
|
|
(define clicked-point #f)
|
|
(define clicked-x 0)
|
|
(define clicked-y 0)
|
|
(define orig-x 0)
|
|
(define orig-y 0)
|
|
(define/override (on-paint)
|
|
(draw-callback (get-dc) 1 #t points 0 0 line-size))
|
|
(define/override (on-event evt)
|
|
(cond
|
|
[(send evt button-down? 'left)
|
|
(let-values ([(w h) (get-client-size)])
|
|
(let ([x (send evt get-x)]
|
|
[y (send evt get-y)])
|
|
(let ([point (find-point this x y)])
|
|
(when point
|
|
(set! clicked-x x)
|
|
(set! clicked-y y)
|
|
(set! clicked-point point)
|
|
(let ([orig-point (assoc point points)])
|
|
(set! orig-x (list-ref orig-point 1))
|
|
(set! orig-y (list-ref orig-point 2)))))))]
|
|
[(and clicked-point (send evt moving?))
|
|
(set! points
|
|
(map (λ (x)
|
|
(if (eq? (car x) clicked-point)
|
|
(list (list-ref x 0)
|
|
(+ orig-x (- (send evt get-x) clicked-x))
|
|
(+ orig-y (- (send evt get-y) clicked-y)))
|
|
x))
|
|
points))
|
|
(refresh)
|
|
(send csmall refresh)]
|
|
[(send evt button-up? 'left)
|
|
(set! clicked-point #f)]))
|
|
(super-new)))
|
|
|
|
(define (find-point c x y)
|
|
(let loop ([points (normalize points)])
|
|
(cond
|
|
[(null? points) #f]
|
|
[else (let ([point (car points)])
|
|
(if (and (<= (- (list-ref point 1) 4)
|
|
x
|
|
(+ (list-ref point 1) 4))
|
|
(<= (- (list-ref point 2) 4)
|
|
y
|
|
(+ (list-ref point 2) 4)))
|
|
(car point)
|
|
(loop (cdr points))))])))
|
|
|
|
(define f (new frame% [label ""] [width 400] [height 400]))
|
|
(define cp (new horizontal-panel% [parent f]))
|
|
(define cbig (new c% [parent cp]))
|
|
(define csmall
|
|
(new canvas%
|
|
[parent cp]
|
|
[paint-callback (λ (c dc)
|
|
(draw-callback dc small-factor #f running-points 0 0 line-size)
|
|
(draw-callback dc small-factor #f waiting-points 30 0 line-size)
|
|
(draw-callback dc small-factor #f points 30 50 line-size)
|
|
(draw-callback dc small-factor #f points 0 50 line-size))]))
|
|
(define cbitmap (new message% [label (get-bitmap points (send the-color-database find-color "black"))] [parent cp]))
|
|
(define bp (new horizontal-panel% [parent f] [stretchable-height #f]))
|
|
(new button%
|
|
[parent bp]
|
|
[label "Show"]
|
|
[callback
|
|
(λ (x y)
|
|
(pretty-print points))])
|
|
(new button%
|
|
[parent bp]
|
|
[label "Toggle dots"]
|
|
[callback
|
|
(λ (x y)
|
|
(set! show-dots? (not show-dots?))
|
|
(send cbig refresh))])
|
|
(new button%
|
|
[parent bp]
|
|
[label "Bitmap"]
|
|
[callback
|
|
(λ (x y)
|
|
(send cbitmap set-label (get-bitmap points (send the-color-database find-color "black"))))])
|
|
(send f show #t))
|
|
|
|
(let ()
|
|
(define f (new frame% [label ""]))
|
|
(define hp (new horizontal-panel% [parent f]))
|
|
(define left-column (new vertical-panel% [parent hp]))
|
|
(define right-column (new vertical-panel% [parent hp]))
|
|
(define green-rb (get-running-bitmap))
|
|
(define black (send the-color-database find-color "black"))
|
|
(define rb (get-bitmap running-points black))
|
|
(define wb (get-bitmap waiting-points black))
|
|
(define wb2 (get-bitmap waiting-points/2 black))
|
|
(define rm (new message% [label rb] [parent left-column]))
|
|
(define grm (new message% [label green-rb] [parent right-column]))
|
|
(new message% [label wb] [parent left-column])
|
|
(new message% [label wb2] [parent left-column])
|
|
(new message% [label wb2] [parent right-column])
|
|
(new message% [label wb] [parent right-column])
|
|
(new grow-box-spacer-pane% [parent f])
|
|
(send green-rb save-file (build-path (collection-path "icons") "run.png") 'png)
|
|
(send rb save-file (build-path (collection-path "icons") "b-run.png") 'png)
|
|
(send wb save-file (build-path (collection-path "icons") "b-wait.png") 'png)
|
|
(send wb2 save-file (build-path (collection-path "icons") "b-wait2.png") 'png)
|
|
(send f show #t))
|
|
|
|
#;(edit-points waiting-points/2)
|
|
#;(edit-points running-points))
|