From b94e6113b078a14e579055074f8dbbcbbca0b9af Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 8 Sep 2015 20:11:16 -0400 Subject: [PATCH 01/27] Initial commit --- .gitignore | 1 + prospect-gl/2d.rkt | 336 +++++++++++++++++++++++++++++++++ prospect-gl/examples/basic.rkt | 41 ++++ prospect-gl/texture.rkt | 49 +++++ 4 files changed, 427 insertions(+) create mode 100644 .gitignore create mode 100644 prospect-gl/2d.rkt create mode 100644 prospect-gl/examples/basic.rkt create mode 100644 prospect-gl/texture.rkt diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..724bbe1 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +compiled/ diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt new file mode 100644 index 0000000..02707c2 --- /dev/null +++ b/prospect-gl/2d.rkt @@ -0,0 +1,336 @@ +#lang racket/gui + +(provide (struct-out window) + (struct-out frame-event) + (struct-out key-event) + (struct-out scene) + (except-out (struct-out sprite) sprite) + (rename-out [sprite ] [make-sprite sprite]) + update-scene + update-sprites + 2d-world) + +(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 prospect) +(require prospect/route) +(require prospect/ground) + +(require "texture.rkt") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Shared state maintained by world. Describes current window dimensions. +(struct window (width height) #:transparent) + +;; Message sent by world. Describes frame about to be rendered. +(struct frame-event (counter timestamp) #:transparent) + +;; Message sent by world. Describes a key event. Key is a sealed +;; key-event%. +(struct key-event (code key) #: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) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (update-scene prelude postlude) + (patch-seq (retract (scene ? ?) #:meta-level 1) + (assert (scene (seal prelude) (seal postlude)) #:meta-level 1))) + +(define (make-sprite z instructions) + (sprite z (seal instructions))) + +(define (update-sprites . ss) + (patch-seq* (cons (retract (sprite ? ?) #:meta-level 1) + (map (lambda (s) (assert s #:meta-level 1)) ss)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(struct compiled-instructions (render-thunk resources)) + +(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 render-thunk (eval `(lambda () ,code) ns)) + (compiled-instructions render-thunk resources)) + +(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 (color-number? n) + (and (number? n) + (<= 0.0 n 1.0))) + +(define (instruction->racket-code instr) + (match instr + [`(rotate ,(? number? deg)) + (values `(glRotated ,deg) '())] + [`(scale ,(? number? x) ,(? number? y)) + (values `(glScaled ,x ,y 1) '())] + [`(translate ,(? number? x) ,(? number? y)) + (values `(glTranslated ,x ,y 0) '())] + [`(color ,(? color-number? r) ,(? color-number? g) ,(? color-number? b) ,(? color-number? a)) + (values `(glColor4d ,r ,g ,b ,a) '())] + [`(texture ,i) + (define tex (image->texture i)) + (values `(draw-gl-face ,tex) (list tex))] + [`(push-matrix ,instr ...) + (define-values (code resources) (instructions->racket-code instr)) + (values `(begin (glPushMatrix) ,@code (glPopMatrix)) resources)] + [`(begin ,instr ...) + (define-values (code resources) (instructions->racket-code instr)) + (values `(begin ,@code (void)) resources)] + [other + (error 'instruction->racket-code "unknown render instruction: ~v" other)])) + +(define (image->bitmap i) + (cond + [(image:image? i) + (define w (image:image-width i)) + (define h (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)] + [(is-a? i bitmap%) + i] + [else + (error 'image->bitmap "unsupported image type ~v" i)])) + +(define (image->texture i) + (define bm (image->bitmap i)) + (new texture% [bitmap bm])) + +;; (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 (compile-projection (?! (scene ? ?)))) +(define sprite-projection (compile-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 world-canvas% + (class canvas% + (inherit refresh with-gl-context swap-gl-buffers) + + (init boot-actions) + + (define counter 0) + (define start-time (current-inexact-milliseconds)) + (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 world (make-world boot-actions)) + (define event-queue (make-queue)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (inject-event! e) + (enqueue! event-queue e)) + + (define (deliver-event e) + (clean-transition (world-handle-event e world))) + + (define (quiesce!) + (let loop ((txn #f) (need-poll? #t)) + (match txn + [#f ;; inert + (if (queue-empty? event-queue) + (when need-poll? (loop (deliver-event #f) #f)) + (loop (deliver-event (dequeue! event-queue)) #t))] + [(transition new-world actions) + (set! world new-world) + (for-each process-action! actions) + (loop #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 body) (void)])) + + (define (process-scene-updates! p) + (define-values (added removed) (patch-project/set/single p scene-projection)) + (when (not (set-empty? removed)) + (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! post (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))) + + (define (process-stop-requests! p) + (when (matcher-match-value (patch-added p) 'stop #f) + (send (send this get-top-level-window) show #f))) + + (define (process-fullscreen-requests! p) + (define changed? #f) + (when (matcher-match-value (patch-removed p) 'fullscreen #f) + (set! changed? #t) + (set! fullscreen? #f)) + (when (matcher-match-value (patch-added p) 'fullscreen #f) + (set! changed? #t) + (set! fullscreen? #t)) + (when changed? + (send (send this get-top-level-window) fullscreen fullscreen?))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define/override (on-paint) + (with-gl-context + (lambda () + (inject-event! (message (frame-event counter (sim-time)))) + (set! counter (+ counter 1)) + (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 () (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 (key-event (send key get-key-code) (seal key)))) + (quiesce!)))) + + (super-new (style '(gl no-autoclear))))) + +(define (2d-world #:width [width #f] + #:height [height #f] + . boot-actions) + (define frame (new frame% + [style '(fullscreen-button)] + [label "prospect-gl"] + [width (or width 640)] + [height (or height 480)])) + (define c (new world-canvas% + [parent frame] + [boot-actions boot-actions])) + (unless (send (send (send c get-dc) get-gl-context) ok?) + (error '2d-world "OpenGL context failed to initialize")) + (send c focus) + (send frame show #t) + (yield 'wait)) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt new file mode 100644 index 0000000..dcbf819 --- /dev/null +++ b/prospect-gl/examples/basic.rkt @@ -0,0 +1,41 @@ +#lang racket + +(require prospect) +(require 2htdp/image) +(require "../2d.rkt") + +(define window-projection (compile-projection (at-meta (?! (window ? ?))))) + +(2d-world (spawn (lambda (e s) + (match e + [(? patch? p) + (define-values (added removed) (patch-project/set/single p window-projection)) + (transition s (for/list [(w added)] + (match-define (window width height) w) + (update-scene `((push-matrix (scale ,width ,height) + (texture ,(rectangle 1 1 "solid" "white")))) + `())))] + [_ #f])) + (void) + (sub (window ? ?) #:meta-level 1) + ;; (assert 'fullscreen #:meta-level 1) + ) + (spawn (lambda (e s) #f) + (void) + (update-sprites (sprite 0 `((translate 50 50) + (scale 50 50) + (texture ,(circle 50 "solid" "orange")) + )) + (sprite -1 `((translate 60 60) + (scale 50 50) + (texture ,(circle 50 "solid" "green")) + )))) + (spawn (lambda (e s) + (match e + [(message _) + (transition s (assert 'stop #:meta-level 1))] + [_ #f])) + (void) + (sub (key-event #\q ?) #:meta-level 1)) + ) +(exit 0) diff --git a/prospect-gl/texture.rkt b/prospect-gl/texture.rkt new file mode 100644 index 0000000..d733332 --- /dev/null +++ b/prospect-gl/texture.rkt @@ -0,0 +1,49 @@ +#lang racket/gui + +(provide texture%) + +(require sgl/gl) +(require sgl/gl-vectors) + +(define texture% + (class object% + (init [(initial-bitmap bitmap)]) + (field [width 0] + [height 0] + [textures #f]) + + (define/public (get-width) width) + (define/public (get-height) height) + + (define/public (bind-texture) + (when (not textures) (error 'bind-texture "Attempt to use disposed texture%")) + (glBindTexture GL_TEXTURE_2D (gl-vector-ref textures 0))) + + (define/public (load-from-bitmap! bitmap) + (when textures (dispose)) + (set! textures (glGenTextures 1)) + (bind-texture) + (define image-data + (let () + (set! width (send bitmap get-width)) + (set! height (send bitmap get-height)) + (define dc (new bitmap-dc% [bitmap bitmap])) + (define pixels (* width height)) + (define vec (make-gl-ubyte-vector (* pixels 4))) + (define data (make-bytes (* pixels 4))) + (send dc get-argb-pixels 0 0 width height data #f #t) ;; premultiplied + (for ((i (in-range pixels))) + (for ((j (in-range 4))) + (gl-vector-set! vec (+ (* i 4) j) (bytes-ref data (+ (* i 4) (- 3 j)))))) + vec)) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR) + (glTexImage2D GL_TEXTURE_2D 0 4 width height 0 GL_BGRA GL_UNSIGNED_BYTE image-data)) + + (define/public (dispose) + (when textures + (glDeleteTextures textures) + (set! textures #f))) + + (super-new) + (load-from-bitmap! initial-bitmap))) From 7f06f3ceee46313542d2c132bd203ba0b4ee200a Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 8 Sep 2015 20:15:52 -0400 Subject: [PATCH 02/27] simple-sprite --- prospect-gl/2d.rkt | 6 ++++++ prospect-gl/examples/basic.rkt | 10 ++-------- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 02707c2..e33f84d 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -6,6 +6,7 @@ (struct-out scene) (except-out (struct-out sprite) sprite) (rename-out [sprite ] [make-sprite sprite]) + simple-sprite update-scene update-sprites 2d-world) @@ -55,6 +56,11 @@ (define (make-sprite z instructions) (sprite z (seal instructions))) +(define (simple-sprite z x y w h i) + (make-sprite z `((translate ,x ,y) + (scale ,w ,h) + (texture ,i)))) + (define (update-sprites . ss) (patch-seq* (cons (retract (sprite ? ?) #:meta-level 1) (map (lambda (s) (assert s #:meta-level 1)) ss)))) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index dcbf819..0eec63e 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -22,14 +22,8 @@ ) (spawn (lambda (e s) #f) (void) - (update-sprites (sprite 0 `((translate 50 50) - (scale 50 50) - (texture ,(circle 50 "solid" "orange")) - )) - (sprite -1 `((translate 60 60) - (scale 50 50) - (texture ,(circle 50 "solid" "green")) - )))) + (update-sprites (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange")) + (simple-sprite -1 60 60 50 50 (circle 50 "solid" "green")))) (spawn (lambda (e s) (match e [(message _) From 6bd6eecf0e95a3424a2c5b29d87b99a83a36e3a9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 8 Sep 2015 20:23:02 -0400 Subject: [PATCH 03/27] Keyboard-controlled sprite --- prospect-gl/examples/basic.rkt | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index 0eec63e..7ae763e 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -20,6 +20,20 @@ (sub (window ? ?) #:meta-level 1) ;; (assert 'fullscreen #:meta-level 1) ) + (let ((move-to (lambda (x y) + (transition (list x y) + (update-sprites (simple-sprite 0 x y 10 10 (rectangle 1 1 "solid" "blue"))))))) + (spawn (lambda (e s) + (match-define (list x y) s) + (match e + [(message (at-meta (key-event 'left _))) (move-to (- x 2) y)] + [(message (at-meta (key-event 'right _))) (move-to (+ x 2) y)] + [(message (at-meta (key-event 'up _))) (move-to x (- y 2))] + [(message (at-meta (key-event 'down _))) (move-to x (+ y 2))] + [_ #f])) + (list 100 100) + (update-sprites (simple-sprite -0.5 100 100 10 10 (rectangle 1 1 "solid" "blue"))) + (sub (key-event ? ?) #:meta-level 1))) (spawn (lambda (e s) #f) (void) (update-sprites (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange")) From 14bd1f282d13e39914997619e976d7becd66abae Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 8 Sep 2015 20:25:55 -0400 Subject: [PATCH 04/27] Fix glRotated call --- prospect-gl/2d.rkt | 2 +- prospect-gl/examples/basic.rkt | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index e33f84d..97e1de3 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -96,7 +96,7 @@ (define (instruction->racket-code instr) (match instr [`(rotate ,(? number? deg)) - (values `(glRotated ,deg) '())] + (values `(glRotated ,deg 0 0 -1) '())] [`(scale ,(? number? x) ,(? number? y)) (values `(glScaled ,x ,y 1) '())] [`(translate ,(? number? x) ,(? number? y)) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index 7ae763e..1930590 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -13,7 +13,10 @@ (transition s (for/list [(w added)] (match-define (window width height) w) (update-scene `((push-matrix (scale ,width ,height) - (texture ,(rectangle 1 1 "solid" "white")))) + (texture ,(rectangle 1 1 "solid" "white"))) + ;; (rotate -30) + ;; (scale 5 5) + ) `())))] [_ #f])) (void) From c7ae3c64d3ada048f0096ed2ba403d14702119e4 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 9 Sep 2015 11:03:30 -0400 Subject: [PATCH 05/27] FPS meter --- prospect-gl/examples/basic.rkt | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index 1930590..c5ea99b 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -41,6 +41,18 @@ (void) (update-sprites (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange")) (simple-sprite -1 60 60 50 50 (circle 50 "solid" "green")))) + (spawn (lambda (e s) + (match e + [(message (at-meta (frame-event counter elapsed-ms))) + (and (> elapsed-ms 0) + (let ((i (text (format "~a fps" (/ counter (/ elapsed-ms 1000.0))) 22 "black"))) + (transition s (update-sprites (simple-sprite -10 300 10 + (image-width i) + (image-height i) + i)))))] + [_ #f])) + (void) + (sub (frame-event ? ?) #:meta-level 1)) (spawn (lambda (e s) (match e [(message _) From 112c33302ef1854e2cc714795a79f3ae0362cb44 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 9 Sep 2015 11:44:42 -0400 Subject: [PATCH 06/27] 'gradient' --- prospect-gl/examples/basic.rkt | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index c5ea99b..20ac1d6 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -12,8 +12,12 @@ (define-values (added removed) (patch-project/set/single p window-projection)) (transition s (for/list [(w added)] (match-define (window width height) w) - (update-scene `((push-matrix (scale ,width ,height) - (texture ,(rectangle 1 1 "solid" "white"))) + (update-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) ) From c8642c255792dd6755ff4d231ced3a984c2b1869 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 22 Oct 2015 19:47:31 -0400 Subject: [PATCH 07/27] Better key press/release handling --- prospect-gl/2d.rkt | 15 +++++--- prospect-gl/examples/basic.rkt | 62 +++++++++++++++++++++++++++------- 2 files changed, 59 insertions(+), 18 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 97e1de3..41d8563 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -35,8 +35,9 @@ (struct frame-event (counter timestamp) #:transparent) ;; Message sent by world. Describes a key event. Key is a sealed -;; key-event%. -(struct key-event (code key) #:transparent) +;; 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) ;; Shared state maintained by program. Prelude and postlude are to be ;; sealed instruction lists. It is an error to have more than exactly @@ -117,6 +118,8 @@ (define (image->bitmap i) (cond + [(is-a? i bitmap%) + i] [(image:image? i) (define w (image:image-width i)) (define h (image:image-height i)) @@ -131,8 +134,6 @@ bm] [(pict:pict? i) (pict:pict->bitmap i)] - [(is-a? i bitmap%) - i] [else (error 'image->bitmap "unsupported image type ~v" i)])) @@ -319,7 +320,11 @@ (define/override (on-char key) (with-gl-context (lambda () - (inject-event! (message (key-event (send key get-key-code) (seal key)))) + (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!)))) (super-new (style '(gl no-autoclear))))) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index 20ac1d6..62e3c37 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -4,7 +4,14 @@ (require 2htdp/image) (require "../2d.rkt") +;; This little dance is because of https://github.com/racket/racket/issues/1099 +(require (rename-in 2htdp/planetcute [character-cat-girl character-cat-girl*])) +(define CC character-cat-girl*) + +(struct key-pressed (code) #:transparent) + (define window-projection (compile-projection (at-meta (?! (window ? ?))))) +(define key-pressed-projection (compile-projection (key-pressed (?!)))) (2d-world (spawn (lambda (e s) (match e @@ -27,25 +34,54 @@ (sub (window ? ?) #:meta-level 1) ;; (assert 'fullscreen #:meta-level 1) ) - (let ((move-to (lambda (x y) - (transition (list x y) - (update-sprites (simple-sprite 0 x y 10 10 (rectangle 1 1 "solid" "blue"))))))) + (spawn (lambda (e s) + (match e + [(message (at-meta (key-event code press? _))) + (transition (void) ((if press? assert retract) (key-pressed code)))] + [#f #f])) + (void) + (sub (key-event ? ? ?) #:meta-level 1)) + (let ((move-to (lambda (x y keys-down) + (transition (list x y keys-down) + (update-sprites + (simple-sprite 0 + x + y + (image-width CC) + (image-height CC) + CC)))))) (spawn (lambda (e s) - (match-define (list x y) s) + (match-define (list x y keys-down) s) (match e - [(message (at-meta (key-event 'left _))) (move-to (- x 2) y)] - [(message (at-meta (key-event 'right _))) (move-to (+ x 2) y)] - [(message (at-meta (key-event 'up _))) (move-to x (- y 2))] - [(message (at-meta (key-event 'down _))) (move-to x (+ y 2))] + [(? patch? p) + (define-values (added removed) + (patch-project/set/single p key-pressed-projection)) + (define new-keys-down (set-subtract (set-union keys-down added) removed)) + (transition (list x y new-keys-down) '())] + [(message (at-meta (frame-event _ _))) + (define-values (old-x old-y) (values x y)) + (define speed 6) + (let* ((x (if (set-member? keys-down 'left) (- x speed) x)) + (x (if (set-member? keys-down 'right) (+ x speed) x)) + (y (if (set-member? keys-down 'up) (- y speed) y)) + (y (if (set-member? keys-down 'down) (+ y speed) y))) + (and (not (and (= x old-x) (= y old-y))) + (move-to x y keys-down)))] [_ #f])) - (list 100 100) - (update-sprites (simple-sprite -0.5 100 100 10 10 (rectangle 1 1 "solid" "blue"))) - (sub (key-event ? ?) #:meta-level 1))) + (list 100 100 (set)) + (update-sprites (simple-sprite -0.5 + 100 + 100 + (image-width CC) + (image-height CC) + CC)) + (sub (frame-event ? ?) #:meta-level 1) + (sub (key-pressed ?)))) (spawn (lambda (e s) #f) (void) (update-sprites (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange")) (simple-sprite -1 60 60 50 50 (circle 50 "solid" "green")))) - (spawn (lambda (e s) + #;(spawn (lambda (e s) (match e [(message (at-meta (frame-event counter elapsed-ms))) (and (> elapsed-ms 0) @@ -63,6 +99,6 @@ (transition s (assert 'stop #:meta-level 1))] [_ #f])) (void) - (sub (key-event #\q ?) #:meta-level 1)) + (sub (key-event #\q #t ?) #:meta-level 1)) ) (exit 0) From 8875fd2351687ef4974dc6ca182ecb8a9895d1b8 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 23 Oct 2015 11:24:19 -0400 Subject: [PATCH 08/27] TODO --- TODO.md | 1 + 1 file changed, 1 insertion(+) create mode 100644 TODO.md diff --git a/TODO.md b/TODO.md new file mode 100644 index 0000000..ce68e12 --- /dev/null +++ b/TODO.md @@ -0,0 +1 @@ + - Some way of clamping the frame rate to e.g. 60Hz and failing that 24Hz From f81d727bd94a1a727452406872e53451f61d3182 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 23 Oct 2015 11:29:33 -0400 Subject: [PATCH 09/27] Package infrastructure --- .gitignore | 1 + Makefile | 44 ++++++++++++++++++++++++++++++++++++++++++++ info.rkt | 10 ++++++++++ 3 files changed, 55 insertions(+) create mode 100644 Makefile create mode 100644 info.rkt diff --git a/.gitignore b/.gitignore index 724bbe1..b20942e 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,2 @@ compiled/ +scratch/ diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..4ae2ce0 --- /dev/null +++ b/Makefile @@ -0,0 +1,44 @@ +PACKAGENAME=prospect-gl +MAINCOLLECT=prospect-gl +COLLECTS=$(MAINCOLLECT) + +all: setup + +clean: + find . -name compiled -type d | xargs rm -rf + rm -rf htmldocs + +setup: + raco setup $(COLLECTS) + +link: + raco pkg install --link -n $(PACKAGENAME) $$(pwd) + +unlink: + raco pkg remove $(PACKAGENAME) + +htmldocs: + raco scribble \ + --html \ + --dest htmldocs \ + --dest-name index \ + ++main-xref-in \ + --redirect-main http://docs.racket-lang.org/ \ + \ + $(MAINCOLLECT)/scribblings/$(MAINCOLLECT).scrbl + +pages: + @(git branch -v | grep -q gh-pages || (echo local gh-pages branch missing; false)) + @echo + @git branch -av | grep gh-pages + @echo + @(echo 'Is the branch up to date? Press enter to continue.'; read dummy) + git clone -b gh-pages . pages + +publish: htmldocs pages + rm -rf pages/* + cp -r htmldocs/. pages/. + (cd pages; git add -A) + -(cd pages; git commit -m "Update $$(date +%Y%m%d%H%M%S)") + (cd pages; git push) + rm -rf pages diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..e177f42 --- /dev/null +++ b/info.rkt @@ -0,0 +1,10 @@ +#lang setup/infotab +(define collection 'multi) +(define deps '("prospect" + "base" + "data-lib" + "gui-lib" + "htdp-lib" + "pict-lib" + "sgl" + )) From a6d857fe83a712df54d6120e00cdb881e3ba0998 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 23 Oct 2015 11:38:45 -0400 Subject: [PATCH 10/27] Factor out KeyboardIntegrator and clean up basic.rkt --- prospect-gl/2d.rkt | 18 ++++ prospect-gl/examples/basic.rkt | 155 ++++++++++++++++----------------- 2 files changed, 91 insertions(+), 82 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 41d8563..46dca0d 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -3,12 +3,14 @@ (provide (struct-out window) (struct-out frame-event) (struct-out key-event) + (struct-out key-pressed) (struct-out scene) (except-out (struct-out sprite) sprite) (rename-out [sprite ] [make-sprite sprite]) simple-sprite update-scene update-sprites + spawn-keyboard-integrator 2d-world) (require data/order) @@ -39,6 +41,10 @@ ;; 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) + ;; 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. @@ -68,6 +74,18 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; KeyboardIntegrator. Integrates key-events into key-pressed assertions. +(define (spawn-keyboard-integrator) + (spawn (lambda (e s) + (match e + [(message (at-meta (key-event code press? _))) + (transition (void) ((if press? assert retract) (key-pressed code)))] + [#f #f])) + (void) + (sub (key-event ? ? ?) #:meta-level 1))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (struct compiled-instructions (render-thunk resources)) (define-namespace-anchor ns-anchor) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index 62e3c37..c381345 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -4,95 +4,86 @@ (require 2htdp/image) (require "../2d.rkt") -;; This little dance is because of https://github.com/racket/racket/issues/1099 -(require (rename-in 2htdp/planetcute [character-cat-girl character-cat-girl*])) -(define CC character-cat-girl*) - -(struct key-pressed (code) #:transparent) - (define window-projection (compile-projection (at-meta (?! (window ? ?))))) (define key-pressed-projection (compile-projection (key-pressed (?!)))) -(2d-world (spawn (lambda (e s) - (match e - [(? patch? p) - (define-values (added removed) (patch-project/set/single p window-projection)) - (transition s (for/list [(w added)] - (match-define (window width height) w) - (update-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) - ) - `())))] - [_ #f])) - (void) - (sub (window ? ?) #:meta-level 1) - ;; (assert 'fullscreen #:meta-level 1) - ) - (spawn (lambda (e s) - (match e - [(message (at-meta (key-event code press? _))) - (transition (void) ((if press? assert retract) (key-pressed code)))] - [#f #f])) - (void) - (sub (key-event ? ? ?) #:meta-level 1)) - (let ((move-to (lambda (x y keys-down) - (transition (list x y keys-down) - (update-sprites - (simple-sprite 0 - x - y - (image-width CC) - (image-height CC) - CC)))))) - (spawn (lambda (e s) - (match-define (list x y keys-down) s) - (match e - [(? patch? p) - (define-values (added removed) - (patch-project/set/single p key-pressed-projection)) - (define new-keys-down (set-subtract (set-union keys-down added) removed)) - (transition (list x y new-keys-down) '())] - [(message (at-meta (frame-event _ _))) - (define-values (old-x old-y) (values x y)) - (define speed 6) - (let* ((x (if (set-member? keys-down 'left) (- x speed) x)) - (x (if (set-member? keys-down 'right) (+ x speed) x)) - (y (if (set-member? keys-down 'up) (- y speed) y)) - (y (if (set-member? keys-down 'down) (+ y speed) y))) - (and (not (and (= x old-x) (= y old-y))) - (move-to x y keys-down)))] - [_ #f])) - (list 100 100 (set)) - (update-sprites (simple-sprite -0.5 - 100 - 100 - (image-width CC) - (image-height CC) - CC)) - (sub (frame-event ? ?) #:meta-level 1) - (sub (key-pressed ?)))) +(define (spawn-background) + (spawn (lambda (e s) + (match e + [(? patch? p) + (define-values (added removed) (patch-project/set/single p window-projection)) + (transition s (for/list [(w added)] + (match-define (window width height) w) + (update-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) + ) + `())))] + [_ #f])) + (void) + (sub (window ? ?) #:meta-level 1) + ;; (assert 'fullscreen #:meta-level 1) + )) + +(define (spawn-player-avatar) + ;; This little dance is because of https://github.com/racket/racket/issues/1099 + (local-require (rename-in 2htdp/planetcute [character-cat-girl character-cat-girl*])) + (define CC character-cat-girl*) + (define (move-to x y keys-down) + (transition (list x y keys-down) + (update-sprites + (simple-sprite 0 x y (image-width CC) (image-height CC) CC)))) + (spawn (lambda (e s) + (match-define (list x y keys-down) s) + (match e + [(? patch? p) + (define-values (added removed) + (patch-project/set/single p key-pressed-projection)) + (define new-keys-down (set-subtract (set-union keys-down added) removed)) + (transition (list x y new-keys-down) '())] + [(message (at-meta (frame-event _ _))) + (define-values (old-x old-y) (values x y)) + (define speed 6) + (let* ((x (if (set-member? keys-down 'left) (- x speed) x)) + (x (if (set-member? keys-down 'right) (+ x speed) x)) + (y (if (set-member? keys-down 'up) (- y speed) y)) + (y (if (set-member? keys-down 'down) (+ y speed) y))) + (and (not (and (= x old-x) (= y old-y))) + (move-to x y keys-down)))] + [_ #f])) + (list 100 100 (set)) + (update-sprites + (simple-sprite -0.5 100 100 (image-width CC) (image-height CC) CC)) + (sub (frame-event ? ?) #:meta-level 1) + (sub (key-pressed ?)))) + +(define (spawn-frame-counter) + (spawn (lambda (e s) + (match e + [(message (at-meta (frame-event counter elapsed-ms))) + (and (> elapsed-ms 0) + (let ((i (text (format "~a fps" (/ counter (/ elapsed-ms 1000.0))) 22 "black"))) + (transition s (update-sprites (simple-sprite -10 300 10 + (image-width i) + (image-height i) + i)))))] + [_ #f])) + (void) + (sub (frame-event ? ?) #:meta-level 1))) + +(2d-world (spawn-keyboard-integrator) + (spawn-background) + (spawn-frame-counter) + (spawn-player-avatar) (spawn (lambda (e s) #f) (void) (update-sprites (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange")) (simple-sprite -1 60 60 50 50 (circle 50 "solid" "green")))) - #;(spawn (lambda (e s) - (match e - [(message (at-meta (frame-event counter elapsed-ms))) - (and (> elapsed-ms 0) - (let ((i (text (format "~a fps" (/ counter (/ elapsed-ms 1000.0))) 22 "black"))) - (transition s (update-sprites (simple-sprite -10 300 10 - (image-width i) - (image-height i) - i)))))] - [_ #f])) - (void) - (sub (frame-event ? ?) #:meta-level 1)) (spawn (lambda (e s) (match e [(message _) From 1105a545430489012e1af902d641e657cd1d119b Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 23 Oct 2015 11:49:16 -0400 Subject: [PATCH 11/27] Limit frame rate --- TODO.md | 3 ++- prospect-gl/2d.rkt | 18 +++++++++++++++++- 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/TODO.md b/TODO.md index ce68e12..8663c61 100644 --- a/TODO.md +++ b/TODO.md @@ -1 +1,2 @@ - - Some way of clamping the frame rate to e.g. 60Hz and failing that 24Hz + - Some way of adjusting target frame rate based on whether we're + achieving the goal or not; e.g. fall back from 60Hz to 24Hz diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 46dca0d..c9a0787 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -239,6 +239,22 @@ (define world (make-world boot-actions)) (define event-queue (make-queue)) + (define target-frame-rate 30) + (define frame-count 0) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (sleep-and-refresh) + (define target-sim-time (* frame-count (/ target-frame-rate))) + (define sleep-time (- target-sim-time (/ (sim-time) 1000.0))) + (when (positive? sleep-time) + (sleep/yield sleep-time)) + (refresh) + (set! frame-count (+ frame-count 1))) + + (define/public (set-target-frame-rate! r) + (set! target-frame-rate r)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (inject-event! e) @@ -319,7 +335,7 @@ (render-scene! prelude sprites postlude) (glFlush) (swap-gl-buffers))) - (queue-callback (lambda () (refresh)) #f)) + (queue-callback (lambda () (sleep-and-refresh)) #f)) (define/override (on-size width height) (with-gl-context From 419bb054f1912ca57754ad5cf307c2a6d0bfa2fd Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 23 Oct 2015 11:50:06 -0400 Subject: [PATCH 12/27] Comment out frame counter again --- prospect-gl/examples/basic.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index c381345..0c0b641 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -78,7 +78,7 @@ (2d-world (spawn-keyboard-integrator) (spawn-background) - (spawn-frame-counter) + ;; (spawn-frame-counter) (spawn-player-avatar) (spawn (lambda (e s) #f) (void) From a5db6ebc1852ed1ef035b66e43efcd59f62d3a00 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 23 Oct 2015 11:54:41 -0400 Subject: [PATCH 13/27] Communicate target-frame-rate in frame-events --- prospect-gl/2d.rkt | 4 ++-- prospect-gl/examples/basic.rkt | 10 +++++----- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index c9a0787..e546e66 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -34,7 +34,7 @@ (struct window (width height) #:transparent) ;; Message sent by world. Describes frame about to be rendered. -(struct frame-event (counter timestamp) #:transparent) +(struct frame-event (counter timestamp target-frame-rate) #:transparent) ;; Message sent by world. Describes a key event. Key is a sealed ;; key-event%. `press?` is #t when the key is pressed (or @@ -320,7 +320,7 @@ (define/override (on-paint) (with-gl-context (lambda () - (inject-event! (message (frame-event counter (sim-time)))) + (inject-event! (message (frame-event counter (sim-time) target-frame-rate))) (set! counter (+ counter 1)) (quiesce!) (unless initialised? diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index 0c0b641..c6eadbd 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -46,9 +46,9 @@ (patch-project/set/single p key-pressed-projection)) (define new-keys-down (set-subtract (set-union keys-down added) removed)) (transition (list x y new-keys-down) '())] - [(message (at-meta (frame-event _ _))) + [(message (at-meta (frame-event _ _ target-frame-rate))) (define-values (old-x old-y) (values x y)) - (define speed 6) + (define speed (/ 360.0 target-frame-rate)) (let* ((x (if (set-member? keys-down 'left) (- x speed) x)) (x (if (set-member? keys-down 'right) (+ x speed) x)) (y (if (set-member? keys-down 'up) (- y speed) y)) @@ -59,13 +59,13 @@ (list 100 100 (set)) (update-sprites (simple-sprite -0.5 100 100 (image-width CC) (image-height CC) CC)) - (sub (frame-event ? ?) #:meta-level 1) + (sub (frame-event ? ? ?) #:meta-level 1) (sub (key-pressed ?)))) (define (spawn-frame-counter) (spawn (lambda (e s) (match e - [(message (at-meta (frame-event counter elapsed-ms))) + [(message (at-meta (frame-event counter elapsed-ms _))) (and (> elapsed-ms 0) (let ((i (text (format "~a fps" (/ counter (/ elapsed-ms 1000.0))) 22 "black"))) (transition s (update-sprites (simple-sprite -10 300 10 @@ -74,7 +74,7 @@ i)))))] [_ #f])) (void) - (sub (frame-event ? ?) #:meta-level 1))) + (sub (frame-event ? ? ?) #:meta-level 1))) (2d-world (spawn-keyboard-integrator) (spawn-background) From 2420abe2e1f28052ceaf51502eec0d861aefcaa9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 23 Oct 2015 11:56:22 -0400 Subject: [PATCH 14/27] https://github.com/racket/racket/issues/1099 fixed by samth --- prospect-gl/examples/basic.rkt | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index c6eadbd..4cf126c 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -31,9 +31,8 @@ )) (define (spawn-player-avatar) - ;; This little dance is because of https://github.com/racket/racket/issues/1099 - (local-require (rename-in 2htdp/planetcute [character-cat-girl character-cat-girl*])) - (define CC character-cat-girl*) + (local-require 2htdp/planetcute) + (define CC character-cat-girl) (define (move-to x y keys-down) (transition (list x y keys-down) (update-sprites From 5409cebe8881de922840d8cc61a1d0c0589d550f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 23 Oct 2015 21:11:33 -0400 Subject: [PATCH 15/27] Support 2d-world-meta-level parameter. TODO revisit parameterization --- prospect-gl/2d.rkt | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index e546e66..343445b 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -7,6 +7,7 @@ (struct-out scene) (except-out (struct-out sprite) sprite) (rename-out [sprite ] [make-sprite sprite]) + 2d-world-meta-level simple-sprite update-scene update-sprites @@ -56,9 +57,19 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; TODO: Parameters don't work very well for this. We want it to be a +;; local, relative idea -- some actors will engage at metalevel 1, +;; some at metalevel 2, and we would prefer to just be able to say +;; (parameterize ((2d-world-meta-level N)) (spawn ...)), but we can't, +;; because parameterization *isn't lexical enough*. +;; +;; Perhaps the current-parameterization should be saved at spawn time? +;; +(define 2d-world-meta-level (make-parameter 1)) + (define (update-scene prelude postlude) - (patch-seq (retract (scene ? ?) #:meta-level 1) - (assert (scene (seal prelude) (seal postlude)) #:meta-level 1))) + (patch-seq (retract (scene ? ?) #:meta-level (2d-world-meta-level)) + (assert (scene (seal prelude) (seal postlude)) #:meta-level (2d-world-meta-level)))) (define (make-sprite z instructions) (sprite z (seal instructions))) @@ -69,8 +80,8 @@ (texture ,i)))) (define (update-sprites . ss) - (patch-seq* (cons (retract (sprite ? ?) #:meta-level 1) - (map (lambda (s) (assert s #:meta-level 1)) ss)))) + (patch-seq* (cons (retract (sprite ? ?) #:meta-level (2d-world-meta-level)) + (map (lambda (s) (assert s #:meta-level (2d-world-meta-level))) ss)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -82,7 +93,7 @@ (transition (void) ((if press? assert retract) (key-pressed code)))] [#f #f])) (void) - (sub (key-event ? ? ?) #:meta-level 1))) + (sub (key-event ? ? ?) #:meta-level (2d-world-meta-level)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 8083ddf890e5d8f1d33c0ae582a2ce4cc68aa005 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 23 Oct 2015 21:49:50 -0400 Subject: [PATCH 16/27] Remove 2d-world-meta-level parameter in favour of explicit arguments --- prospect-gl/2d.rkt | 27 ++++++++------------------- 1 file changed, 8 insertions(+), 19 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 343445b..8079e83 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -7,7 +7,6 @@ (struct-out scene) (except-out (struct-out sprite) sprite) (rename-out [sprite ] [make-sprite sprite]) - 2d-world-meta-level simple-sprite update-scene update-sprites @@ -57,19 +56,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; TODO: Parameters don't work very well for this. We want it to be a -;; local, relative idea -- some actors will engage at metalevel 1, -;; some at metalevel 2, and we would prefer to just be able to say -;; (parameterize ((2d-world-meta-level N)) (spawn ...)), but we can't, -;; because parameterization *isn't lexical enough*. -;; -;; Perhaps the current-parameterization should be saved at spawn time? -;; -(define 2d-world-meta-level (make-parameter 1)) - -(define (update-scene prelude postlude) - (patch-seq (retract (scene ? ?) #:meta-level (2d-world-meta-level)) - (assert (scene (seal prelude) (seal postlude)) #:meta-level (2d-world-meta-level)))) +(define (update-scene prelude postlude #:meta-level [meta-level 1]) + (patch-seq (retract (scene ? ?) #:meta-level meta-level) + (assert (scene (seal prelude) (seal postlude)) #:meta-level meta-level))) (define (make-sprite z instructions) (sprite z (seal instructions))) @@ -79,21 +68,21 @@ (scale ,w ,h) (texture ,i)))) -(define (update-sprites . ss) - (patch-seq* (cons (retract (sprite ? ?) #:meta-level (2d-world-meta-level)) - (map (lambda (s) (assert s #:meta-level (2d-world-meta-level))) ss)))) +(define (update-sprites #:meta-level [meta-level 1] . ss) + (patch-seq* (cons (retract (sprite ? ?) #:meta-level meta-level) + (map (lambda (s) (assert s #:meta-level meta-level)) ss)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; KeyboardIntegrator. Integrates key-events into key-pressed assertions. -(define (spawn-keyboard-integrator) +(define (spawn-keyboard-integrator #:meta-level [meta-level 1]) (spawn (lambda (e s) (match e [(message (at-meta (key-event code press? _))) (transition (void) ((if press? assert retract) (key-pressed code)))] [#f #f])) (void) - (sub (key-event ? ? ?) #:meta-level (2d-world-meta-level)))) + (sub (key-event ? ? ?) #:meta-level meta-level))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 71bd34ac5bc1df8bae3974d53180d3918fa987d5 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 23 Oct 2015 21:56:47 -0400 Subject: [PATCH 17/27] Add interframe time delta to frame-events --- prospect-gl/2d.rkt | 20 ++++++++++++-------- prospect-gl/examples/basic.rkt | 22 +++++++++++----------- 2 files changed, 23 insertions(+), 19 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 8079e83..c7844f4 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -34,7 +34,7 @@ (struct window (width height) #:transparent) ;; Message sent by world. Describes frame about to be rendered. -(struct frame-event (counter timestamp target-frame-rate) #:transparent) +(struct frame-event (counter timestamp elapsed-ms target-frame-rate) #:transparent) ;; Message sent by world. Describes a key event. Key is a sealed ;; key-event%. `press?` is #t when the key is pressed (or @@ -223,6 +223,7 @@ (define counter 0) (define start-time (current-inexact-milliseconds)) + (define prev-frame-time start-time) (define/public (sim-time) (- (current-inexact-milliseconds) start-time)) @@ -239,18 +240,16 @@ (define world (make-world boot-actions)) (define event-queue (make-queue)) - (define target-frame-rate 30) - (define frame-count 0) + (define target-frame-rate 60) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (sleep-and-refresh) - (define target-sim-time (* frame-count (/ target-frame-rate))) + (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) - (set! frame-count (+ frame-count 1))) + (refresh)) (define/public (set-target-frame-rate! r) (set! target-frame-rate r)) @@ -320,8 +319,13 @@ (define/override (on-paint) (with-gl-context (lambda () - (inject-event! (message (frame-event counter (sim-time) target-frame-rate))) - (set! counter (+ counter 1)) + (let ((this-frame-time (sim-time))) + (inject-event! (message (frame-event counter + this-frame-time + (- this-frame-time prev-frame-time) + 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 diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index 4cf126c..d7edf7d 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -45,35 +45,35 @@ (patch-project/set/single p key-pressed-projection)) (define new-keys-down (set-subtract (set-union keys-down added) removed)) (transition (list x y new-keys-down) '())] - [(message (at-meta (frame-event _ _ target-frame-rate))) + [(message (at-meta (frame-event _ _ elapsed-ms _))) (define-values (old-x old-y) (values x y)) - (define speed (/ 360.0 target-frame-rate)) - (let* ((x (if (set-member? keys-down 'left) (- x speed) x)) - (x (if (set-member? keys-down 'right) (+ x speed) x)) - (y (if (set-member? keys-down 'up) (- y speed) y)) - (y (if (set-member? keys-down 'down) (+ y speed) y))) + (define distance (* 0.360 elapsed-ms)) + (let* ((x (if (set-member? keys-down 'left) (- x distance) x)) + (x (if (set-member? keys-down 'right) (+ x distance) x)) + (y (if (set-member? keys-down 'up) (- y distance) y)) + (y (if (set-member? keys-down 'down) (+ y distance) y))) (and (not (and (= x old-x) (= y old-y))) (move-to x y keys-down)))] [_ #f])) (list 100 100 (set)) (update-sprites (simple-sprite -0.5 100 100 (image-width CC) (image-height CC) CC)) - (sub (frame-event ? ? ?) #:meta-level 1) + (sub (frame-event ? ? ? ?) #:meta-level 1) (sub (key-pressed ?)))) (define (spawn-frame-counter) (spawn (lambda (e s) (match e - [(message (at-meta (frame-event counter elapsed-ms _))) - (and (> elapsed-ms 0) - (let ((i (text (format "~a fps" (/ counter (/ elapsed-ms 1000.0))) 22 "black"))) + [(message (at-meta (frame-event counter sim-time-ms _ _))) + (and (> sim-time-ms 0) + (let ((i (text (format "~a fps" (/ counter (/ sim-time-ms 1000.0))) 22 "black"))) (transition s (update-sprites (simple-sprite -10 300 10 (image-width i) (image-height i) i)))))] [_ #f])) (void) - (sub (frame-event ? ? ?) #:meta-level 1))) + (sub (frame-event ? ? ? ?) #:meta-level 1))) (2d-world (spawn-keyboard-integrator) (spawn-background) From f90ff642f1f870e0ff9589dd4912962c5656ab6a Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 27 Oct 2015 12:07:31 -0400 Subject: [PATCH 18/27] Cache textures; significant performance improvement --- prospect-gl/2d.rkt | 12 ++++----- prospect-gl/texture.rkt | 58 ++++++++++++++++++++++++++++++++++++++++- 2 files changed, 63 insertions(+), 7 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index c7844f4..f7c5da8 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -123,8 +123,8 @@ [`(color ,(? color-number? r) ,(? color-number? g) ,(? color-number? b) ,(? color-number? a)) (values `(glColor4d ,r ,g ,b ,a) '())] [`(texture ,i) - (define tex (image->texture i)) - (values `(draw-gl-face ,tex) (list tex))] + (define entry (image->texture-cache-entry i)) + (values `(draw-gl-face ,(send entry get-texture)) (list entry))] [`(push-matrix ,instr ...) (define-values (code resources) (instructions->racket-code instr)) (values `(begin (glPushMatrix) ,@code (glPopMatrix)) resources)] @@ -155,9 +155,8 @@ [else (error 'image->bitmap "unsupported image type ~v" i)])) -(define (image->texture i) - (define bm (image->bitmap i)) - (new texture% [bitmap bm])) +(define (image->texture-cache-entry i) + (texture-cache-get i image->bitmap)) ;; (define (lerp a b v) (+ (* v a) (* (- 1 v) b))) @@ -297,7 +296,8 @@ (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))) + (for [(s added)] (add-sprite! sprites s)) + (flush-texture-cache!)) (define (process-stop-requests! p) (when (matcher-match-value (patch-added p) 'stop #f) diff --git a/prospect-gl/texture.rkt b/prospect-gl/texture.rkt index d733332..9b8d544 100644 --- a/prospect-gl/texture.rkt +++ b/prospect-gl/texture.rkt @@ -1,6 +1,8 @@ #lang racket/gui -(provide texture%) +(provide texture% + texture-cache-get + flush-texture-cache!) (require sgl/gl) (require sgl/gl-vectors) @@ -47,3 +49,57 @@ (super-new) (load-from-bitmap! initial-bitmap))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define texture-cache (make-hasheq)) +(define texture-second-chances (make-hasheq)) +(define last-flush 0) + +(define entry% + (class object% + (init-field key + texture) + (super-new) + (define ref-count 0) + + (define/public (get-texture) + texture) + + (define/public (inc-ref-count!) + (set! ref-count (+ ref-count 1))) + + (define/public (dispose) + (set! ref-count (- ref-count 1)) + (when (zero? ref-count) + (hash-remove! texture-cache key) + (hash-set! texture-second-chances key this))) + + (define/public (*cleanup) + (send texture dispose)))) + +(define (texture-cache-get key key->bitmap) + (define entry + (hash-ref texture-cache + key + (lambda () + (define t (cond + [(hash-has-key? texture-second-chances key) + (define t (hash-ref texture-second-chances key)) + (hash-remove! texture-second-chances key) + t] + [else + (define bm (key->bitmap key)) + (new entry% [key key] [texture (new texture% [bitmap bm])])])) + (hash-set! texture-cache key t) + t))) + (send entry inc-ref-count!) + entry) + +(define (flush-texture-cache!) + (define now (current-seconds)) + (when (> now (+ last-flush 10)) + ;; (log-info "flushing texture cache (~a entries)" (hash-count texture-second-chances)) + (for [(entry (in-hash-values texture-second-chances))] (send entry *cleanup)) + (hash-clear! texture-second-chances) + (set! last-flush now))) From 543a1753ca242466fef4b8f668c96b42b9b6a2eb Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 27 Oct 2015 12:22:51 -0400 Subject: [PATCH 19/27] Fix texture leak in scene updates --- prospect-gl/2d.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index f7c5da8..8efdae0 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -285,6 +285,8 @@ (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)] From e2dfe2fe78befd3d5ff5d5796be4a94321ca54a9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 27 Oct 2015 12:23:02 -0400 Subject: [PATCH 20/27] Add (commented-out) debug aids --- prospect-gl/2d.rkt | 1 + prospect-gl/texture.rkt | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 8efdae0..161cfd8 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -299,6 +299,7 @@ ;; 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)) (flush-texture-cache!)) (define (process-stop-requests! p) diff --git a/prospect-gl/texture.rkt b/prospect-gl/texture.rkt index 9b8d544..451a7a7 100644 --- a/prospect-gl/texture.rkt +++ b/prospect-gl/texture.rkt @@ -72,6 +72,7 @@ (define/public (dispose) (set! ref-count (- ref-count 1)) (when (zero? ref-count) + ;; (log-info "releasing texture cache entry for ~a" key) (hash-remove! texture-cache key) (hash-set! texture-second-chances key this))) @@ -85,11 +86,13 @@ (lambda () (define t (cond [(hash-has-key? texture-second-chances key) + ;; (log-info "recycling texture cache entry for ~a" key) (define t (hash-ref texture-second-chances key)) (hash-remove! texture-second-chances key) t] [else (define bm (key->bitmap key)) + ;; (log-info "allocating new texture cache entry for ~a" key) (new entry% [key key] [texture (new texture% [bitmap bm])])])) (hash-set! texture-cache key t) t))) @@ -98,6 +101,9 @@ (define (flush-texture-cache!) (define now (current-seconds)) + ;; (log-info "~a cache entries, ~a second-chances" + ;; (hash-count texture-cache) + ;; (hash-count texture-second-chances)) (when (> now (+ last-flush 10)) ;; (log-info "flushing texture cache (~a entries)" (hash-count texture-second-chances)) (for [(entry (in-hash-values texture-second-chances))] (send entry *cleanup)) From 2fa90c59b6e1e8325c1ff7af3341169a10d37c0d Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 3 Dec 2015 20:44:37 -0500 Subject: [PATCH 21/27] Adapt to new generalized spawn boot actions --- prospect-gl/examples/basic.rkt | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index d7edf7d..03350f2 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -26,9 +26,10 @@ `())))] [_ #f])) (void) - (sub (window ? ?) #:meta-level 1) - ;; (assert 'fullscreen #:meta-level 1) - )) + (patch-seq + (sub (window ? ?) #:meta-level 1) + ;; (assert 'fullscreen #:meta-level 1) + ))) (define (spawn-player-avatar) (local-require 2htdp/planetcute) @@ -56,10 +57,11 @@ (move-to x y keys-down)))] [_ #f])) (list 100 100 (set)) - (update-sprites - (simple-sprite -0.5 100 100 (image-width CC) (image-height CC) CC)) - (sub (frame-event ? ? ? ?) #:meta-level 1) - (sub (key-pressed ?)))) + (patch-seq + (update-sprites + (simple-sprite -0.5 100 100 (image-width CC) (image-height CC) CC)) + (sub (frame-event ? ? ? ?) #:meta-level 1) + (sub (key-pressed ?))))) (define (spawn-frame-counter) (spawn (lambda (e s) From 1ab7475869d598a2822d162c79e26540027fbc3e Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 20 Jan 2016 14:13:49 -0500 Subject: [PATCH 22/27] world --> network --- prospect-gl/2d.rkt | 28 ++++++++++++++-------------- prospect-gl/examples/basic.rkt | 32 ++++++++++++++++---------------- 2 files changed, 30 insertions(+), 30 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 161cfd8..76a7457 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -11,7 +11,7 @@ update-scene update-sprites spawn-keyboard-integrator - 2d-world) + 2d-network) (require data/order) (require data/splay-tree) @@ -30,13 +30,13 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Shared state maintained by world. Describes current window dimensions. +;; Shared state maintained by network. Describes current window dimensions. (struct window (width height) #:transparent) -;; Message sent by world. Describes frame about to be rendered. +;; Message sent by network. Describes frame about to be rendered. (struct frame-event (counter timestamp elapsed-ms target-frame-rate) #:transparent) -;; Message sent by world. Describes a key event. Key is a sealed +;; Message sent by network. 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) @@ -214,7 +214,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define world-canvas% +(define network-canvas% (class canvas% (inherit refresh with-gl-context swap-gl-buffers) @@ -236,7 +236,7 @@ (define postlude empty-instructions) (define fullscreen? #f) - (define world (make-world boot-actions)) + (define network (make-network boot-actions)) (define event-queue (make-queue)) (define target-frame-rate 60) @@ -259,7 +259,7 @@ (enqueue! event-queue e)) (define (deliver-event e) - (clean-transition (world-handle-event e world))) + (clean-transition (network-handle-event e network))) (define (quiesce!) (let loop ((txn #f) (need-poll? #t)) @@ -268,8 +268,8 @@ (if (queue-empty? event-queue) (when need-poll? (loop (deliver-event #f) #f)) (loop (deliver-event (dequeue! event-queue)) #t))] - [(transition new-world actions) - (set! world new-world) + [(transition new-network actions) + (set! network new-network) (for-each process-action! actions) (loop #f #t)]))) @@ -370,19 +370,19 @@ (super-new (style '(gl no-autoclear))))) -(define (2d-world #:width [width #f] - #:height [height #f] - . boot-actions) +(define (2d-network #:width [width #f] + #:height [height #f] + . boot-actions) (define frame (new frame% [style '(fullscreen-button)] [label "prospect-gl"] [width (or width 640)] [height (or height 480)])) - (define c (new world-canvas% + (define c (new network-canvas% [parent frame] [boot-actions boot-actions])) (unless (send (send (send c get-dc) get-gl-context) ok?) - (error '2d-world "OpenGL context failed to initialize")) + (error '2d-network "OpenGL context failed to initialize")) (send c focus) (send frame show #t) (yield 'wait)) diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index 03350f2..526a8c7 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -77,20 +77,20 @@ (void) (sub (frame-event ? ? ? ?) #:meta-level 1))) -(2d-world (spawn-keyboard-integrator) - (spawn-background) - ;; (spawn-frame-counter) - (spawn-player-avatar) - (spawn (lambda (e s) #f) - (void) - (update-sprites (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange")) - (simple-sprite -1 60 60 50 50 (circle 50 "solid" "green")))) - (spawn (lambda (e s) - (match e - [(message _) - (transition s (assert 'stop #:meta-level 1))] - [_ #f])) - (void) - (sub (key-event #\q #t ?) #:meta-level 1)) - ) +(2d-network (spawn-keyboard-integrator) + (spawn-background) + ;; (spawn-frame-counter) + (spawn-player-avatar) + (spawn (lambda (e s) #f) + (void) + (update-sprites (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange")) + (simple-sprite -1 60 60 50 50 (circle 50 "solid" "green")))) + (spawn (lambda (e s) + (match e + [(message _) + (transition s (assert 'stop #:meta-level 1))] + [_ #f])) + (void) + (sub (key-event #\q #t ?) #:meta-level 1)) + ) (exit 0) From 5fcb4cb777045561fe635e5d2c9c69ba0a2fcb48 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 21 Jan 2016 22:02:24 -0500 Subject: [PATCH 23/27] Rename "matcher" to "trie". --- prospect-gl/2d.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 76a7457..7e06932 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -303,15 +303,15 @@ (flush-texture-cache!)) (define (process-stop-requests! p) - (when (matcher-match-value (patch-added p) 'stop #f) + (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 (matcher-match-value (patch-removed p) 'fullscreen #f) + (when (trie-lookup (patch-removed p) 'fullscreen #f) (set! changed? #t) (set! fullscreen? #f)) - (when (matcher-match-value (patch-added p) 'fullscreen #f) + (when (trie-lookup (patch-added p) 'fullscreen #f) (set! changed? #t) (set! fullscreen? #t)) (when changed? From a7eae9b00e82341ddf1419acbd7700e8f39f1419 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 15 Mar 2016 09:53:52 -0400 Subject: [PATCH 24/27] Update for route.rkt -> trie.rkt switch --- prospect-gl/2d.rkt | 6 +++--- prospect-gl/examples/basic.rkt | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 7e06932..b6c51b5 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -23,7 +23,7 @@ (require (prefix-in pict: pict)) (require prospect) -(require prospect/route) +(require prospect/trie) (require prospect/ground) (require "texture.rkt") @@ -180,8 +180,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define scene-projection (compile-projection (?! (scene ? ?)))) -(define sprite-projection (compile-projection (?! (sprite ? ?)))) +(define scene-projection (?! (scene ? ?))) +(define sprite-projection (?! (sprite ? ?))) (define sprite-order (order 'sprite-order diff --git a/prospect-gl/examples/basic.rkt b/prospect-gl/examples/basic.rkt index 526a8c7..6251183 100644 --- a/prospect-gl/examples/basic.rkt +++ b/prospect-gl/examples/basic.rkt @@ -4,8 +4,8 @@ (require 2htdp/image) (require "../2d.rkt") -(define window-projection (compile-projection (at-meta (?! (window ? ?))))) -(define key-pressed-projection (compile-projection (key-pressed (?!)))) +(define window-projection (at-meta (?! (window ? ?)))) +(define key-pressed-projection (key-pressed (?!))) (define (spawn-background) (spawn (lambda (e s) From 0a4e1b208853db5947867aafab4e0f1214b52faf Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 27 Mar 2016 12:07:58 -0400 Subject: [PATCH 25/27] Add (request-gc) message. --- prospect-gl/2d.rkt | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index b6c51b5..4ef640e 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -7,6 +7,7 @@ (struct-out scene) (except-out (struct-out sprite) sprite) (rename-out [sprite ] [make-sprite sprite]) + (struct-out request-gc) simple-sprite update-scene update-sprites @@ -54,6 +55,12 @@ ;; 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]) @@ -280,7 +287,9 @@ (process-sprite-updates! p) (process-stop-requests! p) (process-fullscreen-requests! p)] - [(message body) (void)])) + [(message (request-gc)) + (perform-gc-request!)] + [(message _) (void)])) (define (process-scene-updates! p) (define-values (added removed) (patch-project/set/single p scene-projection)) @@ -317,6 +326,14 @@ (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) @@ -373,6 +390,8 @@ (define (2d-network #:width [width #f] #:height [height #f] . boot-actions) + (collect-garbage 'incremental) + (collect-garbage 'major) (define frame (new frame% [style '(fullscreen-button)] [label "prospect-gl"] From 2307b1bd50c170b448f77722f72f930806bd145d Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 27 Mar 2016 12:56:05 -0400 Subject: [PATCH 26/27] Fix pernicious typo --- prospect-gl/2d.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/prospect-gl/2d.rkt b/prospect-gl/2d.rkt index 4ef640e..ce3d661 100644 --- a/prospect-gl/2d.rkt +++ b/prospect-gl/2d.rkt @@ -301,7 +301,7 @@ (for [(s added)] (match-define (scene (seal pre) (seal post)) s) (set! prelude (compile-instructions pre)) - (set! post (compile-instructions post)))) + (set! postlude (compile-instructions post)))) (define (process-sprite-updates! p) (define-values (added removed) (patch-project/set/single p sprite-projection)) From 6a71676df00173fcb9ef2ace1825ae1b168e38f6 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 1 Apr 2016 19:18:00 -0400 Subject: [PATCH 27/27] Move to submodule in prep for merge --- .gitignore | 2 - Makefile | 44 ------------------- {prospect-gl => racket/prospect-gl}/2d.rkt | 0 TODO.md => racket/prospect-gl/TODO.md | 0 .../prospect-gl}/examples/basic.rkt | 0 .../prospect-gl}/texture.rkt | 0 6 files changed, 46 deletions(-) delete mode 100644 .gitignore delete mode 100644 Makefile rename {prospect-gl => racket/prospect-gl}/2d.rkt (100%) rename TODO.md => racket/prospect-gl/TODO.md (100%) rename {prospect-gl => racket/prospect-gl}/examples/basic.rkt (100%) rename {prospect-gl => racket/prospect-gl}/texture.rkt (100%) diff --git a/.gitignore b/.gitignore deleted file mode 100644 index b20942e..0000000 --- a/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -compiled/ -scratch/ diff --git a/Makefile b/Makefile deleted file mode 100644 index 4ae2ce0..0000000 --- a/Makefile +++ /dev/null @@ -1,44 +0,0 @@ -PACKAGENAME=prospect-gl -MAINCOLLECT=prospect-gl -COLLECTS=$(MAINCOLLECT) - -all: setup - -clean: - find . -name compiled -type d | xargs rm -rf - rm -rf htmldocs - -setup: - raco setup $(COLLECTS) - -link: - raco pkg install --link -n $(PACKAGENAME) $$(pwd) - -unlink: - raco pkg remove $(PACKAGENAME) - -htmldocs: - raco scribble \ - --html \ - --dest htmldocs \ - --dest-name index \ - ++main-xref-in \ - --redirect-main http://docs.racket-lang.org/ \ - \ - $(MAINCOLLECT)/scribblings/$(MAINCOLLECT).scrbl - -pages: - @(git branch -v | grep -q gh-pages || (echo local gh-pages branch missing; false)) - @echo - @git branch -av | grep gh-pages - @echo - @(echo 'Is the branch up to date? Press enter to continue.'; read dummy) - git clone -b gh-pages . pages - -publish: htmldocs pages - rm -rf pages/* - cp -r htmldocs/. pages/. - (cd pages; git add -A) - -(cd pages; git commit -m "Update $$(date +%Y%m%d%H%M%S)") - (cd pages; git push) - rm -rf pages diff --git a/prospect-gl/2d.rkt b/racket/prospect-gl/2d.rkt similarity index 100% rename from prospect-gl/2d.rkt rename to racket/prospect-gl/2d.rkt diff --git a/TODO.md b/racket/prospect-gl/TODO.md similarity index 100% rename from TODO.md rename to racket/prospect-gl/TODO.md diff --git a/prospect-gl/examples/basic.rkt b/racket/prospect-gl/examples/basic.rkt similarity index 100% rename from prospect-gl/examples/basic.rkt rename to racket/prospect-gl/examples/basic.rkt diff --git a/prospect-gl/texture.rkt b/racket/prospect-gl/texture.rkt similarity index 100% rename from prospect-gl/texture.rkt rename to racket/prospect-gl/texture.rkt