From cb47ca44b0302ab7906e5dad18f829631dcaf1e1 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Wed, 26 Jun 2019 16:57:56 -0400
Subject: Add shmup prototype example.

---
 examples/shmup/images/back-buildings.png    | Bin 0 -> 7194 bytes
 examples/shmup/images/bipedal-unit1.png     | Bin 0 -> 841 bytes
 examples/shmup/images/bullet_2.png          | Bin 0 -> 351 bytes
 examples/shmup/images/bullets.png           | Bin 0 -> 516 bytes
 examples/shmup/images/drone-1.png           | Bin 0 -> 1824 bytes
 examples/shmup/images/far-buildings.png     | Bin 0 -> 6763 bytes
 examples/shmup/images/foreground.png        | Bin 0 -> 15269 bytes
 examples/shmup/images/player.png            | Bin 0 -> 8443 bytes
 examples/shmup/images/ship.png              | Bin 0 -> 1589 bytes
 examples/shmup/images/shot-1.png            | Bin 0 -> 165 bytes
 examples/shmup/images/shot-2.png            | Bin 0 -> 1040 bytes
 examples/shmup/images/space-marine-idle.png | Bin 0 -> 3081 bytes
 examples/shmup/images/space-marine.png      | Bin 0 -> 1448 bytes
 examples/shmup/images/v-police.png          | Bin 0 -> 4043 bytes
 examples/shmup/shmup                        |   7 +
 examples/shmup/shmup.scm                    | 764 ++++++++++++++++++++++++++++
 16 files changed, 771 insertions(+)
 create mode 100644 examples/shmup/images/back-buildings.png
 create mode 100644 examples/shmup/images/bipedal-unit1.png
 create mode 100644 examples/shmup/images/bullet_2.png
 create mode 100644 examples/shmup/images/bullets.png
 create mode 100644 examples/shmup/images/drone-1.png
 create mode 100644 examples/shmup/images/far-buildings.png
 create mode 100644 examples/shmup/images/foreground.png
 create mode 100644 examples/shmup/images/player.png
 create mode 100644 examples/shmup/images/ship.png
 create mode 100644 examples/shmup/images/shot-1.png
 create mode 100644 examples/shmup/images/shot-2.png
 create mode 100644 examples/shmup/images/space-marine-idle.png
 create mode 100644 examples/shmup/images/space-marine.png
 create mode 100644 examples/shmup/images/v-police.png
 create mode 100755 examples/shmup/shmup
 create mode 100644 examples/shmup/shmup.scm

diff --git a/examples/shmup/images/back-buildings.png b/examples/shmup/images/back-buildings.png
new file mode 100644
index 0000000..e427882
Binary files /dev/null and b/examples/shmup/images/back-buildings.png differ
diff --git a/examples/shmup/images/bipedal-unit1.png b/examples/shmup/images/bipedal-unit1.png
new file mode 100644
index 0000000..425e0b4
Binary files /dev/null and b/examples/shmup/images/bipedal-unit1.png differ
diff --git a/examples/shmup/images/bullet_2.png b/examples/shmup/images/bullet_2.png
new file mode 100644
index 0000000..2e1e6a4
Binary files /dev/null and b/examples/shmup/images/bullet_2.png differ
diff --git a/examples/shmup/images/bullets.png b/examples/shmup/images/bullets.png
new file mode 100644
index 0000000..f4c430d
Binary files /dev/null and b/examples/shmup/images/bullets.png differ
diff --git a/examples/shmup/images/drone-1.png b/examples/shmup/images/drone-1.png
new file mode 100644
index 0000000..f16ee5b
Binary files /dev/null and b/examples/shmup/images/drone-1.png differ
diff --git a/examples/shmup/images/far-buildings.png b/examples/shmup/images/far-buildings.png
new file mode 100644
index 0000000..7c81747
Binary files /dev/null and b/examples/shmup/images/far-buildings.png differ
diff --git a/examples/shmup/images/foreground.png b/examples/shmup/images/foreground.png
new file mode 100644
index 0000000..f958dae
Binary files /dev/null and b/examples/shmup/images/foreground.png differ
diff --git a/examples/shmup/images/player.png b/examples/shmup/images/player.png
new file mode 100644
index 0000000..9e0a312
Binary files /dev/null and b/examples/shmup/images/player.png differ
diff --git a/examples/shmup/images/ship.png b/examples/shmup/images/ship.png
new file mode 100644
index 0000000..7c3aba4
Binary files /dev/null and b/examples/shmup/images/ship.png differ
diff --git a/examples/shmup/images/shot-1.png b/examples/shmup/images/shot-1.png
new file mode 100644
index 0000000..709de06
Binary files /dev/null and b/examples/shmup/images/shot-1.png differ
diff --git a/examples/shmup/images/shot-2.png b/examples/shmup/images/shot-2.png
new file mode 100644
index 0000000..ee647d2
Binary files /dev/null and b/examples/shmup/images/shot-2.png 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
Binary files /dev/null and b/examples/shmup/images/space-marine-idle.png differ
diff --git a/examples/shmup/images/space-marine.png b/examples/shmup/images/space-marine.png
new file mode 100644
index 0000000..5878af2
Binary files /dev/null and b/examples/shmup/images/space-marine.png differ
diff --git a/examples/shmup/images/v-police.png b/examples/shmup/images/v-police.png
new file mode 100644
index 0000000..110e99b
Binary files /dev/null and b/examples/shmup/images/v-police.png 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>)))
-- 
cgit v1.2.3