From 773d1e953ba79a2c9184fe48ee2049e2fd6b1e0c Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 27 Sep 2016 17:08:24 -0400 Subject: [PATCH] Support coordinate-map in syndicate-gl/2d --- racket/syndicate-gl/2d.rkt | 197 ++++++++++++++++--------- racket/syndicate-gl/affine.rkt | 14 +- racket/syndicate-gl/examples/basic.rkt | 10 +- 3 files changed, 143 insertions(+), 78 deletions(-) diff --git a/racket/syndicate-gl/2d.rkt b/racket/syndicate-gl/2d.rkt index 1ab0423..c13068b 100644 --- a/racket/syndicate-gl/2d.rkt +++ b/racket/syndicate-gl/2d.rkt @@ -7,6 +7,7 @@ (struct-out mouse-event) (struct-out mouse-state) (struct-out touching) + (struct-out coordinate-map) (struct-out scene) (except-out (struct-out sprite) sprite) (rename-out [sprite ] [make-sprite sprite]) @@ -64,6 +65,10 @@ ;; Assertion. Indicates that the mouse is touching a particular touchable. (struct touching (id) #:transparent) +;; Assertion. Communicates aggregate device-to-user transformation +;; requested as part of sprite instruction sequences. +(struct coordinate-map (id matrix) #: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. @@ -102,6 +107,7 @@ (define (simple-sprite z x y w h i #:parent [parent-id #f] #:rotation [rotation 0] + #:coordinate-map-id [coordinate-map-id #f] #:touchable-id [touchable-id #f] #:touchable-predicate [touchable-predicate in-unit-square?]) (make-sprite #:id touchable-id @@ -115,6 +121,9 @@ `((touchable ,touchable-id ,touchable-predicate)) `()) (texture ,i)) + ,@(if coordinate-map-id + `((coordinate-map ,coordinate-map-id)) + `()) (render-children)))) (define (update-sprites #:meta-level [meta-level 1] . ss) @@ -155,12 +164,14 @@ ;; predicate on user coordinates, and an ID to use when the ;; predicate answers truthily. ;; -;; - (touchable-map TransformationMatrix) -;; Represents a partial device-to-user transformation used when -;; mapping along parent-child relationship edges in the sprite tree. +;; - (touchable-map) +;; Represents the location in a sequence of touchables where the +;; aggregate partial device-to-user transformation used when mapping +;; along parent-child relationship edges in the sprite tree should +;; be applied to child sprites. ;; (struct touchable (id transformation predicate) #:transparent) -(struct touchable-map (matrix) #:transparent) +(struct touchable-map () #:transparent) ;; A Children is a (SplayTree Sprite CompiledInstructions), ordered ;; first by sprite-z, then sprite-id hash code, then @@ -171,84 +182,92 @@ ;; (compiled-instructions (ChildMap SpriteID -> Void) ;; (Listof Touchable) +;; (Listof CoordinateMap) ;; (Listof Resource) ;; (Option 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 child-xform, if present, is the transformation needed to map -;; between mouse coordinates and child sprite space; if absent, no -;; (render-children) instruction was found in this sprite's render -;; code. -(struct compiled-instructions (render-proc touchables resources)) +;; A single compiled sprite. The resources and coordinate-maps 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 child-xform, if present, is the +;; transformation needed to map between mouse coordinates and child +;; sprite space; if absent, no (render-children) instruction was found +;; in this sprite's render code. +(struct compiled-instructions (render-proc touchables coordinate-maps resources child-xform)) (define-namespace-anchor ns-anchor) (define ns (namespace-anchor->namespace ns-anchor)) (define (compile-instructions instrs) - (define-values (code touchables resources xform) + (define touchables '()) + (define coordinate-maps '()) + (define resources '()) + (define child-xform #f) + + (define (instructions->racket-code instrs xform) + (define-values (code-rev new-xform) + (for/fold [(code-rev '()) (xform xform)] [(instr (in-list instrs))] + (define-values (new-code new-xform) (instruction->racket-code instr xform)) + (values (cons new-code code-rev) new-xform))) + (values (reverse code-rev) new-xform)) + + (define (instruction->racket-code instr xform) + (match instr + [`(rotate ,(? number? deg)) + (values `(glRotated ,deg 0 0 -1) + (compose-transformation xform (rotation-transformation deg)))] + [`(scale ,(? number? x) ,(? number? y)) + (values `(glScaled ,x ,y 1) + (compose-transformation xform (stretching-transformation x y)))] + [`(translate ,(? number? x) ,(? number? y)) + (values `(glTranslated ,x ,y 0) + (compose-transformation xform (translation-transformation x y)))] + [`(color ,(? color-number? r) ,(? color-number? g) ,(? color-number? b) ,(? color-number? a)) + (values `(glColor4d ,r ,g ,b ,a) xform)] + [`(texture ,i) + (define entry (image->texture-cache-entry i)) + (set! resources (cons entry resources)) + (values `(draw-gl-face ,(send entry get-texture)) xform)] + [`(texture ,i ,l ,t ,w ,h) #:when (andmap number? (list l t w h)) + (define entry (image->texture-cache-entry i)) + (set! resources (cons entry resources)) + (values `(draw-gl-face ,(send entry get-texture) ,l ,t ,w ,h) xform)] + [`(touchable ,id ,predicate) + (set! touchables (cons (touchable id xform predicate) touchables)) + (values `(void) xform)] + [`(coordinate-map ,id) + (set! coordinate-maps (cons (coordinate-map id xform) coordinate-maps)) + (values `(void) xform)] + [`(push-matrix ,instr ...) + (define-values (code _new-xform) (instructions->racket-code instr xform)) + (values `(begin (glPushMatrix) ,@code (glPopMatrix)) xform)] + [`(begin ,instr ...) + (define-values (code new-xform) (instructions->racket-code instr xform)) + (values `(begin ,@code (void)) new-xform)] + [`(render-children) ;; we assume that there will only be one of these + (set! child-xform xform) + (set! touchables (cons (touchable-map) touchables)) + (values `(render-sprites! CHILDMAP SELF-ID) xform)] + [other + (error 'instruction->racket-code "unknown render instruction: ~v" other)])) + + (define-values (code final-transformation) (instruction->racket-code `(begin ,@instrs) identity-transformation)) (define render-proc (eval `(lambda (CHILDMAP SELF-ID) ,code) ns)) (compiled-instructions render-proc touchables - resources)) + coordinate-maps + resources + child-xform)) (define (compiled-instructions-dispose! i) (when i (for [(resource (compiled-instructions-resources i))] (send resource dispose)))) -(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 xform) - (match instr - [`(rotate ,(? number? deg)) - (values `(glRotated ,deg 0 0 -1) '() '() - (compose-transformation xform (rotation-transformation deg)))] - [`(scale ,(? number? x) ,(? number? y)) - (values `(glScaled ,x ,y 1) '() '() - (compose-transformation xform (stretching-transformation x y)))] - [`(translate ,(? number? x) ,(? number? y)) - (values `(glTranslated ,x ,y 0) '() '() - (compose-transformation xform (translation-transformation x y)))] - [`(color ,(? color-number? r) ,(? color-number? g) ,(? color-number? b) ,(? color-number? 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) xform)] - [`(texture ,i ,l ,t ,w ,h) #:when (andmap number? (list l t w h)) - (define entry (image->texture-cache-entry i)) - (values `(draw-gl-face ,(send entry get-texture) ,l ,t ,w ,h) '() (list entry) xform)] - [`(touchable ,id ,predicate) - (values `(void) (list (touchable id xform predicate)) '() xform)] - [`(push-matrix ,instr ...) - (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 touchables resources new-xform) (instructions->racket-code instr xform)) - (values `(begin ,@code (void)) touchables resources new-xform)] - [`(render-children) - (values `(render-sprites! CHILDMAP SELF-ID) (list (touchable-map xform)) '() xform)] - [other - (error 'instruction->racket-code "unknown render instruction: ~v" other)])) - (define (image->bitmap i) (cond [(is-a? i bitmap%) @@ -334,14 +353,19 @@ (define i (compile-instructions instrs)) (splay-tree-set! sprites s i)) -(define (render-sprites! childmap self-id) - (define sprites (hash-ref childmap self-id #f)) - (let loop ((iter (and sprites (splay-tree-iterate-first sprites)))) +(define (for-each-child-sprite childmap id f) + (define children (hash-ref childmap id #f)) + (let loop ((iter (and children (splay-tree-iterate-first children)))) (when iter - (define s (splay-tree-iterate-key sprites iter)) - (define proc (compiled-instructions-render-proc (splay-tree-iterate-value sprites iter))) - (proc childmap (sprite-id s)) - (loop (splay-tree-iterate-next sprites iter))))) + (define s (splay-tree-iterate-key children iter)) + (define ci (splay-tree-iterate-value children iter)) + (f s ci) + (loop (splay-tree-iterate-next children iter))))) + +(define (render-sprites! childmap self-id) + (for-each-child-sprite childmap self-id + (lambda (s ci) + ((compiled-instructions-render-proc ci) childmap (sprite-id s))))) (define (render-scene! prelude childmap postlude) ((compiled-instructions-render-proc prelude) childmap #f) @@ -372,7 +396,8 @@ [(touchable id xform contains?) (define-values (ux uy) (untransform-point* xform x y)) (and (contains? ux uy) (touching id))] - [(touchable-map xform) + [(touchable-map) + (define xform (compiled-instructions-child-xform ci)) (define-values (ux uy) (untransform-point* xform x y)) (detect-sprites-touch childmap self-id ux uy)]))) @@ -406,6 +431,7 @@ (define current-mouse-state #f) (define current-touching #f) + (define current-coordinate-maps (hash)) (define-values (proc pending-transition) (spawn->process+transition (spawn-dataspace boot-actions))) @@ -478,7 +504,8 @@ (for [(s removed)] (remove-sprite! childmap s)) (for [(s added)] (add-sprite! childmap s)) (when (not (and (set-empty? added) (set-empty? removed))) - (update-touching!)) + (update-touching!) + (update-coordinate-maps!)) (flush-texture-cache!)) (define (process-stop-requests! p) @@ -579,6 +606,36 @@ (inject-event! retract-old)) (set! current-touching new-touching))) + (define (update-coordinate-maps!) + (define aggregate-patch patch-empty) + + (define (update-single-map! cmid cmx) + (define existing (hash-ref current-coordinate-maps cmid #f)) + (define proposed (coordinate-map cmid cmx)) + (when (not (equal? existing proposed)) + (set! current-coordinate-maps (hash-set current-coordinate-maps cmid proposed)) + (set! aggregate-patch (patch-seq aggregate-patch + (retract (coordinate-map cmid ?)) + (assert proposed))))) + + (let process-children-of ((id #f) (xform identity-transformation)) + (for-each-child-sprite childmap id + (lambda (s ci) + (for-each (lambda (cm) + (match-define (coordinate-map cmid cmx) cm) + (update-single-map! + cmid + (compose-transformation xform cmx))) + (compiled-instructions-coordinate-maps ci)) + (define child-xform (compiled-instructions-child-xform ci)) + (when child-xform + (process-children-of (sprite-id s) + (compose-transformation xform + child-xform)))))) + + (when (not (patch-empty? aggregate-patch)) + (inject-event! aggregate-patch))) + (super-new (style '(gl no-autoclear))))) (define ((2d-dataspace #:label [frame-label "syndicate-gl"] diff --git a/racket/syndicate-gl/affine.rkt b/racket/syndicate-gl/affine.rkt index 1fe07f3..f27ef7a 100644 --- a/racket/syndicate-gl/affine.rkt +++ b/racket/syndicate-gl/affine.rkt @@ -144,21 +144,21 @@ (check-= (transform-point (stretching-transformation 2) 1+i) 2+2i eps) (check-= (transform-point (compose-transformation (translation-transformation 0 2) - (rotation-transformation 45)) - 1) + (rotation-transformation 45)) + 1) (make-rectangular invrt2 (+ invrt2 2)) eps) (check-= (transform-point (compose-transformation (rotation-transformation 45) - (translation-transformation 0 2)) - 1) + (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) + (compose-transformation (rotation-transformation 45) + (translation-transformation 0 2))) + -0.7071067811865474+2.121320343559643i) 1 eps) diff --git a/racket/syndicate-gl/examples/basic.rkt b/racket/syndicate-gl/examples/basic.rkt index a3fe4c5..bd954e7 100644 --- a/racket/syndicate-gl/examples/basic.rkt +++ b/racket/syndicate-gl/examples/basic.rkt @@ -34,10 +34,13 @@ (idle)) -(define (draggable-shape name orig-x orig-y z plain-image hover-image #:parent [parent-id #f]) +(define (draggable-shape name orig-x orig-y z plain-image hover-image + #:coordinate-map-id [coordinate-map-id #f] + #:parent [parent-id #f]) (actor (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 @@ -69,6 +72,7 @@ (actor (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)]) @@ -79,6 +83,10 @@ (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 _)))