From b37f78330c87f0ec3f072712dad16335daefd140 Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 17:10:00 +0800 Subject: [PATCH 01/14] Pass requested entity components as arguments to 'entity systems --- engine/core.scm | 12 +++++- samples/bounce.scm | 103 ++++++++++++++++++++------------------------- 2 files changed, 57 insertions(+), 58 deletions(-) diff --git a/engine/core.scm b/engine/core.scm index 92808e2..9a432fe 100644 --- a/engine/core.scm +++ b/engine/core.scm @@ -271,7 +271,17 @@ (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)))))) + ((eqv? (system-mode system) 'entity) + (for-each (lambda (e) + (apply (system-process system) + (cons e + (map (lambda (component) + (find (lambda (c) + (eqv? (rtd-name (record-rtd c)) + component)) + e)) + (system-criteria system))))) + entities)))))) (define (execute-systems) (for-each diff --git a/samples/bounce.scm b/samples/bounce.scm index 4890d51..4849f51 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -17,23 +17,21 @@ 0 'entity '( ) - (lambda (ball) - (let ((vis-2d (find visual-2d? ball)) - (transform (find screen-transform? ball))) - (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 () - ((if (circle-2d-filled? circle) - draw-circle - draw-circle-lines) - (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))))))))))) + (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 () + ((if (circle-2d-filled? circle) + draw-circle + draw-circle-lines) + (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 @@ -49,64 +47,56 @@ 0 'entity '() - (lambda (body) - (let ((rbody (find rigidbody-2d? body))) - (set-rigidbody-2d-velocity! rbody - (vector-+ (rigidbody-2d-velocity rbody) - (vector-* - (make-vector2 (get-frame-time) - (get-frame-time)) - +gravity+))))))) + (lambda (_ rbody) + (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)))))))))) + (lambda (_ rbody transform) + (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))))))))) + (lambda (_ rbody transform) + (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)))))))) + (lambda (_ rbody) + (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))))))) + (lambda (_ rbody transform) + (set-position! transform + (vector-+ (rigidbody-2d-velocity rbody) + (position transform)))))) (define-record-type (make-key-press key) @@ -127,12 +117,11 @@ 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)))))))) + (lambda (_ rbody) + (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 -- 2.47.3 From b4a08ea918e584ce9f80b8fa8678dd400e13cbeb Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 19:00:44 +0800 Subject: [PATCH 02/14] Ideal state for vector ops and interface --- samples/bounce.scm | 61 +++++++++++++++++++++++----------------------- 1 file changed, 30 insertions(+), 31 deletions(-) diff --git a/samples/bounce.scm b/samples/bounce.scm index 4849f51..904b70d 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -39,7 +39,7 @@ rigidbody-2d? (velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!)) -(define +gravity+ (make-vector2 0 9.8)) +(define +gravity+ (make-vector 0 9.8)) (define +friction+ -0.1) (add-system @@ -49,11 +49,9 @@ '() (lambda (_ rbody) (set-rigidbody-2d-velocity! rbody - (vector-+ (rigidbody-2d-velocity rbody) - (vector-* - (make-vector2 (get-frame-time) - (get-frame-time)) - +gravity+)))))) + (+ (rigidbody-2d-velocity rbody) + (* (get-frame-time) + +gravity+)))))) (add-system (make-system 'apply-bounce @@ -63,7 +61,8 @@ (lambda (_ rbody transform) (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))))))))) + (* (rigidbody-2d-velocity rbody) + (make-vector 1 -1))))))) (add-system (make-system 'apply-wall-bounce @@ -74,7 +73,8 @@ (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)))))))) + (* (rigidbody-2d-velocity rbody) + (make-vector -1 1))))))) (add-system (make-system 'apply-friction @@ -83,10 +83,9 @@ '() (lambda (_ rbody) (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))))))) + (+ (rigidbody-2d-velocity rbody) + (* (get-frame-time) +friction+ + (rigidbody-2d-velocity rbody))))))) (add-system (make-system 'move-rigidbody @@ -95,8 +94,8 @@ '( ) (lambda (_ rbody transform) (set-position! transform - (vector-+ (rigidbody-2d-velocity rbody) - (position transform)))))) + (+ (rigidbody-2d-velocity rbody) + (position transform)))))) (define-record-type (make-key-press key) @@ -120,8 +119,8 @@ (lambda (_ rbody) (when (peek-event 'input 'boost) (set-rigidbody-2d-velocity! rbody - (vector-* (make-vector2 2 2) - (rigidbody-2d-velocity rbody))))))) + (* 2 + (rigidbody-2d-velocity rbody))))))) (add-system (make-system 'clear-boost-input @@ -134,53 +133,53 @@ (create-entity (make-visual-2d (make-circle-2d - (make-vector2 0 0) + (make-vector 0 0) +ball-radius+ #t) (make-color 0 0 1 1) 0) (make-screen-transform - (make-vector2 100 100) - (make-vector2 0 0) + (make-vector 100 100) + (make-vector 0 0) 0 - (make-vector2 1 1) + (make-vector 1 1) 'center 'none) - (make-rigidbody-2d (make-vector2 5 1))) + (make-rigidbody-2d (make-vector 5 1))) (create-entity (make-visual-2d (make-circle-2d - (make-vector2 0 0) + (make-vector 0 0) +ball-radius+ #t) (make-color 0 1 0 1) 0) (make-screen-transform - (make-vector2 100 100) - (make-vector2 0 0) + (make-vector 100 100) + (make-vector 0 0) 0 - (make-vector2 1 1) + (make-vector 1 1) 'center 'none) - (make-rigidbody-2d (make-vector2 -2 -2))) + (make-rigidbody-2d (make-vector -2 -2))) (create-entity (make-visual-2d (make-circle-2d - (make-vector2 0 0) + (make-vector 0 0) +ball-radius+ #t) (make-color 1 0 0 1) 0) (make-screen-transform - (make-vector2 100 100) - (make-vector2 0 0) + (make-vector 100 100) + (make-vector 0 0) 0 - (make-vector2 1 1) + (make-vector 1 1) 'center 'none) - (make-rigidbody-2d (make-vector2 10 -5))) + (make-rigidbody-2d (make-vector 10 -5))) (create-window) ) -- 2.47.3 From 1b759d77716755f3400e1691af8396c59cf0a0f6 Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 19:25:42 +0800 Subject: [PATCH 03/14] Nicer rendering interface --- samples/bounce.scm | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/samples/bounce.scm b/samples/bounce.scm index 904b70d..a52e285 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -23,15 +23,15 @@ (push-render-object 'screen (visual-2d-layer vis-2d) (lambda () - ((if (circle-2d-filled? circle) - draw-circle - draw-circle-lines) - (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)))))))))) + (let ((draw-pos (+ (position transform) + (circle-2d-center circle)))) + ((if (circle-2d-filled? circle) + draw-circle + draw-circle-lines) + (vector-x draw-pos) + (vector-y draw-pos) + (circle-2d-radius circle) + (visual-2d-color vis-2d)))))))))) (define-record-type -- 2.47.3 From 190a32ac545b5a8f62f9a3c5dd963c3c1432d492 Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 19:27:23 +0800 Subject: [PATCH 04/14] Easier way to register inputs --- samples/bounce.scm | 14 +------------- 1 file changed, 1 insertion(+), 13 deletions(-) diff --git a/samples/bounce.scm b/samples/bounce.scm index a52e285..bfe85b4 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -97,19 +97,7 @@ (+ (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)))))) +(register-action 'boost 'key-press KEY_SPACE) (add-system (make-system 'boost-rigidbody -- 2.47.3 From 072c66c334d00cfc556ecb7fdbbbb5b4016d55e1 Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 19:55:16 +0800 Subject: [PATCH 05/14] + -> v+, * -> v* --- samples/bounce.scm | 43 ++++++++++++++++++------------------------- 1 file changed, 18 insertions(+), 25 deletions(-) diff --git a/samples/bounce.scm b/samples/bounce.scm index bfe85b4..d05a6f6 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -23,8 +23,8 @@ (push-render-object 'screen (visual-2d-layer vis-2d) (lambda () - (let ((draw-pos (+ (position transform) - (circle-2d-center circle)))) + (let ((draw-pos (v+ (position transform) + (circle-2d-center circle)))) ((if (circle-2d-filled? circle) draw-circle draw-circle-lines) @@ -49,9 +49,9 @@ '() (lambda (_ rbody) (set-rigidbody-2d-velocity! rbody - (+ (rigidbody-2d-velocity rbody) - (* (get-frame-time) - +gravity+)))))) + (v+ (rigidbody-2d-velocity rbody) + (v* (get-frame-time) + +gravity+)))))) (add-system (make-system 'apply-bounce @@ -61,8 +61,8 @@ (lambda (_ rbody transform) (when (> (vector-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) (set-rigidbody-2d-velocity! rbody - (* (rigidbody-2d-velocity rbody) - (make-vector 1 -1))))))) + (v* (rigidbody-2d-velocity rbody) + (make-vector 1 -1))))))) (add-system (make-system 'apply-wall-bounce @@ -73,8 +73,8 @@ (when (or (> (vector-x (position transform)) (- (car (*window-size*)) +ball-radius+)) (< (vector-x (position transform)) (+ 0 +ball-radius+))) (set-rigidbody-2d-velocity! rbody - (* (rigidbody-2d-velocity rbody) - (make-vector -1 1))))))) + (v* (rigidbody-2d-velocity rbody) + (make-vector -1 1))))))) (add-system (make-system 'apply-friction @@ -83,9 +83,10 @@ '() (lambda (_ rbody) (set-rigidbody-2d-velocity! rbody - (+ (rigidbody-2d-velocity rbody) - (* (get-frame-time) +friction+ - (rigidbody-2d-velocity rbody))))))) + (v+ (rigidbody-2d-velocity rbody) + (v* (get-frame-time) + +friction+ + (rigidbody-2d-velocity rbody))))))) (add-system (make-system 'move-rigidbody @@ -94,8 +95,8 @@ '( ) (lambda (_ rbody transform) (set-position! transform - (+ (rigidbody-2d-velocity rbody) - (position transform)))))) + (v+ (rigidbody-2d-velocity rbody) + (position transform)))))) (register-action 'boost 'key-press KEY_SPACE) @@ -105,18 +106,10 @@ 'entity '() (lambda (_ rbody) - (when (peek-event 'input 'boost) + (when (pop-event 'input 'boost) (set-rigidbody-2d-velocity! rbody - (* 2 - (rigidbody-2d-velocity rbody))))))) - -(add-system - (make-system 'clear-boost-input - 10 - 'global - '() - (lambda () - (pop-event 'input 'boost)))) + (v* 2 + (rigidbody-2d-velocity rbody))))))) (create-entity (make-visual-2d -- 2.47.3 From d0cada659a65570ed416fd2d9d8e3e4efc05d24b Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 20:00:40 +0800 Subject: [PATCH 06/14] Vector constructor and simplify ball creation --- samples/bounce.scm | 81 +++++++++++++++++----------------------------- 1 file changed, 30 insertions(+), 51 deletions(-) diff --git a/samples/bounce.scm b/samples/bounce.scm index d05a6f6..a6b9e91 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -39,7 +39,7 @@ rigidbody-2d? (velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!)) -(define +gravity+ (make-vector 0 9.8)) +(define +gravity+ (vector 0 9.8)) (define +friction+ -0.1) (add-system @@ -62,7 +62,7 @@ (when (> (vector-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) (set-rigidbody-2d-velocity! rbody (v* (rigidbody-2d-velocity rbody) - (make-vector 1 -1))))))) + (vector 1 -1))))))) (add-system (make-system 'apply-wall-bounce @@ -74,7 +74,7 @@ (< (vector-x (position transform)) (+ 0 +ball-radius+))) (set-rigidbody-2d-velocity! rbody (v* (rigidbody-2d-velocity rbody) - (make-vector -1 1))))))) + (vector -1 1))))))) (add-system (make-system 'apply-friction @@ -111,56 +111,35 @@ (v* 2 (rigidbody-2d-velocity rbody))))))) -(create-entity - (make-visual-2d - (make-circle-2d - (make-vector 0 0) - +ball-radius+ - #t) - (make-color 0 0 1 1) - 0) - (make-screen-transform - (make-vector 100 100) - (make-vector 0 0) - 0 - (make-vector 1 1) - 'center - 'none) - (make-rigidbody-2d (make-vector 5 1))) +(define (make-ball position velocity color) + (create-entity + (make-visual-2d + (make-circle-2d + (vector 0 0) + +ball-radius+ + #t) + color + 0) + (make-screen-transform + position + (vector 0 0) + 0 + (vector 1 1) + 'center + 'none) + (make-rigidbody-2d velocity))) -(create-entity - (make-visual-2d - (make-circle-2d - (make-vector 0 0) - +ball-radius+ - #t) - (make-color 0 1 0 1) - 0) - (make-screen-transform - (make-vector 100 100) - (make-vector 0 0) - 0 - (make-vector 1 1) - 'center - 'none) - (make-rigidbody-2d (make-vector -2 -2))) +(make-ball (vector 100 100) + (vector 5 1) + (make-color 0 0 1 1)) -(create-entity - (make-visual-2d - (make-circle-2d - (make-vector 0 0) - +ball-radius+ - #t) - (make-color 1 0 0 1) - 0) - (make-screen-transform - (make-vector 100 100) - (make-vector 0 0) - 0 - (make-vector 1 1) - 'center - 'none) - (make-rigidbody-2d (make-vector 10 -5))) +(make-ball (vector 300 300) + (vector -2 -2) + (make-color 0 1 0 1)) + +(make-ball (vector 600 600) + (vector -2 -2) + (make-color 1 0 0 1)) (create-window) ) -- 2.47.3 From 30b820688955f659f82d078f992ab740700fbe91 Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 21:41:47 +0800 Subject: [PATCH 07/14] First pass at a global input action system --- engine/core.scm | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/engine/core.scm b/engine/core.scm index 9a432fe..db9d9a4 100644 --- a/engine/core.scm +++ b/engine/core.scm @@ -356,6 +356,44 @@ event) #f))) +;; Input actions alist +(define input-actions '()) + +;; Key-press type action +(define-record-type + (make-key-press key) + key-press? + (key key-press-key)) + +;; Add a new action to the input actions alist +(export register-action) +(define (register-action name type . data) + (assert (symbol? name)) + (assert (member type '(key-press))) + (set! input-actions + (cons (list name + (apply (cond + ((eqv? type 'key-press) make-key-press)) + data)) + 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)) + (push-event 'input + (car action) + (cdr action))))) + input-actions)))) + ;; Render queue exports (export register-render-queue push-render-object evaluate-render-queue) -- 2.47.3 From 66fbc1587cd3dc0bdacd82963e491aa045221810 Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 22:30:34 +0800 Subject: [PATCH 08/14] Change vector math interface --- engine/components.scm | 201 +++++------------------------------------- engine/math.scm | 157 ++++++++++++++++++++++++++++++++- samples/bounce.scm | 35 ++++---- test/components.scm | 36 ++++---- 4 files changed, 215 insertions(+), 214 deletions(-) diff --git a/engine/components.scm b/engine/components.scm index bdbd8c5..d68e07a 100644 --- a/engine/components.scm +++ b/engine/components.scm @@ -3,166 +3,11 @@ (chicken base) (chicken module) (engine guards) + (engine math) (srfi 1) (srfi 4) (srfi 99)) -;; Vector exports -(export make-vector2 vector2? vector-x - set-vector-x! vector-y set-vector-y!) - -;; 2D Vector type -;; TODO: this could be done with a macro to save some definitions -(define-record-type - (int:make-vector2 x y) - vector2? - (x vector2-x int:set-vector2-x!) - (y vector2-y int:set-vector2-y!)) - -;; Type safe 2D vector constructor -(define (make-vector2 x y) - (assert (number? x)) - (assert (number? y)) - (int:make-vector2 x y)) - -;; Type safe 2D vector setter -(define (set-vector2-x! vector2 x) - (assert (vector2? vector2)) - (assert (number? x)) - (int:set-vector2-x! vector2 x)) - -;; Type safe 2D vector setter -(define (set-vector2-y! vector2 y) - (assert (vector2? vector2)) - (assert (number? y)) - (int:set-vector2-y! vector2 y)) - -;; Vector utility functions -(define (vector-x component) - (assert (record? component)) - ((rtd-accessor (record-rtd component) 'x) component)) - -(define (set-vector-x! component x) - (assert (record? component)) - (assert (number? x)) - ((rtd-mutator (record-rtd component) 'x) component x)) - -(define (vector-y component) - (assert (record? component)) - ((rtd-accessor (record-rtd component) 'y) component)) - -(define (set-vector-y! component y) - (assert (record? component)) - (assert (number? y)) - ((rtd-mutator (record-rtd component) 'y) component y)) - -;; Export vector functions -(export vector-= vector-+ vector-- vector-* vector-/ - vector-magnitude vector-normalize vector-dot - vector-angle-between) - -;; TODO: make this function accept any number of vectors -(define (vector-= vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (and (= (vector-x vec1) (vector-x vec2)) - (= (vector-y vec1) (vector-y vec2)))))) - -;; TODO: make this function accept any number of vectors -(define (vector-+ vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (make-vector2 (+ (vector-x vec1) (vector-x vec2)) - (+ (vector-y vec1) (vector-y vec2)))))) - -;; TODO: make this function accept any number of vectors -(define (vector-- vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (make-vector2 (- (vector-x vec1) (vector-x vec2)) - (- (vector-y vec1) (vector-y vec2)))))) - -;; TODO: make this function accept any number of vectors -(define (vector-* vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (make-vector2 (* (vector-x vec1) (vector-x vec2)) - (* (vector-y vec1) (vector-y vec2)))))) - -;; TODO: make this function accept any number of vectors -(define (vector-/ vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (make-vector2 (/ (vector-x vec1) (vector-x vec2)) - (/ (vector-y vec1) (vector-y vec2)))))) - -;; Magnitude -(define (vector-magnitude vec) - (assert ((disjoin vector2?) vec)) - (cond - ((vector2? vec) - (sqrt (+ (expt (vector-x vec) 2) - (expt (vector-y vec) 2)))))) - -(define (vector-dot vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (+ (* (vector-x vec1) (vector-x vec2)) - (* (vector-y vec1) (vector-y vec2)))))) - -(define (vector-angle-between vec1 vec2) - (assert (and (record? vec1) - (record? vec2))) - (assert (eq? (rtd-name (record-rtd vec1)) - (rtd-name (record-rtd vec2)))) - (assert ((disjoin vector2?) vec1)) - (cond - ((vector2? vec1) - (acos (/ (vector-dot vec1 vec2) - (* (vector-magnitude vec1) - (vector-magnitude vec2))))))) - -;; Normalization -(define (vector-normalize vec) - (assert ((disjoin vector2?) vec)) ;; TODO: This assertion should be moved out of here - (let ((magnitude (vector-magnitude vec))) - (cond - ((vector2? vec) - (make-vector2 (/ (vector-x vec) - magnitude) - (/ (vector-y vec) - magnitude)))))) - ;; Color exports (export make-color use-color color-r color-g color-b color-a set-color-r! set-color-g! set-color-b! set-color-a!) @@ -176,7 +21,7 @@ (b color-b int:set-color-b!) (a color-a int:set-color-a!)) -;; Get a raylib color vector from a color +;; Get a raylib color vec from a color (define (use-color col) (assert (color? col)) (u8vector (floor (* 255 (color-r col))) @@ -233,9 +78,9 @@ ;; Type safe constructor (define (make-screen-transform position pivot rotation scale anchor parent) - (assert (vector2? position)) + (assert (vec2? position)) (assert (real? rotation)) - (assert (vector2? scale)) + (assert (vec2? scale)) (assert (and (symbol? anchor) (member anchor '(top-left top-middle top-right center-left center center-right bottom-left bottom-middle bottom-right)))) @@ -255,7 +100,7 @@ (define (set-position! component position) (assert (record? component)) (cond - ((screen-transform? component) (assert (vector2? position)))) + ((screen-transform? component) (assert (vec2? position)))) ((rtd-mutator (record-rtd component) 'position) component position)) (define (pivot component) @@ -265,7 +110,7 @@ (define (set-pivot! component pivot) (assert (record? component)) (cond - ((screen-transform? component) (assert (vector2? pivot)))) + ((screen-transform? component) (assert (vec2? pivot)))) ((rtd-mutator (record-rtd component) 'pivot) component pivot)) (define (rotation component) @@ -285,7 +130,7 @@ (define (set-scale! component scale) (assert (record? component)) (cond - ((screen-transform? component) (assert (vector2? scale)))) + ((screen-transform? component) (assert (vec2? scale)))) ((rtd-mutator (record-rtd component) 'scale) component scale)) (define (anchor component) @@ -323,11 +168,11 @@ (position pixel-2d-position int:set-pixel-2d-position!)) (define (make-pixel-2d position) - (assert (vector2? position)) + (assert (vec2? position)) (int:make-pixel-2d position)) (define set-pixel-2d-position! - (guarded-mutator pixel-2d? 'position vector2?)) + (guarded-mutator pixel-2d? 'position vec2?)) (export line-2d? make-line-2d line-2d-start-pos set-line-2d-start-pos! line-2d-end-pos set-line-2d-end-pos! @@ -340,15 +185,15 @@ (thickness line-2d-thickness int:set-line-2d-thickness!)) (define (make-line-2d start-pos end-pos thickness) - (assert (vector2? start-pos)) - (assert (vector2? end-pos)) + (assert (vec2? start-pos)) + (assert (vec2? end-pos)) (assert ((conjoin integer? positive?) thickness)) (int:make-line-2d start-pos end-pos thickness)) (define set-line-2d-start-pos! - (guarded-mutator line-2d? 'start-pos vector2?)) + (guarded-mutator line-2d? 'start-pos vec2?)) (define set-line-2d-end-pos! - (guarded-mutator line-2d? 'end-pos vector2?)) + (guarded-mutator line-2d? 'end-pos vec2?)) (define set-line-2d-thickness! (guarded-mutator line-2d? 'start-pos (conjoin integer? positive?))) @@ -363,13 +208,13 @@ (filled circle-2d-filled? int:set-circle-2d-filled!)) (define (make-circle-2d center radius filled) - (assert (vector2? center)) + (assert (vec2? center)) (assert ((conjoin integer? positive?) radius)) (assert (boolean? filled)) (int:make-circle-2d center radius filled)) (define set-circle-2d-center! - (guarded-mutator circle-2d? 'center vector2?)) + (guarded-mutator circle-2d? 'center vec2?)) (define set-circle-2d-radius! (guarded-mutator circle-2d? 'radius (conjoin integer? positive?))) (define set-circle-2d-filled! @@ -390,7 +235,7 @@ (thickness rectangle-2d-thickness int:set-rectangle-2d-thickness)) (define (make-rectangle-2d origin width height filled thickness) - (assert (vector2? origin)) + (assert (vec2? origin)) (assert ((conjoin integer? positive?) width)) (assert ((conjoin integer? positive?) height)) (assert (boolean? filled)) @@ -398,7 +243,7 @@ (int:make-rectangle-2d origin width height filled thickness)) (define set-rectangle-2d-origin! - (guarded-mutator rectangle-2d? 'origin vector2?)) + (guarded-mutator rectangle-2d? 'origin vec2?)) (define set-rectangle-2d-width! (guarded-mutator rectangle-2d? 'width (conjoin integer? positive?))) (define set-rectangle-2d-height! @@ -420,18 +265,18 @@ (filled triangle-2d-filled? int:set-triangle-2d-filled!)) (define (make-triangle-2d vertex-1 vertex-2 vertex-3 filled) - (assert (vector2? vertex-1)) - (assert (vector2? vertex-2)) - (assert (vector2? vertex-3)) + (assert (vec2? vertex-1)) + (assert (vec2? vertex-2)) + (assert (vec2? vertex-3)) (assert (boolean? filled)) (int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled)) (define set-triangle-2d-vertex-1! - (guarded-mutator triangle-2d? 'vertex-1 vector2?)) + (guarded-mutator triangle-2d? 'vertex-1 vec2?)) (define set-triangle-2d-vertex-2! - (guarded-mutator triangle-2d? 'vertex-2 vector2?)) + (guarded-mutator triangle-2d? 'vertex-2 vec2?)) (define set-triangle-2d-vertex-3! - (guarded-mutator triangle-2d? 'vertex-3 vector2?)) + (guarded-mutator triangle-2d? 'vertex-3 vec2?)) (define set-triangle-2d-filled! (guarded-mutator triangle-2d? 'filled boolean?)) diff --git a/engine/math.scm b/engine/math.scm index e4f608d..ead9b9b 100644 --- a/engine/math.scm +++ b/engine/math.scm @@ -1,7 +1,9 @@ (module (engine math) () (import scheme (chicken base) - (chicken module)) + (chicken module) + (srfi 1) + (srfi 99)) (export PI PI/2) (define PI @@ -24,4 +26,157 @@ ;; Approximately equal - for real number comparison (define (approx-= x y) (< (abs (- x y)) (*float-precision*))) + +;; Vector exports +(export vec vec? vec2? v-x + set-v-x! v-y set-v-y!) + +;; 2D Vector type +;; TODO: this could be done with a macro to save some definitions +(define-record-type + (int:make-vector2 x y) + vec2? + (x vector2-x int:set-vector2-x!) + (y vector2-y int:set-vector2-y!)) + +;; Type safe 2D vector constructor +(define (vec . args) + (assert (every number? args)) + (apply (case (length args) + ((2) int:make-vector2)) + args)) + +(define vec? + (disjoin vec2?)) + +;; Vector utility functions +(define (v-x component) + (assert (record? component)) + ((rtd-accessor (record-rtd component) 'x) component)) + +(define (set-v-x! component x) + (assert (record? component)) + (assert (number? x)) + ((rtd-mutator (record-rtd component) 'x) component x)) + +(define (v-y component) + (assert (record? component)) + ((rtd-accessor (record-rtd component) 'y) component)) + +(define (set-v-y! component y) + (assert (record? component)) + (assert (number? y)) + ((rtd-mutator (record-rtd component) 'y) component y)) + +;; Vector operations +(export v= v+ v- v* v/) + +;; Vector equality +(define (v= . vecs) + (assert (every record? vecs)) + (assert (every vec? vecs)) + (assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs))))) + (map (compose rtd-name record-rtd) vecs))) + (and (apply = (map v-x vecs)) + (apply = (map v-y vecs)))) + +;; Vector addition +;; Note that each operand can be either a vector OR a number +;; If a number, that number is added to EVERY member of the vector +(define (v+ . operands) + (assert (every (disjoin number? (conjoin record? vec?)) operands)) + (let ((vecs (filter vec? operands))) + (assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs))))) + (map (compose rtd-name record-rtd) vecs)))) + (let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands)) + (y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands))) + (vec (apply + x-parts) + (apply + y-parts)))) + +;; Vector subtractions +;; Note that each operand can be either a vector OR a number +;; If a number, that number is subtracted from EVERY member of the vector +(define (v- . operands) + (assert (every (disjoin number? (conjoin record? vec?)) operands)) + (let ((vecs (filter vec? operands))) + (assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs))))) + (map (compose rtd-name record-rtd) vecs)))) + (let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands)) + (y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands))) + (vec (apply - x-parts) + (apply - y-parts)))) + +;; Vector multiplication +;; Note that each operand can be either a vector OR a number +;; If a number, that number is multiplied to EVERY member of the vector +(define (v* . operands) + (assert (every (disjoin number? (conjoin record? vec?)) operands)) + (let ((vecs (filter vec? operands))) + (assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs))))) + (map (compose rtd-name record-rtd) vecs)))) + (let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands)) + (y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands))) + (vec (apply * x-parts) + (apply * y-parts)))) + +;; Vector division +;; Note that each operand can be either a vector OR a number +;; If a number, EVERY member of the vector is divided by that number +(define (v/ . operands) + (assert (every (disjoin number? (conjoin record? vec?)) operands)) + (let ((vecs (filter vec? operands))) + (assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs))))) + (map (compose rtd-name record-rtd) vecs)))) + (let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands)) + (y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands))) + (vec (apply / x-parts) + (apply / y-parts)))) + +;; More complex vector functions +(export vector-magnitude vector-normalize vector-dot + vector-angle-between) + +;; Magnitude +(define (vector-magnitude vec) + (assert ((disjoin vec2?) vec)) + (cond + ((vec2? vec) + (sqrt (+ (expt (v-x vec) 2) + (expt (v-y vec) 2)))))) + +;; Dot product of vectors +(define (vector-dot vec1 vec2) + (assert (and (record? vec1) + (record? vec2))) + (assert (eq? (rtd-name (record-rtd vec1)) + (rtd-name (record-rtd vec2)))) + (assert ((disjoin vec2?) vec1)) + (cond + ((vec2? vec1) + (+ (* (v-x vec1) (v-x vec2)) + (* (v-y vec1) (v-y vec2)))))) + +;; Angle between vectors +(define (vector-angle-between vec1 vec2) + (assert (and (record? vec1) + (record? vec2))) + (assert (eq? (rtd-name (record-rtd vec1)) + (rtd-name (record-rtd vec2)))) + (assert ((disjoin vec2?) vec1)) + (cond + ((vec2? vec1) + (acos (/ (vector-dot vec1 vec2) + (* (vector-magnitude vec1) + (vector-magnitude vec2))))))) + +;; Normalization +(define (vector-normalize v) + (assert ((disjoin vec2?) v)) ;; TODO: This assertion should be moved out of here + (let ((magnitude (vector-magnitude v))) + (cond + ((vec2? v) + (vec (/ (v-x v) + magnitude) + (/ (v-y v) + magnitude)))))) ) diff --git a/samples/bounce.scm b/samples/bounce.scm index a6b9e91..4543a4c 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -4,6 +4,7 @@ raylib (engine core) (engine components core) + (engine math) (srfi 1) (srfi 99)) @@ -28,8 +29,8 @@ ((if (circle-2d-filled? circle) draw-circle draw-circle-lines) - (vector-x draw-pos) - (vector-y draw-pos) + (v-x draw-pos) + (v-y draw-pos) (circle-2d-radius circle) (visual-2d-color vis-2d)))))))))) @@ -39,7 +40,7 @@ rigidbody-2d? (velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!)) -(define +gravity+ (vector 0 9.8)) +(define +gravity+ (vec 0 9.8)) (define +friction+ -0.1) (add-system @@ -59,10 +60,10 @@ 'entity '( ) (lambda (_ rbody transform) - (when (> (vector-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) + (when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) (set-rigidbody-2d-velocity! rbody (v* (rigidbody-2d-velocity rbody) - (vector 1 -1))))))) + (vec 1 -1))))))) (add-system (make-system 'apply-wall-bounce @@ -70,11 +71,11 @@ 'entity '( ) (lambda (_ rbody transform) - (when (or (> (vector-x (position transform)) (- (car (*window-size*)) +ball-radius+)) - (< (vector-x (position transform)) (+ 0 +ball-radius+))) + (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) - (vector -1 1))))))) + (vec -1 1))))))) (add-system (make-system 'apply-friction @@ -115,30 +116,30 @@ (create-entity (make-visual-2d (make-circle-2d - (vector 0 0) + (vec 0 0) +ball-radius+ #t) color 0) (make-screen-transform position - (vector 0 0) + (vec 0 0) 0 - (vector 1 1) + (vec 1 1) 'center 'none) (make-rigidbody-2d velocity))) -(make-ball (vector 100 100) - (vector 5 1) +(make-ball (vec 100 100) + (vec 5 1) (make-color 0 0 1 1)) -(make-ball (vector 300 300) - (vector -2 -2) +(make-ball (vec 300 300) + (vec -2 -2) (make-color 0 1 0 1)) -(make-ball (vector 600 600) - (vector -2 -2) +(make-ball (vec 600 600) + (vec -2 -2) (make-color 1 0 0 1)) (create-window) diff --git a/test/components.scm b/test/components.scm index d297f0e..317ab9c 100644 --- a/test/components.scm +++ b/test/components.scm @@ -7,24 +7,24 @@ (srfi 78) (srfi 99)) -(define v1 (make-vector2 0 0)) -(define v2 (make-vector2 10 10)) +(define v1 (vec 0 0)) +(define v2 (vec 10 10)) -(check (vector-= v2 (make-vector2 10 10)) => #t) -(check (vector-= (make-vector2 20 20) - (vector-+ v2 (make-vector2 10 10))) => #t) -(check (vector-= v1 - (vector-- v2 (make-vector2 10 10))) => #t) -(check (vector-= (make-vector2 100 100) - (vector-* v2 (make-vector2 10 10))) => #t) -(check (vector-= (make-vector2 1 1) - (vector-/ v2 (make-vector2 10 10))) => #t) -(check (vector-magnitude (make-vector2 100 0)) => 100) -(check (vector-= (make-vector2 1 0) - (vector-normalize (make-vector2 100 0))) => #t) -(check (vector-dot (make-vector2 1 2) - (make-vector2 3 4)) => 11) +(check (v= v2 (vec 10 10)) => #t) +(check (v= (vec 20 20) + (v+ v2 (vec 10 10))) => #t) +(check (v= v1 + (v- v2 (vec 10 10))) => #t) +(check (v= (vec 100 100) + (v* v2 (vec 10 10))) => #t) +(check (v= (vec 1 1) + (v/ v2 (vec 10 10))) => #t) +(check (vector-magnitude (vec 100 0)) => 100) +(check (v= (vec 1 0) + (vector-normalize (vec 100 0))) => #t) +(check (vector-dot (vec 1 2) + (vec 3 4)) => 11) (check (rad-to-deg - (vector-angle-between (make-vector2 1 2) - (make-vector2 3 4))) (=> approx-=) 10.305) + (vector-angle-between (vec 1 2) + (vec 3 4))) (=> approx-=) 10.305) ) -- 2.47.3 From 5f95f1f527d0a38ec2dfffb342116c53f706d4c4 Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 22:33:24 +0800 Subject: [PATCH 09/14] Temporarily revert rendering change so we have a working example --- samples/bounce.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/samples/bounce.scm b/samples/bounce.scm index 4543a4c..b42298d 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -29,10 +29,10 @@ ((if (circle-2d-filled? circle) draw-circle draw-circle-lines) - (v-x draw-pos) - (v-y draw-pos) + (inexact->exact (round (v-x draw-pos))) + (inexact->exact (round (v-y draw-pos))) (circle-2d-radius circle) - (visual-2d-color vis-2d)))))))))) + (use-color (visual-2d-color vis-2d))))))))))) (define-record-type @@ -134,11 +134,11 @@ (vec 5 1) (make-color 0 0 1 1)) -(make-ball (vec 300 300) +(make-ball (vec 200 200) (vec -2 -2) (make-color 0 1 0 1)) -(make-ball (vec 600 600) +(make-ball (vec 300 300) (vec -2 -2) (make-color 1 0 0 1)) -- 2.47.3 From da164ae3c4c3fbf6c000b0bb49bc915e734022f7 Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 22:38:59 +0800 Subject: [PATCH 10/14] Fix action registration --- engine/core.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/engine/core.scm b/engine/core.scm index db9d9a4..f4a43cc 100644 --- a/engine/core.scm +++ b/engine/core.scm @@ -371,7 +371,7 @@ (assert (symbol? name)) (assert (member type '(key-press))) (set! input-actions - (cons (list name + (cons (cons name (apply (cond ((eqv? type 'key-press) make-key-press)) data)) @@ -389,9 +389,10 @@ (lambda (action) (cond ((key-press? (cdr action)) - (push-event 'input - (car action) - (cdr action))))) + (when (key-pressed? (key-press-key (cdr action))) + (push-event 'input + (car action) + (cdr action)))))) input-actions)))) ;; Render queue exports -- 2.47.3 From 04e3ec5fa62670c16efffd3aad6f393d2629728a Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 22:41:30 +0800 Subject: [PATCH 11/14] Ensure boost acts on all balls --- samples/bounce.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/samples/bounce.scm b/samples/bounce.scm index b42298d..b35bb39 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -107,11 +107,19 @@ 'entity '() (lambda (_ rbody) - (when (pop-event 'input 'boost) + (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 (make-ball position velocity color) (create-entity (make-visual-2d -- 2.47.3 From 8c48d4ee424690c3e232720cf979de7196d90773 Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Fri, 17 Apr 2026 22:44:22 +0800 Subject: [PATCH 12/14] Undo the rendering wrapper so it can be moved out --- samples/bounce.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/samples/bounce.scm b/samples/bounce.scm index b35bb39..97f1d23 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -29,10 +29,10 @@ ((if (circle-2d-filled? circle) draw-circle draw-circle-lines) - (inexact->exact (round (v-x draw-pos))) - (inexact->exact (round (v-y draw-pos))) + (v-x draw-pos) + (v-y draw-pos) (circle-2d-radius circle) - (use-color (visual-2d-color vis-2d))))))))))) + (visual-2d-color vis-2d)))))))))) (define-record-type -- 2.47.3 From 69dd991ab9ecdde1f6c846fbe5f5676bb2a4193f Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Sat, 18 Apr 2026 09:05:31 +0800 Subject: [PATCH 13/14] Move drawing code to it's own module and simplify draw interface --- engine/components.scm | 207 ++----------------------------------- engine/drawing.scm | 230 ++++++++++++++++++++++++++++++++++++++++++ engine/math.scm | 6 ++ samples/bounce.scm | 11 +- 4 files changed, 247 insertions(+), 207 deletions(-) create mode 100644 engine/drawing.scm diff --git a/engine/components.scm b/engine/components.scm index d68e07a..54b220d 100644 --- a/engine/components.scm +++ b/engine/components.scm @@ -2,65 +2,12 @@ (import scheme (chicken base) (chicken module) + (engine core) (engine guards) (engine math) (srfi 1) - (srfi 4) (srfi 99)) -;; Color exports -(export make-color use-color color-r color-g color-b color-a - set-color-r! set-color-g! set-color-b! set-color-a!) - -;; Color type -(define-record-type - (int:make-color r g b a) - color? - (r color-r int:set-color-r!) - (g color-g int:set-color-g!) - (b color-b int:set-color-b!) - (a color-a int:set-color-a!)) - -;; Get a raylib color vec from a color -(define (use-color col) - (assert (color? col)) - (u8vector (floor (* 255 (color-r col))) - (floor (* 255 (color-g col))) - (floor (* 255 (color-b col))) - (floor (* 255 (color-a col))))) - -;; 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))) - (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))) - (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))) - (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))) - (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))) - (int:set-color-a! color a)) - ;; Screen transform record and exports (export make-screen-transform screen-transform?) @@ -84,7 +31,7 @@ (assert (and (symbol? anchor) (member anchor '(top-left top-middle top-right center-left center center-right bottom-left bottom-middle bottom-right)))) - (assert (and (symbol? parent))) + (assert (or (null? parent) (screen-transform? parent))) (int:make-screen-transform position pivot rotation scale anchor parent)) ;; Generic accessors and mutators for position, rotation, scale, anchor, and parent @@ -95,7 +42,10 @@ (define (position component) (assert (record? component)) - ((rtd-accessor (record-rtd component) 'position) component)) + (if (null? (parent component)) + ((rtd-accessor (record-rtd component) 'position) component) + (v+ ((rtd-accessor (record-rtd component) 'position) component) + (position (parent component))))) (define (set-position! component position) (assert (record? component)) @@ -157,149 +107,4 @@ ((screen-transform? component) (assert (symbol? anchor)))) ((rtd-mutator (record-rtd component) 'parent) component parent)) - -;; Visuals -;; Primitive shape visual types -(export pixel-2d? make-pixel-2d - pixel-2d-position set-pixel-2d-position!) -(define-record-type - (int:make-pixel-2d position) - pixel-2d? - (position pixel-2d-position int:set-pixel-2d-position!)) - -(define (make-pixel-2d position) - (assert (vec2? position)) - (int:make-pixel-2d position)) - -(define set-pixel-2d-position! - (guarded-mutator pixel-2d? 'position vec2?)) - -(export line-2d? make-line-2d line-2d-start-pos - set-line-2d-start-pos! line-2d-end-pos set-line-2d-end-pos! - line-2d-thickness set-line-2d-thickness!) -(define-record-type - (int:make-line-2d start-pos end-pos thickness) - line-2d? - (start-pos line-2d-start-pos int:set-line-2d-start-pos!) - (end-pos line-2d-end-pos int:set-line-2d-end-pos!) - (thickness line-2d-thickness int:set-line-2d-thickness!)) - -(define (make-line-2d start-pos end-pos thickness) - (assert (vec2? start-pos)) - (assert (vec2? end-pos)) - (assert ((conjoin integer? positive?) thickness)) - (int:make-line-2d start-pos end-pos thickness)) - -(define set-line-2d-start-pos! - (guarded-mutator line-2d? 'start-pos vec2?)) -(define set-line-2d-end-pos! - (guarded-mutator line-2d? 'end-pos vec2?)) -(define set-line-2d-thickness! - (guarded-mutator line-2d? 'start-pos (conjoin integer? positive?))) - -(export circle-2d? make-circle-2d circle-2d-center - set-circle-2d-center! circle-2d-radius set-circle-2d-radius! - circle-2d-filled? set-circle-2d-filled!) -(define-record-type - (int:make-circle-2d center radius filled) - circle-2d? - (center circle-2d-center int:set-circle-2d-center!) - (radius circle-2d-radius int:set-circle-2d-radius!) - (filled circle-2d-filled? int:set-circle-2d-filled!)) - -(define (make-circle-2d center radius filled) - (assert (vec2? center)) - (assert ((conjoin integer? positive?) radius)) - (assert (boolean? filled)) - (int:make-circle-2d center radius filled)) - -(define set-circle-2d-center! - (guarded-mutator circle-2d? 'center vec2?)) -(define set-circle-2d-radius! - (guarded-mutator circle-2d? 'radius (conjoin integer? positive?))) -(define set-circle-2d-filled! - (guarded-mutator circle-2d? 'filled boolean?)) - -;; TODO: might be nicer to have the origin and width/height inside a rect-2d type or similar -(export rectangle-2d? make-rectangle-2d rectangle-2d-origin - set-rectangle-2d-origin! rectangle-2d-width set-rectangle-2d-width! - rectangle-2d-height set-rectangle-2d-height! rectangle-2d-filled? - set-rectangle-2d-filled! rectangle-2d-thickness set-rectangle-2d-thickness!) -(define-record-type - (int:make-rectangle-2d origin width height filled thickness) - rectangle-2d? - (origin rectangle-2d-origin int:set-rectangle-2d-origin!) - (width rectangle-2d-width int:set-rectangle-2d-width!) - (height rectangle-2d-height int:set-rectangle-2d-height!) - (filled rectangle-2d-filled? int:set-rectangle-2d-filled!) - (thickness rectangle-2d-thickness int:set-rectangle-2d-thickness)) - -(define (make-rectangle-2d origin width height filled thickness) - (assert (vec2? origin)) - (assert ((conjoin integer? positive?) width)) - (assert ((conjoin integer? positive?) height)) - (assert (boolean? filled)) - (assert ((conjoin integer? positive?) thickness)) - (int:make-rectangle-2d origin width height filled thickness)) - -(define set-rectangle-2d-origin! - (guarded-mutator rectangle-2d? 'origin vec2?)) -(define set-rectangle-2d-width! - (guarded-mutator rectangle-2d? 'width (conjoin integer? positive?))) -(define set-rectangle-2d-height! - (guarded-mutator rectangle-2d? 'height (conjoin integer? positive?))) -(define set-rectangle-2d-filled! - (guarded-mutator rectangle-2d? 'filled boolean?)) -(define set-rectangle-2d-thickness! - (guarded-mutator rectangle-2d? 'thickness (conjoin integer? positive?))) - -(export triangle-2d? make-triangle-2d triangle-2d-vertex-1 - set-triangle-2d-vertex-1! triangle-2d-vertex-2 set-triangle-2d-vertex-2! - triangle-2d-vertex-3 set-triangle-2d-vertex-3! triangle-2d-filled? set-triangle-2d-filled!) -(define-record-type - (int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled) - triangle-2d? - (vertex-1 triangle-2d-vertex-1 int:set-triangle-2d-vertex-1!) - (vertex-2 triangle-2d-vertex-2 int:set-triangle-2d-vertex-2!) - (vertex-3 triangle-2d-vertex-3 int:set-triangle-2d-vertex-3!) - (filled triangle-2d-filled? int:set-triangle-2d-filled!)) - -(define (make-triangle-2d vertex-1 vertex-2 vertex-3 filled) - (assert (vec2? vertex-1)) - (assert (vec2? vertex-2)) - (assert (vec2? vertex-3)) - (assert (boolean? filled)) - (int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled)) - -(define set-triangle-2d-vertex-1! - (guarded-mutator triangle-2d? 'vertex-1 vec2?)) -(define set-triangle-2d-vertex-2! - (guarded-mutator triangle-2d? 'vertex-2 vec2?)) -(define set-triangle-2d-vertex-3! - (guarded-mutator triangle-2d? 'vertex-3 vec2?)) -(define set-triangle-2d-filled! - (guarded-mutator triangle-2d? 'filled boolean?)) - -;; Visual component -(export visual-2d? make-visual-2d visual-2d-draw set-visual-2d-draw! - visual-2d-color set-visual-2d-color! visual-2d-layer set-visual-2d-layer!) -(define-record-type - (int:make-visual-2d draw color layer) - visual-2d? - (draw visual-2d-draw int:set-visual-2d-draw!) ;; NOTE: Typing here: pixel-2d, line-2d, circle-2d, rectangle-2d, triangle-2d etc - (color visual-2d-color int:set-visual-2d-color!) - (layer visual-2d-layer int:set-visual-2d-layer!)) - -(define (make-visual-2d draw color layer) - (assert ((disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?) draw)) - (assert (color? color)) - (assert (integer? layer)) - (int:make-visual-2d draw color layer)) - -(define set-visual-2d-draw! - (guarded-mutator visual-2d? 'draw (disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?))) -(define set-visual-2d-color! - (guarded-mutator visual-2d? 'color color?)) -(define set-visual-2d-layer! - (guarded-mutator visual-2d? 'layer integer?)) ) diff --git a/engine/drawing.scm b/engine/drawing.scm new file mode 100644 index 0000000..758ac5d --- /dev/null +++ b/engine/drawing.scm @@ -0,0 +1,230 @@ +(module (engine drawing) () +(import scheme + (chicken base) + (chicken module) + raylib + (engine guards) + (engine math) + (srfi 4) + (srfi 99)) + +;; Color exports +(export make-color color-r color-g color-b color-a + set-color-r! set-color-g! set-color-b! set-color-a!) + +;; Color type +(define-record-type + (int:make-color r g b a) + color? + (r color-r int:set-color-r!) + (g color-g int:set-color-g!) + (b color-b int:set-color-b!) + (a color-a int:set-color-a!)) + +;; Get a raylib color vec from a color +(define (use-color col) + (assert (color? col)) + (u8vector (floor (* 255 (color-r col))) + (floor (* 255 (color-g col))) + (floor (* 255 (color-b col))) + (floor (* 255 (color-a col))))) + +;; 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))) + (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))) + (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))) + (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))) + (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))) + (int:set-color-a! color a)) + + +;; Visuals +;; Primitive shape visual types +;; Pixel +(export pixel-2d? make-pixel-2d + pixel-2d-position set-pixel-2d-position!) +(define-record-type + (int:make-pixel-2d position) + pixel-2d? + (position pixel-2d-position int:set-pixel-2d-position!)) + +(define (make-pixel-2d position) + (assert (vec2? position)) + (int:make-pixel-2d position)) + +(define set-pixel-2d-position! + (guarded-mutator pixel-2d? 'position vec2?)) + +;; Line2D +(export line-2d? make-line-2d line-2d-start-pos + set-line-2d-start-pos! line-2d-end-pos set-line-2d-end-pos! + line-2d-thickness set-line-2d-thickness!) +(define-record-type + (int:make-line-2d start-pos end-pos thickness) + line-2d? + (start-pos line-2d-start-pos int:set-line-2d-start-pos!) + (end-pos line-2d-end-pos int:set-line-2d-end-pos!) + (thickness line-2d-thickness int:set-line-2d-thickness!)) + +(define (make-line-2d start-pos end-pos thickness) + (assert (vec2? start-pos)) + (assert (vec2? end-pos)) + (assert ((conjoin integer? positive?) thickness)) + (int:make-line-2d start-pos end-pos thickness)) + +(define set-line-2d-start-pos! + (guarded-mutator line-2d? 'start-pos vec2?)) +(define set-line-2d-end-pos! + (guarded-mutator line-2d? 'end-pos vec2?)) +(define set-line-2d-thickness! + (guarded-mutator line-2d? 'start-pos (conjoin integer? positive?))) + +;; Circle2D +(export circle-2d? make-circle-2d circle-2d-center + set-circle-2d-center! circle-2d-radius set-circle-2d-radius! + circle-2d-filled? set-circle-2d-filled!) +(define-record-type + (int:make-circle-2d center radius filled) + circle-2d? + (center circle-2d-center int:set-circle-2d-center!) + (radius circle-2d-radius int:set-circle-2d-radius!) + (filled circle-2d-filled? int:set-circle-2d-filled!)) + +(define (make-circle-2d center radius filled) + (assert (vec2? center)) + (assert ((conjoin integer? positive?) radius)) + (assert (boolean? filled)) + (int:make-circle-2d center radius filled)) + +(define set-circle-2d-center! + (guarded-mutator circle-2d? 'center vec2?)) +(define set-circle-2d-radius! + (guarded-mutator circle-2d? 'radius (conjoin integer? positive?))) +(define set-circle-2d-filled! + (guarded-mutator circle-2d? 'filled boolean?)) + +;; Rectangle2D +;; TODO: might be nicer to have the origin and width/height inside a rect-2d type or similar +(export rectangle-2d? make-rectangle-2d rectangle-2d-origin + set-rectangle-2d-origin! rectangle-2d-width set-rectangle-2d-width! + rectangle-2d-height set-rectangle-2d-height! rectangle-2d-filled? + set-rectangle-2d-filled! rectangle-2d-thickness set-rectangle-2d-thickness!) +(define-record-type + (int:make-rectangle-2d origin width height filled thickness) + rectangle-2d? + (origin rectangle-2d-origin int:set-rectangle-2d-origin!) + (width rectangle-2d-width int:set-rectangle-2d-width!) + (height rectangle-2d-height int:set-rectangle-2d-height!) + (filled rectangle-2d-filled? int:set-rectangle-2d-filled!) + (thickness rectangle-2d-thickness int:set-rectangle-2d-thickness)) + +(define (make-rectangle-2d origin width height filled thickness) + (assert (vec2? origin)) + (assert ((conjoin integer? positive?) width)) + (assert ((conjoin integer? positive?) height)) + (assert (boolean? filled)) + (assert ((conjoin integer? positive?) thickness)) + (int:make-rectangle-2d origin width height filled thickness)) + +(define set-rectangle-2d-origin! + (guarded-mutator rectangle-2d? 'origin vec2?)) +(define set-rectangle-2d-width! + (guarded-mutator rectangle-2d? 'width (conjoin integer? positive?))) +(define set-rectangle-2d-height! + (guarded-mutator rectangle-2d? 'height (conjoin integer? positive?))) +(define set-rectangle-2d-filled! + (guarded-mutator rectangle-2d? 'filled boolean?)) +(define set-rectangle-2d-thickness! + (guarded-mutator rectangle-2d? 'thickness (conjoin integer? positive?))) + +;; Triangle2D +(export triangle-2d? make-triangle-2d triangle-2d-vertex-1 + set-triangle-2d-vertex-1! triangle-2d-vertex-2 set-triangle-2d-vertex-2! + triangle-2d-vertex-3 set-triangle-2d-vertex-3! triangle-2d-filled? set-triangle-2d-filled!) +(define-record-type + (int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled) + triangle-2d? + (vertex-1 triangle-2d-vertex-1 int:set-triangle-2d-vertex-1!) + (vertex-2 triangle-2d-vertex-2 int:set-triangle-2d-vertex-2!) + (vertex-3 triangle-2d-vertex-3 int:set-triangle-2d-vertex-3!) + (filled triangle-2d-filled? int:set-triangle-2d-filled!)) + +(define (make-triangle-2d vertex-1 vertex-2 vertex-3 filled) + (assert (vec2? vertex-1)) + (assert (vec2? vertex-2)) + (assert (vec2? vertex-3)) + (assert (boolean? filled)) + (int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled)) + +(define set-triangle-2d-vertex-1! + (guarded-mutator triangle-2d? 'vertex-1 vec2?)) +(define set-triangle-2d-vertex-2! + (guarded-mutator triangle-2d? 'vertex-2 vec2?)) +(define set-triangle-2d-vertex-3! + (guarded-mutator triangle-2d? 'vertex-3 vec2?)) +(define set-triangle-2d-filled! + (guarded-mutator triangle-2d? 'filled boolean?)) + +;; Visual component +(export visual-2d? make-visual-2d visual-2d-draw set-visual-2d-draw! + visual-2d-color set-visual-2d-color! visual-2d-layer set-visual-2d-layer!) +(define-record-type + (int:make-visual-2d draw color layer) + visual-2d? + (draw visual-2d-draw int:set-visual-2d-draw!) ;; NOTE: Typing here: pixel-2d, line-2d, circle-2d, rectangle-2d, triangle-2d etc + (color visual-2d-color int:set-visual-2d-color!) + (layer visual-2d-layer int:set-visual-2d-layer!)) + +(define (make-visual-2d draw color layer) + (assert ((disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?) draw)) + (assert (color? color)) + (assert (integer? layer)) + (int:make-visual-2d draw color layer)) + +(define set-visual-2d-draw! + (guarded-mutator visual-2d? 'draw (disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?))) +(define set-visual-2d-color! + (guarded-mutator visual-2d? 'color color?)) +(define set-visual-2d-layer! + (guarded-mutator visual-2d? 'layer integer?)) + +;; Drawing functions +;; Helper wrappers for raylib functions +(export draw-circle-2d) +(define (draw-circle-2d pos-vec radius color filled) + (assert (vec2? pos-vec)) + (assert (number? radius)) + (assert (color? color)) + (assert (boolean? filled)) + ((if filled + draw-circle + draw-circle-2d) + (number->integer (v-x pos-vec)) + (number->integer (v-y pos-vec)) + (number->integer radius) + (use-color color))) +) diff --git a/engine/math.scm b/engine/math.scm index ead9b9b..ca82e91 100644 --- a/engine/math.scm +++ b/engine/math.scm @@ -27,6 +27,12 @@ (define (approx-= x y) (< (abs (- x y)) (*float-precision*))) +;; Somewhat reliable fixnum conversion +(export number->integer) +(define (number->integer number) + (assert (number? number)) + (inexact->exact (round number))) + ;; Vector exports (export vec vec? vec2? v-x set-v-x! v-y set-v-y!) diff --git a/samples/bounce.scm b/samples/bounce.scm index 97f1d23..7f84621 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -5,6 +5,7 @@ (engine core) (engine components core) (engine math) + (engine drawing) (srfi 1) (srfi 99)) @@ -26,13 +27,11 @@ (lambda () (let ((draw-pos (v+ (position transform) (circle-2d-center circle)))) - ((if (circle-2d-filled? circle) - draw-circle - draw-circle-lines) - (v-x draw-pos) - (v-y draw-pos) + (draw-circle-2d + draw-pos (circle-2d-radius circle) - (visual-2d-color vis-2d)))))))))) + (visual-2d-color vis-2d) + (circle-2d-filled? circle)))))))))) (define-record-type -- 2.47.3 From e7bfc01f7bafa34aa841949c5c9c3e6dc32f0d8e Mon Sep 17 00:00:00 2001 From: BirDt_ Date: Sat, 18 Apr 2026 09:07:16 +0800 Subject: [PATCH 14/14] Global and local position --- engine/components.scm | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/engine/components.scm b/engine/components.scm index 54b220d..87b12c8 100644 --- a/engine/components.scm +++ b/engine/components.scm @@ -37,15 +37,20 @@ ;; Generic accessors and mutators for position, rotation, scale, anchor, and parent ;; This allows us to abstract across different transform types - (position) will work for ;; screen-transform and 2D-transform, with type checking -(export position set-position! rotation set-rotation! scale set-scale! - anchor set-anchor! parent set-parent!) +(export global-position position set-position! rotation + set-rotation! scale set-scale! anchor set-anchor! + parent set-parent!) -(define (position component) +(define (global-position component) (assert (record? component)) (if (null? (parent component)) ((rtd-accessor (record-rtd component) 'position) component) (v+ ((rtd-accessor (record-rtd component) 'position) component) - (position (parent component))))) + (global-position (parent component))))) + +(define (position component) + (assert (record? component)) + ((rtd-accessor (record-rtd component) 'position) component)) (define (set-position! component position) (assert (record? component)) -- 2.47.3