foss-mmo/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:

(use-modules (dom canvas)
             (dom document)
             (dom element)
             (dom event)
             (dom image)
             (dom media)
             (dom window)
             (game actors)
             (goblins core)
             (hoot ffi)
             (hoot hashtables)
             (ice-9 match)
             (math)
             (math rect)
             (math vector))

(define game-width 320.0)
(define game-height 240.0)
(define tile-width 16.0)
(define tile-height 16.0)
(define level-width (inexact->exact (floor (/ game-width tile-width))))
(define level-height (inexact->exact (floor (/ game-height tile-height))))

(define *canvas-scale* 0.0)
(define *canvas-width* 0)
(define *canvas-height* 0)

(define image:tiles (make-image "assets/images/cirkoban.png"))

;; Game state
(define *actormap* (make-whactormap))
(define (call-with-goblins thunk)
  (actormap-churn-run! *actormap* thunk))
(define-syntax-rule (with-goblins body ...)
  (call-with-goblins (lambda () body ...)))

(define *level* #f)
;; Latest representation of all actors in level
(define *grid* #f)

(define *snapshots* '())
(define (clear-snapshots!)
  (set! *snapshots* '()))
(define (save-snapshot!)
  (set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*)))

(define (update-grid!)
  (set! *grid* ($ *level* 'describe)))

(define (reset-game!)
  (set! *actormap* (make-whactormap))
  (clear-snapshots!)
  (with-goblins
   (set! *level* (spawn ^level level-width level-height))
   (update-grid!)))

;; Update loop
(define (move-player dir)
  (with-goblins
   ($ *level* 'move-player dir)
   (update-grid!))
  ;; (save-snapshot!)
  )

(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
(define (update)
  ;; TODO: what kind of work do we need to do each frame?
  (timeout update-callback dt))
(define update-callback (procedure->external update))

;; Render loop
(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-player x y)
  (draw-image context image:tiles
              0.0 0.0 tile-width tile-height
              (* x tile-width) (* y tile-height) tile-width tile-height))

(define (draw-wall type x y)
  (match type
    ('brick
     (draw-image context image:tiles
                 32.0 16.0 tile-width tile-height
                 (* x tile-width) (* y tile-height) tile-width tile-height))
    (_
     (draw-image context image:tiles
                 48.0 0.0 tile-width tile-height
                 (* x tile-width) (* y tile-height) tile-width tile-height)))
  (match type
    ('electron-head
     (draw-image context image:tiles
                 64.0 0.0 tile-width tile-height
                 (* x tile-width) (* y tile-height) tile-width tile-height))
    ('electron-tail
     (draw-image context image:tiles
                 80.0 0.0 tile-width tile-height
                 (* x tile-width) (* y tile-height) tile-width tile-height))
    (_ #f)))

(define (draw-block type x y)
  (draw-image context image:tiles
              32.0 0.0 tile-width tile-height
              (* x tile-width) (* y tile-height) tile-width tile-height)
  (match type
    ('electron-head
     (draw-image context image:tiles
                 64.0 0.0 tile-width tile-height
                 (* x tile-width) (* y tile-height) tile-width tile-height))
    ('electron-tail
     (draw-image context image:tiles
                 80.0 0.0 tile-width tile-height
                 (* x tile-width) (* y tile-height) tile-width tile-height))
    (_ #f)))

(define (draw-clock-emitter x y)
  (draw-image context image:tiles
              48.0 0.0 tile-width tile-height
              (* x tile-width) (* y tile-height) tile-width tile-height))

(define (draw-tile x y obj)
  (match obj
    (#f #f)
    (('player) (draw-player x y))
    (('wall type) (draw-wall type x y))
    (('block type) (draw-block type x y))
    (('clock-emitter) (draw-clock-emitter x y))))

(define (draw-level)
  (let ((grid *grid*))
    (let y-loop ((y 0))
      (when (< y level-height)
        (let x-loop ((x 0))
          (when (< x level-width)
            (draw-tile x y (vector-ref grid (+ (* y level-width) x)))
            (x-loop (1+ x))))
        (y-loop (1+ y))))))

(define (draw prev-time)
  (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)
  (set-fill-color! context "#cbdbfc")
  (fill-rect context 0.0 0.0 *canvas-width* *canvas-height*)
  (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
  (set-scale! context *canvas-scale* *canvas-scale*)
  (draw-level)
  (request-animation-frame draw-callback))
(define draw-callback (procedure->external draw))

;; Input
(define key:left "ArrowLeft")
(define key:right "ArrowRight")
(define key:down "ArrowDown")
(define key:up "ArrowUp")
(define key:confirm "Enter")

(define (on-key-down event)
  (let ((key (keyboard-event-code event)))
    (cond
     ((string=? key key:left)
      (move-player 'left))
     ((string=? key key:right)
      (move-player 'right))
     ((string=? key key:up)
      (move-player 'up))
     ((string=? key key:down)
      (move-player 'down)))))

(define (on-key-up event)
  (let ((key (keyboard-event-code event)))
    (pk 'key-up key)))

;; Canvas and event loop setup
(define canvas (get-element-by-id "canvas"))
(define context (get-context canvas "2d"))

(define (resize-canvas)
  (let* ((win (current-window))
         (w (window-inner-width win))
         (h (window-inner-height win))
         (gw (inexact->exact game-width))
         (gh (inexact->exact game-height))
         (scale (max (min (quotient w gw) (quotient h gh)) 1))
         (cw (* gw scale))
         (ch (* gh scale)))
    (set-element-width! canvas cw)
    (set-element-height! canvas ch)
    (set-image-smoothing-enabled! context 0)
    (set! *canvas-scale* (exact->inexact scale))
    (set! *canvas-width* (* game-width *canvas-scale*))
    (set! *canvas-height* (* game-height *canvas-scale*))
    (pk 'resize-canvas *canvas-scale* *canvas-width* *canvas-height*)))

(set-element-width! canvas (inexact->exact game-width))
(set-element-height! canvas (inexact->exact game-height))
(add-event-listener! (current-window) "resize"
                     (procedure->external (lambda (_) (resize-canvas))))
(add-event-listener! (current-document) "keydown"
                     (procedure->external on-key-down))
(add-event-listener! (current-document) "keyup"
                     (procedure->external on-key-up))
(resize-canvas)
(request-animation-frame draw-callback)
(timeout update-callback dt)
(reset-game!)