2024-05-17 13:08:43 -04:00
|
|
|
;;; 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:
|
|
|
|
|
2024-05-17 17:49:43 -04:00
|
|
|
(use-modules (dom canvas)
|
|
|
|
(dom document)
|
|
|
|
(dom element)
|
|
|
|
(dom event)
|
|
|
|
(dom image)
|
|
|
|
(dom media)
|
|
|
|
(dom window)
|
2024-05-18 14:04:35 -04:00
|
|
|
(game actors)
|
2024-05-18 18:51:45 -04:00
|
|
|
(game tileset)
|
2024-05-18 14:04:35 -04:00
|
|
|
(goblins core)
|
2024-05-17 17:49:43 -04:00
|
|
|
(hoot ffi)
|
|
|
|
(hoot hashtables)
|
|
|
|
(ice-9 match)
|
|
|
|
(math)
|
|
|
|
(math rect)
|
|
|
|
(math vector))
|
|
|
|
|
|
|
|
(define game-width 320.0)
|
|
|
|
(define game-height 240.0)
|
2024-05-17 17:58:43 -04:00
|
|
|
(define tile-width 16.0)
|
|
|
|
(define tile-height 16.0)
|
2024-05-18 14:04:35 -04:00
|
|
|
(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)
|
2024-05-17 17:58:43 -04:00
|
|
|
|
2024-05-18 18:51:45 -04:00
|
|
|
(define tileset
|
|
|
|
(make-tileset (make-image "assets/images/cirkoban.png")
|
|
|
|
320 240
|
|
|
|
(inexact->exact tile-width)
|
|
|
|
(inexact->exact tile-height)))
|
2024-05-17 13:08:43 -04:00
|
|
|
|
2024-05-18 14:04:35 -04:00
|
|
|
;; 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*)))
|
2024-05-18 18:51:45 -04:00
|
|
|
(define (rollback-snapshot!)
|
|
|
|
(match *snapshots*
|
|
|
|
(() #f)
|
|
|
|
((snapshot . older-snapshots)
|
|
|
|
(set! *actormap* snapshot)
|
|
|
|
(set! *snapshots* older-snapshots))))
|
2024-05-18 14:04:35 -04:00
|
|
|
|
|
|
|
(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)
|
2024-05-18 18:51:45 -04:00
|
|
|
(save-snapshot!)
|
2024-05-18 14:04:35 -04:00
|
|
|
(with-goblins
|
|
|
|
($ *level* 'move-player dir)
|
2024-05-18 18:51:45 -04:00
|
|
|
(update-grid!)))
|
2024-05-18 14:04:35 -04:00
|
|
|
|
2024-05-17 13:08:43 -04:00
|
|
|
(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
|
|
|
|
(define (update)
|
2024-05-18 14:04:35 -04:00
|
|
|
;; TODO: what kind of work do we need to do each frame?
|
2024-05-17 13:08:43 -04:00
|
|
|
(timeout update-callback dt))
|
|
|
|
(define update-callback (procedure->external update))
|
|
|
|
|
2024-05-18 14:04:35 -04:00
|
|
|
;; Render loop
|
2024-05-17 13:08:43 -04:00
|
|
|
(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)))))
|
|
|
|
|
2024-05-18 14:04:35 -04:00
|
|
|
(define (draw-player x y)
|
2024-05-18 18:51:45 -04:00
|
|
|
(draw-tile context tileset 0 x y))
|
2024-05-18 14:04:35 -04:00
|
|
|
|
|
|
|
(define (draw-wall type x y)
|
|
|
|
(match type
|
|
|
|
('brick
|
2024-05-18 18:51:45 -04:00
|
|
|
(draw-tile context tileset 22 x y))
|
2024-05-18 14:04:35 -04:00
|
|
|
(_
|
2024-05-18 18:51:45 -04:00
|
|
|
(draw-tile context tileset 2 x y)))
|
2024-05-18 14:04:35 -04:00
|
|
|
(match type
|
|
|
|
('electron-head
|
2024-05-18 18:51:45 -04:00
|
|
|
(draw-tile context tileset 4 x y))
|
2024-05-18 14:04:35 -04:00
|
|
|
('electron-tail
|
2024-05-18 18:51:45 -04:00
|
|
|
(draw-tile context tileset 5 x y))
|
2024-05-18 14:04:35 -04:00
|
|
|
(_ #f)))
|
|
|
|
|
|
|
|
(define (draw-block type x y)
|
2024-05-18 18:51:45 -04:00
|
|
|
(draw-tile context tileset 3 x y)
|
2024-05-18 14:04:35 -04:00
|
|
|
(match type
|
|
|
|
('electron-head
|
2024-05-18 18:51:45 -04:00
|
|
|
(draw-tile context tileset 4 x y))
|
2024-05-18 14:04:35 -04:00
|
|
|
('electron-tail
|
2024-05-18 18:51:45 -04:00
|
|
|
(draw-tile context tileset 5 x y))
|
2024-05-18 14:04:35 -04:00
|
|
|
(_ #f)))
|
|
|
|
|
|
|
|
(define (draw-clock-emitter x y)
|
2024-05-18 18:51:45 -04:00
|
|
|
(draw-tile context tileset 2 x y))
|
|
|
|
|
|
|
|
(define (draw-object x y obj)
|
|
|
|
(and obj
|
|
|
|
(let ((x (* x tile-width))
|
|
|
|
(y (* y tile-height)))
|
|
|
|
(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))))))
|
2024-05-18 14:04:35 -04:00
|
|
|
|
|
|
|
(define (draw-level)
|
|
|
|
(let ((grid *grid*))
|
|
|
|
(let y-loop ((y 0))
|
|
|
|
(when (< y level-height)
|
|
|
|
(let x-loop ((x 0))
|
|
|
|
(when (< x level-width)
|
2024-05-18 18:51:45 -04:00
|
|
|
(draw-object x y (vector-ref grid (+ (* y level-width) x)))
|
2024-05-18 14:04:35 -04:00
|
|
|
(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)
|
2024-05-17 13:08:43 -04:00
|
|
|
(request-animation-frame draw-callback))
|
|
|
|
(define draw-callback (procedure->external draw))
|
|
|
|
|
|
|
|
;; Input
|
|
|
|
(define key:left "ArrowLeft")
|
|
|
|
(define key:right "ArrowRight")
|
2024-05-18 14:04:35 -04:00
|
|
|
(define key:down "ArrowDown")
|
|
|
|
(define key:up "ArrowUp")
|
2024-05-17 13:08:43 -04:00
|
|
|
(define key:confirm "Enter")
|
2024-05-18 18:51:45 -04:00
|
|
|
(define key:undo "KeyZ")
|
2024-05-17 13:08:43 -04:00
|
|
|
|
|
|
|
(define (on-key-down event)
|
|
|
|
(let ((key (keyboard-event-code event)))
|
2024-05-18 14:04:35 -04:00
|
|
|
(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)
|
2024-05-18 18:51:45 -04:00
|
|
|
(move-player 'down))
|
|
|
|
((string=? key key:undo)
|
|
|
|
(rollback-snapshot!)
|
|
|
|
(with-goblins (update-grid!))))))
|
2024-05-17 13:08:43 -04:00
|
|
|
|
|
|
|
(define (on-key-up event)
|
|
|
|
(let ((key (keyboard-event-code event)))
|
2024-05-17 17:49:43 -04:00
|
|
|
(pk 'key-up key)))
|
2024-05-17 13:08:43 -04:00
|
|
|
|
|
|
|
;; Canvas and event loop setup
|
|
|
|
(define canvas (get-element-by-id "canvas"))
|
|
|
|
(define context (get-context canvas "2d"))
|
2024-05-18 14:04:35 -04:00
|
|
|
|
|
|
|
(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*)))
|
|
|
|
|
2024-05-17 17:49:43 -04:00
|
|
|
(set-element-width! canvas (inexact->exact game-width))
|
|
|
|
(set-element-height! canvas (inexact->exact game-height))
|
2024-05-18 14:04:35 -04:00
|
|
|
(add-event-listener! (current-window) "resize"
|
|
|
|
(procedure->external (lambda (_) (resize-canvas))))
|
2024-05-17 13:08:43 -04:00
|
|
|
(add-event-listener! (current-document) "keydown"
|
|
|
|
(procedure->external on-key-down))
|
|
|
|
(add-event-listener! (current-document) "keyup"
|
|
|
|
(procedure->external on-key-up))
|
2024-05-18 14:04:35 -04:00
|
|
|
(resize-canvas)
|
2024-05-17 13:08:43 -04:00
|
|
|
(request-animation-frame draw-callback)
|
|
|
|
(timeout update-callback dt)
|
2024-05-18 14:04:35 -04:00
|
|
|
(reset-game!)
|