2024-05-19 17:34:25 +02:00
|
|
|
(import (scheme base)
|
|
|
|
(scheme inexact)
|
|
|
|
(hoot ffi)
|
2024-05-20 16:37:08 +02:00
|
|
|
(hoot debug)
|
2024-05-19 17:34:25 +02:00
|
|
|
(dom canvas)
|
|
|
|
(dom document)
|
|
|
|
(dom element)
|
|
|
|
(dom event)
|
|
|
|
(dom image)
|
|
|
|
(dom media)
|
2024-05-20 16:37:08 +02:00
|
|
|
(dom window)
|
|
|
|
(console))
|
2024-05-19 17:34:25 +02:00
|
|
|
|
|
|
|
|
|
|
|
(define game-width 640.0)
|
|
|
|
(define game-height 480.0)
|
|
|
|
|
|
|
|
(define canvas (get-element-by-id "canvas"))
|
|
|
|
(define context (get-context canvas "2d"))
|
|
|
|
|
2024-05-20 17:05:28 +02:00
|
|
|
(define *element-x* (/ game-width 2.0))
|
|
|
|
|
2024-05-19 17:34:25 +02:00
|
|
|
;; Draw
|
|
|
|
(define (draw prev-time)
|
2024-05-20 17:05:28 +02:00
|
|
|
(clear-rect context 0.0 0.0 game-width game-height)
|
2024-05-19 17:34:25 +02:00
|
|
|
(set-fill-color! context "#140c1c")
|
|
|
|
(set-text-align! context "center")
|
|
|
|
(set-font! context "bold 24px monospace")
|
2024-05-20 17:05:28 +02:00
|
|
|
(fill-text context "Hello, World! :)" *element-x* (/ game-height 2.0))
|
2024-05-19 17:34:25 +02:00
|
|
|
(request-animation-frame draw-callback))
|
|
|
|
(define draw-callback (procedure->external draw))
|
|
|
|
|
|
|
|
(set-element-width! canvas (exact game-width))
|
|
|
|
(set-element-height! canvas (exact game-height))
|
|
|
|
|
|
|
|
(request-animation-frame draw-callback)
|
2024-05-20 16:37:08 +02:00
|
|
|
|
|
|
|
(dprint "game-height" game-height)
|
|
|
|
(console-log canvas)
|
2024-05-20 17:05:28 +02:00
|
|
|
|
|
|
|
;; Input
|
|
|
|
(define key:left "ArrowLeft")
|
|
|
|
(define key:right "ArrowRight")
|
|
|
|
|
|
|
|
(define (on-key-down event)
|
|
|
|
(let ((key (keyboard-event-code event)))
|
|
|
|
(cond
|
|
|
|
((string=? key key:left)
|
|
|
|
(dprint "key:" key)
|
|
|
|
(set! *element-x* (- *element-x* 10)))
|
|
|
|
((string=? key key:right)
|
|
|
|
(dprint "key:" key)
|
|
|
|
(set! *element-x* (+ *element-x* 10))))))
|
|
|
|
|
|
|
|
(add-event-listener! (current-document) "keydown"
|
|
|
|
(procedure->external on-key-down))
|