From f3fb51ef1d5d5407ea95c8c8b24cdcd9767cd1fa Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sun, 22 Oct 2023 08:09:14 -0400
Subject: Day 1 progress.

---
 game.scm | 527 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 527 insertions(+)
 create mode 100644 game.scm

(limited to 'game.scm')

diff --git a/game.scm b/game.scm
new file mode 100644
index 0000000..d84cdfa
--- /dev/null
+++ b/game.scm
@@ -0,0 +1,527 @@
+(let ()
+  (define-foreign request-animation-frame
+    "window" "requestAnimationFrame"
+    (ref eq) -> none)
+
+  (define-foreign timeout
+    "window" "setTimeout"
+    (ref eq) f64 -> i32)
+
+  (define-foreign current-document
+    "document" "get"
+    -> (ref extern))
+
+  (define-foreign document-body
+    "document" "body"
+    -> (ref extern))
+
+  (define-foreign get-element-by-id
+    "document" "getElementById"
+    (ref string) -> (ref null extern))
+
+  (define-foreign make-text-node
+    "document" "createTextNode"
+    (ref string) -> (ref extern))
+
+  (define-foreign make-element
+    "document" "createElement"
+    (ref string) -> (ref extern))
+
+  (define-foreign element-value
+    "element" "value"
+    (ref extern) -> (ref string))
+
+  (define-foreign set-element-value!
+    "element" "setValue"
+    (ref extern) (ref string) -> none)
+
+  (define-foreign set-element-width!
+    "element" "setWidth"
+    (ref extern) i32 -> none)
+
+  (define-foreign set-element-height!
+    "element" "setHeight"
+    (ref extern) i32 -> none)
+
+  (define-foreign append-child!
+    "element" "appendChild"
+    (ref extern) (ref extern) -> (ref extern))
+
+  (define-foreign remove!
+    "element" "remove"
+    (ref extern) -> none)
+
+  (define-foreign replace-with!
+    "element" "replaceWith"
+    (ref extern) (ref extern) -> none)
+
+  (define-foreign set-attribute!
+    "element" "setAttribute"
+    (ref extern) (ref string) (ref string) -> none)
+
+  (define-foreign remove-attribute!
+    "element" "removeAttribute"
+    (ref extern) (ref string) -> none)
+
+  (define-foreign add-event-listener!
+    "element" "addEventListener"
+    (ref extern) (ref string) (ref eq) -> none)
+
+  (define-foreign remove-event-listener!
+    "element" "removeEventListener"
+    (ref extern) (ref string) (ref eq) -> none)
+
+  (define-foreign keyboard-event-code
+    "event" "keyboardCode"
+    (ref extern) -> (ref string))
+
+  (define-foreign get-context
+    "canvas" "getContext"
+    (ref extern) (ref string) -> (ref extern))
+
+  (define-foreign set-fill-color!
+    "canvas" "setFillColor"
+    (ref extern) (ref string) -> none)
+
+  (define-foreign clear-rect
+    "canvas" "clearRect"
+    (ref extern) f64 f64 f64 f64 -> none)
+
+  (define-foreign fill-rect
+    "canvas" "fillRect"
+    (ref extern) f64 f64 f64 f64 -> none)
+
+  (define-foreign draw-image
+    "canvas" "drawImage"
+    (ref extern) (ref extern) f64 f64 f64 f64 f64 f64 f64 f64 -> none)
+
+  (define-foreign set-scale!
+    "canvas" "setScale"
+    (ref extern) f64 f64 -> none)
+
+  (define-foreign set-transform!
+    "canvas" "setTransform"
+    (ref extern) f64 f64 f64 f64 f64 f64 -> none)
+
+  (define-foreign set-image-smoothing-enabled!
+    "canvas" "setImageSmoothingEnabled"
+    (ref extern) i32 -> none)
+
+  ;; Hoot's exact and inexact aren't working right.  These next two
+  ;; procedures are alternatives for now.
+  (define (trunc x)
+    ;; rational? is also borked so can't use that here.
+    (unless (inexact? x)
+      (error "expected inexact rational" x))
+    (%inline-wasm
+     '(func (param $x (ref eq)) (result (ref eq))
+            (call $s64->scm
+                  (i64.trunc_f64_s
+                   (struct.get $flonum $val (ref.cast $flonum (local.get $x))))))
+     x))
+  (define (inexact x)
+    (unless (and (exact? x) (integer? x))
+      (error "expected exact integer" x))
+    (%inline-wasm
+     '(func (param $x (ref eq)) (result (ref eq))
+            (if (ref eq)
+                (call $fixnum? (local.get $x))
+                (then
+                 (struct.new $flonum
+                             (i32.const 0)
+                             (f64.convert_i32_s
+                              (call $fixnum->i32 (ref.cast i31 (local.get $x))))))
+                (else
+                 (struct.new $flonum
+                             (i32.const 0)
+                             (f64.convert_i64_s
+                              (call $bignum-get-i64
+                                    (struct.get $bignum $val
+                                                (ref.cast $bignum (local.get $x)))))))))
+     x))
+
+  (define pi (* 4.0 (atan 1.0)))
+  (define pi/2 (/ pi 2.0))
+  (define tau (* pi 2.0))
+
+  (define (clamp x min max)
+    (cond ((< x min) min)
+          ((> x max) max)
+          (else x)))
+
+  (define (vec2 x y)
+    (let ((v (make-bytevector 16)))
+      (set-vec2-x! v x)
+      (set-vec2-y! v y)
+      v))
+  (define (vec2-x v)
+    (bytevector-ieee-double-native-ref v 0))
+  (define (vec2-y v)
+    (bytevector-ieee-double-native-ref v 8))
+  (define (set-vec2-x! v x)
+    (bytevector-ieee-double-native-set! v 0 x))
+  (define (set-vec2-y! v y)
+    (bytevector-ieee-double-native-set! v 8 y))
+  (define (vec2-add! v w)
+    (set-vec2-x! v (+ (vec2-x v) (vec2-x w)))
+    (set-vec2-y! v (+ (vec2-y v) (vec2-y w))))
+  (define (vec2-mul-scalar! v x)
+    (set-vec2-x! v (* (vec2-x v) x))
+    (set-vec2-y! v (* (vec2-y v) x)))
+  (define (vec2-magnitude v)
+    (sqrt (+ (* (vec2-x v) (vec2-x v)) (* (vec2-y v) (vec2-y v)))))
+  (define (vec2-normalize! v)
+    (unless (and (= (vec2-x v) 0.0) (= (vec2-y v) 0.0))
+      (let ((m (vec2-magnitude v)))
+        (set-vec2-x! v (/ (vec2-x v) m))
+        (set-vec2-y! v (/ (vec2-y v) m)))))
+  (define (vec2-clamp! v xmin ymin xmax ymax)
+    (set-vec2-x! v (clamp (vec2-x v) xmin xmax))
+    (set-vec2-y! v (clamp (vec2-y v) ymin ymax)))
+
+  (define (make-rect x y w h)
+    (let ((r (make-bytevector (* 8 4))))
+      (bytevector-ieee-double-native-set! r 0 x)
+      (bytevector-ieee-double-native-set! r 8 y)
+      (bytevector-ieee-double-native-set! r 16 w)
+      (bytevector-ieee-double-native-set! r 24 h)
+      r))
+  (define (rect-x r)
+    (bytevector-ieee-double-native-ref r 0))
+  (define (rect-y r)
+    (bytevector-ieee-double-native-ref r 8))
+  (define (rect-w r)
+    (bytevector-ieee-double-native-ref r 16))
+  (define (rect-h r)
+    (bytevector-ieee-double-native-ref r 24))
+
+  (define (within? x y rx ry rw rh)
+    (and (>= x rx)
+         (>= y ry)
+         (<= x (+ rx rw))
+         (<= y (+ ry rh))))
+    (define (vec2-within-rect? v r)
+    (within? (vec2-x v) (vec2-y v)
+             (rect-x r) (rect-y r) (rect-w r) (rect-h r)))
+
+  (define demichrome0 "#211e20")
+  (define demichrome1 "#555568")
+  (define demichrome2 "#a0a08b")
+  (define demichrome3 "#e9efec")
+
+  (define game-width 240.0)
+  (define game-height 320.0)
+  (define canvas-scale 2.0)
+  (define canvas-width (* game-width canvas-scale))
+  (define canvas-height (* game-height canvas-scale))
+  (define canvas (get-element-by-id "canvas"))
+  (define context (get-context canvas "2d"))
+  (define image:player (get-element-by-id "image-player"))
+  (define image:player-bullet (get-element-by-id "image-player-bullet"))
+  (define image:map (get-element-by-id "image-map"))
+
+  ;; header: length, capacity
+  (define %bullet-pool-header-size (+ 4 4))
+  ;; per bullet: type, x, y, dx, dy
+  (define %bullet-pool-bullet-size (+ 4 8 8 8 8))
+  (define (make-bullet-pool capacity)
+    (let ((pool (make-bytevector (+ %bullet-pool-header-size
+                                    (* capacity %bullet-pool-bullet-size)))))
+      (bytevector-s32-native-set! pool 4 capacity)
+      pool))
+  (define (bullet-pool-length pool)
+    (bytevector-s32-native-ref pool 0))
+  (define (set-bullet-pool-length! pool length)
+    (bytevector-s32-native-set! pool 0 length))
+  (define (bullet-pool-capacity pool)
+    (bytevector-s32-native-ref pool 4))
+  (define (bullet-pool-offset i)
+    (+ %bullet-pool-header-size (* i %bullet-pool-bullet-size)))
+  (define (bullet-pool-add! pool type x y dx dy)
+    (let* ((k (bullet-pool-length pool))
+           (offset (bullet-pool-offset k)))
+      (bytevector-s32-native-set! pool offset type)
+      (bytevector-ieee-double-native-set! pool (+ offset 4) x)
+      (bytevector-ieee-double-native-set! pool (+ offset 12) y)
+      (bytevector-ieee-double-native-set! pool (+ offset 20) dx)
+      (bytevector-ieee-double-native-set! pool (+ offset 28) dy)
+      (set-bullet-pool-length! pool (+ k 1))))
+  (define (bullet-pool-remove! pool i)
+    (let ((k (bullet-pool-length pool)))
+      (when (and (>= i 0) (< i k))
+        (let ((at (bullet-pool-offset i))
+              (start (bullet-pool-offset (- k 1))))
+          (bytevector-copy! pool at pool start
+                            (+ start %bullet-pool-bullet-size))
+          (set-bullet-pool-length! pool (- k 1))))))
+  (define (bullet-pool-ref pool i)
+    (let ((offset (bullet-pool-offset i)))
+      (values
+       (bytevector-s32-native-ref pool offset)
+       (bytevector-ieee-double-native-ref pool (+ offset 4))
+       (bytevector-ieee-double-native-ref pool (+ offset 12))
+       (bytevector-ieee-double-native-ref pool (+ offset 20))
+       (bytevector-ieee-double-native-ref pool (+ offset 28)))))
+  (define (bullet-pool-update! pool)
+    (let ((padding 16.0))
+      (let loop ((i 0) (k (bullet-pool-length player-bullets)))
+        (let* ((offset (bullet-pool-offset i))
+               (x (bytevector-ieee-double-native-ref pool (+ offset 4)))
+               (y (bytevector-ieee-double-native-ref pool (+ offset 12)))
+               (dx (bytevector-ieee-double-native-ref pool (+ offset 20)))
+               (dy (bytevector-ieee-double-native-ref pool (+ offset 28)))
+               (x* (+ x dx))
+               (y* (+ y dy)))
+          (cond
+           ((= i k) #t)
+           ((or (not (within? x* y* (- padding) (- padding)
+                              (+ game-width padding) (+ game-height padding)))
+                (point-collides-with-level? level x* y*))
+            (bullet-pool-remove! pool i)
+            (loop i (- k 1)))
+           (else
+            (bytevector-ieee-double-native-set! pool (+ offset 4) x*)
+            (bytevector-ieee-double-native-set! pool (+ offset 12) y*)
+            (loop (+ i 1) k)))))))
+  (define (draw-bullets pool image w h)
+    (let ((k (bullet-pool-length player-bullets)))
+      (do ((i 0 (+ i 1)))
+          ((= i k))
+        (let* ((offset (bullet-pool-offset i))
+               (type (bytevector-s32-native-ref pool offset))
+               (x (bytevector-ieee-double-native-ref pool (+ offset 4)))
+               (y (bytevector-ieee-double-native-ref pool (+ offset 12))))
+          (draw-image context image (* type w) (* type h) w h
+                      (- x (/ w 2.0)) (- y (/ w 2.0)) w h)))))
+
+  (define player-bullets (make-bullet-pool 100))
+  (define enemy-bullets (make-bullet-pool 200))
+
+  (define *scroll* game-width)
+
+  ;; Map:
+  ;; sprite sheet offset, x, y
+  (define %tile-size (+ 8 8 8))
+  (define tile-width 16.0)
+  (define tile-height 16.0)
+  (define (make-level tiles)
+    (let ((k (length tiles)))
+      (unless (= (modulo k 15) 0)
+        (error "incomplete level data"))
+      (let ((bv (make-bytevector (* k %tile-size))))
+        (let y-loop ((tiles tiles) (y 0))
+          (match tiles
+            (() #t)
+            (tiles
+             (y-loop
+              (let x-loop ((tiles tiles) (x 0))
+                (if (< x 15)
+                    (match tiles
+                      ((t . rest)
+                       (let ((n (match t
+                                  ('_ -1.0)
+                                  ('X 0.0)
+                                  ('\ 1.0)
+                                  ('/ 2.0)))
+                             (offset (* (+ x (* y 15)) %tile-size)))
+                         (bytevector-ieee-double-native-set! bv offset n)
+                         (bytevector-ieee-double-native-set! bv (+ offset 8)
+                                                             (* (inexact x) tile-width))
+                         (bytevector-ieee-double-native-set! bv (+ offset 16)
+                                                             (* (inexact y) tile-height)))
+                       (x-loop rest (+ x 1))))
+                    tiles))
+              (+ y 1)))))
+        (list 15 (/ k 15) bv))))
+  (define-syntax-rule (define-level name tile ...)
+    (define name (make-level '(tile ...))))
+  (define-level level
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ X X X _ _ _ _ _ X
+    X _ _ _ _ _ X X X _ _ _ _ _ X
+    X _ _ _ _ _ X X X _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X _ _ _ _ _ _ _ _ _ _ _ _ _ X
+    X \ _ _ _ _ _ _ _ _ _ _ _ / X
+    X X \ _ _ _ _ _ _ _ _ _ / X X
+    X X X X X X X X X X X X X X X)
+  (define (level-offset x y)
+    (* (+ (* 15 y) x) %tile-size))
+  (define (point-collides-with-level? level x y)
+    (match level
+      ((width height tiles)
+       (let ((tx (trunc (/ x tile-width)))
+             (ty (trunc (/ y tile-height))))
+         (and (>= tx 0) (< tx 15)
+              (>= ty 0) (< tx height)
+              (>= (bytevector-ieee-double-native-ref tiles (level-offset tx ty)) 0))))))
+  (define (rect-collides-with-level? level x y w h)
+    (match level
+      ((width height tiles)
+       (let ((tx0 (trunc (/ x tile-width)))
+             (ty0 (trunc (/ y tile-height)))
+             (tx1 (trunc (/ (+ x w) tile-width)))
+             (ty1 (trunc (/ (+ y h) tile-height))))
+         (define (occupied? x y)
+           (and (>= x 0) (< x 15)
+                (>= y 0) (< x height)
+                (>= (bytevector-ieee-double-native-ref tiles (level-offset x y)) 0)))
+         (or (occupied? tx0 ty0)
+             (occupied? tx1 ty0)
+             (occupied? tx1 ty1)
+             (occupied? tx0 ty1))))))
+  (define (draw-tiles level)
+    (match level
+      ((width height tiles)
+       (let* ((tw tile-width)
+              (th tile-height)
+              (y-end height)
+              (y-start (- y-end 20)))
+         (do ((y 0 (+ y 1)))
+             ((= y 20))
+           (do ((x 0 (+ x 1)))
+               ((= x 15))
+             (let* ((offset (* (+ (* 15 y) x) %tile-size))
+                    (t (bytevector-ieee-double-native-ref tiles offset))
+                    (tx (bytevector-ieee-double-native-ref tiles (+ offset 8)))
+                    (ty (bytevector-ieee-double-native-ref tiles (+ offset 16))))
+               (draw-image context image:map
+                           (* t tw) 0.0 tw th
+                           tx ty tw th))))))))
+
+  ;; Player state:
+  (define player-position (vec2 (/ game-width 2.0) (- game-height 12.0)))
+  (define player-velocity (vec2 0.0 0.0))
+  (define player-speed 4.0)
+  (define player-bullet-speed 12.0)
+  (define player-width 24.0)
+  (define player-height 24.0)
+  (define *player-fire-counter* 0)
+  (define player-fire-interval 3)
+  ;; left, right, down, up, fire
+  (define key-state (vector #f #f #f #f #f))
+  (define (update-player-velocity!)
+    ;; TODO: Normalize
+    (match key-state
+      (#(left? right? down? up? _)
+       (set-vec2-x! player-velocity
+                    (+ (if left? -1.0 0.0)
+                       (if right? 1.0 0.0)))
+       (set-vec2-y! player-velocity
+                    (+ (if down? 1.0 0.0)
+                       (if up? -1.0 0.0)))
+       (vec2-normalize! player-velocity)
+       (vec2-mul-scalar! player-velocity player-speed))))
+  (define (set-left! pressed?)
+    (vector-set! key-state 0 pressed?)
+    (update-player-velocity!))
+  (define (set-right! pressed?)
+    (vector-set! key-state 1 pressed?)
+    (update-player-velocity!))
+  (define (set-down! pressed?)
+    (vector-set! key-state 2 pressed?)
+    (update-player-velocity!))
+  (define (set-up! pressed?)
+    (vector-set! key-state 3 pressed?)
+    (update-player-velocity!))
+  (define (set-firing! pressed?)
+    (let ((was-firing? (firing?)))
+      (vector-set! key-state 4 pressed?)
+      (when (and pressed? (not was-firing?))
+        (set! *player-fire-counter* 0))))
+  (define (firing?)
+    (vector-ref key-state 4))
+
+  (define (clear-screen)
+    (clear-rect context 0.0 0.0 canvas-width canvas-height))
+
+  (define (draw-player-bullets)
+    (draw-bullets player-bullets image:player-bullet 8.0 8.0))
+
+  (define (draw-player)
+    (draw-image context image:player
+                0.0 0.0 player-width player-height
+                (- (vec2-x player-position)
+                   (/ player-width 2.0))
+                (- (vec2-y player-position)
+                   (/ player-height 2.0))
+                player-width player-height))
+
+  (define (draw time)
+    (clear-screen)
+    (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
+    (set-scale! context canvas-scale canvas-scale)
+    (set-fill-color! context demichrome0)
+    (fill-rect context 0.0 0.0 game-width game-height)
+    (draw-tiles level)
+    (draw-player-bullets)
+    (draw-player)
+    (request-animation-frame draw))
+
+  (define (on-key-down event)
+    (let ((code (keyboard-event-code event)))
+      (cond
+       ((string-=? code "ArrowLeft")
+        (set-left! #t))
+       ((string-=? code "ArrowRight")
+        (set-right! #t))
+       ((string-=? code "ArrowDown")
+        (set-down! #t))
+       ((string-=? code "ArrowUp")
+        (set-up! #t))
+       ((string-=? code "KeyZ")
+        (set-firing! #t)))))
+
+  (define (on-key-up event)
+    (let ((code (keyboard-event-code event)))
+      (cond
+       ((string-=? code "ArrowLeft")
+        (set-left! #f))
+       ((string-=? code "ArrowRight")
+        (set-right! #f))
+       ((string-=? code "ArrowDown")
+        (set-down! #f))
+       ((string-=? code "ArrowUp")
+        (set-up! #f))
+       ((string-=? code "KeyZ")
+        (set-firing! #f)))))
+
+  (define dt (/ 1000.0 60.0))
+  (define (update)
+    (vec2-add! player-position player-velocity)
+    (vec2-clamp! player-position 0.0 0.0 game-width game-height)
+    (bullet-pool-update! player-bullets)
+    (when (firing?)
+      (set! *player-fire-counter*
+            (modulo (+ *player-fire-counter* 1) player-fire-interval))
+      (when (= *player-fire-counter* 0)
+        (let ((xoff 4.0))
+          (bullet-pool-add! player-bullets 0
+                            (- (vec2-x player-position) xoff)
+                            (vec2-y player-position)
+                            0.0 (- player-bullet-speed))
+          (bullet-pool-add! player-bullets 0
+                            (+ (vec2-x player-position) xoff)
+                            (vec2-y player-position)
+                            0.0 (- player-bullet-speed)))
+        (set! *player-fire-counter* 0)))
+    (timeout update dt))
+
+  (set-element-width! canvas (trunc canvas-width))
+  (set-element-height! canvas (trunc canvas-height))
+  (add-event-listener! (current-document) "keydown" on-key-down)
+  (add-event-listener! (current-document) "keyup" on-key-up)
+  (set-image-smoothing-enabled! context 0)
+  (request-animation-frame draw)
+  (timeout update dt))
-- 
cgit v1.2.3