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

Add scene structure #15

Merged
BirDt merged 1 commit from feature/scenes into master 2026-04-19 10:17:22 +08:00
Conversation 0 Commits 1 Files changed 3 +197 -115
3 changed files with 197 additions and 115 deletions
Download patch file Download diff file Expand all files Collapse all files

48
engine/core.scm
View file

@ -293,7 +293,7 @@
;; Event bus interface ;; Event bus interface
(export register-event-bus remove-event-bus fetch-event-bus (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 ;; Register a new event bus
(define (register-event-bus name) (define (register-event-bus name)
@ -315,6 +315,18 @@
name) name)
#f)) #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 ;; Fetch an event bus by name, or #f if it doesn't exist
(define (fetch-event-bus name) (define (fetch-event-bus name)
(assert (symbol? name)) (assert (symbol? name))
@ -366,7 +378,7 @@
(key key-press-key)) (key key-press-key))
;; Add a new action to the input actions alist ;; Add a new action to the input actions alist
(export register-action) (export register-action push-actions)
(define (register-action name type . data) (define (register-action name type . data)
(assert (symbol? name)) (assert (symbol? name))
(assert (member type '(key-press))) (assert (member type '(key-press)))
@ -378,22 +390,22 @@
input-actions))) input-actions)))
;; Default global system for simple input management ;; Default global system for simple input management
(add-system (define push-actions
(make-system (make-system
'push-actions 'push-actions
0 0
'global 'global
'() '()
(lambda () (lambda ()
(for-each (for-each
(lambda (action) (lambda (action)
(cond (cond
((key-press? (cdr action)) ((key-press? (cdr action))
(when (key-pressed? (key-press-key (cdr action))) (when (key-pressed? (key-press-key (cdr action)))
(push-event 'input (push-event 'input
(car action) (car action)
(cdr action)))))) (cdr action))))))
input-actions)))) input-actions))))
;; Render queue exports ;; Render queue exports
(export register-render-queue push-render-object evaluate-render-queue) (export register-render-queue push-render-object evaluate-render-queue)

42
engine/scene.scm Normal file
View file

@ -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 <entity>
(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))))
)

222
samples/bounce.scm
View file

