536 lines
20 KiB
Racket
536 lines
20 KiB
Racket
#lang racket/gui
|
|
|
|
(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 scene)
|
|
(except-out (struct-out sprite) sprite)
|
|
(rename-out [sprite <sprite>] [make-sprite sprite])
|
|
(struct-out request-gc)
|
|
in-unit-circle?
|
|
in-unit-square?
|
|
simple-sprite
|
|
update-scene
|
|
update-sprites
|
|
spawn-keyboard-integrator
|
|
spawn-mouse-integrator
|
|
2d-dataspace)
|
|
|
|
(require data/order)
|
|
(require data/splay-tree)
|
|
(require data/queue)
|
|
(require sgl/gl)
|
|
(require sgl/gl-vectors)
|
|
|
|
(require (prefix-in image: 2htdp/image))
|
|
(require (prefix-in pict: pict))
|
|
|
|
(require syndicate)
|
|
(require syndicate/trie)
|
|
(require syndicate/ground)
|
|
|
|
(require "texture.rkt")
|
|
(require "affine.rkt")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Shared state maintained by dataspace. Describes current window dimensions.
|
|
(struct window (width height) #:transparent)
|
|
|
|
;; Message sent by dataspace. Describes frame about to be rendered.
|
|
(struct frame-event (counter timestamp elapsed-ms target-frame-rate) #:transparent)
|
|
|
|
;; 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.
|
|
(struct key-event (code press? key) #:transparent)
|
|
|
|
;; Assertion. Indicates that the named key is held down. See role
|
|
;; 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.
|
|
(struct scene (prelude postlude) #:transparent)
|
|
|
|
;; Shared state maintained by program. Z is to be a number, negative
|
|
;; toward camera. Instructions to be a sealed instruction list.
|
|
(struct sprite (z instructions) #:transparent)
|
|
|
|
;; Message. Requests that the OpenGL loop perform a major
|
|
;; garbage-collection while *pausing the simulation's real-time
|
|
;; correspondence*. This lets a GC take place without such severe
|
|
;; simulation glitches as happen when doing it in-world.
|
|
(struct request-gc () #:transparent)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (update-scene prelude postlude #:meta-level [meta-level 1])
|
|
(patch-seq (retract (outbound* meta-level (scene ? ?)))
|
|
(assert (outbound* meta-level (scene (seal prelude) (seal postlude))))))
|
|
|
|
(define (make-sprite z instructions)
|
|
(sprite 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
|
|
#:touchable-id [touchable-id #f]
|
|
#:touchable-predicate [touchable-predicate in-unit-square?])
|
|
(make-sprite z `((translate ,x ,y)
|
|
(scale ,w ,h)
|
|
,@(if touchable-id
|
|
`((touchable ,touchable-id ,touchable-predicate))
|
|
`())
|
|
(texture ,i))))
|
|
|
|
(define (update-sprites #:meta-level [meta-level 1] . ss)
|
|
(patch-seq* (cons (retract (outbound* meta-level (sprite ? ?)))
|
|
(map (lambda (s) (assert (outbound* meta-level s))) ss))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; KeyboardIntegrator. Integrates key-events into key-pressed assertions.
|
|
(define (spawn-keyboard-integrator #:meta-level [meta-level 1])
|
|
(spawn (lambda (e s)
|
|
(match e
|
|
[(message (inbound* meta-level (key-event code press? _)))
|
|
(transition (void) ((if press? assert retract) (key-pressed code)))]
|
|
[#f #f]))
|
|
(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 ? ?)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; (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 touchables resources xform)
|
|
(instruction->racket-code `(begin ,@instrs) identity-transformation))
|
|
(define render-thunk (eval `(lambda () ,code) ns))
|
|
(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 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)]
|
|
[`(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)]
|
|
[other
|
|
(error 'instruction->racket-code "unknown render instruction: ~v" other)]))
|
|
|
|
(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)
|
|
(send texture bind-texture)
|
|
(glBegin GL_QUADS)
|
|
(glNormal3d 0 0 -1)
|
|
(glTexCoord2i 0 0)
|
|
(glVertex3d 0 0 0)
|
|
(glTexCoord2i 1 0)
|
|
(glVertex3d 1 0 0)
|
|
(glTexCoord2i 1 1)
|
|
(glVertex3d 1 1 0)
|
|
(glTexCoord2i 0 1)
|
|
(glVertex3d 0 1 0)
|
|
(glEnd))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define empty-instructions (compile-instructions '()))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define scene-projection (?! (scene ? ?)))
|
|
(define sprite-projection (?! (sprite ? ?)))
|
|
|
|
(define sprite-order
|
|
(order 'sprite-order
|
|
sprite?
|
|
(lambda (a b) (and (= (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))
|
|
(< (eq-hash-code (sprite-instructions a))
|
|
(eq-hash-code (sprite-instructions b))))))))
|
|
|
|
(define (remove-sprite! sprites s)
|
|
(compiled-instructions-dispose! (splay-tree-ref sprites s #f))
|
|
(splay-tree-remove! sprites s))
|
|
|
|
(define (add-sprite! sprites s)
|
|
(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 (render-scene! prelude sprites postlude)
|
|
((compiled-instructions-render-thunk prelude))
|
|
(let loop ((iter (splay-tree-iterate-first sprites)))
|
|
(when iter
|
|
((compiled-instructions-render-thunk (splay-tree-iterate-value sprites iter)))
|
|
(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 (untransform-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%
|
|
(class canvas%
|
|
(inherit refresh with-gl-context swap-gl-buffers)
|
|
|
|
(init boot-actions)
|
|
|
|
(define counter 0)
|
|
(define start-time (current-inexact-milliseconds))
|
|
(define prev-frame-time start-time)
|
|
(define/public (sim-time)
|
|
(- (current-inexact-milliseconds) start-time))
|
|
|
|
(define initialised? #f)
|
|
|
|
(define near-depth 10) ;; 2.5D
|
|
(define far-depth 15) ;; 2.5D
|
|
|
|
(define prelude empty-instructions)
|
|
(define sprites (make-splay-tree sprite-order))
|
|
(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))
|
|
|
|
(define target-frame-rate 60)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (sleep-and-refresh)
|
|
(define target-sim-time (* counter (/ target-frame-rate)))
|
|
(define sleep-time (- target-sim-time (/ (sim-time) 1000.0)))
|
|
(when (positive? sleep-time)
|
|
(sleep/yield sleep-time))
|
|
(refresh))
|
|
|
|
(define/public (set-target-frame-rate! r)
|
|
(set! target-frame-rate r))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (inject-event! e)
|
|
(enqueue! event-queue e))
|
|
|
|
(define (deliver-event e)
|
|
(clean-transition ((process-behavior proc) e (process-state proc))))
|
|
|
|
(define (quiesce!)
|
|
(define txn pending-transition)
|
|
(set! pending-transition #f)
|
|
(process-transition txn #t))
|
|
|
|
(define (process-transition txn need-poll?)
|
|
(match txn
|
|
[#f ;; inert
|
|
(if (queue-empty? event-queue)
|
|
(when need-poll? (process-transition (deliver-event #f) #f))
|
|
(process-transition (deliver-event (dequeue! event-queue)) #t))]
|
|
[(transition new-state actions)
|
|
(set! proc (update-process-state proc new-state))
|
|
(for-each process-action! actions)
|
|
(process-transition #f #t)]))
|
|
|
|
(define (process-action! a)
|
|
(match a
|
|
[(? patch? p)
|
|
(process-scene-updates! p)
|
|
(process-sprite-updates! p)
|
|
(process-stop-requests! p)
|
|
(process-fullscreen-requests! p)]
|
|
[(message (request-gc))
|
|
(perform-gc-request!)]
|
|
[(message _) (void)]))
|
|
|
|
(define (process-scene-updates! p)
|
|
(define-values (added removed) (patch-project/set/single p scene-projection))
|
|
(when (not (set-empty? removed))
|
|
(compiled-instructions-dispose! prelude)
|
|
(compiled-instructions-dispose! postlude)
|
|
(set! prelude empty-instructions)
|
|
(set! postlude empty-instructions))
|
|
(for [(s added)]
|
|
(match-define (scene (seal pre) (seal post)) s)
|
|
(set! prelude (compile-instructions pre))
|
|
(set! postlude (compile-instructions post))))
|
|
|
|
(define (process-sprite-updates! p)
|
|
(define-values (added removed) (patch-project/set/single p sprite-projection))
|
|
;; Remove old sprites first, to recycle their texture identifiers (if any)
|
|
(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)
|
|
(when (trie-lookup (patch-added p) 'stop #f)
|
|
(send (send this get-top-level-window) show #f)))
|
|
|
|
(define (process-fullscreen-requests! p)
|
|
(define changed? #f)
|
|
(when (trie-lookup (patch-removed p) 'fullscreen #f)
|
|
(set! changed? #t)
|
|
(set! fullscreen? #f))
|
|
(when (trie-lookup (patch-added p) 'fullscreen #f)
|
|
(set! changed? #t)
|
|
(set! fullscreen? #t))
|
|
(when changed?
|
|
(send (send this get-top-level-window) fullscreen fullscreen?)))
|
|
|
|
(define (perform-gc-request!)
|
|
(define pre-gc (current-inexact-milliseconds))
|
|
(collect-garbage 'major)
|
|
(define post-gc (current-inexact-milliseconds))
|
|
(define delta (- post-gc pre-gc))
|
|
(log-info "(request-gc) took ~a milliseconds" delta)
|
|
(set! start-time (+ start-time delta)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/override (on-paint)
|
|
(with-gl-context
|
|
(lambda ()
|
|
(let* ((this-frame-time (sim-time))
|
|
(elapsed-ms (- this-frame-time prev-frame-time)))
|
|
(when (not (negative? elapsed-ms))
|
|
(inject-event! (message
|
|
(frame-event counter this-frame-time elapsed-ms target-frame-rate)))
|
|
(set! counter (+ counter 1)))
|
|
(set! prev-frame-time this-frame-time))
|
|
(quiesce!)
|
|
(unless initialised?
|
|
(glBlendFunc GL_ONE GL_ONE_MINUS_SRC_ALPHA) ;; premultiplied
|
|
(glEnable GL_BLEND)
|
|
(glEnable GL_TEXTURE_2D)
|
|
(glClearColor 0 0 0 1)
|
|
(set! initialised? #t))
|
|
(glClear GL_COLOR_BUFFER_BIT)
|
|
(glLoadIdentity)
|
|
(glTranslated 0 0 (- near-depth))
|
|
(render-scene! prelude sprites postlude)
|
|
(glFlush)
|
|
(swap-gl-buffers)))
|
|
(queue-callback (lambda () (sleep-and-refresh)) #f))
|
|
|
|
(define/override (on-size width height)
|
|
(with-gl-context
|
|
(lambda ()
|
|
(inject-event! (patch-seq (retract (window ? ?))
|
|
(assert (window width height))))
|
|
(quiesce!)
|
|
(glViewport 0 0 width height)
|
|
(glMatrixMode GL_PROJECTION)
|
|
(glLoadIdentity)
|
|
(glOrtho 0 width height 0 0.1 100)
|
|
(glMatrixMode GL_MODELVIEW)
|
|
(glLoadIdentity)))
|
|
(refresh))
|
|
|
|
(define/override (on-char key)
|
|
(with-gl-context
|
|
(lambda ()
|
|
(inject-event!
|
|
(message
|
|
(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))])))
|
|
(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"]
|
|
#:width [width #f]
|
|
#:height [height #f]
|
|
#:exit? [exit? #t])
|
|
. boot-actions)
|
|
(collect-garbage 'incremental)
|
|
(collect-garbage 'major)
|
|
(define frame (new frame%
|
|
[style '(fullscreen-button)]
|
|
[label frame-label]
|
|
[width (or width 640)]
|
|
[height (or height 480)]))
|
|
(define c (new dataspace-canvas%
|
|
[parent frame]
|
|
[boot-actions boot-actions]))
|
|
(unless (send (send (send c get-dc) get-gl-context) ok?)
|
|
(error '2d-dataspace "OpenGL context failed to initialize"))
|
|
(send c focus)
|
|
(send frame show #t)
|
|
(yield 'wait)
|
|
(when exit? (exit 0)))
|