draggable-mixin in syndicate-gl/examples/basic.rkt
This commit is contained in:
parent
45c12bacf0
commit
b56f559f45
|
@ -19,6 +19,32 @@
|
||||||
))
|
))
|
||||||
(seal `())))))))
|
(seal `())))))))
|
||||||
|
|
||||||
|
(define (draggable-mixin touching? x y)
|
||||||
|
(define (idle)
|
||||||
|
(react (stop-when #:when (touching?)
|
||||||
|
(message (inbound (mouse-event 'left-down (mouse-state $mx $my _ _ _))))
|
||||||
|
(dragging (- mx (x)) (- my (y))))))
|
||||||
|
|
||||||
|
(define (dragging dx dy)
|
||||||
|
(react (on (message (inbound (mouse-event 'motion (mouse-state $mx $my _ _ _))))
|
||||||
|
(x (- mx dx))
|
||||||
|
(y (- my dy)))
|
||||||
|
(stop-when (message (inbound (mouse-event 'left-up _))) (idle))
|
||||||
|
(stop-when (message (inbound (mouse-event 'leave _))) (idle))))
|
||||||
|
|
||||||
|
(idle))
|
||||||
|
|
||||||
|
(define (draggable-shape name orig-x orig-y z plain-image hover-image)
|
||||||
|
(actor (field [x orig-x] [y orig-y])
|
||||||
|
(define/query-value touching? #f (inbound (touching name _ _ _)) #t)
|
||||||
|
(assert (outbound (simple-sprite #:touchable-id name
|
||||||
|
#:touchable-predicate in-unit-circle?
|
||||||
|
z (x) (y) 50 50
|
||||||
|
(if (touching?)
|
||||||
|
hover-image
|
||||||
|
plain-image))))
|
||||||
|
(on-start (draggable-mixin touching? x y))))
|
||||||
|
|
||||||
(define (spawn-player-avatar)
|
(define (spawn-player-avatar)
|
||||||
(local-require 2htdp/planetcute)
|
(local-require 2htdp/planetcute)
|
||||||
(define CC character-cat-girl)
|
(define CC character-cat-girl)
|
||||||
|
@ -32,6 +58,9 @@
|
||||||
(on (retracted (key-pressed $k)) (keys-down (set-remove (keys-down) k)))
|
(on (retracted (key-pressed $k)) (keys-down (set-remove (keys-down) k)))
|
||||||
(define (key->delta k distance) (if (set-member? (keys-down) k) distance 0))
|
(define (key->delta k distance) (if (set-member? (keys-down) k) distance 0))
|
||||||
|
|
||||||
|
(define/query-value touching? #f (inbound (touching 'player _ _ _)) #t)
|
||||||
|
(on-start (draggable-mixin touching? x y))
|
||||||
|
|
||||||
(on (message (inbound (frame-event _ _ $elapsed-ms _)))
|
(on (message (inbound (frame-event _ _ $elapsed-ms _)))
|
||||||
(define-values (old-x old-y) (values (x) (y)))
|
(define-values (old-x old-y) (values (x) (y)))
|
||||||
(define distance (* 0.360 elapsed-ms))
|
(define distance (* 0.360 elapsed-ms))
|
||||||
|
@ -57,16 +86,14 @@
|
||||||
;; (spawn-frame-counter)
|
;; (spawn-frame-counter)
|
||||||
(spawn-player-avatar)
|
(spawn-player-avatar)
|
||||||
|
|
||||||
(actor (define/query-value touching-orange? #f (inbound (touching 'orange _ _ _)) #t)
|
(draggable-shape 'orange 50 50 0
|
||||||
(assert (outbound (simple-sprite #:touchable-id 'orange
|
(circle 50 "solid" "orange")
|
||||||
#:touchable-predicate in-unit-circle?
|
(circle 50 "solid" "red"))
|
||||||
0 50 50 50 50 (circle 50 "solid"
|
|
||||||
(if (touching-orange?)
|
(draggable-shape 'green 60 60 -1
|
||||||
"red"
|
(circle 50 "solid" "green")
|
||||||
"orange")))))
|
(circle 50 "solid" "cyan"))
|
||||||
(assert (outbound (simple-sprite #:touchable-id 'green
|
|
||||||
#:touchable-predicate in-unit-circle?
|
|
||||||
-1 60 60 50 50 (circle 50 "solid" "green")))))
|
|
||||||
(actor* (until (message (inbound (key-event #\q #t _))))
|
(actor* (until (message (inbound (key-event #\q #t _))))
|
||||||
(assert! (outbound 'stop)))
|
(assert! (outbound 'stop)))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue