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 atomics)
        (hoot debug)
        (hoot ffi)
        (hoot hashtables)
        (hoot match)
        (dom canvas)
        (dom console)
        (dom document)
        (dom element)
        (dom event)
        (dom image)
        (dom media)
        (dom window)
        (math)
        (math rect)
        (math vector)
        (ces entity)
        (ces system)
        (ces system sprite-renderer)
        (ces system keyboard-reader)
        (ces system tilemap-renderer)
        (ces system-manager)
        (ces entity-manager)
        (game-core)
        (game game-manager)
        (logging)
        (media))

;; Canvas settings
(define canvas (get-element-by-id "canvas"))
(define context (get-context canvas "2d"))

(define game-width 640.0)
(define game-height 480.0)

(define game-images `((player . ,(make-image "assets/sprites/player.png"))
                      (barrel . ,(make-image "assets/sprites/barrel.png"))
                      (bricks . ,(make-image "assets/sprites/bricks.png"))
                      (stones . ,(make-image "assets/sprites/stones.png"))
                      (card-back . ,(make-image "assets/sprites/bricks.png"))
                      (tile-blank . ,(make-image "assets/tiles/blank.png"))
                      (tile-floor . ,(make-image "assets/tiles/floor-light.png"))
                      (tile-wall . ,(make-image "assets/tiles/bricks-light.png"))
                      (tile-door . ,(make-image "assets/tiles/door-light.png"))))

(parameterize ((*logger* #f))
  (parameterize ((*media-library* (create-media-library)))
    (add-images! (get-media-library) game-images)

    (write-log! "Creating bootstrap managers")
    (define bootstrap-entity-manager (create-entity-manager))
    (define bootstrap-system-manager (create-entity-manager))
    (write-log! "Creating entity manager")
    (define e-manager (parameterize ((*entity-manager-parameter* bootstrap-entity-manager)
                                     (*system-manager-parameter* bootstrap-system-manager))
                        (write-log! "Entering e-manager creation")
                        (let ((init-entities (init-game-entities)))
                          (write-log! "Got initial game entities.")
                          (create-entity-manager init-entities))))

    (write-log! "Creating system manager")
    (define s-manager (parameterize ((*entity-manager-parameter* e-manager))
                        (create-system-manager
                         (init-game-systems draw-image context))))

    (pk "System information"
        "Systems: " (system-manager-systems s-manager)
        "System-manager proc table" (system-manager-proc-table s-manager))

    (write-log! "Creating game")
    (define game (make-game e-manager s-manager 0))
    (define dt (/ 1000.0 60.0))
    (define game-atom (make-atomic-box #f))
    (atomic-box-set! game-atom (initialize-game! game))
    (write-log! "Initialized game.")

    (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)))))

    (write-log! "Defining game loop.")
    (define (update-game-loop)
      (parameterize ((*logger* #f))
        (write-log! "Heartbeat")
        (let* ((last-game-state (atomic-box-ref game-atom))
               (next-game-state (step-game! last-game-state dt)))
          (write-log! "Looped")
          (atomic-box-set! game-atom next-game-state)
          (timeout timeout-callback dt))))

    (write-log! "Defining update callback")
    (define timeout-callback (procedure->external update-game-loop))

    (write-log! "Setting canvas size")
    (set-element-width! canvas (exact game-width))
    (set-element-height! canvas (exact game-height))

    (write-log! "Starting game")
    (timeout timeout-callback dt)))


;; Canvas and event loop setup
;; Preserved for reference.
;;
;;(add-event-listener! (current-document) "keydown"
;;                     (procedure->external on-key-down))
;;(add-event-listener! (current-document) "keyup"
;;                     (procedure->external on-key-up))
;;(timeout update-callback dt)
;;(define draw-callback (procedure->external draw))