374 lines
14 KiB
Scheme
374 lines
14 KiB
Scheme
;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; Example game showing off several common game programming things.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(import (scheme base)
|
|
(scheme inexact)
|
|
(hoot debug)
|
|
(hoot ffi)
|
|
(hoot hashtables)
|
|
(hoot match)
|
|
(dom canvas)
|
|
(dom document)
|
|
(dom element)
|
|
(dom event)
|
|
(dom image)
|
|
(dom media)
|
|
(dom window)
|
|
(math)
|
|
(math rect)
|
|
(math vector))
|
|
|
|
;; Data types
|
|
(define-record-type <brick-type>
|
|
(make-brick-type image points)
|
|
brick-type?
|
|
(image brick-type-image)
|
|
(points brick-type-points))
|
|
|
|
(define-record-type <brick>
|
|
(make-brick type hitbox)
|
|
brick?
|
|
(type brick-type)
|
|
(hitbox brick-hitbox)
|
|
(broken? brick-broken? set-brick-broken!))
|
|
|
|
(define-record-type <ball>
|
|
(make-ball velocity hitbox)
|
|
ball?
|
|
(velocity ball-velocity)
|
|
(hitbox ball-hitbox))
|
|
|
|
(define-record-type <paddle>
|
|
(make-paddle velocity hitbox)
|
|
paddle?
|
|
(velocity paddle-velocity)
|
|
(hitbox paddle-hitbox))
|
|
|
|
(define-record-type <level>
|
|
(make-level state bricks ball paddle score move-left? move-right? move-up? move-down?)
|
|
level?
|
|
(state level-state set-level-state!) ; play, win, lose
|
|
(bricks level-bricks)
|
|
(ball level-ball)
|
|
(paddle level-paddle)
|
|
(score level-score set-level-score!)
|
|
(move-left? level-move-left? set-level-move-left!)
|
|
(move-right? level-move-right? set-level-move-right!)
|
|
(move-up? level-move-up? set-level-move-up!)
|
|
(move-down? level-move-down? set-level-move-up!))
|
|
|
|
;; Assets
|
|
(define image:paddle (make-image "assets/images/paddle.png"))
|
|
(define image:ball (make-image "assets/images/ball.png"))
|
|
(define image:brick-red (make-image "assets/images/brick-red.png"))
|
|
(define image:brick-green (make-image "assets/images/brick-green.png"))
|
|
(define image:brick-blue (make-image "assets/images/brick-blue.png"))
|
|
(define audio:brick (make-audio "assets/sounds/brick.wav"))
|
|
(define audio:paddle (make-audio "assets/sounds/paddle.wav"))
|
|
|
|
;; Game data
|
|
(define game-width 640.0)
|
|
(define game-height 480.0)
|
|
(define brick-width 64.0)
|
|
(define brick-height 32.0)
|
|
(define ball-width 22.0)
|
|
(define ball-height 22.0)
|
|
(define paddle-width 104.0)
|
|
(define paddle-height 24.0)
|
|
(define paddle-speed 6.0)
|
|
(define brick:red (make-brick-type image:brick-red 10))
|
|
(define brick:green (make-brick-type image:brick-green 20))
|
|
(define brick:blue (make-brick-type image:brick-blue 30))
|
|
|
|
(define (make-brick* type x y)
|
|
(make-brick type (make-rect x y brick-width brick-height)))
|
|
|
|
(define (make-brick-grid types)
|
|
(let* ((h (vector-length types))
|
|
(w (vector-length (vector-ref types 0)))
|
|
(offset-x (/ (- game-width (* w brick-width)) 2.0))
|
|
(offset-y 48.0)
|
|
(bricks (make-vector (* w h))))
|
|
(do ((y 0 (+ y 1)))
|
|
((= y h))
|
|
(let ((row (vector-ref types y)))
|
|
(do ((x 0 (+ x 1)))
|
|
((= x w))
|
|
(vector-set! bricks (+ (* y w) x)
|
|
(make-brick* (vector-ref row x)
|
|
(+ offset-x (* x brick-width))
|
|
(+ offset-y (* y brick-height)))))))
|
|
bricks))
|
|
|
|
(define (make-level-1)
|
|
(make-level 'play
|
|
(make-brick-grid
|
|
(vector
|
|
(vector brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green)
|
|
(vector brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue)
|
|
(vector brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red)
|
|
(vector brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green)
|
|
(vector brick:green brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue)
|
|
(vector brick:blue brick:red brick:green brick:blue brick:red brick:green brick:blue brick:red)))
|
|
(make-ball (vec2 1.0 3.0)
|
|
(make-rect (/ game-width 2.0) (/ game-height 2.0)
|
|
ball-width ball-height))
|
|
(make-paddle (vec2 0.0 0.0)
|
|
(make-rect (- (/ game-width 2.0)
|
|
(/ paddle-width 2.0))
|
|
(- game-height paddle-height 8.0)
|
|
paddle-width paddle-height))
|
|
0 #f #f #f #f))
|
|
|
|
;; Game state
|
|
(define *level* (make-level-1))
|
|
|
|
(define (level-clear? level)
|
|
(let ((bricks (level-bricks level)))
|
|
(let loop ((i 0))
|
|
(if (< i (vector-length bricks))
|
|
(if (brick-broken? (vector-ref bricks i))
|
|
(loop (+ i 1))
|
|
#f)
|
|
#t))))
|
|
|
|
(define (win! level)
|
|
(set-level-state! level 'win))
|
|
|
|
(define (lose! level)
|
|
(set-level-state! level 'lose))
|
|
|
|
(define (update-paddle-velocity! level)
|
|
(let ((speed (* paddle-speed
|
|
(+ (if (level-move-left? level) -1.0 0.0)
|
|
(if (level-move-right? level) 1.0 0.0)
|
|
(if (level-move-up? level) 0.0 1.0)
|
|
(if (level-move-down? level) 0.0 -1.0)))))
|
|
(set-vec2-x! (paddle-velocity (level-paddle level)) speed)))
|
|
|
|
(define (speed-up-ball! ball)
|
|
(let* ((v (ball-velocity ball))
|
|
(speed (+ (vec2-magnitude v) (* (random) 0.1)))
|
|
;; Also change its angle slightly. Not the proper Breakout
|
|
;; behavior but I don't want to write the code for that. :)
|
|
(dir (+ (atan (vec2-y v) (vec2-x v))
|
|
(- (* (random) 0.5) 0.25))))
|
|
(set-vec2-x! v (* (cos dir) speed))
|
|
(set-vec2-y! v (* (sin dir) speed))))
|
|
|
|
(define (reflect-ball! ball x? y?)
|
|
(let ((v (ball-velocity ball)))
|
|
(when x? (set-vec2-x! v (- (vec2-x v))))
|
|
(when y? (set-vec2-y! v (- (vec2-y v))))))
|
|
|
|
(define (collide-ball! ball hitbox)
|
|
(let ((b-hitbox (ball-hitbox ball)))
|
|
(and (rect-intersects? b-hitbox hitbox)
|
|
(let ((overlap (rect-clip b-hitbox hitbox)))
|
|
;; Resolve collision by adjusting the ball's position the
|
|
;; minimum amount along the X or Y axis.
|
|
(if (< (rect-width overlap) (rect-height overlap))
|
|
(begin
|
|
(reflect-ball! ball #t #f)
|
|
(if (= (rect-x b-hitbox) (rect-x overlap))
|
|
(set-rect-x! b-hitbox (+ (rect-x b-hitbox) (rect-width overlap)))
|
|
(set-rect-x! b-hitbox (- (rect-x b-hitbox) (rect-width overlap)))))
|
|
(begin
|
|
(reflect-ball! ball #f #t)
|
|
(if (= (rect-y b-hitbox) (rect-y overlap))
|
|
(set-rect-y! b-hitbox (+ (rect-y b-hitbox) (rect-height overlap)))
|
|
(set-rect-y! b-hitbox (- (rect-y b-hitbox) (rect-height overlap))))))))))
|
|
|
|
(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
|
|
(define (update)
|
|
(match (level-state *level*)
|
|
('play
|
|
(let* ((bricks (level-bricks *level*))
|
|
(ball (level-ball *level*))
|
|
(b-velocity (ball-velocity ball))
|
|
(b-hitbox (ball-hitbox ball))
|
|
(paddle (level-paddle *level*))
|
|
(p-velocity (paddle-velocity paddle))
|
|
(p-hitbox (paddle-hitbox paddle))
|
|
(score (level-score *level*)))
|
|
;; Move ball and paddle
|
|
(set-rect-x! b-hitbox (+ (rect-x b-hitbox) (vec2-x b-velocity)))
|
|
(set-rect-y! b-hitbox (+ (rect-y b-hitbox) (vec2-y b-velocity)))
|
|
;; We only move the paddle along the x-axis.
|
|
(set-rect-x! p-hitbox
|
|
(clamp (+ (rect-x p-hitbox) (vec2-x p-velocity))
|
|
0.0
|
|
(- game-width paddle-width)))
|
|
;; Collide ball against walls, bricks, and paddle.
|
|
(cond
|
|
((< (rect-x b-hitbox) 0.0) ; left wall
|
|
(set-rect-x! b-hitbox 0.0)
|
|
(reflect-ball! ball #t #f))
|
|
((> (+ (rect-x b-hitbox) (rect-width b-hitbox)) game-width) ; right wall
|
|
(set-rect-x! b-hitbox (- game-width (rect-width b-hitbox)))
|
|
(reflect-ball! ball #t #f))
|
|
((< (rect-y b-hitbox) 0.0) ; top wall
|
|
(set-rect-y! b-hitbox 0.0)
|
|
(reflect-ball! ball #f #t))
|
|
((> (+ (rect-y b-hitbox) (rect-height b-hitbox)) game-height) ; bottom wall
|
|
(lose! *level*))
|
|
((collide-ball! ball (paddle-hitbox paddle))
|
|
(media-play audio:paddle)
|
|
(speed-up-ball! ball))
|
|
(else
|
|
(let loop ((i 0) (hit? #f))
|
|
(if (< i (vector-length bricks))
|
|
(let ((brick (vector-ref bricks i)))
|
|
(if (and (not (brick-broken? brick))
|
|
(collide-ball! ball (brick-hitbox brick)))
|
|
(begin
|
|
(media-play audio:brick)
|
|
(speed-up-ball! ball)
|
|
(set-brick-broken! brick #t)
|
|
(set-level-score! *level*
|
|
(+ (level-score *level*)
|
|
(brick-type-points (brick-type brick))))
|
|
(loop (+ i 1) #t))
|
|
(loop (+ i 1) hit?)))
|
|
;; Maybe change to win state if all bricks are broken.
|
|
(when (and hit? (level-clear? *level*))
|
|
(win! *level*))))))))
|
|
(_ #t))
|
|
(timeout update-callback dt))
|
|
(define update-callback (procedure->external update))
|
|
|
|
;; Rendering
|
|
(define number->string*
|
|
(let ((cache (make-eq-hashtable))) ; assuming fixnums only
|
|
(lambda (x)
|
|
(or (hashtable-ref cache x)
|
|
(let ((str (number->string x)))
|
|
(hashtable-set! cache x str)
|
|
str)))))
|
|
|
|
(define (draw prev-time)
|
|
(let ((bricks (level-bricks *level*))
|
|
(ball (level-ball *level*))
|
|
(paddle (level-paddle *level*))
|
|
(score (level-score *level*)))
|
|
;; Draw background
|
|
(set-fill-color! context "#140c1c")
|
|
(fill-rect context 0.0 0.0 game-width game-height)
|
|
;; Draw bricks
|
|
(do ((i 0 (+ i 1)))
|
|
((= i (vector-length bricks)))
|
|
(let* ((brick (vector-ref bricks i))
|
|
(type (brick-type brick))
|
|
(hitbox (brick-hitbox brick)))
|
|
(unless (brick-broken? brick)
|
|
(draw-image context (brick-type-image type)
|
|
0.0 0.0
|
|
brick-width brick-height
|
|
(rect-x hitbox) (rect-y hitbox)
|
|
brick-width brick-height))))
|
|
;; Draw paddle
|
|
(let ((w 104.0)
|
|
(h 24.0)
|
|
(hitbox (paddle-hitbox paddle)))
|
|
(draw-image context image:paddle
|
|
0.0 0.0 w h
|
|
(rect-x hitbox) (rect-y hitbox) w h))
|
|
;; Draw ball
|
|
(let ((w 22.0)
|
|
(h 22.0)
|
|
(hitbox (ball-hitbox ball)))
|
|
(draw-image context image:ball
|
|
0.0 0.0 w h
|
|
(rect-x hitbox) (rect-y hitbox) w h))
|
|
;; Print score
|
|
(set-fill-color! context "#ffffff")
|
|
(set-font! context "bold 24px monospace")
|
|
(set-text-align! context "left")
|
|
(fill-text context "SCORE:" 16.0 36.0)
|
|
(fill-text context (number->string* score) 108.0 36.0)
|
|
(match (level-state *level*)
|
|
('win
|
|
(set-text-align! context "center")
|
|
(fill-text context "YAY YOU DID IT!!!" (/ game-width 2.0) (/ game-height 2.0)))
|
|
('lose
|
|
(set-text-align! context "center")
|
|
(fill-text context "OH NO, GAME OVER :(" (/ game-width 2.0) (/ game-height 2.0)))
|
|
(_ #t)))
|
|
(request-animation-frame draw-callback))
|
|
(define draw-callback (procedure->external draw))
|
|
|
|
;; Input
|
|
(define key:left "ArrowLeft")
|
|
(define key:right "ArrowRight")
|
|
(define key:up "ArrowUp")
|
|
(define key:down "ArrowDown")
|
|
(define key:confirm "Enter")
|
|
|
|
(define (on-key-down event)
|
|
(let ((key (keyboard-event-code event)))
|
|
(match (level-state *level*)
|
|
('play
|
|
(cond
|
|
((string=? key key:left)
|
|
(set-level-move-left! *level* #t)
|
|
(update-paddle-velocity! *level*))
|
|
((string=? key key:right)
|
|
(set-level-move-right! *level* #t)
|
|
(update-paddle-velocity! *level*))
|
|
((string=? key key:up)
|
|
(set-level-move-up! *level* #t)
|
|
(update-paddle-velocity! *level*))
|
|
((string=? key key:down)
|
|
(set-level-move-down! *level* #t)
|
|
(update-paddle-velocity! *level*))))
|
|
((or 'win 'lose)
|
|
(when (string=? key key:confirm)
|
|
(set! *level* (make-level-1)))))))
|
|
|
|
(define (on-key-up event)
|
|
(let ((key (keyboard-event-code event)))
|
|
(match (level-state *level*)
|
|
('play
|
|
(cond
|
|
((string=? key key:left)
|
|
(set-level-move-left! *level* #f)
|
|
(update-paddle-velocity! *level*))
|
|
((string=? key key:right)
|
|
(set-level-move-right! *level* #f)
|
|
(update-paddle-velocity! *level*))
|
|
((string=? key key:up)
|
|
(set-level-move-up! *level* #f)
|
|
(update-paddle-velocity! *level*))
|
|
((string=? key key:down)
|
|
(set-level-move-down! *level* #f)
|
|
(update-paddle-velocity! *level*))))
|
|
(_ #t))))
|
|
|
|
;; Canvas and event loop setup
|
|
(define canvas (get-element-by-id "canvas"))
|
|
(define context (get-context canvas "2d"))
|
|
(set-element-width! canvas (exact game-width))
|
|
(set-element-height! canvas (exact game-height))
|
|
(add-event-listener! (current-document) "keydown"
|
|
(procedure->external on-key-down))
|
|
(add-event-listener! (current-document) "keyup"
|
|
(procedure->external on-key-up))
|
|
(request-animation-frame draw-callback)
|
|
(timeout update-callback dt)
|