lisp-game-jam/game.scm

;;; 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)
        (ces entity)
        (ces system)
        (ces system renderer)
        (ces system-manager)
        (ces entity-manager)
        (game-core))

;; Data types

(define-record-type <level>
    (make-level state player move-left? move-right? move-up? move-down?)
  level?
  (state level-state set-level-state!) ; play, win, lose
  (player level-player)
  (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-down!))

(define-record-type <player>
    (make-player velocity position hitbox weapon-primary)
  entity?
  (velocity player-velocity player-velocity-set!)
  (position player-position player-position-set!)
  (hitbox player-hitbox player-hitbox-set!)
  (weapon-primary player-weapon-primary player-weapon-primary-set!))

;; Assets
(define image:player       (make-image "assets/images/ball.png"))

;; Game data
(define game-width    640.0)
(define game-height   480.0)
(define player-width    22.0)
(define player-height   22.0)
(define player-speed  6.0)

(define (make-player* x y)
  (make-player (vec2 0.0 0.0)
               (vec2 x y)
               (vec2 player-width player-height)
               'test-shot))

(define (make-level-1)
  (make-level 'play
              (make-player* 0.0 0.0)
              #f #f #f #f))

;; Game state
(define *level* (make-level-1))

(define (level-clear? level)
  #f)

(define (win! level)
  (set-level-state! level 'win))

(define (lose! level)
  (set-level-state! level 'lose))

(define (update-player-velocity! level)
  (let ((speed (* player-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! (player-velocity (level-player level)) speed)
    (set-vec2-y! (player-velocity (level-player level)) speed)))

(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
(define (update)
  (match (level-state *level*)
    ('play
     (let* ((player (level-player *level*))
            (p-velocity (player-velocity player))
            (p-position (player-position player))
            (p-hitbox (player-hitbox player)))
       ;; Move player
       (set-vec2-x! p-position (+ (vec2-x p-position) (vec2-x p-velocity)))
       (set-vec2-y! p-position (+ (vec2-y p-position) (vec2-y p-velocity)))

       ;; Keep player within the bounds of the game
       (cond
        ((< (vec2-x p-position) 0.0)      ; left wall
         (set-vec2-x! p-position 0.0))
        ((> (vec2-x p-position) game-width) ; right wall
         (set-vec2-x! p-position game-width)))
       ((< (vec2-y p-position) 0.0)      ; top wall
        (set-vec2-y! p-position 0.0))
       ((> (vec2-y p-position) game-height) ; bottom wall
        (set-vec2-y! p-position game-height))))
    (_ #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 ((player (level-player *level*)))
    ;; Draw background
    (set-fill-color! context "#140c1c")
    (fill-rect context 0.0 0.0 game-width game-height)
    
    ;; Draw player
    (let ((w 22.0)
          (h 22.0)
          (position (player-position player)))
      (draw-image context image:player
                  0.0 0.0 w h
                  (vec2-x position) (vec2-y position) w h)))
  (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-player-velocity! *level*))
        ((string=? key key:right)
         (set-level-move-right! *level* #t)
         (update-player-velocity! *level*))
        ((string=? key key:up)
         (set-level-move-up! *level* #t)
         (update-player-velocity! *level*))
        ((string=? key key:down)
         (set-level-move-down! *level* #t)
         (update-player-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))
        ((string=? key key:right)
         (set-level-move-right! *level* #f))
        ((string=? key key:up)
         (set-level-move-up! *level* #f))
        ((string=? key key:down)
         (set-level-move-down! *level* #f))))
      (_ #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)