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)
|
|
|
|
(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)
|
|
|
|
|
|
|
|
(define image:tiles (make-image "assets/images/cirkoban.png"))
|
2024-05-17 13:08:43 -04:00
|
|
|
|
|
|
|
(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
|
|
|
|
(define (update)
|
2024-05-17 17:49:43 -04:00
|
|
|
#t
|
2024-05-17 13:08:43 -04:00
|
|
|
(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)
|
2024-05-17 17:49:43 -04:00
|
|
|
(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)
|
2024-05-17 17:58:43 -04:00
|
|
|
(draw-image context image:tiles
|
|
|
|
0.0 0.0 tile-width tile-height
|
|
|
|
100.0 100.0 tile-width tile-height)
|
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")
|
|
|
|
(define key:confirm "Enter")
|
|
|
|
|
|
|
|
(define (on-key-down event)
|
|
|
|
(let ((key (keyboard-event-code event)))
|
2024-05-17 17:49:43 -04:00
|
|
|
(pk 'key-down key)))
|
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-17 17:49:43 -04:00
|
|
|
(set-element-width! canvas (inexact->exact game-width))
|
|
|
|
(set-element-height! canvas (inexact->exact game-height))
|
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))
|
|
|
|
(request-animation-frame draw-callback)
|
|
|
|
(timeout update-callback dt)
|