#lang syndicate (require racket/set) (require 2htdp/image) (require "../2d.rkt") (define (spawn-background) (spawn (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 `()))))))) (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 #:coordinate-map-id [coordinate-map-id #f] #:parent [parent-id #f]) (spawn (field [x orig-x] [y orig-y]) (define/query-value touching? #f (inbound (touching name)) #t) (assert (outbound (simple-sprite #:parent parent-id #:coordinate-map-id coordinate-map-id #: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 (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) (+ (y) (* 1/2 h) (- (* 1/2 (image-height label)))) (image-width label) (image-height label) label))))) (define (spawn-player-avatar) (local-require 2htdp/planetcute) (define CC character-cat-girl) (spawn (field [x 100] [y 100]) (assert (outbound (simple-sprite #:touchable-id 'player #:coordinate-map-id 'player -0.5 (x) (y) (image-width CC) (image-height CC) CC))) (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)) (define/query-value touching? #f (inbound (touching 'player)) #t) (on-start (draggable-mixin touching? x y)) (on (asserted (inbound (coordinate-map 'player $xform))) ;; TODO: figure out why this causes lag in frame updates (log-info "Player coordinate map: ~v" xform)) (on-start (tooltip touching? x y (image-width CC) (image-height CC) "The Player")) (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))))) (define (spawn-frame-counter) (spawn (field [i empty-image]) (assert (outbound (simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i)))) (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")))))) (spawn-keyboard-integrator) (spawn-mouse-integrator) (spawn-background) ;; (spawn-frame-counter) (spawn-player-avatar) (draggable-shape 'orange 50 50 0 (circle 50 "solid" "orange") (circle 50 "solid" "red")) (draggable-shape 'yellow 10 -10 0 #:parent 'orange (circle 50 "solid" "yellow") (circle 50 "solid" "purple")) (draggable-shape 'green 60 60 -1 (circle 50 "solid" "green") (circle 50 "solid" "cyan")) (spawn* (until (message (inbound (key-event #\q #t _)))) (assert! (outbound 'stop))) (spawn (during (inbound (touching $id)) (on-start (log-info "Touching ~v" id)) (on-stop (log-info "No longer touching ~v" id)))) (module+ main (current-ground-dataspace (2d-dataspace)))