First steps toward mouse-based picking in syndicate-gl

This commit is contained in:
Tony Garnock-Jones 2016-09-01 19:50:03 +01:00
parent 1ae40c1ff1
commit b60fa8c755
3 changed files with 381 additions and 24 deletions

View File

@ -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"]

View File

@ -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))
)

View File

@ -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)))