path: root/super-bloom/game.scm

;;; 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 (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 flower)
  #:use-module (super-bloom player)
  #:use-module (super-bloom water)
  #:export (<super-bloom-mode>
            reset-game!))

(define-asset (background-texture (file (scope-datadir "images/background.png")))
  (load-image file))

(define-asset (chickadee-texture (file (scope-datadir "images/chickadee.png")))
  (load-image file))

(define-asset (water-particle-texture (file (scope-datadir "images/water-particle.png")))
  (load-image file))

(define-asset (trail-particle-texture (file (scope-datadir "images/trail-particle.png")))
  (load-image file))

(define-asset (explosion-particle-texture (file (scope-datadir "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>)
  (show-instructions? #:accessor show-instructions? #:init-value #t
                      #:init-keyword #:show-instructions?)
  (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 2
           #: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 2
           #: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 2
           #: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 <flower>
                 #:name 'flower
                 #:rank 4
                 #:position (vec2 (/ %game-width:float 2.0)
                                  (/ %game-height:float 2.0))
                 #:quadtree (quadtree mode)
                 #:growth-goal 20
                 #:growth-interval 3.0)
               (make <player>
                 #:name 'player
                 #:rank 5
                 #:position (vec2 (/ %game-width:float 2.0)
                                  (/ %game-height:float 4.0))
                 #:quadtree (quadtree mode)
                 #:water-particles water-particles
                 #:trail-particles trail-particles))
    (run-script mode
      (show-instructions mode)
      (start-game mode))))

(define-method (spawn-water (mode <super-bloom-mode>) position)
  (attach-to (parent mode)
             (make <water>
               #:rank 3
               #:position position
               #:quadtree (quadtree mode))))

(define-method (spawn-dirt-ball (mode <super-bloom-mode>) position)
  (attach-to (parent mode)
             (make <dirt-ball>
               #:rank 3
               #:position position
               #:quadtree (quadtree mode)
               #:flower (& (parent mode) flower)
               #:speed 1.0
               #:explosion-particles (& (parent mode) explosion-particles))))

(define-method (spawn-random-water (mode <super-bloom-mode>))
  (spawn-water mode (vec2 (random:float %game-width:float)
                          (random:float %game-height:float))))

(define-method (spawn-random-dirt-ball (mode <super-bloom-mode>))
  (spawn-dirt-ball mode (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))))))

(define-method (wave1 (mode <super-bloom-mode>))
  (spawn-random-water mode)
  (sleep 1.0)
  (spawn-random-water mode)
  (sleep 1.0)
  (spawn-random-dirt-ball mode))

(define-method (wave2 (mode <super-bloom-mode>))
  (spawn-random-water mode)
  (spawn-random-water mode)
  (sleep 1.0)
  (spawn-random-water mode)
  (spawn-random-water mode)
  (sleep 1.0)
  (spawn-random-dirt-ball mode)
  (sleep 1.0)
  (spawn-random-dirt-ball mode)
  (sleep 1.0)
  (spawn-random-dirt-ball mode))

(define-method (wave3 (mode <super-bloom-mode>))
  (spawn-random-water mode)
  (spawn-random-water mode)
  (spawn-random-water mode)
  (spawn-random-water mode)
  (spawn-random-water mode)
  (spawn-random-water mode)
  (sleep 1.0)
  (spawn-random-dirt-ball mode)
  (sleep 1.0)
  (spawn-random-dirt-ball mode)
  (spawn-random-dirt-ball mode)
  (sleep 1.0)
  (spawn-random-dirt-ball mode))

(define hw (/ %game-width:float 2.0))
(define hh (/ %game-height:float 2.0))

(define-method (wave4 (mode <super-bloom-mode>))
  (let ((offset 200.0))
    (spawn-random-water mode)
    (spawn-random-water mode)
    (sleep 1.0)
    (spawn-dirt-ball mode (vec2 hw (+ hh offset)))
    (spawn-dirt-ball mode (vec2 hw (- hh offset)))
    (spawn-dirt-ball mode (vec2 (+ hw offset) hh))
    (spawn-dirt-ball mode (vec2 (- hw offset) hh))))

(define waves (vector wave1 wave2 wave3 wave4))

(define-method (do-random-wave (mode <super-bloom-mode>))
  (let ((wave (vector-ref waves (random (vector-length waves)))))
    (wave mode)))

(define-method (show-instructions (mode <super-bloom-mode>))
  (when (show-instructions? mode)
    (set! (show-instructions? mode) #f)
    (let ((scene (parent mode))
          (label (make <label>
                   #:name 'instructions
                   #:rank 99
                   #:position (vec2 0.0 140.0)
                   #:font monogram-font)))
      (define (show-instruction str)
        (set! (text label) str)
        (center-horizontal-in-parent label))
      (sleep 1.0)
      (attach-to scene label)
      (show-instruction "move with <arrows>")
      (sleep 2.0)
      (show-instruction "collect water by moving over droplets")
      (sleep 2.0)
      (show-instruction "spray stored water with <z> to water the plant")
      (sleep 2.0)
      (show-instruction "spray the dirt balls trying to kill the flower")
      (sleep 2.0)
      (show-instruction "good luck!")
      (sleep 2.0)
      (detach label))))

(define-method (start-game (mode <super-bloom-mode>))
  (spawn-water mode (vec2 120.0 100.0))
  (sleep 1.0)
  (spawn-water mode (vec2 160.0 140.0))
  (sleep 1.0)
  (spawn-water mode (vec2 200.0 100.0))
  (sleep 3.0)
  (wave1 mode)
  (sleep 5.0)
  (wave2 mode)
  (sleep 5.0)
  (forever
   (do-random-wave mode)
   (sleep 5.0)))

(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 (do-spray-water (mode <super-bloom-mode>))
  (spray-water (player mode)))

(define-method (do-quit (mode <major-mode>))
  (exit-catbird))

(define-method (update (mode <super-bloom-mode>) dt)
  (with-agenda (agenda mode)
    (update-agenda dt))
  (let* ((scene (parent mode))
         (flower (& scene flower)))
    (if flower
        (when (= (growth-progress flower) (growth-goal flower))
          (stop-moving (& scene player))
          (for-each-child (lambda (child)
                            (when (is-a? child <dirt-ball>)
                              (set! (dead? child) #t)))
                          scene)
          (replace-major-mode scene (make <win-mode>)))
        (begin
          (stop-moving (& scene player))
          (replace-major-mode scene (make <game-over-mode>))))))

(define-method (do-reset (mode <major-mode>))
  (let ((scene (parent mode)))
    (clear scene)
    (replace-major-mode scene
                        (make <super-bloom-mode>
                          #:show-instructions? #f))))

(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 'z) do-spray-water)
;;(bind-input <super-bloom-mode> (key-press 'r) do-reset)

(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)))

(bind-input <game-over-mode> (key-press 'escape) do-quit)
(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)))

(bind-input <win-mode> (key-press 'escape) do-quit)
(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>))))