path: root/game.scm

(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))