Finish bouncing balls example

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))
+					     (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)))
+		  (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
+	      '(<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)))))))
+
 (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)
 )