diff options
| -rw-r--r-- | game.scm | 126 |
1 files changed, 71 insertions, 55 deletions
@@ -1,8 +1,8 @@ (let () + ;; Host imports (define-foreign request-animation-frame "window" "requestAnimationFrame" (ref eq) -> none) - (define-foreign timeout "window" "setTimeout" (ref eq) f64 -> i32) @@ -10,19 +10,15 @@ (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)) @@ -30,47 +26,36 @@ (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 clone-element "element" "clone" (ref extern) -> (ref extern)) @@ -82,31 +67,24 @@ (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) @@ -114,15 +92,12 @@ (define-foreign load-audio "audio" "new" (ref string) -> (ref extern)) - (define-foreign audio-play "audio" "play" (ref extern) -> none) - (define-foreign audio-volume "audio" "volume" (ref extern) -> f64) - (define-foreign set-audio-volume! "audio" "setVolume" (ref extern) f64 -> none) @@ -309,8 +284,12 @@ (define *scheduler* (make-scheduler 100)) (define %script-tag (make-prompt-tag "script")) (define (run-script thunk) + (define script (vector #f)) + (define (cancelled?) + (vector-ref script 0)) (define (run thunk) - (call-with-prompt %script-tag thunk handler)) + (unless (cancelled?) + (call-with-prompt %script-tag thunk handler))) (define (handler k delay) (when delay (scheduler-add! *scheduler* (lambda () (run k)) delay))) @@ -321,7 +300,10 @@ ;; thunk messes up the Scheme stack, resulting in an invalid ;; ref.cast somewhere. So, we *never* fall through. Instead, ;; we create a continuation that gets thrown away. - (abort-to-prompt %script-tag #f)))) + (abort-to-prompt %script-tag #f))) + script) + (define (cancel! script) + (vector-set! script 0 #t)) (define (wait delay) (abort-to-prompt %script-tag delay)) @@ -529,18 +511,18 @@ (* t tw) 0.0 tw th tx (- ty pixel-y-offset) tw th)))))))) - ;; Enemies: - ;; length, capacity, pool + ;; Enemy pool: + ;; length, capacity, enemies, scripts ;; enemy: type, health, x, y, w, h, dx, dy (define %enemy-size (+ 4 4 8 8 8 8 8 8)) (define (make-enemy-pool capacity) (let ((enemies (make-bytevector (* capacity %enemy-size)))) - (vector 0 capacity enemies))) + (vector 0 capacity enemies (make-vector capacity)))) (define (enemy-pool-offset i) (* i %enemy-size)) - (define (enemy-pool-add! pool type hp x y w h dx dy) + (define (enemy-pool-add! pool type hp x y w h dx dy script) (match pool - (#(length capacity enemies) + (#(length capacity enemies scripts) (unless (= length capacity) (let ((offset (enemy-pool-offset length))) (s32-set! enemies offset type) @@ -551,18 +533,54 @@ (f64-set! enemies (+ offset 32) h) (f64-set! enemies (+ offset 40) dx) (f64-set! enemies (+ offset 48) dy) + (vector-set! scripts length + (and script + (run-script + (lambda () + (script length))))) (vector-set! pool 0 (+ length 1))))))) (define (enemy-pool-remove! pool i) (match pool - (#(length capacity enemies) + (#(length capacity enemies scripts) (when (and (>= i 0) (< i length)) - (let ((at (enemy-pool-offset i)) - (start (enemy-pool-offset (- length 1)))) + (let* ((j (- length 1)) + (at (enemy-pool-offset i)) + (start (enemy-pool-offset j))) (bytevector-copy! enemies at enemies start (+ start %enemy-size)) - (vector-set! pool 0 (- length 1))))))) + (let ((script (vector-ref scripts i))) + (and script (cancel! script))) + (vector-set! scripts i (vector-ref scripts j)) + (vector-set! scripts j #f) + (vector-set! pool 0 j)))))) + (define (enemy-x pool i) + (match pool + (#(length capacity enemies scripts) + (let ((offset (enemy-pool-offset i))) + (f64-ref enemies (+ offset 8)))))) + (define (enemy-y pool i) + (match pool + (#(length capacity enemies scripts) + (let ((offset (enemy-pool-offset i))) + (f64-ref enemies (+ offset 16)))))) + (define (enemy-dx pool i) + (match pool + (#(length capacity enemies scripts) + (let ((offset (enemy-pool-offset i))) + (f64-ref enemies (+ offset 40)))))) + (define (enemy-dy pool i) + (match pool + (#(length capacity enemies scripts) + (let ((offset (enemy-pool-offset i))) + (f64-ref enemies (+ offset 48)))))) + (define (set-enemy-velocity! pool i dx dy) + (match pool + (#(length capacity enemies scripts) + (let ((offset (enemy-pool-offset i))) + (f64-set! enemies (+ offset 40) dx) + (f64-set! enemies (+ offset 48) dy))))) (define (enemy-pool-update! pool collide) (match pool - (#(length capacity enemies) + (#(length capacity enemies scripts) (let ((padding 16.0)) (let loop ((i 0) (k length)) (unless (= i k) @@ -590,7 +608,7 @@ (loop (+ i 1) k))))))))))) (define (draw-enemies pool) (match pool - (#(length capacity enemies) + (#(length capacity enemies scripts) (do ((i 0 (+ i 1))) ((= i length)) (let* ((offset (enemy-pool-offset i)) @@ -610,7 +628,7 @@ hbw hbh)))))) (define (find-enemy pool x y w h) (match pool - (#(length capacity enemies) + (#(length capacity enemies scripts) (let loop ((i 0)) (and (< i length) (let* ((offset (enemy-pool-offset i)) @@ -625,14 +643,25 @@ (loop (+ i 1))))))))) (define (damage-enemy! pool i damage) (match pool - (#(length capacity enemies) + (#(length capacity enemies scripts) (when (and (>= i 0) (< i length)) (let* ((offset (enemy-pool-offset i)) (hp (s32-ref enemies (+ offset 4)))) (s32-set! enemies (+ offset 4) (- hp damage))))))) (define enemies (make-enemy-pool 64)) - (enemy-pool-add! enemies 0 20 70.0 100.0 16.0 16.0 0.0 0.0) + (enemy-pool-add! enemies 0 20 70.0 100.0 16.0 16.0 0.0 0.0 + (lambda (id) + (let ((speed 2.0)) + (let loop ((theta 0.0)) + (let ((dx (* (cos theta) speed)) + (dy (* (sin theta) speed))) + (bullet-pool-add! enemy-bullets 0 + (enemy-x enemies id) + (enemy-y enemies id) + dx dy)) + (wait 2) + (loop (+ theta 0.2)))))) ;; Player state: (define player-position (vec2 (/ game-width 2.0) (- game-height 12.0))) @@ -845,19 +874,6 @@ (enemy-pool-update! enemies enemy-collide) (timeout update dt)) - ;; Temp hacky scripts - (run-script - (lambda () - (let ((ox 70.0) - (oy 100.0) - (speed 2.0)) - (let loop ((theta 0.0)) - (let ((dx (* (cos theta) speed)) - (dy (* (sin theta) speed))) - (bullet-pool-add! enemy-bullets 0 ox oy dx dy)) - (wait 2) - (loop (+ theta 0.2)))))) - (set-element-width! canvas (trunc canvas-width)) (set-element-height! canvas (trunc canvas-height)) (add-event-listener! (current-document) "keydown" on-key-down) |