Update hacky shmup prototype code.

2 files changed, 153 insertions, 47 deletions

diff --git a/examples/shmup/images/ship.png b/examples/shmup/images/ship.png
deleted file mode 100644
index 7c3aba4..0000000
--- a/examples/shmup/images/ship.png
+++ /dev/null
diff --git a/examples/shmup/shmup.scm b/examples/shmup/shmup.scm
index 5fe51d7..fa757e5 100644
--- a/examples/shmup/shmup.scm
+++ b/examples/shmup/shmup.scm
@@ -24,7 +24,7 @@
 ;;;
 
 (define *render-hitboxes?* #t)
-(define *god-mode?* #f)
+(define *god-mode?* #t)
 
 
 ;;;
@@ -377,17 +377,13 @@
                #: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)
+  (health #:accessor health #:init-form 40)
   (hitboxes #:getter hitboxes
             #:init-form (list (make <hitbox>
                                 #:rect (make-rect -18.0 -26.0 40.0 52.0)))))
@@ -399,20 +395,32 @@
                #: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))))
+  ;;    (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 0.0 10 1.5)
+  ;;    (sleep 5)
+  ;;    (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 0.5 10 1.5)
+  ;;    (sleep 5)
+  ;;    (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 1.0 10 1.5)
+  ;;    (sleep 5)))
+  ;; (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
+    ;; (teleport drone 3600.0 120.0)
+    ;; (move-to drone 290.0 120.0 90)
+    (forever
+     (let ((theta (angle-to-player (parent drone) drone 0 0)))
+       (repeat 6
+               (emit-bullet drone space-marine-bullet-type 0.0 0.0 theta 3.0)
+               (emit-bullet drone space-marine-bullet-type 0.0 0.0 (+ theta 0.04) 3.0)
+               (emit-bullet drone space-marine-bullet-type 0.0 0.0 (- theta 0.04) 3.0)
+               ;; (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 theta 20 3.0)
+               ;; (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 (+ theta 0.04) 20 3.0)
+               ;; (emit-bullet/circle drone space-marine-bullet-type 0.0 0.0 (- theta 0.04) 20 3.0)
+               (sleep 2))
+       (sleep 90))))
   )
 
 
@@ -425,9 +433,11 @@
   (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)
+  (speed #:accessor speed #:init-keyword #:speed #:init-form 2.0)
   (shooting? #:accessor shooting? #:init-form #f)
   (shooting-timer #:accessor shooting-timer #:init-form 0)
+  (guarding? #:accessor guarding? #:init-form #f)
+  (shield-charge #:accessor shield-charge #:init-form 100.0)
   (invincible? #:accessor invincible? #:init-form #f)
   (lives #:accessor lives #:init-form 3)
   (score #:accessor score #:init-form 0))
@@ -437,8 +447,9 @@
   (set! (lives player) 1)
   (set! (shooting? player) #f)
   (set! (shooting-timer player) 0)
+  (set! (guarding? player) #f)
+  (set! (shield-charge player) 100.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))
@@ -456,7 +467,7 @@
 
 (define-method (on-boot (player <player>))
   (attach-to player
-             (mae <animated-sprite>
+             (make <animated-sprite>
                #:name 'sprite
                #:atlas player-atlas
                #:origin #v(41.0 44.0)
@@ -466,7 +477,12 @@
                               (shoot . ,(make <animation>
                                           #:frames #(23 24 25)
                                           #:frame-duration 50)))
-               #:default-animation 'idle)))
+               #:default-animation 'idle)
+             (make <filled-rect>
+               #:name 'shield
+               #:region (make-rect -30.0 -35.0 60.0 60.0)
+               #:color (make-color 1.0 0.0 1.0 0.5)
+               #:visible? #f)))
 
 (define-method (emit-bullet (player <player>) ox oy theta speed)
   (let ((p (position player)))
@@ -512,6 +528,9 @@
     (when (zero? (modulo (shooting-timer player) 2))
       (shoot player))
     (set! (shooting-timer player) (+ (shooting-timer player) 1)))
+  (if (guarding? player)
+      (set! (shield-charge player) (max (- (shield-charge player) 1.0) 0.0))
+      (set! (shield-charge player) (min (+ (shield-charge player) 0.1) 100.0)))
   (next-method))
 
 (define-method (change-direction (player <player>) left? right? down? up?)
@@ -521,8 +540,8 @@
                   (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)))
+    (vec2-normalize! v)
+    (vec2-mult! v (speed player))))
 
 (define-method (begin-shooting (player <player>))
   (set! (shooting? player) #t)
@@ -533,6 +552,47 @@
   (set! (shooting? player) #f)
   (change-animation (& player sprite) 'idle))
 
+(define-method (begin-guarding (player <player>))
+  (set! (guarding? player) #t)
+  (show (& player shield)))
+
+(define-method (end-guarding (player <player>))
+  (set! (guarding? player) #f)
+  (hide (& player shield)))
+
+
+;;;
+;;; Meter
+;;;
+
+(define-class <meter> (<node-2d>)
+  (width #:accessor width #:init-keyword #:width)
+  (thickness #:accessor thickness #:init-keyword #:thickness)
+  (proc #:accessor proc #:init-keyword #:proc)
+  (background-color #:accessor background-color #:init-form black
+                    #:init-keyword #:background-color)
+  (fill-color #:accessor fill-color #:init-form tango-light-scarlet-red
+              #:init-keyword #:fill-color)
+  (background-rect #:getter background-rect #:init-form (make-rect 0.0 0.0 0.0 0.0))
+  (fill-rect #:getter fill-rect #:init-form (make-rect 0.0 0.0 0.0 0.0)))
+
+(define-method (update (meter <meter>) dt)
+  (let ((b (background-rect meter))
+        (f (fill-rect meter))
+        (w (width meter))
+        (h (thickness meter))
+        (t ((proc meter))))
+    (set-rect-width! b w)
+    (set-rect-height! b h)
+    (set-rect-width! f (* w t))
+    (set-rect-height! f h)))
+
+(define-method (render (meter <meter>) alpha)
+  (draw-filled-rect (background-rect meter) (background-color meter)
+                    #:matrix (world-matrix meter))
+  (draw-filled-rect (fill-rect meter) (fill-color meter)
+                    #:matrix (world-matrix meter)))
+
 
 ;;;
 ;;; Shmup scene
@@ -540,35 +600,56 @@
 
 (define-class <shmup> (<scene-2d>)
   (state #:accessor state #:init-form 'play)
-  (enemies #:accessor enemies #:init-form '()))
+  (enemies #:accessor enemies #:init-form '())
+  (cont #:accessor cont #:init-form #f)
+  (cont-x #:accessor cont-x #:init-form +inf.0))
 
 (define-method (update-hud (shmup <shmup>))
   (let ((player (& shmup player)))
     (set! (text (& shmup hud-lives))
-      (format #f "LIVES ~d" (max (- (lives player) 1) 0)))
+      (format #f "lives ~d" (max (- (lives player) 1) 0)))
     (set! (text (& shmup hud-score))
-      (format #f "SCORE ~7d" (score player)))))
+      (format #f "score ~7d" (score player)))))
+
+(define (wait-for-scroll shmup x)
+  (yield
+   (lambda (k)
+     (set! (cont shmup) k)
+     (set! (cont-x shmup) x))))
+
+(define-method (stage-1 (shmup <shmup>))
+  (wait-for-scroll shmup 100.0)
+  ;; (add-enemy shmup
+  ;;            (make <drone>))
+  ;; (wait-for-scroll shmup 500.0)
+  ;; (add-enemy shmup
+  ;;            (make <drone>
+  ;;              #:position #v(290.0 120.0)))
+  )
 
 (define-method (reset-game (shmup <shmup>))
+  (set! (enemies 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))))
+  (run-script shmup (stage-1 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))
+  (for-each detach (enemies shmup))
   (reset-game shmup))
 
 (define-method (on-boot (shmup <shmup>))
@@ -616,7 +697,19 @@
                #:name 'hud-score
                #:rank 5
                #:position #v(230.0 228.0)
-               #:text ""))
+               #:text "")
+             (make <label>
+               #:name 'hud-shield
+               #:rank 5
+               #:position #v(60.0 0.0)
+               #:text "shield")
+             (make <meter>
+               #:position #v(100.0 4.0)
+               #:width 120
+               #:thickness 2
+               #:proc (lambda ()
+                        (/ (shield-charge (& shmup player)) 100.0))
+               #:rank 5))
   (reset-game shmup))
 
 (define-method (game-over-maybe (shmup <shmup>))
@@ -644,6 +737,10 @@
      (let ((player (& shmup player))
            (player-bullets (& shmup player-bullets))
            (enemy-bullets (& shmup enemy-bullets)))
+       (when (and (cont shmup) (>= (x (& shmup background)) (cont-x shmup)))
+         (let ((k (cont shmup)))
+           (set! (cont shmup) #f)
+           (k)))
        (collide enemy-bullets player
                 (lambda (bullet-id hitbox)
                   (kill-bullet enemy-bullets bullet-id)
@@ -704,6 +801,11 @@
       (begin-shooting (& shmup player))
       (end-shooting (& shmup player))))
 
+(define-method (update-player-guarding (shmup <shmup>))
+  (if (key-pressed? 'x)
+      (begin-guarding (& shmup player))
+      (end-guarding (& shmup player))))
+
 (define-method (pause-game (shmup <shmup>))
   (set! (state shmup) 'pause)
   (pause (& shmup background))
@@ -722,19 +824,15 @@
   (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))
+       ('x (update-player-guarding shmup))
        ('return (pause-game shmup))
+       ('r (reset-game shmup))
        (_ #f)))
     ('pause
      (match key
@@ -752,9 +850,17 @@
      (match key
        ((or 'up 'down 'left 'right) (update-player-movement shmup))
        ('z (update-player-shooting shmup))
+       ('x (update-player-guarding shmup))
        (_ #f)))
     (_ #f)))
 
+(define-method (on-mouse-press (shmup <shmup>) button clicks x y)
+  (match button
+    ('left
+     (add-enemy shmup
+                (make <drone> #:position (vec2 (/ x game-scale) (/ y game-scale)))))
+    (_ #f)))
+
 (boot-kernel (make <kernel>
                #:window-config (make <window-config>
                                  #:title "shmup game thing i guess whatever"