gl-2d driver and examples
This commit is contained in:
Tony Garnock-Jones
parent
38c6bfd20e
commit
2b2d12075a
|
|
@ -0,0 +1,718 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(provide (struct-out window)
|
||||
(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 coordinate-map)
|
||||
(struct-out scene)
|
||||
(except-out (struct-out sprite) sprite)
|
||||
(rename-out [sprite <sprite>] [make-sprite sprite])
|
||||
(struct-out gl-control)
|
||||
in-unit-circle?
|
||||
in-unit-square?
|
||||
simple-sprite
|
||||
assert-scene
|
||||
spawn-keyboard-integrator
|
||||
spawn-mouse-integrator
|
||||
spawn-gl-2d-driver)
|
||||
|
||||
(require data/order)
|
||||
(require data/splay-tree)
|
||||
(require data/queue)
|
||||
(require sgl/gl)
|
||||
(require sgl/gl-vectors)
|
||||
|
||||
(require racket/gui/base)
|
||||
(require racket/dict)
|
||||
(require (only-in racket/class
|
||||
send is-a? make-object class class* inherit this new super-new init
|
||||
define/public define/override define/augment))
|
||||
(require (only-in racket/math sqr))
|
||||
|
||||
(require (prefix-in image: 2htdp/image))
|
||||
(require (prefix-in pict: pict))
|
||||
|
||||
(require syndicate-gl/texture)
|
||||
(require syndicate-gl/affine)
|
||||
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Shared state maintained by dataspace. Describes current window dimensions.
|
||||
(assertion-struct window (width height))
|
||||
|
||||
;; Message sent by dataspace. Describes render time.
|
||||
(message-struct frame-event (counter timestamp elapsed-ms target-frame-rate))
|
||||
|
||||
;; Message sent by dataspace. Describes a key event. Key is a sealed
|
||||
;; key-event%. `press?` is #t when the key is pressed (or
|
||||
;; autorepeated!), and #f when it is released.
|
||||
(message-struct key-event (code press? key))
|
||||
|
||||
;; Assertion. Indicates that the named key is held down. See role
|
||||
;; KeyboardIntegrator and spawn-keyboard-integrator.
|
||||
(assertion-struct key-pressed (code))
|
||||
|
||||
;; Message sent by dataspace. Describes a mouse event. State is a
|
||||
;; MouseState.
|
||||
(message-struct mouse-event (type state))
|
||||
|
||||
;; Assertion. Indicates that the mouse is in a particular state. See
|
||||
;; role MouseIntegrator and spawn-mouse-integrator.
|
||||
(assertion-struct mouse-state (x y left-down? middle-down? right-down?))
|
||||
|
||||
;; Assertion. Indicates that the mouse is touching a particular touchable.
|
||||
(assertion-struct touching (id))
|
||||
|
||||
;; Assertion. Communicates aggregate device-to-user transformation
|
||||
;; requested as part of sprite instruction sequences.
|
||||
(assertion-struct coordinate-map (id matrix))
|
||||
|
||||
;; 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.
|
||||
(assertion-struct scene (prelude postlude))
|
||||
|
||||
;; A SpriteID is an equal?-comparable dataspace-unique value.
|
||||
|
||||
;; Shared state maintained by program. `id` is a SpriteID, and
|
||||
;; `parent-id` is an (Option SpriteID); #f in `parent-id` means that
|
||||
;; this sprite is a child of the root. Z is to be a number, negative
|
||||
;; toward camera. Instructions to be a sealed instruction list.
|
||||
(assertion-struct sprite (id parent-id z instructions))
|
||||
|
||||
;; Message and assertion.
|
||||
;;
|
||||
;; When sent as a message with `body` of `'stop`, closes the GL window
|
||||
;; and terminates the driver.
|
||||
;;
|
||||
;; When asserted with `body` of `'fullscreen`, causes the window to be
|
||||
;; fullscreen; otherwise, it is a normal window.
|
||||
;;
|
||||
(assertion-struct gl-control (body))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax-rule (assert-scene prelude postlude)
|
||||
(assert (scene (seal prelude) (seal postlude))))
|
||||
|
||||
(define (make-sprite z instructions #:id [id #f] #:parent [parent-id #f])
|
||||
(sprite (or id (gensym 'sprite)) parent-id z (seal instructions)))
|
||||
|
||||
(define (in-unit-circle? x y)
|
||||
(<= (+ (sqr (- x 0.5)) (sqr (- y 0.5))) (sqr 0.5)))
|
||||
|
||||
(define (in-unit-square? x y)
|
||||
(and (<= 0 x 1)
|
||||
(<= 0 y 1)))
|
||||
|
||||
(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
|
||||
#:parent parent-id
|
||||
z
|
||||
`((translate ,x ,y)
|
||||
,@(if (zero? rotation) `() `((rotate ,rotation)))
|
||||
(push-matrix
|
||||
(scale ,w ,h)
|
||||
,@(if touchable-id
|
||||
`((touchable ,touchable-id ,touchable-predicate))
|
||||
`())
|
||||
(texture ,i))
|
||||
,@(if coordinate-map-id
|
||||
`((coordinate-map ,coordinate-map-id))
|
||||
`())
|
||||
(render-children))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; KeyboardIntegrator. Integrates key-events into key-pressed assertions.
|
||||
(define (spawn-keyboard-integrator)
|
||||
(spawn #:name 'gl-2d/keyboard-integratpr
|
||||
(local-require racket/set)
|
||||
(define keys-pressed (mutable-set))
|
||||
;; TODO: consider adding set-semantics assert!/retract! API for this kind of thing
|
||||
(on (message (key-event $code #t _))
|
||||
(unless (set-member? keys-pressed code)
|
||||
(set-add! keys-pressed code)
|
||||
(assert! (key-pressed code))))
|
||||
(on (message (key-event $code #f _))
|
||||
(when (set-member? keys-pressed code)
|
||||
(set-remove! keys-pressed code)
|
||||
(retract! (key-pressed code))))))
|
||||
|
||||
;; MouseIntegrator. Integrates mouse-events into mouse-state assertions.
|
||||
(define (spawn-mouse-integrator)
|
||||
(spawn #:name 'gl-2d/mouse-integrator
|
||||
(field [in-bounds? #f] [state #f])
|
||||
(assert #:when (in-bounds?) (state))
|
||||
(on (message (mouse-event $type $new-state))
|
||||
(in-bounds? (not (eq? type 'leave)))
|
||||
(state new-state))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; A Touchable is one of
|
||||
;;
|
||||
;; - (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.
|
||||
;;
|
||||
;; - (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 () #:transparent)
|
||||
|
||||
;; A Children is a (SplayTree Sprite CompiledInstructions), ordered
|
||||
;; first by sprite-z, then sprite-id hash code, then
|
||||
;; sprite-instructions hash-code.
|
||||
;;
|
||||
;; A ChildMap is a (Hash SpriteID Children), mapping sprite-id to the
|
||||
;; children of that sprite.
|
||||
|
||||
;; (compiled-instructions (ChildMap SpriteID -> Void)
|
||||
;; (Listof Touchable)
|
||||
;; (Listof CoordinateMap)
|
||||
;; (Listof Resource)
|
||||
;; (Option TransformationMatrix))
|
||||
;; 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 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)))
|
||||
(let ((code (reverse code-rev)))
|
||||
(values (lambda (CHILDMAP SELF-ID)
|
||||
(for [(p (in-list code))]
|
||||
(p CHILDMAP SELF-ID)))
|
||||
new-xform)))
|
||||
|
||||
(define (instruction->racket-code instr xform)
|
||||
(match instr
|
||||
[`(rotate ,(? number? deg))
|
||||
(values (lambda (CHILDMAP SELF-ID) (glRotated deg 0 0 -1))
|
||||
(compose-transformation xform (rotation-transformation (- deg))))]
|
||||
[`(scale ,(? number? x) ,(? number? y))
|
||||
(values (lambda (CHILDMAP SELF-ID) (glScaled x y 1))
|
||||
(compose-transformation xform (stretching-transformation x y)))]
|
||||
[`(translate ,(? number? x) ,(? number? y))
|
||||
(values (lambda (CHILDMAP SELF-ID) (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 (lambda (CHILDMAP SELF-ID) (glColor4d r g b a)) xform)]
|
||||
[`(texture ,i)
|
||||
(define entry (image->texture-cache-entry i))
|
||||
(define tex (send entry get-texture))
|
||||
(set! resources (cons entry resources))
|
||||
(values (lambda (CHILDMAP SELF-ID) (draw-gl-face tex)) xform)]
|
||||
[`(texture ,i ,l ,t ,w ,h) #:when (andmap number? (list l t w h))
|
||||
(define entry (image->texture-cache-entry i))
|
||||
(define tex (send entry get-texture))
|
||||
(set! resources (cons entry resources))
|
||||
(values (lambda (CHILDMAP SELF-ID) (draw-gl-face tex 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 (lambda (CHILDMAP SELF-ID)
|
||||
(glPushMatrix)
|
||||
(code CHILDMAP SELF-ID)
|
||||
(glPopMatrix))
|
||||
xform)]
|
||||
[`(begin ,instr ...)
|
||||
(define-values (code new-xform) (instructions->racket-code instr xform))
|
||||
(values code 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! xform)]
|
||||
[other
|
||||
(error 'instruction->racket-code "unknown render instruction: ~v" other)]))
|
||||
|
||||
(define-values (render-proc final-transformation)
|
||||
(instruction->racket-code `(begin ,@instrs) identity-transformation))
|
||||
(compiled-instructions render-proc
|
||||
touchables
|
||||
coordinate-maps
|
||||
resources
|
||||
child-xform))
|
||||
|
||||
;; (define (compile-instructions instrs)
|
||||
;; (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
|
||||
;; coordinate-maps
|
||||
;; resources
|
||||
;; child-xform))
|
||||
|
||||
(define empty-instructions (compile-instructions '()))
|
||||
|
||||
(define (compiled-instructions-dispose! i)
|
||||
(when i
|
||||
(for [(resource (in-list (compiled-instructions-resources i)))]
|
||||
(send resource dispose))))
|
||||
|
||||
(define (color-number? n)
|
||||
(and (number? n)
|
||||
(<= 0.0 n 1.0)))
|
||||
|
||||
(define (image->bitmap i)
|
||||
(cond
|
||||
[(is-a? i bitmap%)
|
||||
i]
|
||||
[(image:image? i)
|
||||
(define w (max 1 (image:image-width i)))
|
||||
(define h (max 1 (image:image-height i)))
|
||||
(define bm (make-object bitmap% w h #f #t))
|
||||
(define dc (send bm make-dc))
|
||||
(send i draw dc
|
||||
0 0
|
||||
0 0
|
||||
w h
|
||||
0 0
|
||||
#f)
|
||||
bm]
|
||||
[(pict:pict? i)
|
||||
(pict:pict->bitmap i)]
|
||||
[else
|
||||
(error 'image->bitmap "unsupported image type ~v" i)]))
|
||||
|
||||
(define (image->texture-cache-entry i)
|
||||
(texture-cache-get i image->bitmap))
|
||||
|
||||
;; (define (lerp a b v) (+ (* v a) (* (- 1 v) b)))
|
||||
|
||||
(define (draw-gl-face texture [left 0] [top 0] [width 1] [height 1])
|
||||
(define bot (+ top height))
|
||||
(define right (+ left width))
|
||||
(send texture bind-texture)
|
||||
(glBegin GL_QUADS)
|
||||
(glNormal3d 0 0 -1)
|
||||
(glTexCoord2d left top)
|
||||
(glVertex3d 0 0 0)
|
||||
(glTexCoord2d right top)
|
||||
(glVertex3d 1 0 0)
|
||||
(glTexCoord2d right bot)
|
||||
(glVertex3d 1 1 0)
|
||||
(glTexCoord2d left bot)
|
||||
(glVertex3d 0 1 0)
|
||||
(glEnd))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define sprite-order
|
||||
(order 'sprite-order
|
||||
sprite?
|
||||
(lambda (a b) (and (equal? (sprite-id a) (sprite-id b))
|
||||
(= (sprite-z a) (sprite-z b))
|
||||
(eq? (sprite-instructions a)
|
||||
(sprite-instructions b))))
|
||||
(lambda (a b) (or (> (sprite-z a) (sprite-z b))
|
||||
(and (= (sprite-z a) (sprite-z b))
|
||||
(let ((a-id-code (equal-hash-code (sprite-id a)))
|
||||
(b-id-code (equal-hash-code (sprite-id b))))
|
||||
(or (< a-id-code b-id-code)
|
||||
(and (= a-id-code b-id-code)
|
||||
(< (eq-hash-code (sprite-instructions a))
|
||||
(eq-hash-code (sprite-instructions b)))))))))))
|
||||
|
||||
(define (remove-sprite! childmap s)
|
||||
(define sprites (hash-ref childmap (sprite-parent-id s) #f))
|
||||
(when sprites
|
||||
(compiled-instructions-dispose! (splay-tree-ref sprites s #f))
|
||||
(splay-tree-remove! sprites s)
|
||||
(when (dict-empty? sprites) (hash-remove! childmap (sprite-parent-id s)))))
|
||||
|
||||
(define (add-sprite! childmap s)
|
||||
(define sprites (hash-ref childmap (sprite-parent-id s)
|
||||
(lambda ()
|
||||
(define ss (make-splay-tree sprite-order))
|
||||
(hash-set! childmap (sprite-parent-id s) ss)
|
||||
ss)))
|
||||
(define instrs `((color 1 1 1 1)
|
||||
(push-matrix ,@(seal-contents (sprite-instructions s)))))
|
||||
(define i (compile-instructions instrs))
|
||||
(splay-tree-set! sprites s i))
|
||||
|
||||
(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 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)
|
||||
(render-sprites! childmap #f)
|
||||
((compiled-instructions-render-proc postlude) childmap #f))
|
||||
|
||||
(define (detect-touch prelude childmap postlude state)
|
||||
(and state
|
||||
(let ()
|
||||
(define x (mouse-state-x state))
|
||||
(define y (mouse-state-y state))
|
||||
(or (detect-touch* childmap #f postlude x y)
|
||||
(detect-sprites-touch childmap #f x y)
|
||||
(detect-touch* childmap #f prelude x y)))))
|
||||
|
||||
(define (detect-sprites-touch childmap self-id x y)
|
||||
(define sprites (hash-ref childmap self-id #f))
|
||||
(let loop ((iter (and sprites (splay-tree-iterate-greatest sprites))))
|
||||
(and iter
|
||||
(let ((s (splay-tree-iterate-key sprites iter)))
|
||||
(define ci (splay-tree-iterate-value sprites iter))
|
||||
(or (detect-touch* childmap (sprite-id s) ci x y)
|
||||
(loop (splay-tree-iterate-greatest/<? sprites s)))))))
|
||||
|
||||
(define (detect-touch* childmap self-id ci x y)
|
||||
(for/or [(t (in-list (compiled-instructions-touchables ci)))]
|
||||
(match t
|
||||
[(touchable id xform contains?)
|
||||
(define-values (ux uy) (untransform-point* xform x y))
|
||||
(and (contains? ux uy) (touching id))]
|
||||
[(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)])))
|
||||
|
||||
(define (untransform-point* xform x y)
|
||||
(define p (untransform-point xform (make-rectangular x y)))
|
||||
(values (real-part p) (imag-part p)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define dataspace-frame%
|
||||
(class* frame% ()
|
||||
(init ground-ch)
|
||||
(super-new)
|
||||
(define (stop!)
|
||||
(parameterize ((current-ground-event-async-channel ground-ch))
|
||||
(ground-send! (gl-control 'stop))))
|
||||
(define/augment (on-close) (stop!))))
|
||||
|
||||
(define dataspace-canvas%
|
||||
(class canvas%
|
||||
(inherit refresh with-gl-context swap-gl-buffers)
|
||||
|
||||
(init [(eventspace0 eventspace)])
|
||||
(init ground-ch)
|
||||
|
||||
(define eventspace eventspace0)
|
||||
|
||||
(define (! msg)
|
||||
(parameterize ((current-ground-event-async-channel ground-ch))
|
||||
(ground-send! msg)))
|
||||
|
||||
(define (++ assertion)
|
||||
(parameterize ((current-ground-event-async-channel ground-ch))
|
||||
(ground-assert! assertion)))
|
||||
|
||||
(define (-- assertion)
|
||||
(parameterize ((current-ground-event-async-channel ground-ch))
|
||||
(ground-retract! assertion)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define initialised? #f)
|
||||
|
||||
(define near-depth 10) ;; 2.5D
|
||||
(define far-depth 15) ;; 2.5D
|
||||
|
||||
(define prelude empty-instructions)
|
||||
(define childmap (make-hash))
|
||||
(define postlude empty-instructions)
|
||||
|
||||
(define current-window-width #f)
|
||||
(define current-window-height #f)
|
||||
(define current-mouse-state #f)
|
||||
(define current-coordinate-maps (hash))
|
||||
(define current-touching #f)
|
||||
|
||||
(define render-needed? #t)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (mark-dirty!)
|
||||
(when (not render-needed?)
|
||||
(parameterize ((current-eventspace eventspace))
|
||||
(queue-callback (lambda () (refresh)))))
|
||||
(set! render-needed? #t))
|
||||
|
||||
(define/public (replace-scene! new-prelude new-postlude)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(compiled-instructions-dispose! prelude)
|
||||
(compiled-instructions-dispose! postlude)
|
||||
(set! prelude (compile-instructions new-prelude))
|
||||
(set! postlude (compile-instructions new-postlude)))))
|
||||
|
||||
(define/public (alter-sprites! changes)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(for [(change (in-list changes))]
|
||||
(match change
|
||||
[(cons '+ s) (add-sprite! childmap s)]
|
||||
[(cons '- s) (remove-sprite! childmap s)]))
|
||||
(mark-dirty!))))
|
||||
|
||||
(define/public (initialize!)
|
||||
(unless initialised?
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(glBlendFunc GL_ONE GL_ONE_MINUS_SRC_ALPHA) ;; premultiplied
|
||||
(glEnable GL_BLEND)
|
||||
(glEnable GL_TEXTURE_2D)
|
||||
(glClearColor 0 0 0 1)
|
||||
(set! initialised? #t)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define/override (on-paint)
|
||||
(initialize!)
|
||||
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(update-touching!)
|
||||
(update-coordinate-maps!)
|
||||
(flush-texture-cache!)
|
||||
|
||||
(glClear GL_COLOR_BUFFER_BIT)
|
||||
(glLoadIdentity)
|
||||
(glTranslated 0 0 (- near-depth))
|
||||
(render-scene! prelude childmap postlude)
|
||||
(glFlush)
|
||||
(swap-gl-buffers)
|
||||
|
||||
(set! render-needed? #f))))
|
||||
|
||||
(define/override (on-size width height)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(when (not (and (equal? current-window-width width)
|
||||
(equal? current-window-height height)))
|
||||
(-- (window current-window-width current-window-height))
|
||||
(set! current-window-width width)
|
||||
(set! current-window-height height)
|
||||
(++ (window current-window-width current-window-height)))
|
||||
(glViewport 0 0 width height)
|
||||
(glMatrixMode GL_PROJECTION)
|
||||
(glLoadIdentity)
|
||||
(glOrtho 0 width height 0 0.1 100)
|
||||
(glMatrixMode GL_MODELVIEW)
|
||||
(glLoadIdentity)
|
||||
(mark-dirty!))))
|
||||
|
||||
(define/override (on-char key)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(! (match (send key get-key-code)
|
||||
['release (key-event (send key get-key-release-code) #f (seal key))]
|
||||
[code (key-event code #t (seal key))])))))
|
||||
|
||||
(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!)
|
||||
(! (mouse-event (send mouse get-event-type) s)))))
|
||||
|
||||
(define (update-touching!)
|
||||
(define new-touching (detect-touch prelude childmap postlude current-mouse-state))
|
||||
(when (not (equal? current-touching new-touching))
|
||||
(when current-touching (-- current-touching))
|
||||
(set! current-touching new-touching)
|
||||
(when current-touching (++ current-touching))))
|
||||
|
||||
(define (update-coordinate-maps!)
|
||||
(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))
|
||||
(-- existing)
|
||||
(++ proposed)))
|
||||
|
||||
(let process-children-of ((id #f) (xform identity-transformation))
|
||||
(for-each-child-sprite childmap id
|
||||
(lambda (s ci)
|
||||
(for [(cm (in-list (compiled-instructions-coordinate-maps ci)))]
|
||||
(match-define (coordinate-map cmid cmx) cm)
|
||||
(update-single-map! cmid (compose-transformation xform cmx)))
|
||||
(define child-xform (compiled-instructions-child-xform ci))
|
||||
(when child-xform
|
||||
(process-children-of (sprite-id s)
|
||||
(compose-transformation xform
|
||||
child-xform)))))))
|
||||
|
||||
(super-new (style '(gl no-autoclear)))))
|
||||
|
||||
(define (spawn-gl-2d-driver #:label [frame-label "syndicate-gl"]
|
||||
#:width [width #f]
|
||||
#:height [height #f])
|
||||
(spawn #:name 'gl-2d/driver
|
||||
(define frame #f) ;; "frame" here refers to *window frame* onscreen, i.e. GUI, not GL
|
||||
(define c #f)
|
||||
|
||||
(parameterize ((current-eventspace (make-eventspace)))
|
||||
(set! frame (new dataspace-frame%
|
||||
[style '(fullscreen-button)]
|
||||
[label frame-label]
|
||||
[width (or width 640)]
|
||||
[height (or height 480)]
|
||||
[ground-ch (current-ground-event-async-channel)]))
|
||||
(set! c (new dataspace-canvas%
|
||||
[parent frame]
|
||||
[eventspace (current-eventspace)]
|
||||
[ground-ch (current-ground-event-async-channel)]))
|
||||
(unless (send (send (send c get-dc) get-gl-context) ok?)
|
||||
(error 'gl-2d "OpenGL context failed to initialize"))
|
||||
(send c focus)
|
||||
(send frame show #t))
|
||||
|
||||
(define start-time (current-inexact-milliseconds))
|
||||
(define frame-counter 0)
|
||||
(define target-frame-rate 60)
|
||||
(define changes '())
|
||||
(define dirty? #f)
|
||||
|
||||
(field [sim-time 0])
|
||||
|
||||
(on (asserted (later-than (+ (sim-time) start-time)))
|
||||
(define per-frame-ms (* (/ target-frame-rate) 1000.0))
|
||||
(send! (frame-event frame-counter (sim-time) per-frame-ms target-frame-rate))
|
||||
(set! frame-counter (+ frame-counter 1))
|
||||
(sim-time (* frame-counter per-frame-ms))
|
||||
(when dirty?
|
||||
(send c alter-sprites! (reverse changes))
|
||||
(set! changes '())
|
||||
(set! dirty? #f)))
|
||||
|
||||
;; TODO: maybe add a means of setting target frame rate?
|
||||
;; (define/public (set-target-frame-rate! r)
|
||||
;; (set! target-frame-rate r))
|
||||
|
||||
(on (asserted (scene $sealed-prelude $sealed-postlude))
|
||||
(send c replace-scene!
|
||||
(seal-contents sealed-prelude)
|
||||
(seal-contents sealed-postlude))
|
||||
(set! dirty? #t))
|
||||
|
||||
(on (retracted ($ s (sprite _ _ _ _)))
|
||||
(set! changes (cons (cons '- s) changes))
|
||||
(set! dirty? #t))
|
||||
(on (asserted ($ s (sprite _ _ _ _)))
|
||||
(set! changes (cons (cons '+ s) changes))
|
||||
(set! dirty? #t))
|
||||
|
||||
(on (message (gl-control 'stop))
|
||||
(send frame show #f)
|
||||
(stop-current-facet))
|
||||
|
||||
(during (gl-control 'fullscreen)
|
||||
(on-start (send frame fullscreen #t))
|
||||
(on-stop (send frame fullscreen #f)))
|
||||
|
||||
))
|
||||
|
|
@ -0,0 +1,133 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require racket/set)
|
||||
(require 2htdp/image)
|
||||
(require/activate imperative-syndicate/drivers/gl-2d)
|
||||
|
||||
(define (spawn-background)
|
||||
(spawn (during (window $width $height)
|
||||
(assert-scene `((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)
|
||||
)
|
||||
`()))))
|
||||
|
||||
(define (draggable-mixin touching? x y)
|
||||
(define (idle)
|
||||
(react (stop-when #:when (touching?)
|
||||
(message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
|
||||
(log-info "idle -> dragging; in-script? ~v" (in-script?))
|
||||
(dragging (- mx (x)) (- my (y))))))
|
||||
|
||||
(define (dragging dx dy)
|
||||
(react (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
|
||||
(x (- mx dx))
|
||||
(y (- my dy)))
|
||||
(stop-when (message (mouse-event 'left-up _)) (idle))
|
||||
(stop-when (message (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 (touching name) #t)
|
||||
(assert (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?)
|
||||
(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 (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 (touching 'player) #t)
|
||||
(on-start (draggable-mixin touching? x y))
|
||||
|
||||
(on (asserted (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 (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 (simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i)))
|
||||
(on (message (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 (key-event #\q #t _)))
|
||||
(assert! (gl-control 'stop)))
|
||||
|
||||
(spawn (during (touching $id)
|
||||
(on-start (log-info "Touching ~v" id))
|
||||
(on-stop (log-info "No longer touching ~v" id))))
|
||||
|
||||
(spawn-gl-2d-driver)
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
#lang imperative-syndicate
|
||||
;; Multiple animated sprites.
|
||||
;;
|
||||
;; 2018-05-01 With the new "imperative" implementation of Syndicate,
|
||||
;; the same 2.6GHz laptop mentioned below can animate 135 logos in a
|
||||
;; 640x480 window at 60 fps on a single core, with a bit of headroom
|
||||
;; to spare.
|
||||
;;
|
||||
;; 2016-12-12 With the current implementations of (a) Syndicate's
|
||||
;; dataspaces and (b) Syndicate's 2D sprite support, my reasonably new
|
||||
;; 2.6GHz laptop can animate 20 logos at 256x256 pixels at about 20
|
||||
;; frames per second on a single core.
|
||||
;;
|
||||
;; For comparison, Kay recounts in "The Early History of Smalltalk"
|
||||
;; (1993) that "by the Fall of '73 [Steve Purcell] could demo 80
|
||||
;; ping-pong balls and 10 flying horses running at 10 frames per
|
||||
;; second in 2 1/2 D" in an early Smalltalk (?) on a NOVA.
|
||||
|
||||
(require 2htdp/image)
|
||||
(require images/logos)
|
||||
(require/activate imperative-syndicate/drivers/gl-2d)
|
||||
|
||||
(define speed-limit 40)
|
||||
(define sprite-count 135)
|
||||
|
||||
(define (spawn-background)
|
||||
(spawn
|
||||
(during (window $width $height)
|
||||
(assert-scene `((push-matrix (scale ,width ,height)
|
||||
(texture ,(rectangle 1 1 "solid" "white"))))
|
||||
`()))))
|
||||
|
||||
(define i:logo (plt-logo))
|
||||
(define i:logo-width (image-width i:logo))
|
||||
(define i:logo-height (image-height i:logo))
|
||||
|
||||
(define (spawn-logo)
|
||||
(spawn (field [x 100] [y 100])
|
||||
(field [dx (* (- (random) 0.5) speed-limit)]
|
||||
[dy (* (- (random) 0.5) speed-limit)])
|
||||
(define/query-value w #f ($ w (window _ _)) w)
|
||||
(assert (simple-sprite 0
|
||||
(x)
|
||||
(y)
|
||||
i:logo-width
|
||||
i:logo-height
|
||||
i:logo))
|
||||
(define (bounce f df limit)
|
||||
(define v (f))
|
||||
(define limit* (- limit i:logo-width))
|
||||
(cond [(< v 0) (f 0) (df (abs (df)))]
|
||||
[(> v limit*) (f limit*) (df (- (abs (df))))]
|
||||
[else (void)]))
|
||||
(on (message (frame-event _ _ _ _))
|
||||
(when (w) ;; don't animate until we know the window bounds
|
||||
(x (+ (x) (dx)))
|
||||
(y (+ (y) (dy)))
|
||||
(bounce x dx (window-width (w)))
|
||||
(bounce y dy (window-height (w)))))))
|
||||
|
||||
(spawn-background)
|
||||
(for [(i sprite-count)]
|
||||
(spawn-logo))
|
||||
|
||||
(spawn (define start-time #f)
|
||||
(log-info "Sprite count: ~a" sprite-count)
|
||||
(on (message (frame-event $counter $timestamp _ _))
|
||||
(if (eq? start-time #f)
|
||||
(set! start-time (current-inexact-milliseconds))
|
||||
(let ((delta (- (current-inexact-milliseconds) start-time)))
|
||||
(when (and (zero? (modulo counter 100)) (positive? delta))
|
||||
(log-info "~v frames, ~v ms ==> ~v Hz"
|
||||
counter
|
||||
delta
|
||||
(/ counter (/ delta 1000.0))))))))
|
||||
|
||||
(spawn-gl-2d-driver)
|
||||
|
||||
(spawn (field [fullscreen? #f])
|
||||
(on (message (key-event #\f #t _)) (fullscreen? (not (fullscreen?))))
|
||||
(assert #:when (fullscreen?) (gl-control 'fullscreen))
|
||||
|
||||
(on (message (key-event #\q #t _))
|
||||
(send! (gl-control 'stop))))
|
||||
Loading…
Reference in New Issue