BirDt/imugi
1
0
Fork 0
Code Issues 14 Pull requests Projects 1 Wiki Activity Actions

Pass requested entity components as arguments to 'entity systems

Browse source
This commit is contained in:
BirDt_ 2026-04-17 17:10:00 +08:00
parent d379cd28d7
commit b37f78330c
2 changed files with 57 additions and 58 deletions
Download patch file Download diff file Expand all files Collapse all files

12
engine/core.scm
View file

@ -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

39
samples/bounce.scm
View file

@ -17,9 +17,7 @@
0
'entity
'(<visual-2d> <screen-transform>)
(lambda (ball)
(let ((vis-2d (find visual-2d? ball))
(transform (find screen-transform? ball)))
(lambda (_ vis-2d transform)
(when (circle-2d? (visual-2d-draw vis-2d))
(let ((circle (visual-2d-draw vis-2d)))
(push-render-object 'screen
@ -33,7 +31,7 @@
(inexact->exact (round (+ (vector-y (position transform))
(vector-y (circle-2d-center circle)))))
(circle-2d-radius circle)
(use-color (visual-2d-color vis-2d)))))))))))
(use-color (visual-2d-color vis-2d))))))))))
(define-record-type <rigidbody-2d>
@ -49,64 +47,56 @@
0
'entity
'(<rigidbody-2d>)
(lambda (body)
(let ((rbody (find rigidbody-2d? body)))
(lambda (_ rbody)
(set-rigidbody-2d-velocity! rbody
(vector-+ (rigidbody-2d-velocity rbody)
(vector-*
(make-vector2 (get-frame-time)
(get-frame-time))
+gravity+)))))))
+gravity+))))))
(add-system
(make-system 'apply-bounce
1
'entity
'(<rigidbody-2d> <screen-transform>)
(lambda (ball)
(let ((rbody (find rigidbody-2d? ball))
(transform (find screen-transform? ball)))
(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))))))))))
(make-vector2 (vector-x (rigidbody-2d-velocity rbody)) (* -1 (vector-y (rigidbody-2d-velocity rbody)))))))))
(add-system
(make-system 'apply-wall-bounce
1
'entity
'(<rigidbody-2d> <screen-transform>)
(lambda (ball)
(let ((rbody (find rigidbody-2d? ball))
(transform (find screen-transform? ball)))
(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)))))))))
(make-vector2 (* -1 (vector-x (rigidbody-2d-velocity rbody))) (vector-y (rigidbody-2d-velocity rbody))))))))
(add-system
(make-system 'apply-friction
2
'entity
'(<rigidbody-2d>)
(lambda (ball)
(let ((rbody (find rigidbody-2d? ball)))
(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)))))))
(add-system
(make-system 'move-rigidbody
3
'entity
'(<rigidbody-2d> <screen-transform>)
(lambda (ball)
(let ((rbody (find rigidbody-2d? ball))
(transform (find screen-transform? ball)))
(lambda (_ rbody transform)
(set-position! transform
(vector-+ (rigidbody-2d-velocity rbody)
(position transform)))))))
(position transform))))))
(define-record-type <key-press>
(make-key-press key)
@ -127,12 +117,11 @@
2
'entity
'(<rigidbody-2d>)
(lambda (ball)
(let ((rbody (find rigidbody-2d? ball)))
(lambda (_ rbody)
(when (peek-event 'input 'boost)
(set-rigidbody-2d-velocity! rbody
(vector-* (make-vector2 2 2)
(rigidbody-2d-velocity rbody))))))))
(rigidbody-2d-velocity rbody)))))))
(add-system
(make-system 'clear-boost-input