Render queues and some test fixes

engine/components.scm

@@ -49,34 +49,34 @@
 
 ;; Type safe color constructor
 (define (make-color r g b a)
-  (assert (and (number r) (<= 0 r 1)))
-  (assert (and (number g) (<= 0 g 1)))
-  (assert (and (number b) (<= 0 b 1)))
-  (assert (and (number a) (<= 0 a 1)))
+  (assert (and (number? r) (<= 0 r 1)))
+  (assert (and (number? g) (<= 0 g 1)))
+  (assert (and (number? b) (<= 0 b 1)))
+  (assert (and (number? a) (<= 0 a 1)))
   (int:make-color r g b a))
 
 ;; Type safe color setter
 (define (set-color-r! color r)
   (assert (color? color))
-  (assert (and (number r) (<= 0 r 1)))
+  (assert (and (number? r) (<= 0 r 1)))
   (int:set-color-r! color r))
 
 ;; Type safe color setter
 (define (set-color-g! color g)
   (assert (color? color))
-  (assert (and (number g) (<= 0 g 1)))
+  (assert (and (number? g) (<= 0 g 1)))
   (int:set-color-g! color g))
 
 ;; Type safe color setter
 (define (set-color-b! color b)
   (assert (color? color))
-  (assert (and (number b) (<= 0 b 1)))
+  (assert (and (number? b) (<= 0 b 1)))
   (int:set-color-b! color b))
 
 ;; Type safe color setter
 (define (set-color-a! color a)
   (assert (color? color))
-  (assert (and (number a) (<= 0 a 1)))
+  (assert (and (number? a) (<= 0 a 1)))
   (int:set-color-a! color a))
 
 ;; Screen transform record and exports
@@ -98,7 +98,7 @@
 (define (make-screen-transform position rotation scale anchor parent)
   (assert (vector2? position))
   (assert (real? rotation))
-  (assert (Vector2? scale))
+  (assert (vector2? scale))
   (assert (and (symbol? anchor) (member anchor '(top-left top-middle top-right
 							  center-left center center-right
 							  bottom-left bottom-middle bottom-right))))
@@ -118,8 +118,8 @@
 (define (set-position! component position)
   (assert (record? component))
   (cond
-   ((screen-transform? component) (assert (vector2? positon))))
-  ((rtd-mutator (record-rtd component) 'positon) component position))
+   ((screen-transform? component) (assert (vector2? position))))
+  ((rtd-mutator (record-rtd component) 'position) component position))
 
 (define (pivot component)
   (assert (record? component))

engine/core.scm

@@ -14,7 +14,7 @@
 ;; We export the world, component sets, systems, and event buses so that the core can be extended to
 ;; include serialization functions across all.
 ;; NOTE: direct read/write to these is undefined, and will cause problems.
-(export world component-sets systems event-buses)
+(export world component-sets systems event-buses render-queues render-priority)
 
 ;; The world hash table
 (define world (make-hash-table))
@@ -69,6 +69,7 @@
 
 ;; Add an entity to the incoming queue
 ;; TODO: append! doesn't work here and IDK why
+;; TODO: this could be done with cons anyway because we don't care about the order
 (define (queue-add-entity id components-lst)
   (set! add-entity-queue
     (append add-entity-queue (list (cons id components-lst)))))
@@ -152,25 +153,25 @@
   (assert (integer? priority))
   (assert (every symbol? criteria))
   (assert (procedure? process))
-  (internal-make-system name priority criteria process))
+  (int:make-system name priority criteria process))
 
 ;; Type-checked system priority mutator
 (define (set-system-priority! system priority)
   (assert (system? system))
   (assert (integer? priority))
-  (internal-set-system-priority! system priority))
+  (int:set-system-priority! system priority))
 
 ;; Type-checked system criteria mutator
 (define (set-system-criteria! system criteria)
   (assert (system? system))
   (assert (every symbol? criteria))
-  (internal-set-system-criteria! system criteria))
+  (int:set-system-criteria! system criteria))
 
 ;; Type-checked system process mutator
 (define (set-system-process! system process)
   (assert (system? system))
   (assert (procedure? process))
-  (internal-set-system-process! system process))
+  (int:set-system-process! system process))
 
 ;; The systems list
 (define systems '())
@@ -329,8 +330,69 @@
 	  event)
 	#f)))
 
+;; Render queue exports
+(export register-render-queue push-render-object evaluate-render-queue)
+
+;; Render queues
+(define render-queues (make-hash-table))
+(define render-priority '())
+
+;; Register a new render queue
+(define (register-render-queue name drawing)
+  (assert (symbol? name))
+  (assert (and (symbol? drawing) (member drawing '(screen 2d 3d))))
+  (if (hash-table-exists? render-queues name)
+      #f
+      (begin
+	(hash-table-set! render-queues name '())
+	(set! render-priority (cons (cons name drawing) render-priority))
+	name)))
+
+;; Default render queues
+(register-render-queue '3d '3d)
+(register-render-queue '2d '2d)
+(register-render-queue 'screen 'screen)
+
+;; TODO: camera selection needs a better solution, ideally treating the camera
+;; as an entity.
+(define *active-camera-2d* (make-parameter '()))
+(define *active-camera-3d* (make-parameter '()))
+
+;; Push a render call to the queue
+(define (push-render-object queue-name layer thunk)
+  (assert (symbol? queue-name))
+  (assert (integer? layer))
+  (assert (procedure? thunk))
+  (set! (hash-table-ref render-queues queue-name)
+    (cons (cons layer thunk) (hash-table-ref render-queues queue-name))))
+
+;; Evaluate a single render queue with a specific mode.
+;; Render objects are sorted by their layer
+(define (evaluate-render-queue queue-name mode)
+  (assert (symbol? queue-name))
+  (assert (symbol? mode) (member mode '(screen 2d 3d)))
+  (when (or (eq? mode 'screen)
+	    (and (eq? mode '2d) (not (null? (*active-camera-2d*))))
+	    (and (eq? mode '3d) (not (null? (*active-camera-3d*)))))
+    (let ((queue (hash-table-ref render-queues queue-name)))
+      (when (eq? mode '2d)
+	(begin-mode-2d (*active-camera-2d*)))
+      (when (eq? mode '3d)
+	(begin-mode-3d (*active-camera-3d*)))
+      (for-each
+       (lambda (x) (x))
+       (sort queue
+	     (lambda (render-obj-a render-obj-b)
+	       (< (car render-obj-a)
+		  (car render-obj-b)))))
+      (when (eq? mode '2d)
+	(end-mode-2d))
+      (when (eq? mode '3d)
+	(end-mode-3d))))
+  (set! queue '()))
+
 ;; Frame generation and game loop
-(export resolve-queues next-frame *clear-color*)
+(export resolve-queues next-frame *clear-color* perform-render)
 
 ;; Utility function for guarding parameter values
 (define (guarded-parameter default predicate)
@@ -347,13 +409,21 @@
 ;; Clear color
 (define *clear-color* (guarded-parameter RAYWHITE u8vector?))
 
+;; Render all queues
+(define (perform-render)
+  (begin-drawing)
+  (clear-background (*clear-color*))
+  (for-each
+   (lambda (queue-spec)
+     (evaluate-render-queue (car queue-spec)
+			    (cdr queue-spec)))
+   render-priority)
+  (end-drawing))
+
 ;; Generate the next frame, for use in the main game loop
 (define (next-frame)
   (resolve-queues)
-  (with-drawing
-   (lambda ()
-     (clear-background (*clear-color*))
-     (execute-systems))))
+  (perform-render))
 
 ;; Window creation
 (export *window-size* *window-title* create-window)