@ -6,6 +6,7 @@
(engine components core) (engine components core)
(engine math) (engine math)
(engine drawing) (engine drawing)
(engine scene)
(srfi 1) (srfi 1)
(srfi 99)) (srfi 99))
@ -14,24 +15,24 @@
(define +ball-radius+ 50) (define +ball-radius+ 50)
(add-system (define draw-circles
(make-system 'draw-circles (make-system 'draw-circles
0 0
'entity 'entity
'(<visual-2d> <screen-transform>) '(<visual-2d> <screen-transform>)
(lambda (_ vis-2d transform) (lambda (_ vis-2d transform)
(when (circle-2d? (visual-2d-draw vis-2d)) (when (circle-2d? (visual-2d-draw vis-2d))
(let ((circle (visual-2d-draw vis-2d))) (let ((circle (visual-2d-draw vis-2d)))
(push-render-object 'screen (push-render-object 'screen
(visual-2d-layer vis-2d) (visual-2d-layer vis-2d)
(lambda () (lambda ()
(let ((draw-pos (v+ (position transform) (let ((draw-pos (v+ (position transform)
(circle-2d-center circle)))) (circle-2d-center circle))))
(draw-circle-2d (draw-circle-2d
draw-pos draw-pos
(circle-2d-radius circle) (circle-2d-radius circle)
(visual-2d-color vis-2d) (visual-2d-color vis-2d)
(circle-2d-filled? circle)))))))))) (circle-2d-filled? circle))))))))))
(define-record-type <rigidbody-2d> (define-record-type <rigidbody-2d>
@ -42,85 +43,96 @@
(define +gravity+ (vec 0 9.8)) (define +gravity+ (vec 0 9.8))
(define +friction+ -0.1) (define +friction+ -0.1)
(add-system (define apply-gravity
(make-system 'apply-gravity (make-system 'apply-gravity
0 0
'entity 'entity
'(<rigidbody-2d>) '(<rigidbody-2d>)
(lambda (_ rbody) (lambda (_ rbody)
(set-rigidbody-2d-velocity! rbody (set-rigidbody-2d-velocity! rbody
(v+ (rigidbody-2d-velocity rbody) (v+ (rigidbody-2d-velocity rbody)
(v* (get-frame-time) (v* (get-frame-time)
+gravity+)))))) +gravity+))))))
(add-system (define apply-bounce
(make-system 'apply-bounce (make-system 'apply-bounce
1 1
'entity 'entity
'(<rigidbody-2d> <screen-transform>) '(<rigidbody-2d> <screen-transform>)
(lambda (_ rbody transform) (lambda (_ rbody transform)
(when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) (when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+))
(set-rigidbody-2d-velocity! rbody (set-rigidbody-2d-velocity! rbody
(v* (rigidbody-2d-velocity rbody) (v* (rigidbody-2d-velocity rbody)
(vec 1 -1))))))) (vec 1 -1)))))))
(add-system (define apply-wall-bounce
(make-system 'apply-wall-bounce (make-system 'apply-wall-bounce
1 1
'entity 'entity
'(<rigidbody-2d> <screen-transform>) '(<rigidbody-2d> <screen-transform>)
(lambda (_ rbody transform) (lambda (_ rbody transform)
(when (or (> (v-x (position transform)) (- (car (*window-size*)) +ball-radius+)) (when (or (> (v-x (position transform)) (- (car (*window-size*)) +ball-radius+))
(< (v-x (position transform)) (+ 0 +ball-radius+))) (< (v-x (position transform)) (+ 0 +ball-radius+)))
(set-rigidbody-2d-velocity! rbody (set-rigidbody-2d-velocity! rbody
(v* (rigidbody-2d-velocity rbody) (v* (rigidbody-2d-velocity rbody)
(vec -1 1))))))) (vec -1 1)))))))
(add-system (define apply-friction
(make-system 'apply-friction (make-system 'apply-friction
2 2
'entity 'entity
'(<rigidbody-2d>) '(<rigidbody-2d>)
(lambda (_ rbody) (lambda (_ rbody)
(set-rigidbody-2d-velocity! rbody (set-rigidbody-2d-velocity! rbody
(v+ (rigidbody-2d-velocity rbody) (v+ (rigidbody-2d-velocity rbody)
(v* (get-frame-time) (v* (get-frame-time)
+friction+ +friction+
(rigidbody-2d-velocity rbody))))))) (rigidbody-2d-velocity rbody)))))))
(add-system (define move-rigidbody
(make-system 'move-rigidbody (make-system 'move-rigidbody
3 3
'entity 'entity
'(<rigidbody-2d> <screen-transform>) '(<rigidbody-2d> <screen-transform>)
(lambda (_ rbody transform) (lambda (_ rbody transform)
(set-position! transform (set-position! transform
(v+ (rigidbody-2d-velocity rbody) (v+ (rigidbody-2d-velocity rbody)
(position transform)))))) (position transform))))))
(register-action 'boost 'key-press KEY_SPACE) (register-action 'boost 'key-press KEY_SPACE)
(register-action 'reset 'key-press KEY_R)
(add-system (define boost-rigidbody
(make-system 'boost-rigidbody (make-system 'boost-rigidbody
2 2
'entity 'entity
'(<rigidbody-2d>) '(<rigidbody-2d>)
(lambda (_ rbody) (lambda (_ rbody)
(when (peek-event 'input 'boost) (when (peek-event 'input 'boost)
(set-rigidbody-2d-velocity! rbody (set-rigidbody-2d-velocity! rbody
(v* 2 (v* 2
(rigidbody-2d-velocity rbody))))))) (rigidbody-2d-velocity rbody)))))))
(add-system (define clear-boost
(make-system 'clear-boost (make-system 'clear-boost
4 4
'global 'global
'() '()
(lambda () (lambda ()
(pop-event 'input 'boost)))) (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) (define (make-ball position velocity color)
(create-entity (entity
(make-visual-2d (make-visual-2d
(make-circle-2d (make-circle-2d
(vec 0 0) (vec 0 0)
@ -134,20 +146,36 @@
0 0
(vec 1 1) (vec 1 1)
'center 'center
'none) '())
(make-rigidbody-2d velocity))) (make-rigidbody-2d velocity)))
(make-ball (vec 100 100) (*bounce-scene*
(vec 5 1) (lambda ()
(make-color 0 0 1 1)) (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 200 200) (make-ball (vec 100 100)
(vec -2 -2) (vec 5 1)
(make-color 0 1 0 1)) (make-color 0 0 1 1))
(make-ball (vec 300 300) (make-ball (vec 200 200)
(vec -2 -2) (vec -2 -2)
(make-color 1 0 0 1)) (make-color 0 1 0 1))
(make-ball (vec 300 300)
(vec -2 -2)
(make-color 1 0 0 1)))))
(((*bounce-scene*)))
(create-window) (create-window)
) )