2017-08-10 19:17:28 +00:00
|
|
|
#lang syndicate
|
2015-09-09 00:11:16 +00:00
|
|
|
|
2016-07-16 20:15:19 +00:00
|
|
|
(require racket/set)
|
2015-09-09 00:11:16 +00:00
|
|
|
(require 2htdp/image)
|
|
|
|
(require "../2d.rkt")
|
|
|
|
|
2015-10-23 15:38:45 +00:00
|
|
|
(define (spawn-background)
|
2017-02-15 23:18:19 +00:00
|
|
|
(spawn
|
2016-08-24 16:35:38 +00:00
|
|
|
(during (inbound (window $width $height))
|
|
|
|
(assert (outbound
|
|
|
|
(scene (seal `((push-matrix (scale ,width ,(* height 2))
|
|
|
|
(translate 0 -0.25)
|
|
|
|
(texture
|
|
|
|
,(overlay/xy (rectangle 1 1 "solid" "white")
|
|
|
|
0 0
|
|
|
|
(rectangle 1 2 "solid" "black"))))
|
|
|
|
;; (rotate -30)
|
|
|
|
;; (scale 5 5)
|
|
|
|
))
|
|
|
|
(seal `())))))))
|
2015-10-23 15:38:45 +00:00
|
|
|
|
2016-09-02 09:36:26 +00:00
|
|
|
(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))
|
|
|
|
|
2016-09-27 21:08:24 +00:00
|
|
|
(define (draggable-shape name orig-x orig-y z plain-image hover-image
|
|
|
|
#:coordinate-map-id [coordinate-map-id #f]
|
|
|
|
#:parent [parent-id #f])
|
2017-02-15 23:18:19 +00:00
|
|
|
(spawn (field [x orig-x] [y orig-y])
|
2016-09-02 10:11:56 +00:00
|
|
|
(define/query-value touching? #f (inbound (touching name)) #t)
|
2016-09-24 17:23:07 +00:00
|
|
|
(assert (outbound (simple-sprite #:parent parent-id
|
2016-09-27 21:08:24 +00:00
|
|
|
#:coordinate-map-id coordinate-map-id
|
2016-09-24 17:23:07 +00:00
|
|
|
#:touchable-id name
|
2016-09-02 09:36:26 +00:00
|
|
|
#:touchable-predicate in-unit-circle?
|
|
|
|
z (x) (y) 50 50
|
|
|
|
(if (touching?)
|
|
|
|
hover-image
|
|
|
|
plain-image))))
|
|
|
|
(on-start (draggable-mixin touching? x y))))
|
|
|
|
|
2016-09-02 10:32:10 +00:00
|
|
|
(define (tooltip touching? x y w h label-string)
|
|
|
|
(define label-text (text label-string 22 "black"))
|
|
|
|
(define label (overlay label-text (empty-scene (+ (image-width label-text) 10)
|
|
|
|
(+ (image-height label-text) 10))))
|
|
|
|
(define (pos)
|
|
|
|
(define v (- (x) (image-width label) 10))
|
|
|
|
(if (negative? v)
|
|
|
|
(+ (x) w 10)
|
|
|
|
v))
|
|
|
|
(react (assert #:when (touching?)
|
|
|
|
(outbound (simple-sprite -10
|
|
|
|
(pos)
|
2016-09-02 11:59:42 +00:00
|
|
|
(+ (y) (* 1/2 h) (- (* 1/2 (image-height label))))
|
2016-09-02 10:32:10 +00:00
|
|
|
(image-width label)
|
|
|
|
(image-height label)
|
|
|
|
label)))))
|
|
|
|
|
2015-10-23 15:38:45 +00:00
|
|
|
(define (spawn-player-avatar)
|
2015-10-23 15:56:22 +00:00
|
|
|
(local-require 2htdp/planetcute)
|
|
|
|
(define CC character-cat-girl)
|
2016-07-10 23:22:48 +00:00
|
|
|
|
2017-02-15 23:18:19 +00:00
|
|
|
(spawn (field [x 100] [y 100])
|
2016-09-01 18:50:03 +00:00
|
|
|
(assert (outbound (simple-sprite #:touchable-id 'player
|
2016-09-27 21:08:24 +00:00
|
|
|
#:coordinate-map-id 'player
|
2016-09-01 18:50:03 +00:00
|
|
|
-0.5 (x) (y) (image-width CC) (image-height CC) CC)))
|
2016-07-10 23:22:48 +00:00
|
|
|
|
2016-08-24 16:35:38 +00:00
|
|
|
(field [keys-down (set)])
|
|
|
|
(on (asserted (key-pressed $k)) (keys-down (set-add (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))
|
2016-07-10 23:22:48 +00:00
|
|
|
|
2016-09-02 10:11:56 +00:00
|
|
|
(define/query-value touching? #f (inbound (touching 'player)) #t)
|
2016-09-02 09:36:26 +00:00
|
|
|
(on-start (draggable-mixin touching? x y))
|
|
|
|
|
2016-09-27 21:08:24 +00:00
|
|
|
(on (asserted (inbound (coordinate-map 'player $xform)))
|
|
|
|
;; TODO: figure out why this causes lag in frame updates
|
|
|
|
(log-info "Player coordinate map: ~v" xform))
|
|
|
|
|
2016-09-02 10:32:10 +00:00
|
|
|
(on-start (tooltip touching? x y (image-width CC) (image-height CC) "The Player"))
|
|
|
|
|
2016-08-24 16:35:38 +00:00
|
|
|
(on (message (inbound (frame-event _ _ $elapsed-ms _)))
|
|
|
|
(define-values (old-x old-y) (values (x) (y)))
|
|
|
|
(define distance (* 0.360 elapsed-ms))
|
|
|
|
(define nx (+ old-x (key->delta 'right distance) (key->delta 'left (- distance))))
|
|
|
|
(define ny (+ old-y (key->delta 'down distance) (key->delta 'up (- distance))))
|
|
|
|
(when (not (and (= nx old-x) (= ny old-y)))
|
|
|
|
(x nx)
|
|
|
|
(y ny)))))
|
2015-10-23 15:38:45 +00:00
|
|
|
|
|
|
|
(define (spawn-frame-counter)
|
2017-02-15 23:18:19 +00:00
|
|
|
(spawn (field [i empty-image])
|
2016-08-24 16:35:38 +00:00
|
|
|
(assert (outbound
|
2016-09-02 10:15:22 +00:00
|
|
|
(simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i))))
|
2016-08-24 16:35:38 +00:00
|
|
|
(on (message (inbound (frame-event $counter $sim-time-ms _ _)))
|
|
|
|
(when (> sim-time-ms 0)
|
|
|
|
(define fps (/ counter (/ sim-time-ms 1000.0)))
|
|
|
|
(i (text (format "~a fps" fps) 22 "black"))))))
|
2015-10-23 15:38:45 +00:00
|
|
|
|
2016-07-16 20:15:19 +00:00
|
|
|
(spawn-keyboard-integrator)
|
2016-09-01 18:50:03 +00:00
|
|
|
(spawn-mouse-integrator)
|
2016-07-16 20:15:19 +00:00
|
|
|
(spawn-background)
|
|
|
|
;; (spawn-frame-counter)
|
|
|
|
(spawn-player-avatar)
|
2016-09-01 18:50:03 +00:00
|
|
|
|
2016-09-02 09:36:26 +00:00
|
|
|
(draggable-shape 'orange 50 50 0
|
|
|
|
(circle 50 "solid" "orange")
|
|
|
|
(circle 50 "solid" "red"))
|
|
|
|
|
2016-09-24 17:23:07 +00:00
|
|
|
(draggable-shape 'yellow 10 -10 0 #:parent 'orange
|
|
|
|
(circle 50 "solid" "yellow")
|
|
|
|
(circle 50 "solid" "purple"))
|
|
|
|
|
2016-09-02 09:36:26 +00:00
|
|
|
(draggable-shape 'green 60 60 -1
|
|
|
|
(circle 50 "solid" "green")
|
|
|
|
(circle 50 "solid" "cyan"))
|
|
|
|
|
2017-02-15 23:18:19 +00:00
|
|
|
(spawn* (until (message (inbound (key-event #\q #t _))))
|
2016-08-24 16:35:38 +00:00
|
|
|
(assert! (outbound 'stop)))
|
2016-07-16 20:15:19 +00:00
|
|
|
|
2017-02-15 23:18:19 +00:00
|
|
|
(spawn (during (inbound (touching $id))
|
2016-09-01 18:50:03 +00:00
|
|
|
(on-start (log-info "Touching ~v" id))
|
|
|
|
(on-stop (log-info "No longer touching ~v" id))))
|
|
|
|
|
2016-07-16 20:15:19 +00:00
|
|
|
(module+ main (current-ground-dataspace (2d-dataspace)))
|