From f54f9c4b402edea4d319ac08ac23711432039fa2 Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Sun, 19 Apr 2026 10:15:18 +0800 Subject: [PATCH] Add scene system and update example --- engine/core.scm | 48 ++++++---- engine/scene.scm | 42 +++++++++ samples/bounce.scm | 222 +++++++++++++++++++++++++-------------------- 3 files changed, 197 insertions(+), 115 deletions(-) create mode 100644 engine/scene.scm diff --git a/engine/core.scm b/engine/core.scm index f4a43cc..bfedf65 100644 --- a/engine/core.scm +++ b/engine/core.scm @@ -293,7 +293,7 @@ ;; Event bus interface (export register-event-bus remove-event-bus fetch-event-bus - push-event peek-event pop-event) + clear-event-bus push-event peek-event pop-event) ;; Register a new event bus (define (register-event-bus name) @@ -315,6 +315,18 @@ name) #f)) +(define (clear-event-bus name) + (assert (symbol? name)) + (let ((event-bus (fetch-event-bus name))) + (if event-bus + (begin + (for-each + (lambda (key) + (hash-table-delete! event-bus key)) + (hash-table-keys event-bus)) + #t) + #f))) + ;; Fetch an event bus by name, or #f if it doesn't exist (define (fetch-event-bus name) (assert (symbol? name)) @@ -366,7 +378,7 @@ (key key-press-key)) ;; Add a new action to the input actions alist -(export register-action) +(export register-action push-actions) (define (register-action name type . data) (assert (symbol? name)) (assert (member type '(key-press))) @@ -378,22 +390,22 @@ input-actions))) ;; Default global system for simple input management -(add-system - (make-system - 'push-actions - 0 - 'global - '() - (lambda () - (for-each - (lambda (action) - (cond - ((key-press? (cdr action)) - (when (key-pressed? (key-press-key (cdr action))) - (push-event 'input - (car action) - (cdr action)))))) - input-actions)))) +(define push-actions + (make-system + 'push-actions + 0 + 'global + '() + (lambda () + (for-each + (lambda (action) + (cond + ((key-press? (cdr action)) + (when (key-pressed? (key-press-key (cdr action))) + (push-event 'input + (car action) + (cdr action)))))) + input-actions)))) ;; Render queue exports (export register-render-queue push-render-object evaluate-render-queue) diff --git a/engine/scene.scm b/engine/scene.scm new file mode 100644 index 0000000..f272e02 --- /dev/null +++ b/engine/scene.scm @@ -0,0 +1,42 @@ +(module (engine scene) () +(import scheme + (chicken base) + (chicken module) + (engine core) + (srfi 1) + (srfi 99)) + +;; This is just for easier serialization +(define-record-type + (make-entity name components) + entity? + (name entity-name) + (components entity-components)) + +(export entity named-entity) +(define (entity . components) + (apply make-entity (cons '() (list components)))) + +(define (named-entity name . components) + (apply make-entity (cons name (list components)))) + +(export scene) +;; Every element of items here is either an entity record or system +(define (scene . items) + (lambda () + (clear-world) + (clear-systems) + (clear-event-bus 'input) + (for-each + (lambda (entity) + (if (null? (entity-name entity)) + (apply create-entity (entity-components entity)) + (apply create-named-entity (cons (entity-name entity) + (entity-components entity))))) + (filter entity? items)) + (for-each + (lambda (system) + (add-system system)) + (filter system? items)))) + +) diff --git a/samples/bounce.scm b/samples/bounce.scm index 7f84621..4562f39 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -6,6 +6,7 @@ (engine components core) (engine math) (engine drawing) + (engine scene) (srfi 1) (srfi 99)) @@ -14,24 +15,24 @@ (define +ball-radius+ 50) -(add-system - (make-system 'draw-circles - 0 - 'entity - '( ) - (lambda (_ vis-2d transform) - (when (circle-2d? (visual-2d-draw vis-2d)) - (let ((circle (visual-2d-draw vis-2d))) - (push-render-object 'screen - (visual-2d-layer vis-2d) - (lambda () - (let ((draw-pos (v+ (position transform) - (circle-2d-center circle)))) - (draw-circle-2d - draw-pos - (circle-2d-radius circle) - (visual-2d-color vis-2d) - (circle-2d-filled? circle)))))))))) +(define draw-circles + (make-system 'draw-circles + 0 + 'entity + '( ) + (lambda (_ vis-2d transform) + (when (circle-2d? (visual-2d-draw vis-2d)) + (let ((circle (visual-2d-draw vis-2d))) + (push-render-object 'screen + (visual-2d-layer vis-2d) + (lambda () + (let ((draw-pos (v+ (position transform) + (circle-2d-center circle)))) + (draw-circle-2d + draw-pos + (circle-2d-radius circle) + (visual-2d-color vis-2d) + (circle-2d-filled? circle)))))))))) (define-record-type @@ -42,85 +43,96 @@ (define +gravity+ (vec 0 9.8)) (define +friction+ -0.1) -(add-system - (make-system 'apply-gravity - 0 - 'entity - '() - (lambda (_ rbody) - (set-rigidbody-2d-velocity! rbody - (v+ (rigidbody-2d-velocity rbody) - (v* (get-frame-time) - +gravity+)))))) +(define apply-gravity + (make-system 'apply-gravity + 0 + 'entity + '() + (lambda (_ rbody) + (set-rigidbody-2d-velocity! rbody + (v+ (rigidbody-2d-velocity rbody) + (v* (get-frame-time) + +gravity+)))))) -(add-system - (make-system 'apply-bounce - 1 - 'entity - '( ) - (lambda (_ rbody transform) - (when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) - (set-rigidbody-2d-velocity! rbody - (v* (rigidbody-2d-velocity rbody) - (vec 1 -1))))))) +(define apply-bounce + (make-system 'apply-bounce + 1 + 'entity + '( ) + (lambda (_ rbody transform) + (when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) + (set-rigidbody-2d-velocity! rbody + (v* (rigidbody-2d-velocity rbody) + (vec 1 -1))))))) -(add-system - (make-system 'apply-wall-bounce - 1 - 'entity - '( ) - (lambda (_ rbody transform) - (when (or (> (v-x (position transform)) (- (car (*window-size*)) +ball-radius+)) - (< (v-x (position transform)) (+ 0 +ball-radius+))) - (set-rigidbody-2d-velocity! rbody - (v* (rigidbody-2d-velocity rbody) - (vec -1 1))))))) +(define apply-wall-bounce + (make-system 'apply-wall-bounce + 1 + 'entity + '( ) + (lambda (_ rbody transform) + (when (or (> (v-x (position transform)) (- (car (*window-size*)) +ball-radius+)) + (< (v-x (position transform)) (+ 0 +ball-radius+))) + (set-rigidbody-2d-velocity! rbody + (v* (rigidbody-2d-velocity rbody) + (vec -1 1))))))) -(add-system - (make-system 'apply-friction - 2 - 'entity - '() - (lambda (_ rbody) - (set-rigidbody-2d-velocity! rbody - (v+ (rigidbody-2d-velocity rbody) - (v* (get-frame-time) - +friction+ - (rigidbody-2d-velocity rbody))))))) +(define apply-friction + (make-system 'apply-friction + 2 + 'entity + '() + (lambda (_ rbody) + (set-rigidbody-2d-velocity! rbody + (v+ (rigidbody-2d-velocity rbody) + (v* (get-frame-time) + +friction+ + (rigidbody-2d-velocity rbody))))))) -(add-system - (make-system 'move-rigidbody - 3 - 'entity - '( ) - (lambda (_ rbody transform) - (set-position! transform - (v+ (rigidbody-2d-velocity rbody) - (position transform)))))) +(define move-rigidbody + (make-system 'move-rigidbody + 3 + 'entity + '( ) + (lambda (_ rbody transform) + (set-position! transform + (v+ (rigidbody-2d-velocity rbody) + (position transform)))))) (register-action 'boost 'key-press KEY_SPACE) +(register-action 'reset 'key-press KEY_R) -(add-system - (make-system 'boost-rigidbody - 2 - 'entity - '() - (lambda (_ rbody) - (when (peek-event 'input 'boost) - (set-rigidbody-2d-velocity! rbody - (v* 2 - (rigidbody-2d-velocity rbody))))))) +(define boost-rigidbody + (make-system 'boost-rigidbody + 2 + 'entity + '() + (lambda (_ rbody) + (when (peek-event 'input 'boost) + (set-rigidbody-2d-velocity! rbody + (v* 2 + (rigidbody-2d-velocity rbody))))))) -(add-system - (make-system 'clear-boost - 4 - 'global - '() - (lambda () - (pop-event 'input 'boost)))) +(define clear-boost + (make-system 'clear-boost + 4 + 'global + '() + (lambda () + (pop-event 'input 'boost)))) + +(define *bounce-scene* (make-parameter (lambda () #f))) +(define reload-scene + (make-system 'reload-scene + 4 + 'global + '() + (lambda () + (when (pop-event 'input 'reset) + (((*bounce-scene*))))))) (define (make-ball position velocity color) - (create-entity + (entity (make-visual-2d (make-circle-2d (vec 0 0) @@ -134,20 +146,36 @@ 0 (vec 1 1) 'center - 'none) + '()) (make-rigidbody-2d velocity))) -(make-ball (vec 100 100) - (vec 5 1) - (make-color 0 0 1 1)) +(*bounce-scene* + (lambda () + (scene + push-actions + draw-circles + apply-gravity + apply-bounce + apply-wall-bounce + apply-friction + move-rigidbody + boost-rigidbody + clear-boost + reload-scene + + (make-ball (vec 100 100) + (vec 5 1) + (make-color 0 0 1 1)) -(make-ball (vec 200 200) - (vec -2 -2) - (make-color 0 1 0 1)) + (make-ball (vec 200 200) + (vec -2 -2) + (make-color 0 1 0 1)) -(make-ball (vec 300 300) - (vec -2 -2) - (make-color 1 0 0 1)) + (make-ball (vec 300 300) + (vec -2 -2) + (make-color 1 0 0 1))))) + +(((*bounce-scene*))) (create-window) )