syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Support coordinate-map in syndicate-gl/2d

This commit is contained in:
Tony Garnock-Jones 2016-09-27 17:08:24 -04:00
parent d00f0cbf13
commit 773d1e953b
3 changed files with 143 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

197
racket/syndicate-gl/2d.rkt
View File

@ -7,6 +7,7 @@
(struct-out mouse-event) (struct-out mouse-event)
(struct-out mouse-state) (struct-out mouse-state)
(struct-out touching) (struct-out touching)
(struct-out coordinate-map)
(struct-out scene) (struct-out scene)
(except-out (struct-out sprite) sprite) (except-out (struct-out sprite) sprite)
(rename-out [sprite <sprite>] [make-sprite sprite]) (rename-out [sprite <sprite>] [make-sprite sprite])
@ -64,6 +65,10 @@
;; Assertion. Indicates that the mouse is touching a particular touchable. ;; Assertion. Indicates that the mouse is touching a particular touchable.
(struct touching (id) #:transparent) (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 ;; Shared state maintained by program. Prelude and postlude are to be
;; sealed instruction lists. It is an error to have more than exactly ;; sealed instruction lists. It is an error to have more than exactly
;; one active such record at a given time. ;; one active such record at a given time.
@ -102,6 +107,7 @@
(define (simple-sprite z x y w h i (define (simple-sprite z x y w h i
#:parent [parent-id #f] #:parent [parent-id #f]
#:rotation [rotation 0] #:rotation [rotation 0]
#:coordinate-map-id [coordinate-map-id #f]
#:touchable-id [touchable-id #f] #:touchable-id [touchable-id #f]
#:touchable-predicate [touchable-predicate in-unit-square?]) #:touchable-predicate [touchable-predicate in-unit-square?])
(make-sprite #:id touchable-id (make-sprite #:id touchable-id
@ -115,6 +121,9 @@
`((touchable ,touchable-id ,touchable-predicate)) `((touchable ,touchable-id ,touchable-predicate))
`()) `())
(texture ,i)) (texture ,i))
,@(if coordinate-map-id
`((coordinate-map ,coordinate-map-id))
`())
(render-children)))) (render-children))))
(define (update-sprites #:meta-level [meta-level 1] . ss) (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 on user coordinates, and an ID to use when the
;; predicate answers truthily. ;; predicate answers truthily.
;; ;;
;; - (touchable-map TransformationMatrix) ;; - (touchable-map)
;; Represents a partial device-to-user transformation used when ;; Represents the location in a sequence of touchables where the
;; mapping along parent-child relationship edges in the sprite tree. ;; 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 (id transformation predicate) #:transparent)
(struct touchable-map (matrix) #:transparent) (struct touchable-map () #:transparent)
;; A Children is a (SplayTree Sprite CompiledInstructions), ordered ;; A Children is a (SplayTree Sprite CompiledInstructions), ordered
;; first by sprite-z, then sprite-id hash code, then ;; first by sprite-z, then sprite-id hash code, then
@ -171,84 +182,92 @@
;; (compiled-instructions (ChildMap SpriteID -> Void) ;; (compiled-instructions (ChildMap SpriteID -> Void)
;; (Listof Touchable) ;; (Listof Touchable)
;; (Listof CoordinateMap)
;; (Listof Resource) ;; (Listof Resource)
;; (Option TransformationMatrix)) ;; (Option TransformationMatrix))
;; A single compiled sprite. The resources aren't in any particular ;; A single compiled sprite. The resources and coordinate-maps aren't
;; order, but the touchables are: the leftmost touchable is the first ;; in any particular order, but the touchables are: the leftmost
;; to check; that is, it is the *topmost* touchable in this sprite. ;; touchable is the first to check; that is, it is the *topmost*
;; The child-xform, if present, is the transformation needed to map ;; touchable in this sprite. The child-xform, if present, is the
;; between mouse coordinates and child sprite space; if absent, no ;; transformation needed to map between mouse coordinates and child
;; (render-children) instruction was found in this sprite's render ;; sprite space; if absent, no (render-children) instruction was found
;; code. ;; in this sprite's render code.
(struct compiled-instructions (render-proc touchables resources)) (struct compiled-instructions (render-proc touchables coordinate-maps resources child-xform))
(define-namespace-anchor ns-anchor) (define-namespace-anchor ns-anchor)
(define ns (namespace-anchor->namespace ns-anchor)) (define ns (namespace-anchor->namespace ns-anchor))
(define (compile-instructions instrs) (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)) (instruction->racket-code `(begin ,@instrs) identity-transformation))
(define render-proc (eval `(lambda (CHILDMAP SELF-ID) ,code) ns)) (define render-proc (eval `(lambda (CHILDMAP SELF-ID) ,code) ns))
(compiled-instructions render-proc (compiled-instructions render-proc
touchables touchables
resources)) coordinate-maps
resources
child-xform))
(define (compiled-instructions-dispose! i) (define (compiled-instructions-dispose! i)
(when i (when i
(for [(resource (compiled-instructions-resources i))] (for [(resource (compiled-instructions-resources i))]
(send resource dispose)))) (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) (define (color-number? n)
(and (number? n) (and (number? n)
(<= 0.0 n 1.0))) (<= 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) (define (image->bitmap i)
(cond (cond
[(is-a? i bitmap%) [(is-a? i bitmap%)
@ -334,14 +353,19 @@
(define i (compile-instructions instrs)) (define i (compile-instructions instrs))
(splay-tree-set! sprites s i)) (splay-tree-set! sprites s i))
(define (render-sprites! childmap self-id) (define (for-each-child-sprite childmap id f)
(define sprites (hash-ref childmap self-id #f)) (define children (hash-ref childmap id #f))
(let loop ((iter (and sprites (splay-tree-iterate-first sprites)))) (let loop ((iter (and children (splay-tree-iterate-first children))))
(when iter (when iter
(define s (splay-tree-iterate-key sprites iter)) (define s (splay-tree-iterate-key children iter))
(define proc (compiled-instructions-render-proc (splay-tree-iterate-value sprites iter))) (define ci (splay-tree-iterate-value children iter))
(proc childmap (sprite-id s)) (f s ci)
(loop (splay-tree-iterate-next sprites iter))))) (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) (define (render-scene! prelude childmap postlude)
((compiled-instructions-render-proc prelude) childmap #f) ((compiled-instructions-render-proc prelude) childmap #f)
@ -372,7 +396,8 @@
[(touchable id xform contains?) [(touchable id xform contains?)
(define-values (ux uy) (untransform-point* xform x y)) (define-values (ux uy) (untransform-point* xform x y))
(and (contains? ux uy) (touching id))] (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)) (define-values (ux uy) (untransform-point* xform x y))
(detect-sprites-touch childmap self-id ux uy)]))) (detect-sprites-touch childmap self-id ux uy)])))
@ -406,6 +431,7 @@
(define current-mouse-state #f) (define current-mouse-state #f)
(define current-touching #f) (define current-touching #f)
(define current-coordinate-maps (hash))
(define-values (proc pending-transition) (define-values (proc pending-transition)
(spawn->process+transition (spawn-dataspace boot-actions))) (spawn->process+transition (spawn-dataspace boot-actions)))
@ -478,7 +504,8 @@
(for [(s removed)] (remove-sprite! childmap s)) (for [(s removed)] (remove-sprite! childmap s))
(for [(s added)] (add-sprite! childmap s)) (for [(s added)] (add-sprite! childmap s))
(when (not (and (set-empty? added) (set-empty? removed))) (when (not (and (set-empty? added) (set-empty? removed)))
(update-touching!)) (update-touching!)
(update-coordinate-maps!))
(flush-texture-cache!)) (flush-texture-cache!))
(define (process-stop-requests! p) (define (process-stop-requests! p)
@ -579,6 +606,36 @@
(inject-event! retract-old)) (inject-event! retract-old))
(set! current-touching new-touching))) (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))))) (super-new (style '(gl no-autoclear)))))
(define ((2d-dataspace #:label [frame-label "syndicate-gl"] (define ((2d-dataspace #:label [frame-label "syndicate-gl"]

10
racket/syndicate-gl/examples/basic.rkt
View File

@ -34,10 +34,13 @@
(idle)) (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]) (actor (field [x orig-x] [y orig-y])
(define/query-value touching? #f (inbound (touching name)) #t) (define/query-value touching? #f (inbound (touching name)) #t)
(assert (outbound (simple-sprite #:parent parent-id (assert (outbound (simple-sprite #:parent parent-id
#:coordinate-map-id coordinate-map-id
#:touchable-id name #:touchable-id name
#:touchable-predicate in-unit-circle? #:touchable-predicate in-unit-circle?
z (x) (y) 50 50 z (x) (y) 50 50
@ -69,6 +72,7 @@
(actor (field [x 100] [y 100]) (actor (field [x 100] [y 100])
(assert (outbound (simple-sprite #:touchable-id 'player (assert (outbound (simple-sprite #:touchable-id 'player
#:coordinate-map-id 'player
-0.5 (x) (y) (image-width CC) (image-height CC) CC))) -0.5 (x) (y) (image-width CC) (image-height CC) CC)))
(field [keys-down (set)]) (field [keys-down (set)])
@ -79,6 +83,10 @@
(define/query-value touching? #f (inbound (touching 'player)) #t) (define/query-value touching? #f (inbound (touching 'player)) #t)
(on-start (draggable-mixin touching? x y)) (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-start (tooltip touching? x y (image-width CC) (image-height CC) "The Player"))
(on (message (inbound (frame-event _ _ $elapsed-ms _))) (on (message (inbound (frame-event _ _ $elapsed-ms _)))