145 lines
3.3 KiB
Scheme
145 lines
3.3 KiB
Scheme
(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 ()
|
|
(let ((draw-pos (v+ (position transform)
|
|
(circle-2d-center circle))))
|
|
((if (circle-2d-filled? circle)
|
|
draw-circle
|
|
draw-circle-lines)
|
|
(vector-x draw-pos)
|
|
(vector-y draw-pos)
|
|
(circle-2d-radius circle)
|
|
(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+ (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
|
|
(v+ (rigidbody-2d-velocity rbody)
|
|
(v* (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
|
|
(v* (rigidbody-2d-velocity rbody)
|
|
(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
|
|
(v* (rigidbody-2d-velocity rbody)
|
|
(vector -1 1)))))))
|
|
|
|
(add-system
|
|
(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)))))))
|
|
|
|
(add-system
|
|
(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)
|
|
|
|
(add-system
|
|
(make-system 'boost-rigidbody
|
|
2
|
|
'entity
|
|
'(<rigidbody-2d>)
|
|
(lambda (_ rbody)
|
|
(when (pop-event 'input 'boost)
|
|
(set-rigidbody-2d-velocity! rbody
|
|
(v* 2
|
|
(rigidbody-2d-velocity rbody)))))))
|
|
|
|
(define (make-ball position velocity color)
|
|
(create-entity
|
|
(make-visual-2d
|
|
(make-circle-2d
|
|
(vector 0 0)
|
|
+ball-radius+
|
|
#t)
|
|
color
|
|
0)
|
|
(make-screen-transform
|
|
position
|
|
(vector 0 0)
|
|
0
|
|
(vector 1 1)
|
|
'center
|
|
'none)
|
|
(make-rigidbody-2d velocity)))
|
|
|
|
(make-ball (vector 100 100)
|
|
(vector 5 1)
|
|
(make-color 0 0 1 1))
|
|
|
|
(make-ball (vector 300 300)
|
|
(vector -2 -2)
|
|
(make-color 0 1 0 1))
|
|
|
|
(make-ball (vector 600 600)
|
|
(vector -2 -2)
|
|
(make-color 1 0 0 1))
|
|
|
|
(create-window)
|
|
)
|