imugi/samples/bounce.scm

(module (bounce) ()
(import scheme
	(chicken base)
	raylib
	(engine core)
	(engine components core)
	(srfi 1)
	(srfi 99))

(*window-title* "Bounce!")
(*target-fps* 60)

(define +ball-radius+ 50)

(add-system
 (make-system 'draw-circles
	      0
	      'entity
	      '(<visual-2d> <screen-transform>)
	      (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 <rigidbody-2d>
  (make-rigidbody-2d velocity)
  rigidbody-2d?
  (velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!))

(define +gravity+ (make-vector 0 9.8))
(define +friction+ -0.1)

(add-system
 (make-system 'apply-gravity
	      0
	      'entity
	      '(<rigidbody-2d>)
	      (lambda (_ rbody)
		(set-rigidbody-2d-velocity! rbody
					    (+ (rigidbody-2d-velocity rbody)
					       (* (get-frame-time)
						  +gravity+))))))

(add-system
 (make-system 'apply-bounce
	      1
	      'entity
	      '(<rigidbody-2d> <screen-transform>)
	      (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)))))))

(add-system
 (make-system 'apply-wall-bounce
	      1
	      'entity
	      '(<rigidbody-2d> <screen-transform>)
	      (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
					      (* (rigidbody-2d-velocity rbody)
						 (make-vector -1 1)))))))

(add-system
 (make-system 'apply-friction
	      2
	      'entity
	      '(<rigidbody-2d>)
	      (lambda (_ rbody)
		(set-rigidbody-2d-velocity! rbody
					    (+ (rigidbody-2d-velocity rbody)
					       (* (get-frame-time) +friction+
						  (rigidbody-2d-velocity rbody)))))))

(add-system
 (make-system 'move-rigidbody
	      3
	      'entity
	      '(<rigidbody-2d> <screen-transform>)
	      (lambda (_ rbody transform)
		(set-position! transform
			       (+ (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 (_ rbody)
		(when (peek-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))))

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

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

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

(create-window)
)