From 45791c1360c98957ebe27655d59a2ae9db6cd709 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sun, 4 Jun 2023 09:25:06 -0400
Subject: Giant code and assets drop.

---
 super-bloom/actor.scm     |  99 ++++++++++++++++++
 super-bloom/common.scm    |  69 +++++++++++++
 super-bloom/dirt-ball.scm |  81 +++++++++++++++
 super-bloom/flower.scm    | 146 ++++++++++++++++++++++++++
 super-bloom/game.scm      | 255 ++++++++++++++++++++++++++++++++++++++++++++++
 super-bloom/main.scm      |  75 ++++++++++----
 super-bloom/player.scm    | 170 +++++++++++++++++++++++++++++++
 super-bloom/water.scm     |  60 +++++++++++
 8 files changed, 938 insertions(+), 17 deletions(-)
 create mode 100644 super-bloom/actor.scm
 create mode 100644 super-bloom/common.scm
 create mode 100644 super-bloom/dirt-ball.scm
 create mode 100644 super-bloom/flower.scm
 create mode 100644 super-bloom/game.scm
 create mode 100644 super-bloom/player.scm
 create mode 100644 super-bloom/water.scm

(limited to 'super-bloom')

diff --git a/super-bloom/actor.scm b/super-bloom/actor.scm
new file mode 100644
index 0000000..0ba495f
--- /dev/null
+++ b/super-bloom/actor.scm
@@ -0,0 +1,99 @@
+(define-module (super-bloom actor)
+  #:use-module (catbird asset)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (chickadee audio)
+  #:use-module (chickadee data quadtree)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:export (<actor>
+            velocity
+            hitbox
+            world-hitbox
+            quadtree
+            change-velocity
+            direction-to
+            angle-to
+            after-move
+            on-collide
+            refresh-world-hitbox))
+
+(define-class <actor> (<node-2d>)
+  (velocity #:getter velocity #:init-keyword #:velocity #:init-form (vec2 0.0 0.0))
+  (hitbox #:getter hitbox #:init-keyword #:hitbox)
+  (world-hitbox #:getter world-hitbox #:init-form (make-rect 0.0 0.0 0.0 0.0))
+  (quadtree #:accessor quadtree #:init-keyword #:quadtree))
+
+(define-method (initialize (actor <actor>) initargs)
+  (next-method)
+  (refresh-world-hitbox actor))
+
+(define-method (change-velocity (actor <actor>) dx dy)
+  (set-vec2! (velocity actor) dx dy))
+
+(define-method (direction-to (actor <actor>) (other <actor>))
+  (let ((dir (vec2- (position other) (position actor))))
+    (vec2-normalize! dir)
+    dir))
+
+(define-method (angle-to (actor <actor>) (other <actor>))
+  (let ((p1 (position actor))
+        (p2 (position other)))
+    (atan (- (vec2-y p2) (vec2-y p1))
+          (- (vec2-x p2) (vec2-x p1)))))
+
+(define-method (add-to-quadtree (actor <actor>))
+  (quadtree-insert! (quadtree actor) (world-hitbox actor) actor))
+
+(define-method (remove-from-quadtree (actor <actor>))
+  (quadtree-delete! (quadtree actor) (world-hitbox actor) actor))
+
+(define-method (refresh-world-hitbox (actor <actor>))
+  (let ((p (position actor))
+        (h (hitbox actor))
+        (wh (world-hitbox actor)))
+    (set-rect-x! wh (+ (vec2-x p) (rect-x h)))
+    (set-rect-y! wh (+ (vec2-y p) (rect-y h)))
+    (set-rect-width! wh (rect-width h))
+    (set-rect-height! wh (rect-height h))))
+
+(define-method (on-collide a b)
+  #f)
+
+(define-method (on-enter (actor <actor>))
+  (refresh-world-hitbox actor)
+  (add-to-quadtree actor))
+
+(define-method (on-exit (actor <actor>))
+  (remove-from-quadtree actor))
+
+(define-method (collision-check (actor <actor>))
+  (let ((p (position actor))
+        (r (world-hitbox actor)))
+    (quadtree-find
+     (quadtree actor) r
+     (lambda (other)
+       (and (not (eq? other actor))
+            (rect-intersects? r (world-hitbox other))
+            (on-collide actor other))))))
+
+(define-method (after-move (actor <actor>))
+  #t)
+
+(define-method (update (actor <actor>) dt)
+  (let ((p (position actor))
+        (v (velocity actor)))
+    (if (and (= (vec2-x v) 0.0)
+             (= (vec2-y v) 0.0))
+        (collision-check actor)
+        (begin
+          (remove-from-quadtree actor)
+          (set-vec2! p
+                     (+ (vec2-x p) (vec2-x v))
+                     (+ (vec2-y p) (vec2-y v)))
+          (after-move actor)
+          (refresh-world-hitbox actor)
+          (collision-check actor)
+          (add-to-quadtree actor)
+          (expire-local-matrix actor)))))
diff --git a/super-bloom/common.scm b/super-bloom/common.scm
new file mode 100644
index 0000000..08d4eae
--- /dev/null
+++ b/super-bloom/common.scm
@@ -0,0 +1,69 @@
+;;; Copyright 2023 David Thompson
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-module (super-bloom common)
+  #:use-module (catbird asset)
+  #:use-module (chickadee)
+  #:use-module (chickadee audio)
+  #:use-module (chickadee graphics text)
+  #:use-module (oop goops)
+  #:export (%default-width
+            %default-height
+            %game-width
+            %game-height
+            %game-width:float
+            %game-height:float
+            scope-datadir
+            monogram-font
+            explosion-sound
+            absorb-sound
+            watered-sound
+            spray-sound
+            random:float
+            steps
+            water))
+
+(define %default-width 640)
+(define %default-height 480)
+(define %game-width 320)
+(define %game-height 240)
+(define %game-width:float (exact->inexact %game-width))
+(define %game-height:float (exact->inexact %game-height))
+
+(define (scope-datadir file-name)
+  (let ((prefix (or (getenv "SUPERBLOOM_DATADIR") (getcwd))))
+    (string-append prefix "/" file-name)))
+
+(define-asset (monogram-font (file (scope-datadir "assets/fonts/monogram_extended.ttf")))
+  (load-font file 12 #:smooth? #f))
+
+(define-asset (explosion-sound (file (scope-datadir "assets/audio/explosion.wav")))
+  (load-audio file))
+
+(define-asset (absorb-sound (file (scope-datadir "assets/audio/absorb.wav")))
+  (load-audio file))
+
+(define-asset (watered-sound (file (scope-datadir "assets/audio/watered.wav")))
+  (load-audio file))
+
+(define-asset (spray-sound (file (scope-datadir "assets/audio/spray.wav")))
+  (load-audio file))
+
+(define (random:float n)
+  (* (random:uniform) n))
+
+(define (steps n)
+  (* n (current-timestep)))
+
+(define-accessor water)
diff --git a/super-bloom/dirt-ball.scm b/super-bloom/dirt-ball.scm
new file mode 100644
index 0000000..fd86d5b
--- /dev/null
+++ b/super-bloom/dirt-ball.scm
@@ -0,0 +1,81 @@
+;;; Copyright 2023 David Thompson
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-module (super-bloom dirt-ball)
+  #:use-module (catbird asset)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (chickadee audio)
+  #:use-module (chickadee graphics particles)
+  #:use-module (chickadee graphics texture)
+  #:use-module (chickadee math)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (oop goops)
+  #:use-module (super-bloom actor)
+  #:use-module (super-bloom common)
+  #:use-module (super-bloom flower)
+  #:use-module (super-bloom water)
+  #:export (<dirt-ball>))
+
+(define-asset (dirt-ball-tileset (file (scope-datadir "assets/images/dirt-ball.png")))
+  (load-tileset file 32 32))
+
+(define-class <dirt-ball> (<actor>)
+  (flower #:accessor flower #:init-keyword #:flower)
+  (speed #:accessor speed #:init-keyword #:speed)
+  (dead? #:accessor dead? #:init-value #f)
+  (hitbox #:getter hitbox #:init-form (make-rect -8.0 -8.0 16.0 16.0))
+  (explosion-particles #:accessor explosion-particles #:init-keyword #:explosion-particles))
+
+(define-method (initialize (dirt-ball <dirt-ball>) initargs)
+  (next-method)
+  (attach-to dirt-ball
+             (make <animated-sprite>
+               #:name 'sprite
+               #:atlas dirt-ball-tileset
+               #:origin (vec2 16.0 16.0)
+               #:animations `((default . ,(make <animation>
+                                            #:frames #(0 1)
+                                            #:frame-duration 0.3))
+                              (up . ,(make <animation>
+                                       #:frames #(2 3)
+                                       #:frame-duration 0.3)))))
+  (let ((dir (direction-to dirt-ball (flower dirt-ball))))
+    (change-velocity dirt-ball
+                     (* (vec2-x dir) (speed dirt-ball))
+                     (* (vec2-y dir) (speed dirt-ball))))
+  (update-animation dirt-ball))
+
+(define-method (update-animation (dirt-ball <dirt-ball>))
+  (let ((dy (vec2-y (velocity dirt-ball))))
+    (change-animation (& dirt-ball sprite) (if (> dy 0.0) 'up 'default))))
+
+(define-method (on-splash (dirt-ball <dirt-ball>))
+  (set! (dead? dirt-ball) #t))
+
+(define-method (on-collide (dirt-ball <dirt-ball>) (flower <flower>))
+  (damage flower 5)
+  (set! (dead? dirt-ball) #t))
+
+(define-method (update (dirt-ball <dirt-ball>) _dt)
+  (next-method)
+  (when (dead? dirt-ball)
+    (let ((p (position dirt-ball)))
+      (audio-play (artifact explosion-sound))
+      (add-particle-emitter (particles (explosion-particles dirt-ball))
+                            (make-particle-emitter (make-rect (vec2-x p) (vec2-y p) 0.0 0.0)
+                                                   40 3))
+      (detach dirt-ball))))
diff --git a/super-bloom/flower.scm b/super-bloom/flower.scm
new file mode 100644
index 0000000..428b158
--- /dev/null
+++ b/super-bloom/flower.scm
@@ -0,0 +1,146 @@
+;;; Copyright 2023 David Thompson
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-module (super-bloom flower)
+  #:use-module (catbird asset)
+  #:use-module (catbird mixins)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (chickadee audio)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics particles)
+  #:use-module (chickadee graphics path)
+  #:use-module (chickadee graphics texture)
+  #:use-module (chickadee math)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (oop goops)
+  #:use-module (super-bloom actor)
+  #:use-module (super-bloom common)
+  #:use-module (super-bloom water)
+  #:export (<flower>
+            water
+            damage
+            growth-goal
+            growth-progress))
+
+(define %max-water 1)
+
+(define-asset (flower-tileset (file (scope-datadir "assets/images/flower.png")))
+  (load-tileset file 48 48))
+
+;; Every growth-interval, the flower gains 1 growth point (accumulated
+;; in growth-progress) and consumes 1 unit of water.  If there is no
+;; water, the flower is thirsty and stops growing.
+(define-class <flower> (<actor>)
+  (water #:accessor water #:init-value 0)
+  (growth-goal #:accessor growth-goal #:init-keyword #:growth-goal)
+  (growth-progress #:accessor growth-progress #:init-value 1)
+  (growth-interval #:accessor growth-interval #:init-keyword #:growth-interval)
+  (growth-accumulator #:accessor growth-accumulator #:init-value 0.0)
+  (hitbox #:getter hitbox #:init-form (make-rect -8.0 -8.0 16.0 16.0)))
+
+(define-method (initialize (flower <flower>) initargs)
+  (next-method)
+  (attach-to flower
+             (make <animated-sprite>
+               #:name 'sprite
+               #:atlas flower-tileset
+               #:origin (vec2 24.0 24.0)
+               #:animations `((default . ,(make <animation>
+                                            #:frames #(0 1)
+                                            #:frame-duration 0.3))
+                              (stage-2 . ,(make <animation>
+                                            #:frames #(2 3 4 5)
+                                            #:frame-duration 0.3))
+                              (stage-3 . ,(make <animation>
+                                            #:frames #(6 7 8 9)
+                                            #:frame-duration 0.3))
+                              (stage-4 . ,(make <animation>
+                                            #:frames #(10 11 12 13)
+                                            #:frame-duration 0.3))))
+             (make <canvas>
+               #:name 'progress-meter
+               #:position (vec2 -32.0 -28.0)
+               #:width 64.0
+               #:height 8.0))
+  (update-progress-meter flower))
+
+(define-method (update-progress-meter (flower <flower>))
+  (define w 64.0)
+  (define t (/ (growth-progress flower) (growth-goal flower)))
+  (set! (painter (& flower progress-meter))
+        (superimpose
+         (with-style ((stroke-color (make-color 0.0 0.0 0.0 0.5))
+                      (stroke-width 2.0))
+           (stroke
+            (line (vec2 0.0 0.0) (vec2 w 0.0))))
+         (with-style ((stroke-color db32-tahiti-gold)
+                      (stroke-width 2.0))
+           (stroke
+            (line (vec2 0.0 0.0) (vec2 (* w t) 0.0))))))
+  (resize (& flower progress-meter)
+          (default-width (& flower progress-meter))
+          (default-height (& flower progress-meter))))
+
+
+(define-method (update-animation (flower <flower>))
+  (define t (/ (growth-progress flower) (growth-goal flower)))
+  (change-animation (& flower sprite)
+                    (cond
+                     ((< t 1/3) 'default)
+                     ((< t 2/3) 'stage-2)
+                     ((< t 1) 'stage-3)
+                     (else 'stage-4))))
+
+(define-method (increment-water (flower <flower>) amount)
+  (set! (water flower) (min (+ (water flower) amount) %max-water)))
+
+(define-method (decrement-water (flower <flower>) amount)
+  (set! (water flower) (max (- (water flower) amount) 0)))
+
+(define-method (damage (flower <flower>) amount)
+  (set! (growth-progress flower) (max (- (growth-progress flower) amount) 0))
+  (update-animation flower)
+  (update-progress-meter flower))
+
+(define-method (thirsty? (flower <flower>))
+  (= (water flower) 0))
+
+(define-method (reset-growth-accumulator (flower <flower>))
+  (set! (growth-accumulator flower) 0))
+
+(define-method (on-splash (flower <flower>))
+  (when (thirsty? flower)
+    (increment-water flower 1)
+    (audio-play (artifact watered-sound))))
+
+(define-method (update (flower <flower>) dt)
+  (unless (thirsty? flower)
+    (let ((interval (growth-interval flower))
+          (accum (+ (growth-accumulator flower) dt)))
+      (set! (growth-accumulator flower) accum)
+      (when (>= accum interval)
+        (set! (growth-progress flower)
+              (min (+ (growth-progress flower) 1)
+                   (growth-goal flower)))
+        (set! (growth-accumulator flower)
+              (if (thirsty? flower) 0 (- accum interval)))
+        (decrement-water flower 1)
+        (update-animation flower)
+        (update-progress-meter flower))))
+  (next-method)
+  (when (= (growth-progress flower) 0)
+    (detach flower)))
diff --git a/super-bloom/game.scm b/super-bloom/game.scm
new file mode 100644
index 0000000..f5f1d99
--- /dev/null
+++ b/super-bloom/game.scm
@@ -0,0 +1,255 @@
+;;; Copyright 2023 David Thompson
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-module (super-bloom game)
+  #:use-module (catbird)
+  #:use-module (catbird asset)
+  #:use-module (catbird camera)
+  #:use-module (catbird kernel)
+  #:use-module (catbird mode)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (catbird region)
+  #:use-module (catbird scene)
+  #:use-module (chickadee data quadtree)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics particles)
+  #:use-module (chickadee graphics texture)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:use-module (super-bloom actor)
+  #:use-module (super-bloom common)
+  #:use-module (super-bloom dirt-ball)
+  #:use-module (super-bloom flower)
+  #:use-module (super-bloom player)
+  #:use-module (super-bloom water)
+  #:export (<super-bloom-mode>
+            reset-game!))
+
+(define-asset (background-texture (file (scope-datadir "assets/images/background.png")))
+  (load-image file))
+
+(define-asset (chickadee-texture (file (scope-datadir "assets/images/chickadee.png")))
+  (load-image file))
+
+(define-asset (water-particle-texture (file (scope-datadir "assets/images/water-particle.png")))
+  (load-image file))
+
+(define-asset (trail-particle-texture (file (scope-datadir "assets/images/trail-particle.png")))
+  (load-image file))
+
+(define-asset (explosion-particle-texture (file (scope-datadir "assets/images/explosion-particle.png")))
+  (load-image file))
+
+(define (make-game-quadtree)
+  (make-quadtree (make-rect 0.0 0.0 %game-width %game-height)))
+
+(define-class <super-bloom-mode> (<major-mode>)
+  (quadtree #:getter quadtree #:init-thunk make-game-quadtree))
+
+(define-method (on-enter (mode <super-bloom-mode>))
+  (let ((scene (parent mode))
+        (water-particles
+         (make <particles>
+           #:name 'water-particles
+           #:rank 1
+           #:particles
+           (make-particles 1024
+                           #:texture (artifact water-particle-texture)
+                           #:start-color white
+                           #:end-color white
+                           #:speed-range (vec2 2.0 5.0)
+                           #:acceleration-range (vec2 0.1 0.3)
+                           #:lifetime 10)))
+        (trail-particles
+         (make <particles>
+           #:name 'trail-particles
+           #:rank 1
+           #:particles
+           (make-particles 1024
+                           #:texture (artifact trail-particle-texture)
+                           #:animation-columns 3
+                           #:start-color white
+                           #:end-color white
+                           #:speed-range (vec2 0.2 0.5)
+                           #:acceleration-range (vec2 0.1 0.2)
+                           #:lifetime 12)))
+        (explosion-particles
+         (make <particles>
+           #:name 'explosion-particles
+           #:rank 1
+           #:particles
+           (make-particles 1024
+                           #:texture (artifact explosion-particle-texture)
+                           #:lifetime 20
+                           #:end-color white))))
+    (attach-to scene
+               (make <sprite>
+                 #:name 'background
+                 #:rank 0
+                 #:texture background-texture)
+               water-particles
+               trail-particles
+               explosion-particles
+               (make <player>
+                 #:name 'player
+                 #:rank 2
+                 #:position (vec2 (/ %game-width:float 2.0)
+                                  (/ %game-height:float 4.0))
+                 #:quadtree (quadtree mode)
+                 #:water-particles water-particles
+                 #:trail-particles trail-particles)
+               (make <flower>
+                 #:name 'flower
+                 #:rank 4
+                 #:position (vec2 (/ %game-width:float 2.0)
+                                  (/ %game-height:float 2.0))
+                 #:quadtree (quadtree mode)
+                 #:growth-goal 10
+                 #:growth-interval 0.5))))
+
+(define-method (player (mode <super-bloom-mode>))
+  (& (parent mode) player))
+
+(define-method (player-move-left (mode <super-bloom-mode>))
+  (set! (move-left? (player mode)) #t))
+(define-method (player-move-left-stop (mode <super-bloom-mode>))
+  (set! (move-left? (player mode)) #f))
+(define-method (player-move-right (mode <super-bloom-mode>))
+  (set! (move-right? (player mode)) #t))
+(define-method (player-move-right-stop (mode <super-bloom-mode>))
+  (set! (move-right? (player mode)) #f))
+(define-method (player-move-down (mode <super-bloom-mode>))
+  (set! (move-down? (player mode)) #t))
+(define-method (player-move-down-stop (mode <super-bloom-mode>))
+  (set! (move-down? (player mode)) #f))
+(define-method (player-move-up (mode <super-bloom-mode>))
+  (set! (move-up? (player mode)) #t))
+(define-method (player-move-up-stop (mode <super-bloom-mode>))
+  (set! (move-up? (player mode)) #f))
+
+(define-method (add-random-water (mode <super-bloom-mode>))
+  (let ((p (vec2 (random:float %game-width:float) (random:float %game-height:float))))
+    (attach-to (parent mode)
+               (make <water>
+                 #:rank 3
+                 #:position p
+                 #:quadtree (quadtree mode)))))
+
+(define-method (add-random-dirt-ball (mode <super-bloom-mode>))
+  (let ((p (vec2 (if (= (random 2) 0) -32.0 (+ %game-width:float 32.0))
+                 (+ (/ %game-height 2.0)
+                    (* (/ %game-height 2.0)
+                       (- (random:float 2.0) 1.0))))))
+    (attach-to (parent mode)
+               (make <dirt-ball>
+                 #:rank 3
+                 #:position p
+                 #:quadtree (quadtree mode)
+                 #:flower (& (parent mode) flower)
+                 #:speed 1.0
+                 #:explosion-particles (& (parent mode) explosion-particles)))))
+
+(define-method (do-spray-water (mode <super-bloom-mode>))
+  (spray-water (player mode)))
+
+(define-method (do-quit (mode <super-bloom-mode>))
+  (exit-catbird))
+
+(define-method (update (mode <super-bloom-mode>) dt)
+  (let* ((scene (parent mode))
+         (flower (& scene flower)))
+    (if flower
+        (when (= (growth-progress flower) (growth-goal flower))
+          (stop-moving (& scene player))
+          (replace-major-mode scene (make <win-mode>)))
+        (begin
+          (pk 'no-flower)
+          (stop-moving (& scene player))
+          (replace-major-mode scene (make <game-over-mode>))))))
+
+(bind-input <super-bloom-mode> (key-press 'escape) do-quit)
+(bind-input <super-bloom-mode> (key-press 'left) player-move-left)
+(bind-input <super-bloom-mode> (key-release 'left) player-move-left-stop)
+(bind-input <super-bloom-mode> (key-press 'right) player-move-right)
+(bind-input <super-bloom-mode> (key-release 'right) player-move-right-stop)
+(bind-input <super-bloom-mode> (key-press 'down) player-move-down)
+(bind-input <super-bloom-mode> (key-release 'down) player-move-down-stop)
+(bind-input <super-bloom-mode> (key-press 'up) player-move-up)
+(bind-input <super-bloom-mode> (key-release 'up) player-move-up-stop)
+(bind-input <super-bloom-mode> (key-press 'space) add-random-water)
+(bind-input <super-bloom-mode> (key-press 'return) add-random-dirt-ball)
+(bind-input <super-bloom-mode> (key-press 'z) do-spray-water)
+
+(define-class <game-over-mode> (<major-mode>))
+
+(define-method (on-enter (mode <game-over-mode>))
+  (let ((scene (parent mode)))
+    (attach-to scene
+               (make <label>
+                 #:name 'game-over-label
+                 #:rank 99
+                 #:position (vec2 0.0 200.0)
+                 #:font monogram-font
+                 #:text "GAME OVER")
+               (make <label>
+                 #:name 'instructions-label
+                 #:rank 99
+                 #:font monogram-font
+                 #:text "Press <Z> to play again"))
+    (center-in-parent (& scene game-over-label))
+    (center-horizontal-in-parent (& scene instructions-label))
+    (place-below (& scene game-over-label)
+                 (& scene instructions-label)
+                 #:padding 16.0)))
+
+(define-method (do-reset (mode <game-over-mode>))
+  (clear (parent mode))
+  (replace-major-mode (parent mode) (make <super-bloom-mode>)))
+
+(bind-input <game-over-mode> (key-press 'z) do-reset)
+
+(define-class <win-mode> (<major-mode>))
+
+(define-method (on-enter (mode <win-mode>))
+  (let ((scene (parent mode)))
+    (attach-to scene
+               (make <label>
+                 #:name 'win-label
+                 #:rank 99
+                 #:position (vec2 0.0 200.0)
+                 #:font monogram-font
+                 #:text "YES! YOUR FLOWER HAS BLOOMED :)")
+               (make <label>
+                 #:name 'instructions-label
+                 #:rank 99
+                 #:font monogram-font
+                 #:text "Press <Z> to play again"))
+    (center-horizontal-in-parent (& scene win-label))
+    (center-horizontal-in-parent (& scene instructions-label))
+    (place-below (& scene win-label)
+                 (& scene instructions-label)
+                 #:padding 16.0)))
+
+(define-method (do-reset (mode <win-mode>))
+  (clear (parent mode))
+  (replace-major-mode (parent mode) (make <super-bloom-mode>)))
+
+(bind-input <win-mode> (key-press 'z) do-reset)
+
+(define (reset-game!)
+  (let ((game-scene (scene (find-region-by-name 'main))))
+    (clear game-scene)
+    (replace-major-mode game-scene (make <super-bloom-mode>))))
diff --git a/super-bloom/main.scm b/super-bloom/main.scm
index 2f49e9a..390003b 100644
--- a/super-bloom/main.scm
+++ b/super-bloom/main.scm
@@ -14,37 +14,78 @@
 
 (define-module (super-bloom main)
   #:use-module (catbird)
-  #:use-module (catbird asset)
   #:use-module (catbird camera)
   #:use-module (catbird kernel)
-  #:use-module (catbird node)
-  #:use-module (catbird node-2d)
+  #:use-module (catbird mixins)
   #:use-module (catbird region)
   #:use-module (catbird scene)
   #:use-module (chickadee)
-  #:use-module (chickadee math vector)
-  #:use-module (chickadee graphics sprite)
-  #:use-module (chickadee graphics texture)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee math rect)
   #:use-module (oop goops)
+  #:use-module (super-bloom common)
+  #:use-module (super-bloom game)
   #:export (launch-game))
 
-(define %default-width 1366)
-(define %default-height 768)
+(define-class <upscaled-centered-region> (<region>)
+  (area #:getter area #:init-form (make-rect 0.0 0.0 1.0 1.0))
+  (unscaled-width #:getter unscaled-width #:init-keyword #:unscaled-width)
+  (unscaled-height #:getter unscaled-height #:init-keyword #:unscaled-height))
 
-(define-asset (chickadee-texture (file "assets/images/chickadee.png"))
-  (load-image file))
+(define-method (initialize (region <upscaled-centered-region>) initargs)
+  (next-method)
+  (refresh-area region
+                (window-width (current-window))
+                (window-height (current-window))))
+
+(define-method (on-window-resize (region <upscaled-centered-region>) width height)
+  (refresh-area region width height))
+
+(define-method (refresh-camera (region <upscaled-centered-region>))
+  (let ((c (camera region)))
+    (when c (resize c (unscaled-width region) (unscaled-height region)))))
+
+(define-method (refresh-area (region <upscaled-centered-region>) width height)
+  (let* ((w (unscaled-width region))
+         (h (unscaled-height region))
+         (scale (max (min (truncate-quotient width w)
+                          (truncate-quotient height h))
+                     1))
+         (new-w (* w scale))
+         (new-h (* h scale)))
+    (move region
+          (truncate-quotient (- width new-w) 2)
+          (truncate-quotient (- height new-h) 2))
+    (resize region new-w new-h)))
+
+(define* (create-upscaled-centered-region width height #:key (rank 0) (name #f))
+  (let ((region (make <upscaled-centered-region>
+                  #:name name
+                  #:rank rank
+                  #:unscaled-width width
+                  #:unscaled-height height)))
+    (add-region (current-kernel) region)
+    region))
+
+(define-class <game-scene> (<scene>))
+
+(define-method (width (scene <game-scene>))
+  %game-width:float)
+
+(define-method (height (scene <game-scene>))
+  %game-height:float)
 
 (define (init)
-  (let ((region (create-full-region #:name 'main))
-        (scene (make <scene> #:name 'super-bloom)))
+  (let ((region (create-upscaled-centered-region %game-width %game-height #:name 'main))
+        (scene (make <game-scene> #:name 'super-bloom))
+        (camera (make <camera-2d> #:width %game-width #:height %game-height)))
     (replace-scene region scene)
-    (set-camera region (make <camera-2d>))
-    (attach-to scene (make <sprite>
-                       #:name 'chickadee
-                       #:texture chickadee-texture))
-    (center-in-parent (& scene chickadee))))
+    (set-camera region camera)
+    (replace-major-mode scene (make <super-bloom-mode>))))
 
 (define (launch-game)
   (run-catbird init
+               #:title "SUPER BLOOM (Spring Lisp Game Jam 2023)"
+               #:clear-color black
                #:width %default-width
                #:height %default-height))
diff --git a/super-bloom/player.scm b/super-bloom/player.scm
new file mode 100644
index 0000000..4e00c1d
--- /dev/null
+++ b/super-bloom/player.scm
@@ -0,0 +1,170 @@
+;;; Copyright 2023 David Thompson
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-module (super-bloom player)
+  #:use-module (catbird asset)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (chickadee audio)
+  #:use-module (chickadee data quadtree)
+  #:use-module (chickadee graphics particles)
+  #:use-module (chickadee graphics texture)
+  #:use-module (chickadee math)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (oop goops)
+  #:use-module (super-bloom actor)
+  #:use-module (super-bloom common)
+  #:use-module (super-bloom dirt-ball)
+  #:use-module (super-bloom water)
+  #:export (%max-water
+            <player>
+            move-left?
+            move-right?
+            move-down?
+            move-up?
+            shoot?
+            invincible?
+            speed
+            stop-moving
+            spray-water))
+
+(define %max-water 1)
+
+(define-asset (player-tileset (file (scope-datadir "assets/images/player.png")))
+  (load-tileset file 32 32))
+
+(define-class <player> (<actor>)
+  (move-left? #:accessor move-left? #:init-value #f #:watch? #t)
+  (move-right? #:accessor move-right? #:init-value #f #:watch? #t)
+  (move-down? #:accessor move-down? #:init-value #f)
+  (move-up? #:accessor move-up? #:init-value #f)
+  (shoot? #:accessor shoot? #:init-value #f #:watch? #t)
+  (last-shot #:accessor last-shot #:init-value 0)
+  (speed #:accessor speed #:init-value 3.0)
+  (lives #:accessor lives #:init-value 3)
+  (invincible? #:accessor invincible? #:init-value #f)
+  (water #:accessor water #:init-value 0)
+  (water-particles #:accessor water-particles #:init-keyword #:water-particles)
+  (trail-particles #:accessor trail-particles #:init-keyword #:trail-particles)
+  (hitbox #:getter hitbox #:init-form (make-rect -8.0 -8.0 16.0 16.0)))
+
+(define-method (initialize (player <player>) initargs)
+  (next-method)
+  (attach-to player
+             (make <animated-sprite>
+               #:name 'sprite
+               #:atlas player-tileset
+               #:origin (vec2 16.0 16.0)
+               #:animations `((default . ,(make <animation>
+                                            #:frames #(0 1 2 3)
+                                            #:frame-duration 0.1))
+                              (full . ,(make <animation>
+                                         #:frames #(4 5 6 7)
+                                         #:frame-duration 0.1)))))
+  (add-particle-emitter (particles (trail-particles player))
+                        (make-particle-emitter (world-hitbox player) 2)))
+
+(define-method (update-animation (player <player>))
+  (change-animation (& player sprite)
+                    (if (= (water player) 0)
+                        'default
+                        'full)))
+
+(define-method (stop-moving (player <player>))
+  (set! (move-left? player) #f)
+  (set! (move-right? player) #f)
+  (set! (move-up? player) #f)
+  (set! (move-down? player) #f))
+
+(define-method (after-move (player <player>))
+  (let ((p (position player)))
+    (cond
+     ((< (vec2-x p) 0.0)
+      (set-vec2-x! p 0.0))
+     ((> (vec2-x p) %game-width:float)
+      (set-vec2-x! p %game-width:float)))
+    (cond
+     ((< (vec2-y p) 0.0)
+      (set-vec2-y! p 0.0))
+     ((> (vec2-y p) %game-height:float)
+      (set-vec2-y! p %game-height:float)))))
+
+(define-method (update (player <player>) dt)
+  (let ((v (velocity player)))
+    (set-vec2! v
+               (+ (if (move-left? player) -1.0 0.0)
+                  (if (move-right? player) 1.0 0.0))
+               (+ (if (move-down? player) -1.0 0.0)
+                  (if (move-up? player) 1.0 0.0)))
+    (vec2-normalize! v)
+    (vec2-mult! v (speed player)))
+  (next-method))
+
+(define-method (increment-water (player <player>) amount)
+  (set! (water player) (min (+ (water player) amount) %max-water))
+  (update-animation player))
+
+(define-method (decrement-water (player <player>) amount)
+  (set! (water player) (max (- (water player) amount) 0))
+  (update-animation player))
+
+(define-method (saturated? (player <player>))
+  (= (water player) %max-water))
+
+(define-method (dry? (player <player>))
+  (= (water player) 0))
+
+(define-method (on-collide (player <player>) (droplet <water>))
+  (unless (or (invincible? player) (saturated? player))
+    (increment-water player 1)
+    (absorb! droplet)
+    (audio-play (artifact absorb-sound))))
+
+(define-method (on-collide (player <player>) (dirt-ball <dirt-ball>))
+  (hit player))
+
+(define-method (on-collide (dirt-ball <dirt-ball>) (player <player>))
+  (on-collide player dirt-ball))
+
+(define-method (spray-water (player <player>))
+  (unless (dry? player)
+    (decrement-water player 1)
+    (let ((p (position player))
+          (r (rect-inflate (world-hitbox player) 64.0 64.0)))
+      (add-particle-emitter (particles (water-particles player))
+                            (make-particle-emitter (make-rect (vec2-x p) (vec2-y p) 0.0 0.0)
+                                                   200 2))
+      (quadtree-for-each
+       (quadtree player) r
+       (lambda (other)
+         (when (and (not (eq? other player))
+                    (rect-intersects? r (world-hitbox other)))
+           (on-splash other))))
+      (audio-play (artifact spray-sound)))))
+
+(define-method (hit (player <player>))
+  (unless (invincible? player)
+    ;;(set! (lives player) (max (- (lives player) 1) 0))
+    (set! (water player) 0)
+    (set! (invincible? player) #t)
+    (audio-play (artifact explosion-sound))
+    (update-animation player)
+    ;; (add-particle-emitter (particles (particles (parent player)))
+    ;;                       (make-particle-emitter (world-hitbox player)
+    ;;                                              10 5))
+    (run-script player
+      (blink player 10 (steps 5))
+      (set! (invincible? player) #f))))
diff --git a/super-bloom/water.scm b/super-bloom/water.scm
new file mode 100644
index 0000000..d2533fd
--- /dev/null
+++ b/super-bloom/water.scm
@@ -0,0 +1,60 @@
+;;; Copyright 2023 David Thompson
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-module (super-bloom water)
+  #:use-module (catbird asset)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (chickadee audio)
+  #:use-module (chickadee graphics particles)
+  #:use-module (chickadee graphics texture)
+  #:use-module (chickadee math)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (oop goops)
+  #:use-module (super-bloom actor)
+  #:use-module (super-bloom common)
+  #:export (<water>
+            absorbed?
+            absorb!
+            on-splash))
+
+(define-asset (water-tileset (file (scope-datadir "assets/images/water.png")))
+  (load-tileset file 32 32))
+
+(define-class <water> (<actor>)
+  (hitbox #:getter hitbox #:init-form (make-rect -16.0 -16.0 32.0 32.0))
+  (absorbed? #:accessor absorbed? #:init-value #f))
+
+(define-method (initialize (water <water>) initargs)
+  (next-method)
+  (attach-to water
+             (make <animated-sprite>
+               #:name 'sprite
+               #:atlas water-tileset
+               #:origin (vec2 16.0 16.0)
+               #:animations `((default . ,(make <animation>
+                                            #:frames #(0 1)
+                                            #:frame-duration 0.3))))))
+
+(define-method (absorb! (water <water>))
+  (set! (absorbed? water) #t))
+
+(define-method (update (water <water>) _dt)
+  (when (absorbed? water) (detach water))
+  (next-method))
+
+(define-method (on-splash (actor <actor>))
+  #t)
-- 
cgit v1.2.3