From 69477db047e7844c3e4517f2771a3d28f1b13c5b Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Thu, 16 Apr 2026 17:37:38 +0800 Subject: [PATCH 1/2] Finish bouncing balls example --- samples/bounce.scm | 126 ++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 119 insertions(+), 7 deletions(-) diff --git a/samples/bounce.scm b/samples/bounce.scm index f365c9d..896a09d 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -4,11 +4,14 @@ raylib (engine core) (engine components core) - (srfi 1)) + (srfi 1) + (srfi 99)) (*window-title* "Bounce!") (*target-fps* 60) +(define +ball-radius+ 50) + (add-system (make-system 'draw-circles 0 @@ -25,19 +28,93 @@ ((if (circle-2d-filled? circle) draw-circle draw-circle-lines) - (+ (vector-x (position transform)) - (vector-x (circle-2d-center circle))) - (+ (vector-y (position transform)) - (vector-y (circle-2d-center circle))) + (inexact->exact (round (+ (vector-x (position transform)) + (vector-x (circle-2d-center circle))))) + (inexact->exact (round (+ (vector-y (position transform)) + (vector-y (circle-2d-center circle))))) (circle-2d-radius circle) (use-color (visual-2d-color vis-2d))))))))))) +(define-record-type + (make-rigidbody-2d velocity) + rigidbody-2d? + (velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!)) + +(define +gravity+ (make-vector2 0 9.8)) +(define +friction+ -0.1) + +(add-system + (make-system 'apply-gravity + 0 + 'entity + '() + (lambda (body) + (let ((rbody (find rigidbody-2d? body))) + (display (get-fps)) + (newline) + (set-rigidbody-2d-velocity! rbody + (vector-+ (rigidbody-2d-velocity rbody) + (vector-* + (make-vector2 (get-frame-time) + (get-frame-time)) + +gravity+))))))) + +(add-system + (make-system 'apply-bounce + 1 + 'entity + '( ) + (lambda (ball) + (let ((rbody (find rigidbody-2d? ball)) + (transform (find screen-transform? ball))) + (when (> (vector-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) + (set-rigidbody-2d-velocity! rbody + (make-vector2 (vector-x (rigidbody-2d-velocity rbody)) (* -1 (vector-y (rigidbody-2d-velocity rbody)))))))))) + +(add-system + (make-system 'apply-wall-bounce + 1 + 'entity + '( ) + (lambda (ball) + (let ((rbody (find rigidbody-2d? ball)) + (transform (find screen-transform? ball))) + (when (or (> (vector-x (position transform)) (- (car (*window-size*)) +ball-radius+)) + (< (vector-x (position transform)) (+ 0 +ball-radius+))) + (set-rigidbody-2d-velocity! rbody + (make-vector2 (* -1 (vector-x (rigidbody-2d-velocity rbody))) (vector-y (rigidbody-2d-velocity rbody))))))))) + +(add-system + (make-system 'apply-friction + 2 + 'entity + '() + (lambda (ball) + (let ((rbody (find rigidbody-2d? ball))) + (set-rigidbody-2d-velocity! rbody + (vector-+ (rigidbody-2d-velocity rbody) + (vector-* + (make-vector2 (* (get-frame-time) +friction+) (* (get-frame-time) +friction+)) + (rigidbody-2d-velocity rbody)))))))) + +(add-system + (make-system 'move-rigidbody + 3 + 'entity + '( ) + (lambda (ball) + (let ((rbody (find rigidbody-2d? ball)) + (transform (find screen-transform? ball))) + (set-position! transform + (vector-+ (rigidbody-2d-velocity rbody) + (position transform))))))) + (create-entity (make-visual-2d (make-circle-2d (make-vector2 0 0) - 50 + +ball-radius+ #t) (make-color 0 0 1 1) 0) @@ -47,7 +124,42 @@ 0 (make-vector2 1 1) 'center - 'none)) + 'none) + (make-rigidbody-2d (make-vector2 5 1))) + +(create-entity + (make-visual-2d + (make-circle-2d + (make-vector2 0 0) + +ball-radius+ + #t) + (make-color 0 1 0 1) + 0) + (make-screen-transform + (make-vector2 100 100) + (make-vector2 0 0) + 0 + (make-vector2 1 1) + 'center + 'none) + (make-rigidbody-2d (make-vector2 -2 -2))) + +(create-entity + (make-visual-2d + (make-circle-2d + (make-vector2 0 0) + +ball-radius+ + #t) + (make-color 1 0 0 1) + 0) + (make-screen-transform + (make-vector2 100 100) + (make-vector2 0 0) + 0 + (make-vector2 1 1) + 'center + 'none) + (make-rigidbody-2d (make-vector2 10 -5))) (create-window) ) From d379cd28d7531b82f8e0d4887806cbcf43d01b6e Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Thu, 16 Apr 2026 18:48:39 +0800 Subject: [PATCH 2/2] Add global systems and bounce boosting --- engine/core.scm | 12 +++++++----- samples/bounce.scm | 36 ++++++++++++++++++++++++++++++++++-- 2 files changed, 41 insertions(+), 7 deletions(-) diff --git a/engine/core.scm b/engine/core.scm index aee7e18..92808e2 100644 --- a/engine/core.scm +++ b/engine/core.scm @@ -162,7 +162,7 @@ (define (make-system name priority mode criteria process) (assert (symbol? name)) (assert (integer? priority)) - (assert (member mode '(entity batch))) + (assert (member mode '(entity batch global))) (assert (every symbol? criteria)) (assert (procedure? process)) (int:make-system name priority mode criteria process)) @@ -266,10 +266,12 @@ ;; Execute a single system (define (execute-system system) (assert (system? system)) - (let ((entities (map get-entity (set->list (apply query-by-components (system-criteria system)))))) - (cond - ((eqv? (system-mode system) 'batch) ((system-process system) entities)) - ((eqv? (system-mode system) 'entity) (for-each (lambda (e) ((system-process system) e)) entities))))) + (if (eqv? (system-mode system) 'global) + ((system-process system)) + (let ((entities (map get-entity (set->list (apply query-by-components (system-criteria system)))))) + (cond + ((eqv? (system-mode system) 'batch) ((system-process system) entities)) + ((eqv? (system-mode system) 'entity) (for-each (lambda (e) ((system-process system) e)) entities)))))) (define (execute-systems) (for-each diff --git a/samples/bounce.scm b/samples/bounce.scm index 896a09d..4890d51 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -51,8 +51,6 @@ '() (lambda (body) (let ((rbody (find rigidbody-2d? body))) - (display (get-fps)) - (newline) (set-rigidbody-2d-velocity! rbody (vector-+ (rigidbody-2d-velocity rbody) (vector-* @@ -110,6 +108,40 @@ (vector-+ (rigidbody-2d-velocity rbody) (position transform))))))) +(define-record-type + (make-key-press key) + key-press? + (key key-press-key)) + +(add-system + (make-system 'input + 0 + 'global + '() + (lambda () + (when (key-pressed? KEY_SPACE) + (push-event 'input 'boost (make-key-press 'space)))))) + +(add-system + (make-system 'boost-rigidbody + 2 + 'entity + '() + (lambda (ball) + (let ((rbody (find rigidbody-2d? ball))) + (when (peek-event 'input 'boost) + (set-rigidbody-2d-velocity! rbody + (vector-* (make-vector2 2 2) + (rigidbody-2d-velocity rbody)))))))) + +(add-system + (make-system 'clear-boost-input + 10 + 'global + '() + (lambda () + (pop-event 'input 'boost)))) + (create-entity (make-visual-2d (make-circle-2d