diff options
Diffstat (limited to 'game.scm')
| -rw-r--r-- | game.scm | 527 |
1 files changed, 527 insertions, 0 deletions
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)) |