imugi/samples/bounce.scm

(module (bounce) ()
(import scheme
	(chicken base)
	raylib
	(engine core)
	(engine components core)
	(engine math)
	(engine input)
	(engine drawing)
	(engine scene)
	(srfi 1)
	(srfi 99))

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

(define +ball-radius+ 50)

(define draw-circles
  (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 ()
					   (let ((draw-pos (v+ (position transform)
							       (circle-2d-center circle))))
					     (draw-circle-2d
					      draw-pos
					      (circle-2d-radius circle)
					      (visual-2d-color vis-2d)
					      (circle-2d-filled? circle))))))))))


(define-record-type <rigidbody-2d>
  (make-rigidbody-2d velocity)
  rigidbody-2d?
  (velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!))

(define +gravity+ (vec 0 9.8))
(define +friction+ -0.1)

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

(define apply-bounce
  (make-system 'apply-bounce
	       1
	       'entity
	       '(<rigidbody-2d> <screen-transform>)
	       (lambda (_ rbody transform)
		 (when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+))
		   (set-rigidbody-2d-velocity! rbody
					       (v* (rigidbody-2d-velocity rbody)
						   (vec 1 -1)))))))

(define apply-wall-bounce
  (make-system 'apply-wall-bounce
	       1
	       'entity
	       '(<rigidbody-2d> <screen-transform>)
	       (lambda (_ rbody transform)
		 (when (or (> (v-x (position transform)) (- (car (*window-size*)) +ball-radius+))
			   (< (v-x (position transform)) (+ 0 +ball-radius+)))
		   (set-rigidbody-2d-velocity! rbody
					       (v* (rigidbody-2d-velocity rbody)
						   (vec -1 1)))))))

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

(define move-rigidbody
  (make-system 'move-rigidbody
	       3
	       'entity
	       '(<rigidbody-2d> <screen-transform>)
	       (lambda (_ rbody transform)
		 (set-position! transform
				(v+ (rigidbody-2d-velocity rbody)
				    (position transform))))))

(register-action 'boost 'key-press KEY_SPACE)
(register-action 'reset 'key-press KEY_R)

(define boost-rigidbody
  (make-system 'boost-rigidbody
	       2
	       'entity
	       '(<rigidbody-2d>)
	       (lambda (_ rbody)
		 (when (peek-event 'input 'boost)
		   (set-rigidbody-2d-velocity! rbody
					       (v* 2
						   (rigidbody-2d-velocity rbody)))))))

(define clear-boost
  (make-system 'clear-boost
	       4
	       'global
	       '()
	       (lambda ()
		 (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)
  (entity
   (make-visual-2d
    (make-circle-2d
     (vec 0 0)
     +ball-radius+
     #t)
    color
    0)
   (make-screen-transform
    position
    (vec 0 0)
    0
    (vec 1 1)
    'center
    '())
   (make-rigidbody-2d velocity)))

(*bounce-scene*
 (lambda ()
   (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 100 100)
	       (vec 5 1)
	       (make-color 0 0 1 1))

    (make-ball (vec 200 200)
	       (vec -2 -2)
	       (make-color 0 1 0 1))

    (make-ball (vec 300 300)
	       (vec -2 -2)
	       (make-color 1 0 0 1)))))


(((*bounce-scene*)))
(create-window)
)