First steps toward mouse-based picking in syndicate-gl
This commit is contained in:
parent
1ae40c1ff1
commit
b60fa8c755
|
@ -4,6 +4,9 @@
|
|||
(struct-out frame-event)
|
||||
(struct-out key-event)
|
||||
(struct-out key-pressed)
|
||||
(struct-out mouse-event)
|
||||
(struct-out mouse-state)
|
||||
(struct-out touching)
|
||||
(struct-out scene)
|
||||
(except-out (struct-out sprite) sprite)
|
||||
(rename-out [sprite <sprite>] [make-sprite sprite])
|
||||
|
@ -12,6 +15,7 @@
|
|||
update-scene
|
||||
update-sprites
|
||||
spawn-keyboard-integrator
|
||||
spawn-mouse-integrator
|
||||
2d-dataspace)
|
||||
|
||||
(require data/order)
|
||||
|
@ -28,6 +32,7 @@
|
|||
(require syndicate/ground)
|
||||
|
||||
(require "texture.rkt")
|
||||
(require "affine.rkt")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
@ -46,6 +51,17 @@
|
|||
;; KeyboardIntegrator and spawn-keyboard-integrator.
|
||||
(struct key-pressed (code) #:transparent)
|
||||
|
||||
;; Message sent by dataspace. Describes a mouse event. Event is a
|
||||
;; sealed mouse-event%.
|
||||
(struct mouse-event (type state) #:transparent)
|
||||
|
||||
;; Assertion. Indicates that the mouse is in a particular state. See
|
||||
;; role MouseIntegrator and spawn-mouse-integrator.
|
||||
(struct mouse-state (x y left-down? middle-down? right-down?) #:transparent)
|
||||
|
||||
;; Assertion. Indicates that the mouse is touching a particular touchable.
|
||||
(struct touching (id user-x user-y state) #:transparent)
|
||||
|
||||
;; Shared state maintained by program. Prelude and postlude are to be
|
||||
;; sealed instruction lists. It is an error to have more than exactly
|
||||
;; one active such record at a given time.
|
||||
|
@ -70,9 +86,16 @@
|
|||
(define (make-sprite z instructions)
|
||||
(sprite z (seal instructions)))
|
||||
|
||||
(define (simple-sprite z x y w h i)
|
||||
(define (in-unit-square? x y)
|
||||
(and (<= 0 x 1)
|
||||
(<= 0 y 1)))
|
||||
|
||||
(define (simple-sprite z x y w h i #:touchable-id [touchable-id #f])
|
||||
(make-sprite z `((translate ,x ,y)
|
||||
(scale ,w ,h)
|
||||
,@(if touchable-id
|
||||
`((touchable ,touchable-id ,in-unit-square?))
|
||||
`())
|
||||
(texture ,i))))
|
||||
|
||||
(define (update-sprites #:meta-level [meta-level 1] . ss)
|
||||
|
@ -91,53 +114,95 @@
|
|||
(void)
|
||||
(sub (inbound* meta-level (key-event ? ? ?)))))
|
||||
|
||||
;; MouseIntegrator. Integrates mouse-events into mouse-state assertions.
|
||||
(define (spawn-mouse-integrator #:meta-level [meta-level 1])
|
||||
(define retract-state (retract (mouse-state ? ? ? ? ?)))
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(message (inbound* meta-level (mouse-event 'leave _)))
|
||||
(transition (void) retract-state)]
|
||||
[(message (inbound* meta-level (mouse-event type new-state)))
|
||||
(transition (void) (patch-seq retract-state (assert new-state)))]
|
||||
[#f #f]))
|
||||
(void)
|
||||
(sub (inbound* meta-level (mouse-event ? ?)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(struct compiled-instructions (render-thunk resources))
|
||||
;; (touchable Any TransformationMatrix (Number Number -> Boolean))
|
||||
;; Represents a composed device-to-user transformation, plus a
|
||||
;; predicate on user coordinates, and an ID to use when the predicate
|
||||
;; answers truthily.
|
||||
(struct touchable (id transformation predicate) #:transparent)
|
||||
|
||||
;; (compiled-instructions (-> Void) (Listof Touchable) (Listof Resource) TransformationMatrix)
|
||||
;; A single compiled sprite. The resources aren't in any particular order,
|
||||
;; but the touchables are: the leftmost touchable is the first to check;
|
||||
;; that is, it is the *topmost* touchable in this sprite. The overall
|
||||
;; transformation matrix is the net effect of all the transformations in
|
||||
;; the instruction sequence.
|
||||
(struct compiled-instructions (render-thunk touchables resources xform))
|
||||
|
||||
(define-namespace-anchor ns-anchor)
|
||||
(define ns (namespace-anchor->namespace ns-anchor))
|
||||
|
||||
(define (compile-instructions instrs)
|
||||
(define-values (code resources) (instruction->racket-code `(begin ,@instrs)))
|
||||
(define-values (code touchables resources xform)
|
||||
(instruction->racket-code `(begin ,@instrs) identity-transformation))
|
||||
(define render-thunk (eval `(lambda () ,code) ns))
|
||||
(compiled-instructions render-thunk resources))
|
||||
(compiled-instructions render-thunk touchables resources xform))
|
||||
|
||||
(define (compiled-instructions-dispose! i)
|
||||
(when i
|
||||
(for [(resource (compiled-instructions-resources i))]
|
||||
(send resource dispose))))
|
||||
|
||||
(define (instructions->racket-code instrs)
|
||||
(define-values (code-rev resources)
|
||||
(for/fold [(code-rev '()) (resources '())] [(instr (in-list instrs))]
|
||||
(define-values (new-code new-resources) (instruction->racket-code instr))
|
||||
(values (cons new-code code-rev) (append new-resources resources))))
|
||||
(values (reverse code-rev) resources))
|
||||
(define (instructions->racket-code instrs xform)
|
||||
(define-values (code-rev touchables resources new-xform)
|
||||
(for/fold [(code-rev '())
|
||||
(touchables '())
|
||||
(resources '())
|
||||
(xform xform)]
|
||||
[(instr (in-list instrs))]
|
||||
(define-values (new-code new-touchables new-resources new-xform)
|
||||
(instruction->racket-code instr xform))
|
||||
(values (cons new-code code-rev)
|
||||
(append new-touchables touchables)
|
||||
(append new-resources resources)
|
||||
new-xform)))
|
||||
(values (reverse code-rev) touchables resources new-xform))
|
||||
|
||||
(define (color-number? n)
|
||||
(and (number? n)
|
||||
(<= 0.0 n 1.0)))
|
||||
|
||||
(define (instruction->racket-code instr)
|
||||
(define (instruction->racket-code instr xform)
|
||||
(match instr
|
||||
[`(rotate ,(? number? deg))
|
||||
(values `(glRotated ,deg 0 0 -1) '())]
|
||||
(values `(glRotated ,deg 0 0 -1) '() '()
|
||||
(compose-transformation (invert-transformation (rotation-transformation deg))
|
||||
xform))]
|
||||
[`(scale ,(? number? x) ,(? number? y))
|
||||
(values `(glScaled ,x ,y 1) '())]
|
||||
(values `(glScaled ,x ,y 1) '() '()
|
||||
(compose-transformation (invert-transformation (stretching-transformation x y))
|
||||
xform))]
|
||||
[`(translate ,(? number? x) ,(? number? y))
|
||||
(values `(glTranslated ,x ,y 0) '())]
|
||||
(values `(glTranslated ,x ,y 0) '() '()
|
||||
(compose-transformation (invert-transformation (translation-transformation x y))
|
||||
xform))]
|
||||
[`(color ,(? color-number? r) ,(? color-number? g) ,(? color-number? b) ,(? color-number? a))
|
||||
(values `(glColor4d ,r ,g ,b ,a) '())]
|
||||
(values `(glColor4d ,r ,g ,b ,a) '() '() xform)]
|
||||
[`(texture ,i)
|
||||
(define entry (image->texture-cache-entry i))
|
||||
(values `(draw-gl-face ,(send entry get-texture)) (list entry))]
|
||||
(values `(draw-gl-face ,(send entry get-texture)) '() (list entry) xform)]
|
||||
[`(touchable ,id ,predicate)
|
||||
(values `(void) (list (touchable id xform predicate)) '() xform)]
|
||||
[`(push-matrix ,instr ...)
|
||||
(define-values (code resources) (instructions->racket-code instr))
|
||||
(values `(begin (glPushMatrix) ,@code (glPopMatrix)) resources)]
|
||||
(define-values (code touchables resources _new-xform) (instructions->racket-code instr xform))
|
||||
(values `(begin (glPushMatrix) ,@code (glPopMatrix)) touchables resources xform)]
|
||||
[`(begin ,instr ...)
|
||||
(define-values (code resources) (instructions->racket-code instr))
|
||||
(values `(begin ,@code (void)) resources)]
|
||||
(define-values (code touchables resources new-xform) (instructions->racket-code instr xform))
|
||||
(values `(begin ,@code (void)) touchables resources new-xform)]
|
||||
[other
|
||||
(error 'instruction->racket-code "unknown render instruction: ~v" other)]))
|
||||
|
||||
|
@ -219,6 +284,28 @@
|
|||
(loop (splay-tree-iterate-next sprites iter))))
|
||||
((compiled-instructions-render-thunk postlude)))
|
||||
|
||||
(define (detect-touch prelude sprites postlude state)
|
||||
(and state
|
||||
(let ()
|
||||
(define x (mouse-state-x state))
|
||||
(define y (mouse-state-y state))
|
||||
(or (detect-touch* postlude x y state)
|
||||
(let loop ((iter (splay-tree-iterate-greatest sprites)))
|
||||
(and iter
|
||||
(or (detect-touch* (splay-tree-iterate-value sprites iter) x y state)
|
||||
(loop (splay-tree-iterate-greatest/<?
|
||||
sprites
|
||||
(splay-tree-iterate-key sprites iter))))))
|
||||
(detect-touch* prelude x y state)))))
|
||||
|
||||
(define (detect-touch* ci x y state)
|
||||
(for/or [(t (in-list (compiled-instructions-touchables ci)))]
|
||||
(match-define (touchable id xform contains?) t)
|
||||
(define user-point (transform-point xform (make-rectangular x y)))
|
||||
(define ux (real-part user-point))
|
||||
(define uy (imag-part user-point))
|
||||
(and (contains? ux uy) (touching id ux uy state))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define dataspace-canvas%
|
||||
|
@ -243,6 +330,9 @@
|
|||
(define postlude empty-instructions)
|
||||
(define fullscreen? #f)
|
||||
|
||||
(define current-mouse-state #f)
|
||||
(define current-touching #f)
|
||||
|
||||
(define-values (proc pending-transition)
|
||||
(spawn->process+transition (spawn-dataspace boot-actions)))
|
||||
(define event-queue (make-queue))
|
||||
|
@ -314,6 +404,8 @@
|
|||
(for [(s removed)] (remove-sprite! sprites s))
|
||||
(for [(s added)] (add-sprite! sprites s))
|
||||
;; (log-info "~a sprites" (splay-tree-count sprites))
|
||||
(when (not (and (set-empty? added) (set-empty? removed)))
|
||||
(update-touching!))
|
||||
(flush-texture-cache!))
|
||||
|
||||
(define (process-stop-requests! p)
|
||||
|
@ -390,6 +482,30 @@
|
|||
[code (key-event code #t (seal key))])))
|
||||
(quiesce!))))
|
||||
|
||||
(define/override (on-event mouse)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(define x (send mouse get-x))
|
||||
(define y (send mouse get-y))
|
||||
(define s (mouse-state x
|
||||
y
|
||||
(send mouse get-left-down)
|
||||
(send mouse get-middle-down)
|
||||
(send mouse get-right-down)))
|
||||
(set! current-mouse-state s)
|
||||
(update-touching!)
|
||||
(inject-event! (message (mouse-event (send mouse get-event-type) s)))
|
||||
(quiesce!))))
|
||||
|
||||
(define (update-touching!)
|
||||
(define new-touching (detect-touch prelude sprites postlude current-mouse-state))
|
||||
(when (not (equal? new-touching current-touching))
|
||||
(define retract-old (retract current-touching))
|
||||
(if new-touching
|
||||
(inject-event! (patch-seq retract-old (assert new-touching)))
|
||||
(inject-event! retract-old))
|
||||
(set! current-touching new-touching)))
|
||||
|
||||
(super-new (style '(gl no-autoclear)))))
|
||||
|
||||
(define ((2d-dataspace #:label [frame-label "syndicate-gl"]
|
||||
|
|
|
@ -0,0 +1,227 @@
|
|||
#lang racket/base
|
||||
;; 2D affine transformation matrices.
|
||||
|
||||
;; These are *active* transformations: they transform vectors to new
|
||||
;; vectors, rather than coordinate systems to new coordinate systems.
|
||||
|
||||
(provide (struct-out transformation-matrix)
|
||||
|
||||
identity-transformation
|
||||
translation-transformation
|
||||
rotation-transformation
|
||||
stretching-transformation
|
||||
shearing-transformation
|
||||
invert-transformation
|
||||
compose-transformation
|
||||
|
||||
transform-point
|
||||
transform-vector
|
||||
untransform-point
|
||||
untransform-vector)
|
||||
|
||||
(require (only-in racket/math pi))
|
||||
(require racket/match)
|
||||
|
||||
(struct transformation-matrix (a b c d tx ty) #:prefab)
|
||||
|
||||
(define identity-transformation
|
||||
(transformation-matrix 1 0 0 1 0 0))
|
||||
|
||||
(define (translation-transformation x y)
|
||||
(transformation-matrix 1 0 0 1 x y))
|
||||
|
||||
(define (rad deg) (* deg (/ pi 180.0)))
|
||||
|
||||
(define (rotation-transformation theta-d)
|
||||
(match theta-d
|
||||
[(or 0 360) identity-transformation]
|
||||
[(or 90 -270) (transformation-matrix 0 1 -1 0 0 0)]
|
||||
[180 (transformation-matrix -1 0 0 -1 0 0)]
|
||||
[(or 270 -90) (transformation-matrix 0 -1 1 0 0 0)]
|
||||
[_
|
||||
(define theta-r (rad theta-d))
|
||||
(define c (cos theta-r))
|
||||
(define s (sin theta-r))
|
||||
(transformation-matrix c s (- s) c 0 0)]))
|
||||
|
||||
(define (stretching-transformation sx [sy sx])
|
||||
(transformation-matrix sx 0 0 sy 0 0))
|
||||
|
||||
(define (shearing-transformation sx sy)
|
||||
(transformation-matrix 1 sy sx 1 0 0))
|
||||
|
||||
(define (invert-transformation m)
|
||||
(define det (determinant m))
|
||||
(when (zero? det) (error 'invert-transformation "Zero determinant"))
|
||||
(define -det (- det))
|
||||
(match-define (transformation-matrix a b c d tx ty) m)
|
||||
(transformation-matrix (/ d det)
|
||||
(/ b -det)
|
||||
(/ c -det)
|
||||
(/ a det)
|
||||
(/ (- (* c ty) (* d tx)) det)
|
||||
(/ (- (* b tx) (* a ty)) det)))
|
||||
|
||||
(define (determinant m)
|
||||
(match-define (transformation-matrix a b c d _ _) m)
|
||||
(- (* a d) (* b c)))
|
||||
|
||||
(define (compose-transformation* m1 m0)
|
||||
(match-define (transformation-matrix a b c d tx ty) m1)
|
||||
(match-define (transformation-matrix e f g h sx sy) m0)
|
||||
(transformation-matrix (+ (* a e) (* c f))
|
||||
(+ (* b e) (* d f))
|
||||
(+ (* a g) (* c h))
|
||||
(+ (* b g) (* d h))
|
||||
(+ (* a sx) (* c sy) tx)
|
||||
(+ (* b sx) (* d sy) ty)))
|
||||
|
||||
(define compose-transformation
|
||||
(case-lambda
|
||||
[() identity-transformation]
|
||||
[(m) m]
|
||||
[(m1 m0) (compose-transformation* m1 m0)]
|
||||
[mtxs (foldr compose-transformation* identity-transformation mtxs)]))
|
||||
|
||||
(define (transform-point m v)
|
||||
(match-define (transformation-matrix a b c d tx ty) m)
|
||||
(define x (real-part v))
|
||||
(define y (imag-part v))
|
||||
(make-rectangular (+ (* a x) (* c y) tx)
|
||||
(+ (* b x) (* d y) ty)))
|
||||
|
||||
(define (transform-vector m v)
|
||||
(match-define (transformation-matrix a b c d _ _) m)
|
||||
(define x (real-part v))
|
||||
(define y (imag-part v))
|
||||
(make-rectangular (+ (* a x) (* c y))
|
||||
(+ (* b x) (* d y))))
|
||||
|
||||
(define (untransform-point m v)
|
||||
(transform-point (invert-transformation m) v))
|
||||
|
||||
(define (untransform-vector m v)
|
||||
(transform-vector (invert-transformation m) v))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define eps 0.00001)
|
||||
(define invrt2 (/ (sqrt 2)))
|
||||
|
||||
(define (within-eps a b) (< (magnitude (- a b)) eps))
|
||||
|
||||
(define-binary-check (check-transformation~? actual expected)
|
||||
(match-let (((transformation-matrix aa ab ac ad atx aty) actual)
|
||||
((transformation-matrix ea eb ec ed etx ety) expected))
|
||||
(and (within-eps aa ea)
|
||||
(within-eps ab eb)
|
||||
(within-eps ac ec)
|
||||
(within-eps ad ed)
|
||||
(within-eps atx etx)
|
||||
(within-eps aty ety))))
|
||||
|
||||
(check-= (transform-point (rotation-transformation 0) +i) +i eps)
|
||||
(check-= (transform-point (rotation-transformation 90) +i) -1 eps)
|
||||
(check-= (transform-point (rotation-transformation 180) +i) -i eps)
|
||||
(check-= (transform-point (rotation-transformation 270) +i) 1 eps)
|
||||
(check-= (transform-point (rotation-transformation -90) +i) 1 eps)
|
||||
(check-= (transform-point (rotation-transformation 360) +i) +i eps)
|
||||
|
||||
(check-= (transform-point (rotation-transformation 0) 1) 1 eps)
|
||||
(check-= (transform-point (rotation-transformation 90) 1) +i eps)
|
||||
(check-= (transform-point (rotation-transformation 180) 1) -1 eps)
|
||||
(check-= (transform-point (rotation-transformation 270) 1) -i eps)
|
||||
(check-= (transform-point (rotation-transformation -90) 1) -i eps)
|
||||
(check-= (transform-point (rotation-transformation 360) 1) 1 eps)
|
||||
|
||||
(check-= (transform-point (rotation-transformation -45) 1) (make-rectangular invrt2 (- invrt2)) eps)
|
||||
(check-= (transform-point (rotation-transformation 45) 1) (make-rectangular invrt2 invrt2) eps)
|
||||
(check-= (transform-point (rotation-transformation 135) 1) (make-rectangular (- invrt2) invrt2) eps)
|
||||
|
||||
(check-= (transform-point (stretching-transformation 2) 1) 2 eps)
|
||||
(check-= (transform-point (stretching-transformation 2) +i) +2i eps)
|
||||
(check-= (transform-point (stretching-transformation 2) 1+i) 2+2i eps)
|
||||
|
||||
(check-= (transform-point (compose-transformation (translation-transformation 0 2)
|
||||
(rotation-transformation 45))
|
||||
1)
|
||||
(make-rectangular invrt2 (+ invrt2 2))
|
||||
eps)
|
||||
|
||||
(check-= (transform-point (compose-transformation (rotation-transformation 45)
|
||||
(translation-transformation 0 2))
|
||||
1)
|
||||
-0.7071067811865474+2.121320343559643i
|
||||
eps)
|
||||
|
||||
(check-= (transform-point (invert-transformation
|
||||
(compose-transformation (rotation-transformation 45)
|
||||
(translation-transformation 0 2)))
|
||||
-0.7071067811865474+2.121320343559643i)
|
||||
1
|
||||
eps)
|
||||
|
||||
(check-transformation~? (compose-transformation (rotation-transformation -90)
|
||||
(translation-transformation 0 2)
|
||||
(rotation-transformation 90))
|
||||
(translation-transformation 2 0))
|
||||
|
||||
(check-transformation~? (compose-transformation (rotation-transformation -45)
|
||||
(translation-transformation 0 (* 2 (sqrt 2)))
|
||||
(rotation-transformation 45))
|
||||
(translation-transformation 2 2))
|
||||
|
||||
;; Cairo's drawing model has *device coordinates* and *user
|
||||
;; coordinates*. In the Cairo tutorial, we are given the task of
|
||||
;; mapping a 1.0x1.0 workspace onto the 100x100 pixel square in the
|
||||
;; middle of a 120x120 pixel surface, and shown three different ways
|
||||
;; of achieving this:
|
||||
;;
|
||||
;; - cairo_translate (cr, 10, 10); cairo_scale (cr, 100, 100);
|
||||
;;
|
||||
;; - cairo_scale (cr, 100, 100); cairo_translate (cr, 0.1, 0.1);
|
||||
;;
|
||||
;; - cairo_matrix_t mat; cairo_matrix_init (&mat, 100, 0, 0, 100, 10, 10);
|
||||
;; cairo_transform (cr, &mat);
|
||||
;;
|
||||
;; Let's see what those look like here. We'll assume a right-handed
|
||||
;; coordinate system for both the workspace and the surface, so we
|
||||
;; can judge a correct outcome by seeing that (0,0) on the workspace
|
||||
;; should map to (10,10) on the surface, that (1,1) on the workspace
|
||||
;; should map to (110,110), and that the other two corners should
|
||||
;; map correspondingly.
|
||||
|
||||
(let ()
|
||||
(define (apply-to-inputs m)
|
||||
(map (lambda (v) (transform-point m v))
|
||||
(list 0 1 1+i +i)))
|
||||
|
||||
(define expected-outputs (list 10+10i 110+10i 110+110i 10+110i))
|
||||
|
||||
(define-binary-check (check-list~? actual expected)
|
||||
(andmap within-eps actual expected))
|
||||
|
||||
(check-list~? (apply-to-inputs (compose-transformation (translation-transformation 10 10)
|
||||
(stretching-transformation 100 100)))
|
||||
expected-outputs)
|
||||
(check-list~? (apply-to-inputs (compose-transformation (stretching-transformation 100 100)
|
||||
(translation-transformation 0.1 0.1)))
|
||||
expected-outputs)
|
||||
(check-list~? (apply-to-inputs (transformation-matrix 100 0 0 100 10 10))
|
||||
expected-outputs))
|
||||
|
||||
;; The Cairo tutorial also makes this note regarding line widths:
|
||||
;; "While you're operating under a scale, the width of your line is
|
||||
;; multiplied by that scale." That is, in Cairo, you reason about
|
||||
;; line widths in user coordinates, just as with everything else.
|
||||
|
||||
(let* ((m (transformation-matrix 100 0 0 100 10 10)))
|
||||
;; transform-vector is analogous to Cairo's
|
||||
;; "cairo_user_to_device_distance" function.
|
||||
(check-= (transform-vector m 0.01+0.01i) 1+i eps)
|
||||
;; untransform-vector is analogous to Cairo's
|
||||
;; "cairo_device_to_user_distance" function.
|
||||
(check-= (untransform-vector m 1+i) 0.01+0.01i eps))
|
||||
|
||||
)
|
|
@ -24,7 +24,8 @@
|
|||
(define CC character-cat-girl)
|
||||
|
||||
(actor (field [x 100] [y 100])
|
||||
(assert (outbound (simple-sprite -0.5 (x) (y) (image-width CC) (image-height CC) CC)))
|
||||
(assert (outbound (simple-sprite #:touchable-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)))
|
||||
|
@ -43,19 +44,32 @@
|
|||
(define (spawn-frame-counter)
|
||||
(actor (field [i empty-image])
|
||||
(assert (outbound
|
||||
(simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i))))
|
||||
(simple-sprite #:touchable-id 'frame-counter
|
||||
-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)
|
||||
(actor (assert (outbound (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange"))))
|
||||
(assert (outbound (simple-sprite -1 60 60 50 50 (circle 50 "solid" "green")))))
|
||||
|
||||
(actor (define/query-value touching-orange? #f (inbound (touching 'orange _ _ _)) #t)
|
||||
(assert (outbound (simple-sprite #:touchable-id 'orange
|
||||
0 50 50 50 50 (circle 50 "solid"
|
||||
(if (touching-orange?)
|
||||
"red"
|
||||
"orange")))))
|
||||
(assert (outbound (simple-sprite #:touchable-id 'green
|
||||
-1 60 60 50 50 (circle 50 "solid" "green")))))
|
||||
(actor* (until (message (inbound (key-event #\q #t _))))
|
||||
(assert! (outbound 'stop)))
|
||||
|
||||
(actor (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)))
|
||||
|
|
Loading…
Reference in New Issue