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)
             (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 image:tiles (make-image "assets/images/cirkoban.png"))

(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
(define (update)
  #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)
  (set-fill-color! context "#140c1c")
  (fill-rect context 0.0 0.0 game-width game-height)
  (set-fill-color! context "#ffffff")
  (set-font! context "bold 24px monospace")
  (set-text-align! context "left")
  (fill-text context "HELLO" 16.0 36.0)
  (draw-image context image:tiles
              0.0 0.0 tile-width tile-height
              100.0 100.0 tile-width tile-height)
  (request-animation-frame draw-callback))
(define draw-callback (procedure->external draw))

;; Input
(define key:left "ArrowLeft")
(define key:right "ArrowRight")
(define key:confirm "Enter")

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

(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"))
(set-element-width! canvas (inexact->exact game-width))
(set-element-height! canvas (inexact->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)