182 lines
4.1 KiB
Scheme
182 lines
4.1 KiB
Scheme
(module (bounce) ()
|
|
(import scheme
|
|
(chicken base)
|
|
raylib
|
|
(imugi core)
|
|
(imugi components core)
|
|
(imugi math)
|
|
(imugi input)
|
|
(imugi drawing)
|
|
(imugi 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)
|
|
)
|