summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson@vistahigherlearning.com>2019-06-26 16:57:56 -0400
committerDavid Thompson <dthompson@vistahigherlearning.com>2019-06-26 16:57:56 -0400
commitcb47ca44b0302ab7906e5dad18f829631dcaf1e1 (patch)
treea04e5e5b0f575ae415890b43af4116955d84078d
parent2472663d619f28ac9b79c02d90a298687b046969 (diff)
Add shmup prototype example.
-rw-r--r--examples/shmup/images/back-buildings.pngbin0 -> 7194 bytes
-rw-r--r--examples/shmup/images/bipedal-unit1.pngbin0 -> 841 bytes
-rw-r--r--examples/shmup/images/bullet_2.pngbin0 -> 351 bytes
-rw-r--r--examples/shmup/images/bullets.pngbin0 -> 516 bytes
-rw-r--r--examples/shmup/images/drone-1.pngbin0 -> 1824 bytes
-rw-r--r--examples/shmup/images/far-buildings.pngbin0 -> 6763 bytes
-rw-r--r--examples/shmup/images/foreground.pngbin0 -> 15269 bytes
-rw-r--r--examples/shmup/images/player.pngbin0 -> 8443 bytes
-rw-r--r--examples/shmup/images/ship.pngbin0 -> 1589 bytes
-rw-r--r--examples/shmup/images/shot-1.pngbin0 -> 165 bytes
-rw-r--r--examples/shmup/images/shot-2.pngbin0 -> 1040 bytes
-rw-r--r--examples/shmup/images/space-marine-idle.pngbin0 -> 3081 bytes
-rw-r--r--examples/shmup/images/space-marine.pngbin0 -> 1448 bytes
-rw-r--r--examples/shmup/images/v-police.pngbin0 -> 4043 bytes
-rwxr-xr-xexamples/shmup/shmup7
-rw-r--r--examples/shmup/shmup.scm764
16 files changed, 771 insertions, 0 deletions
diff --git a/examples/shmup/images/back-buildings.png b/examples/shmup/images/back-buildings.png
new file mode 100644
index 0000000..e427882
--- /dev/null
+++ b/examples/shmup/images/back-buildings.png
Binary files differ
diff --git a/examples/shmup/images/bipedal-unit1.png b/examples/shmup/images/bipedal-unit1.png
new file mode 100644
index 0000000..425e0b4
--- /dev/null
+++ b/examples/shmup/images/bipedal-unit1.png
Binary files differ
diff --git a/examples/shmup/images/bullet_2.png b/examples/shmup/images/bullet_2.png
new file mode 100644
index 0000000..2e1e6a4
--- /dev/null
+++ b/examples/shmup/images/bullet_2.png
Binary files differ
diff --git a/examples/shmup/images/bullets.png b/examples/shmup/images/bullets.png
new file mode 100644
index 0000000..f4c430d
--- /dev/null
+++ b/examples/shmup/images/bullets.png
Binary files differ
diff --git a/examples/shmup/images/drone-1.png b/examples/shmup/images/drone-1.png
new file mode 100644
index 0000000..f16ee5b
--- /dev/null
+++ b/examples/shmup/images/drone-1.png
Binary files differ
diff --git a/examples/shmup/images/far-buildings.png b/examples/shmup/images/far-buildings.png
new file mode 100644
index 0000000..7c81747
--- /dev/null
+++ b/examples/shmup/images/far-buildings.png
Binary files differ
diff --git a/examples/shmup/images/foreground.png b/examples/shmup/images/foreground.png
new file mode 100644
index 0000000..f958dae
--- /dev/null
+++ b/examples/shmup/images/foreground.png
Binary files differ
diff --git a/examples/shmup/images/player.png b/examples/shmup/images/player.png
new file mode 100644
index 0000000..9e0a312
--- /dev/null
+++ b/examples/shmup/images/player.png
Binary files differ
diff --git a/examples/shmup/images/ship.png b/examples/shmup/images/ship.png
new file mode 100644
index 0000000..7c3aba4
--- /dev/null
+++ b/examples/shmup/images/ship.png
Binary files differ
diff --git a/examples/shmup/images/shot-1.png b/examples/shmup/images/shot-1.png
new file mode 100644
index 0000000..709de06
--- /dev/null
+++ b/examples/shmup/images/shot-1.png
Binary files differ
diff --git a/examples/shmup/images/shot-2.png b/examples/shmup/images/shot-2.png
new file mode 100644
index 0000000..ee647d2
--- /dev/null
+++ b/examples/shmup/images/shot-2.png
Binary files differ
diff --git a/examples/shmup/images/space-marine-idle.png b/examples/shmup/images/space-marine-idle.png
new file mode 100644
index 0000000..97cf08f
--- /dev/null
+++ b/examples/shmup/images/space-marine-idle.png
Binary files differ
diff --git a/examples/shmup/images/space-marine.png b/examples/shmup/images/space-marine.png
new file mode 100644
index 0000000..5878af2
--- /dev/null
+++ b/examples/shmup/images/space-marine.png
Binary files differ
diff --git a/examples/shmup/images/v-police.png b/examples/shmup/images/v-police.png
new file mode 100644
index 0000000..110e99b
--- /dev/null
+++ b/examples/shmup/images/v-police.png
Binary files differ
diff --git a/examples/shmup/shmup b/examples/shmup/shmup
new file mode 100755
index 0000000..ed6f602
--- /dev/null
+++ b/examples/shmup/shmup
@@ -0,0 +1,7 @@
+#!/bin/sh
+
+set -e
+cd ../..
+make -j8
+cd -
+DEV_MODE=1 ../../pre-inst-env guile shmup.scm
diff --git a/examples/shmup/shmup.scm b/examples/shmup/shmup.scm
new file mode 100644
index 0000000..5fe51d7
--- /dev/null
+++ b/examples/shmup/shmup.scm
@@ -0,0 +1,764 @@
+(use-modules (chickadee)
+ (chickadee math)
+ (chickadee math matrix)
+ (chickadee math rect)
+ (chickadee math vector)
+ (chickadee render color)
+ (chickadee render shapes)
+ (chickadee render texture)
+ (chickadee render sprite)
+ (chickadee scripting)
+ (ice-9 match)
+ (oop goops)
+ (rnrs base)
+ (srfi srfi-1)
+ (starling asset)
+ (starling kernel)
+ (starling node)
+ (starling node-2d)
+ (starling scene))
+
+
+;;;
+;;; Globals
+;;;
+
+(define *render-hitboxes?* #t)
+(define *god-mode?* #f)
+
+
+;;;
+;;; Constants
+;;;
+
+(define game-width 320)
+(define game-height 240)
+(define game-scale 4)
+(define window-width (inexact->exact (* game-width game-scale)))
+(define window-height (inexact->exact (* game-height game-scale)))
+
+
+;;;
+;;; Assets
+;;;
+
+(define (load-atlas file-name tile-width tile-height)
+ (split-texture (load-image file-name) tile-width tile-height))
+
+(define (load-bullet-atlas file-name)
+ (texture-atlas (load-image file-name)
+ '(1 1 10 6) ; red medium bullet
+ '(1 9 6 4) ; pink small bullet
+ '(1 15 10 7) ; blue medium bullet
+ ))
+
+(define-asset foreground (load-image "images/foreground.png"))
+(define-asset background-1 (load-image "images/back-buildings.png"))
+(define-asset background-2 (load-image "images/far-buildings.png"))
+(define-asset player-atlas (load-atlas "images/player.png" 80 80))
+(define-asset drone-texture (load-image "images/drone-1.png"))
+(define-asset police-car (load-image "images/v-police.png"))
+(define-asset small-mech (load-image "images/bipedal-unit1.png"))
+(define-asset space-marine (load-image "images/space-marine.png"))
+(define-asset bullet-atlas (load-bullet-atlas "images/bullets.png"))
+
+
+;;;
+;;; Parallax backgrounds
+;;;
+
+(define-class <parallax-layer> ()
+ (name #:getter name #:init-keyword #:name)
+ (z #:getter z #:init-keyword #:z #:init-form 0)
+ (texture #:getter texture #:init-keyword #:texture)
+ (y-offset #:getter y-offset #:init-keyword #:y #:init-form 0.0)
+ (scalar #:getter scalar #:init-keyword #:scalar #:init-form 1.0))
+
+(define-class <parallax> (<node-2d>)
+ (layers #:accessor layers #:init-keyword #:layers #:init-form '())
+ (speed #:accessor speed #:init-keyword #:speed #:init-form 1.0)
+ (x #:accessor x #:init-form 0.0))
+
+(define-method (on-boot (parallax <parallax>))
+ (for-each (lambda (layer)
+ (let* ((texture (texture layer))
+ (tw (exact->inexact
+ (/ window-width (texture-width (asset-ref texture))))))
+ (attach-to parallax
+ (make <sprite>
+ #:name (name layer)
+ #:rank (z layer)
+ #:texture texture
+ #:position #v(0.0 (y-offset layer))
+ #:source-rect (make-rect 0.0 0.0
+ window-width
+ (texture-height
+ (asset-ref texture)))
+ #:texcoords (make-rect 0.0 0.0 tw 1.0)))))
+ (layers parallax)))
+
+(define-method (update (parallax <parallax>) dt)
+ (let ((new-x (+ (x parallax) (speed parallax))))
+ (set! (x parallax) new-x)
+ (for-each (lambda (layer)
+ (let* ((sprite (child-ref parallax (name layer)))
+ (width (texture-width (asset-ref (texture sprite))))
+ (tx (exact->inexact
+ (/ (mod (* new-x (scalar layer)) width) width)))
+ (r (texcoords sprite)))
+ (set-rect-x! r tx)))
+ (layers parallax))))
+
+
+;;;
+;;; Bullet Field
+;;;
+
+(define-class <bullet-type> ()
+ (tile #:getter tile #:init-keyword #:tile)
+ (hitbox #:getter hitbox #:init-keyword #:hitbox))
+
+(define-class <bullet-field> (<node-2d>)
+ (batch #:getter batch #:init-form (make-sprite-batch #f))
+ (size #:accessor size #:init-form 0)
+ (capacity #:getter capacity #:init-form 1000 #:init-keyword #:capacity)
+ (types #:accessor types)
+ (positions #:accessor positions)
+ (velocities #:accessor velocities)
+ (hitboxes #:accessor hitboxes)
+ (world-hitboxes #:accessor world-hitboxes))
+
+(define-method (initialize (bullets <bullet-field>) initargs)
+ (next-method)
+ (let ((capacity (capacity bullets)))
+ (define (seed-vector thunk)
+ (let ((v (make-vector capacity #f)))
+ (let loop ((i 0))
+ (when (< i capacity)
+ (vector-set! v i (thunk))
+ (loop (+ i 1))))
+ v))
+ (set! (types bullets) (make-vector capacity))
+ (set! (positions bullets) (seed-vector (lambda () #v(0.0 0.0))))
+ (set! (velocities bullets) (seed-vector (lambda () #v(0.0 0.0))))
+ (set! (hitboxes bullets) (seed-vector (lambda () (make-rect 0.0 0.0 0.0 0.0))))
+ (set! (world-hitboxes bullets) (seed-vector (lambda () (make-rect 0.0 0.0 0.0 0.0))))))
+
+(define-method (add-bullet (bullets <bullet-field>) type x y dx dy)
+ (let* ((i (size bullets))
+ (p (vector-ref (positions bullets) i))
+ (v (vector-ref (velocities bullets) i))
+ (h (vector-ref (hitboxes bullets) i))
+ (wh (vector-ref (world-hitboxes bullets) i)))
+ (set! (size bullets) (+ i 1))
+ (vector-set! (types bullets) i type)
+ (set-vec2! p x y)
+ (set-vec2! v dx dy)
+ (set-rect-x! h -1.0)
+ (set-rect-y! h -1.0)
+ (set-rect-width! h 2.0)
+ (set-rect-height! h 2.0)
+ (set-rect-x! wh (+ x -1.0))
+ (set-rect-y! wh (+ y -1.0))
+ (set-rect-width! wh 2.0)
+ (set-rect-height! wh 2.0)))
+
+(define-method (move-bullet (bullets <bullet-field>) from to)
+ (let ((positions (positions bullets))
+ (velocities (velocities bullets))
+ (hitboxes (hitboxes bullets))
+ (world-hitboxes (world-hitboxes bullets)))
+ (vec2-copy! (vector-ref positions from) (vector-ref positions to))
+ (vec2-copy! (vector-ref velocities from) (vector-ref velocities to))
+ (rect-copy! (vector-ref hitboxes from) (vector-ref hitboxes to))
+ (rect-copy! (vector-ref world-hitboxes from) (vector-ref world-hitboxes to))))
+
+(define-method (kill-bullet (bullets <bullet-field>) i)
+ (let ((new-size (- (size bullets) 1)))
+ (set! (size bullets) new-size)
+ (move-bullet bullets new-size i)))
+
+(define-method (clear-bullets (bullets <bullet-field>))
+ (set! (size bullets) 0))
+
+(define-method (update (bullets <bullet-field>) dt)
+ (let ((l (size bullets))
+ (positions (positions bullets))
+ (velocities (velocities bullets))
+ (hitboxes (hitboxes bullets))
+ (world-hitboxes (world-hitboxes bullets))
+ (min-x -16.0)
+ (min-y -16.0)
+ (max-x (+ game-width 16.0))
+ (max-y (+ game-height 16.0)))
+ (define (delete i)
+ (let ((new-l (- l 1)))
+ (set! l new-l)
+ (move-bullet bullets new-l i)))
+ (let loop ((i 0))
+ (when (< i l)
+ (let ((p (vector-ref positions i))
+ (v (vector-ref velocities i))
+ (h (vector-ref hitboxes i))
+ (wh (vector-ref world-hitboxes i)))
+ (vec2-add! p v)
+ ;; Remove bullets that go out of bounds of the play area.
+ (if (or (< (vec2-x p) min-x)
+ (> (vec2-x p) max-x)
+ (< (vec2-y p) min-y)
+ (> (vec2-y p) max-y))
+ (begin
+ (delete i)
+ (loop i))
+ (begin
+ ;; Update hitbox with world coordinates.
+ (set-rect-x! wh (+ (vec2-x p) (rect-x h)))
+ (set-rect-y! wh (+ (vec2-y p) (rect-y h)))
+ (loop (+ i 1)))))))
+ (set! (size bullets) l)))
+
+(define %identity (make-identity-matrix4))
+(define *bullet-rect* (make-rect 0.0 0.0 0.0 0.0))
+
+(define-method (render (bullets <bullet-field>) alpha)
+ (let ((l (size bullets))
+ (batch (batch bullets))
+ (types (types bullets))
+ (positions (positions bullets))
+ (atlas (asset-ref bullet-atlas))
+ (r *bullet-rect*))
+ (set-sprite-batch-texture! batch (texture-atlas-texture atlas))
+ (sprite-batch-clear! batch)
+ (let loop ((i 0))
+ (when (< i l)
+ (let* ((p (vector-ref positions i))
+ (type (vector-ref types i))
+ (texture (texture-atlas-ref atlas (tile type)))
+ (tw (texture-width texture))
+ (th (texture-height texture)))
+ (set-rect-x! r (- (vec2-x p) (/ tw 2.0)))
+ (set-rect-y! r (- (vec2-y p) (/ th 2.0)))
+ (set-rect-width! r tw)
+ (set-rect-height! r th)
+ (sprite-batch-add* batch r %identity
+ #:texture-region texture))
+ (loop (+ i 1))))
+ (draw-sprite-batch* batch (world-matrix bullets))))
+
+
+;;;
+;;; Actor
+;;;
+
+(define-generic rect)
+
+(define-class <hitbox> ()
+ (name #:getter name #:init-keyword #:name #:init-form 'main)
+ (rect #:getter rect #:init-keyword #:rect))
+
+(define-class <actor> (<node-2d>)
+ (world-hitboxes #:accessor world-hitboxes #:init-form '())
+ (dirty-hitboxes? #:accessor dirty-hitboxes? #:init-form #t))
+
+(define-method (dirty! (actor <actor>))
+ (next-method)
+ (set! (dirty-hitboxes? actor) #t))
+
+(define-method (hitboxes (actor <actor>)) '())
+
+(define-method (initialize (actor <actor>) initargs)
+ (next-method)
+ (let ((p (position actor)))
+ (set! (world-hitboxes actor)
+ (let ((table (make-hash-table)))
+ (for-each (lambda (hitbox)
+ (let ((r (rect hitbox)))
+ (hashq-set! table hitbox
+ (make-rect 0.0 0.0
+ (rect-width r)
+ (rect-height r)))))
+ (hitboxes actor))
+ table))))
+
+(define-method (update (actor <actor>) dt)
+ (when (dirty-hitboxes? actor)
+ (let ((p (position actor)))
+ (hash-for-each (lambda (hitbox world-hitbox)
+ (let ((r (rect hitbox)))
+ (set-rect-x! world-hitbox (+ (vec2-x p) (rect-x r)))
+ (set-rect-y! world-hitbox (+ (vec2-y p) (rect-y r)))))
+ (world-hitboxes actor)))
+ (set! (dirty-hitboxes? actor) #f)))
+
+(define %hitbox-color (make-color 1.0 1.0 1.0 0.7))
+
+(define-method (render-tree (actor <actor>) alpha)
+ (next-method)
+ (when (and *render-hitboxes?* (visible? actor))
+ (for-each (lambda (hitbox)
+ (draw-filled-rect (rect hitbox) %hitbox-color
+ #:matrix (world-matrix actor)))
+ (hitboxes actor))))
+
+(define-method (collide (bullets <bullet-field>) (actor <actor>) proc)
+ (define (find-collision bullet-hitbox)
+ (find (lambda (actor-hitbox)
+ (let ((world-hitbox (hashq-ref (world-hitboxes actor)
+ actor-hitbox)))
+ (rect-intersects? bullet-hitbox
+ world-hitbox)))
+ (hitboxes actor)))
+ (let ((l (size bullets))
+ (bullet-hitboxes (world-hitboxes bullets)))
+ (let loop ((i 0))
+ (if (< i l)
+ (let ((hitbox (find-collision (vector-ref bullet-hitboxes i))))
+ (and hitbox (proc i hitbox))
+ (loop (+ i 1)))
+ #f))))
+
+
+;;;
+;;; Base Enemy
+;;;
+
+(define-class <enemy> (<actor>)
+ (health #:accessor health #:init-form 1)
+ (last-blink #:accessor last-blink #:init-form 0))
+
+(define-method (points (enemy <enemy>)) 0)
+
+(define-method (damage (enemy <enemy>) damage)
+ (set! (health enemy) (max (- (health enemy) damage) 0))
+ (run-script enemy
+ (let ((time (agenda-time)))
+ (when (> (- time (last-blink enemy)) 6)
+ (set! (last-blink enemy) time)
+ (blink enemy 1 3)))))
+
+(define-method (dead? (enemy <enemy>))
+ (zero? (health enemy)))
+
+(define-method (emit-bullet (enemy <enemy>) type ox oy theta speed)
+ (let ((p (position enemy)))
+ (add-enemy-bullet (parent enemy)
+ type
+ (+ (vec2-x p) ox)
+ (+ (vec2-y p) oy)
+ theta
+ speed)))
+
+(define-method (emit-bullet/circle (enemy <enemy>) type ox oy otheta n speed)
+ (let loop ((i 0))
+ (when (< i n)
+ (emit-bullet enemy type ox oy (+ (* 2.0 pi (/ i n)) otheta) speed)
+ (loop (+ i 1)))))
+
+
+;;;
+;;; Enemies
+;;;
+
+(define space-marine-bullet-type
+ (make <bullet-type>
+ #:tile 1
+ #:hitbox (make-rect -1.0 -1.0 2.0 2.0)))
+
+(define-class <space-marine> (<enemy>)
+ (health #:accessor health #:init-form 20)
+ (hitboxes #:getter hitboxes
+ #:init-form (list (make <hitbox>
+ #:rect (make-rect -8.0 0.0 16.0 38.0))))
+ (points #:getter points #:init-form 100))
+
+(define-method (on-boot (marine <space-marine>))
+ (attach-to marine
+ (make <sprite>
+ #:texture space-marine
+ #:origin #v(32.0 0.0)))
+ (script
+ ;;(set-vec2-x! (velocity marine) -2.0)
+ (sleep (* 60 5))
+ (set! (health marine) 0))
+ (script
+ (let loop ((theta 0.0))
+ (emit-bullet/circle marine space-marine-bullet-type 0.0 18.0 theta 4 3.0)
+ (sleep 5)
+ (loop (+ theta (/ pi 32.0))))))
+
+(define-class <drone> (<enemy>)
+ (health #:accessor health #:init-form 300)
+ (hitboxes #:getter hitboxes
+ #:init-form (list (make <hitbox>
+ #:rect (make-rect -18.0 -26.0 40.0 52.0)))))
+
+(define-method (on-boot (drone <drone>))
+ (next-method)
+ (attach-to drone
+ (make <sprite>
+ #:texture drone-texture
+ #:origin #v(27.0 26.0)))
+ ;; (run-script drone
+ ;; (let loop ((theta 0.0))
+ ;; (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 theta 20 1.5)
+ ;; (sleep 60)
+ ;; (loop (+ theta (/ pi 33.0)))))
+ (run-script drone
+ (let loop ((theta (/ pi 2.0)))
+ (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 theta 3 1.5)
+ (sleep 10)
+ (loop (- theta (/ pi 33.0)))))
+ ;; (run-script drone
+ ;; (forever
+ ;; (let ((theta (angle-to-player (parent drone) drone 0 0)))
+ ;; (emit-bullet drone space-marine-bullet-type 0.0 0.0 theta 2.0)
+ ;; (sleep 10))))
+ )
+
+
+;;;
+;;; Player
+;;;
+
+(define-class <player> (<actor>)
+ (velocity #:getter velocity #:init-form #v(0.0 0.0))
+ (hitboxes #:getter hitboxes
+ #:init-form (list (make <hitbox>
+ #:rect (make-rect -1.0 -1.0 2.0 2.0))))
+ (speed #:accessor speed #:init-keyword #:speed #:init-form 1.0)
+ (shooting? #:accessor shooting? #:init-form #f)
+ (shooting-timer #:accessor shooting-timer #:init-form 0)
+ (invincible? #:accessor invincible? #:init-form #f)
+ (lives #:accessor lives #:init-form 3)
+ (score #:accessor score #:init-form 0))
+
+(define-method (reset-player (player <player>))
+ (set! (score player) 0)
+ (set! (lives player) 1)
+ (set! (shooting? player) #f)
+ (set! (shooting-timer player) 0)
+ (set! (invincible? player) #f)
+ (set! (speed player) 2.5)
+ (teleport player 8.0 100.0)
+ (set-vec2! (velocity player) 0.0 0.0)
+ (show player))
+
+(define-method (dead? (player <player>))
+ (zero? (lives player)))
+
+(define-method (kill-player (player <player>))
+ (unless (or *god-mode?* (invincible? player))
+ (set! (lives player) (max (- (lives player) 1) 0))
+ (run-script player
+ (set! (invincible? player) #t)
+ (blink player 60 2)
+ (set! (invincible? player) #f))))
+
+(define-method (on-boot (player <player>))
+ (attach-to player
+ (mae <animated-sprite>
+ #:name 'sprite
+ #:atlas player-atlas
+ #:origin #v(41.0 44.0)
+ #:animations `((idle . ,(make <animation>
+ #:frames #(0 1 2 3)
+ #:frame-duration 200))
+ (shoot . ,(make <animation>
+ #:frames #(23 24 25)
+ #:frame-duration 50)))
+ #:default-animation 'idle)))
+
+(define-method (emit-bullet (player <player>) ox oy theta speed)
+ (let ((p (position player)))
+ (add-player-bullet (parent player)
+ (+ (vec2-x p) ox)
+ (+ (vec2-y p) oy)
+ theta
+ speed)))
+
+(define player-bullet-type
+ (make <bullet-type>
+ #:tile 2
+ #:hitbox (make-rect -5.0 -3.5 10.0 7.0)))
+
+(define-method (shoot (player <player>))
+ (let ((p (position player))
+ (ox 20.0)
+ (oy 7.0)
+ (speed 10.0)
+ (theta 0.0)
+ (dtheta 0.05))
+ (emit-bullet player ox oy theta speed)
+ (emit-bullet player ox oy (+ theta dtheta) speed)
+ (emit-bullet player ox oy (- theta dtheta) speed)))
+
+(define-method (update (player <player>) dt)
+ (let ((p (position player))
+ (v (velocity player))
+ (min-x 0.0)
+ (min-y 26.0)
+ (max-x game-width)
+ (max-y game-height))
+ (unless (and (zero? (vec2-x v)) (zero? (vec2-y v)))
+ (vec2-add! p v)
+ (dirty! player)
+ (when (or (< (vec2-x p) min-x)
+ (> (vec2-x p) max-x)
+ (< (vec2-y p) min-y)
+ (> (vec2-y p) max-y))
+ (set-vec2-x! p (max (min (vec2-x p) max-x) min-x))
+ (set-vec2-y! p (max (min (vec2-y p) max-y) min-y)))))
+ (when (shooting? player)
+ (when (zero? (modulo (shooting-timer player) 2))
+ (shoot player))
+ (set! (shooting-timer player) (+ (shooting-timer player) 1)))
+ (next-method))
+
+(define-method (change-direction (player <player>) left? right? down? up?)
+ (let ((v (velocity player)))
+ (set-vec2! v
+ (+ (if left? -1.0 0.0)
+ (if right? 1.0 0.0))
+ (+ (if down? -1.0 0.0)
+ (if up? 1.0 0.0)))
+ (vec2-normalize! v))
+ (vec2-mult! v (speed player)))
+
+(define-method (begin-shooting (player <player>))
+ (set! (shooting? player) #t)
+ (set! (shooting-timer player) 0)
+ (change-animation (& player sprite) 'shoot))
+
+(define-method (end-shooting (player <player>))
+ (set! (shooting? player) #f)
+ (change-animation (& player sprite) 'idle))
+
+
+;;;
+;;; Shmup scene
+;;;
+
+(define-class <shmup> (<scene-2d>)
+ (state #:accessor state #:init-form 'play)
+ (enemies #:accessor enemies #:init-form '()))
+
+(define-method (update-hud (shmup <shmup>))
+ (let ((player (& shmup player)))
+ (set! (text (& shmup hud-lives))
+ (format #f "LIVES ~d" (max (- (lives player) 1) 0)))
+ (set! (text (& shmup hud-score))
+ (format #f "SCORE ~7d" (score player)))))
+
+(define-method (reset-game (shmup <shmup>))
+ (with-agenda (agenda shmup) (reset-agenda))
+ (reset-player (& shmup player))
+ (set! (state shmup) 'play)
+ (update-hud shmup)
+ (run-script shmup
+ (forever
+ (when (null? (enemies shmup))
+ (sleep 30)
+ (add-enemy shmup
+ (make <drone>
+ #:position #v(290.0 120.0)))
+ ;; (add-enemy shmup
+ ;; (make <drone>
+ ;; #:position #v(290.0 170.0)))
+ )
+ (sleep 2))))
+
+(define-method (start-over (shmup <shmup>))
+ (detach (& shmup game-over))
+ (reset-game shmup))
+
+(define-method (on-boot (shmup <shmup>))
+ (set! (views shmup)
+ (list (make <view-2d>
+ #:camera (make <camera-2d>
+ #:width game-width
+ #:height game-height)
+ #:area (make-rect 0 0 window-width window-height))))
+ (attach-to shmup
+ (make <parallax>
+ #:name 'background
+ #:rank 0
+ #:speed 2.0
+ #:layers (list (make <parallax-layer>
+ #:name 'background-2
+ #:texture background-2
+ #:y 48.0
+ #:scalar 0.5)
+ (make <parallax-layer>
+ #:name 'background-1
+ #:z 1
+ #:texture background-1
+ #:y 46.0
+ #:scalar 0.7)
+ (make <parallax-layer>
+ #:name 'foreground-2
+ #:z 2
+ #:texture foreground)))
+ (make <bullet-field>
+ #:name 'player-bullets
+ #:rank 2)
+ (make <bullet-field>
+ #:name 'enemy-bullets
+ #:rank 3)
+ (make <player>
+ #:name 'player
+ #:rank 4)
+ (make <label>
+ #:name 'hud-lives
+ #:rank 5
+ #:position #v(2.0 228.0)
+ #:text "")
+ (make <label>
+ #:name 'hud-score
+ #:rank 5
+ #:position #v(230.0 228.0)
+ #:text ""))
+ (reset-game shmup))
+
+(define-method (game-over-maybe (shmup <shmup>))
+ (let ((player (& shmup player)))
+ (when (dead? player)
+ (set! (state shmup) 'game-over)
+ (stop-scripts player)
+ (hide player)
+ (end-shooting player)
+ (for-each detach (enemies shmup))
+ (set! (enemies shmup) '())
+ (stop-scripts shmup)
+ (clear-bullets (& shmup player-bullets))
+ (clear-bullets (& shmup enemy-bullets))
+ (attach-to shmup
+ (make <label>
+ #:name 'game-over
+ #:rank 5
+ #:text "GAME OVER"
+ #:position #v(130.0 120.0))))))
+
+(define-method (update (shmup <shmup>) dt)
+ (match (state shmup)
+ ('play
+ (let ((player (& shmup player))
+ (player-bullets (& shmup player-bullets))
+ (enemy-bullets (& shmup enemy-bullets)))
+ (collide enemy-bullets player
+ (lambda (bullet-id hitbox)
+ (kill-bullet enemy-bullets bullet-id)
+ (kill-player player)
+ (update-hud shmup)))
+ (for-each (lambda (enemy)
+ (collide player-bullets enemy
+ (lambda (bullet-id hitbox)
+ (kill-bullet player-bullets bullet-id)
+ (damage enemy 1)))
+ (when (dead? enemy)
+ (set! (score player)
+ (+ (score player) (points enemy)))
+ (update-hud shmup)
+ (kill-enemy shmup enemy)))
+ (enemies shmup))
+ (game-over-maybe shmup)))
+ (_ #f)))
+
+(define-method (add-enemy (shmup <shmup>) (enemy <enemy>))
+ (set! (enemies shmup) (cons enemy (enemies shmup)))
+ ;; Give it a proper ranking so that enemies draw before the player
+ ;; and stuff.
+ (set! (rank enemy) 1)
+ (attach-to shmup enemy))
+
+(define-method (kill-enemy (shmup <shmup>) (enemy <enemy>))
+ (detach enemy)
+ (set! (enemies shmup) (delete enemy (enemies shmup))))
+
+(define-method (add-player-bullet (shmup <shmup>) x y theta speed)
+ (let ((dx (* (cos theta) speed))
+ (dy (* (sin theta) speed)))
+ (add-bullet (& shmup player-bullets) player-bullet-type x y dx dy)))
+
+(define-method (angle-to-player (shmup <shmup>) (enemy <enemy>) ox oy)
+ (let* ((player (& shmup player))
+ (pp (position player))
+ (ep (position enemy))
+ (dx (- (vec2-x pp) (+ (vec2-x ep) ox)))
+ (dy (- (vec2-y pp) (+ (vec2-y ep) oy))))
+ (atan dy dx)))
+
+(define-method (add-enemy-bullet (shmup <shmup>) type x y theta speed)
+ (let ((dx (* (cos theta) speed))
+ (dy (* (sin theta) speed)))
+ (add-bullet (& shmup enemy-bullets) type x y dx dy)))
+
+(define-method (update-player-movement (shmup <shmup>))
+ (change-direction (& shmup player)
+ (key-pressed? 'left)
+ (key-pressed? 'right)
+ (key-pressed? 'down)
+ (key-pressed? 'up)))
+
+(define-method (update-player-shooting (shmup <shmup>))
+ (if (key-pressed? 'z)
+ (begin-shooting (& shmup player))
+ (end-shooting (& shmup player))))
+
+(define-method (pause-game (shmup <shmup>))
+ (set! (state shmup) 'pause)
+ (pause (& shmup background))
+ (pause (& shmup player-bullets))
+ (pause (& shmup enemy-bullets))
+ (pause (& shmup player))
+ (for-each pause (enemies shmup)))
+
+(define-method (resume-game (shmup <shmup>))
+ (set! (state shmup) 'play)
+ (resume (& shmup background))
+ (resume (& shmup player-bullets))
+ (resume (& shmup enemy-bullets))
+ (resume (& shmup player))
+ (update-player-movement shmup)
+ (update-player-shooting shmup)
+ (for-each resume (enemies shmup)))
+
+(define-method (begin-shooting (shmup <shmup>))
+ (begin-shooting (& shmup player)))
+
+(define-method (end-shooting (shmup <shmup>))
+ (end-shooting (& shmup player)))
+
+(define-method (on-key-press (shmup <shmup>) key scancode modifiers repeat?)
+ (match (state shmup)
+ ('play
+ (match key
+ ((or 'up 'down 'left 'right) (update-player-movement shmup))
+ ('z (update-player-shooting shmup))
+ ('return (pause-game shmup))
+ (_ #f)))
+ ('pause
+ (match key
+ ('return (resume-game shmup))
+ (_ #f)))
+ ('game-over
+ (match key
+ ('return (start-over shmup))
+ (_ #f)))
+ (_ #f)))
+
+(define-method (on-key-release (shmup <shmup>) key scancode modifiers)
+ (match (state shmup)
+ ('play
+ (match key
+ ((or 'up 'down 'left 'right) (update-player-movement shmup))
+ ('z (update-player-shooting shmup))
+ (_ #f)))
+ (_ #f)))
+
+(boot-kernel (make <kernel>
+ #:window-config (make <window-config>
+ #:title "shmup game thing i guess whatever"
+ #:width window-width
+ #:height window-height))
+ (lambda ()
+ (make <shmup>)))