You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
135 lines
5.7 KiB
135 lines
5.7 KiB
#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)))
|
|
|