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))))))
+  (if (eqv? (system-mode system) 'global)
-    (cond 
+      ((system-process system))
-     ((eqv? (system-mode system) 'batch) ((system-process system) entities))
+      (let ((entities (map get-entity (set->list (apply query-by-components (system-criteria system))))))
-     ((eqv? (system-mode system) 'entity) (for-each (lambda (e) ((system-process system) e)) entities)))))
+	(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

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,125 @@
 					    ((if (circle-2d-filled? circle)
 						 draw-circle
 						 draw-circle-lines)
-					     (+ (vector-x (position transform))
+					     (inexact->exact (round (+ (vector-x (position transform))
-						(vector-x (circle-2d-center circle)))
+								       (vector-x (circle-2d-center circle)))))
-					     (+ (vector-y (position transform))
+					     (inexact->exact (round (+ (vector-y (position transform))
-						(vector-y (circle-2d-center circle)))
+								       (vector-y (circle-2d-center circle)))))
 					     (circle-2d-radius circle)
 					     (use-color (visual-2d-color vis-2d)))))))))))
 
 
+(define-record-type <rigidbody-2d>
+  (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
+	      '(<rigidbody-2d>)
+	      (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+)))))))
+
+(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)))
+		  (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
+	      '(<rigidbody-2d> <screen-transform>)
+	      (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
+	      '(<rigidbody-2d>)
+	      (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
+	      '(<rigidbody-2d> <screen-transform>)
+	      (lambda (ball)
+		(let ((rbody (find rigidbody-2d? ball))
+		      (transform (find screen-transform? ball)))
+		  (set-position! transform
+				 (vector-+ (rigidbody-2d-velocity rbody)
+					   (position transform)))))))
+
+(define-record-type <key-press>
+  (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
+	      '(<rigidbody-2d>)
+	      (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
    (make-vector2 0 0)
-   50
+   +ball-radius+
    #t)
   (make-color 0 0 1 1)
   0)
@@ -47,7 +156,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)
 )