From 111eb3342910bdef15dd59f984d79bab4f5c21b5 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 22 May 2024 18:34:29 -0400
Subject: [PATCH] Spawn ghost gems where gems used to be.

---
 game.js                 |  1 +
 game.scm                | 11 +++++++++--
 modules/dom/canvas.scm  |  4 ++++
 modules/game/actors.scm | 17 +++++++++++++++++
 modules/game/level.scm  |  6 ++++--
 scripts/compile-map.scm |  4 ++--
 6 files changed, 37 insertions(+), 6 deletions(-)

diff --git a/game.js b/game.js
index e063178..74a2be9 100644
--- a/game.js
+++ b/game.js
@@ -58,6 +58,7 @@ window.addEventListener("load", async () => {
         },
         canvas: {
           getContext: (elem, type) => elem.getContext(type),
+          setGlobalAlpha: (ctx, alpha) => ctx.globalAlpha = alpha,
           setFillColor: (ctx, color) => ctx.fillStyle = color,
           setFont: (ctx, font) => ctx.font = font,
           setTextAlign: (ctx, align) => ctx.textAlign = align,
diff --git a/game.scm b/game.scm
index 29de759..444a9bc 100644
--- a/game.scm
+++ b/game.scm
@@ -150,7 +150,7 @@
                            (<= az bz))))))))))
 
 (define (collected-gem? idx)
- (not (memq idx *gems*)))
+ (memq idx *gems*))
 
 (define (load-level! idx)
   (set! *state* 'play)
@@ -288,6 +288,11 @@
 (define (draw-gem pos)
   (draw-tile context tileset 28 (vec2-x pos) (vec2-y pos)))
 
+(define (draw-ghost-gem pos)
+  (set-global-alpha! context 0.5)
+  (draw-tile context tileset 49 (vec2-x pos) (vec2-y pos))
+  (set-global-alpha! context 1.0))
+
 (define (draw-gate pos open?)
   (draw-tile context tileset (if open? 46 45) (vec2-x pos) (vec2-y pos)))
 
@@ -315,6 +320,7 @@
     (('clock-emitter pos) #t)           ; drawn via background
     (('floor-switch pos on?) (draw-floor-switch pos on?))
     (('gem pos) (draw-gem pos))
+    (('ghost-gem pos) (draw-ghost-gem pos))
     (('gate pos open?) (draw-gate pos open?))
     (('and-gate pos state) (draw-logic-gate pos state 42))
     (('or-gate pos state) (draw-logic-gate pos state 43))
@@ -344,7 +350,8 @@
       (fill-text context "OUCH... x_x" (/ game-width 2.0) (/ game-height 2.0)))))
 
 (define (draw-win)
-  (set-fill-color! context "#x000000")
+  (set-fill-color! context "#000000")
+  (set-text-align! context "left")
   (fill-text context "OMG YOU DID IT WOW CONGRATS" 32.0 120.0))
 
 (define (draw prev-time)
diff --git a/modules/dom/canvas.scm b/modules/dom/canvas.scm
index 57bd7fc..7bb03fc 100644
--- a/modules/dom/canvas.scm
+++ b/modules/dom/canvas.scm
@@ -23,6 +23,7 @@
   #:use-module (scheme base)
   #:use-module (hoot ffi)
   #:export (get-context
+            set-global-alpha!
             set-fill-color!
             set-font!
             set-text-align!
@@ -40,6 +41,9 @@
   (ref extern) (ref string) -> (ref extern))
 
 ;; CanvasRenderingContext2D
+(define-foreign set-global-alpha!
+  "canvas" "setGlobalAlpha"
+  (ref extern) f64 -> none)
 (define-foreign set-fill-color!
   "canvas" "setFillColor"
   (ref extern) (ref string) -> none)
diff --git a/modules/game/actors.scm b/modules/game/actors.scm
index ea1f488..07d22e5 100644
--- a/modules/game/actors.scm
+++ b/modules/game/actors.scm
@@ -9,6 +9,7 @@
             ^floor-switch
             ^gate
             ^gem
+            ^ghost-gem
             ^and-gate
             ^xor-gate
             ^or-gate
@@ -268,6 +269,21 @@
      (when (eq? ($ other 'type) 'player)
        ($ picked-up? #t)))))
 
+(define (^ghost-gem bcom x y)
+  (define position (vector x y 1))
+  (match-lambda*
+    (('type) 'ghost-gem)
+    (('position) position)
+    (('tick grid-info) #f)
+    (('post-tick grid-info) #f)
+    (('enter obj grid-info) #f)
+    (('exit obj grid-info) #f)
+    (('wire-state grid-info) #f)
+    (('update-wire-state grid-info) #f)
+    (('alive?) #t)
+    (('describe) `(ghost-gem ,position))
+    (('collide other offset grid-info) #f)))
+
 (define (^gate bcom x y)
   (define position (vector x y 1))
   (define open? (spawn ^cell))
@@ -461,6 +477,7 @@
               ($ event '(bump)))))
        ('switch ($ event '(switch)))
        ('gem ($ event '(gem)))
+       ('ghost-gem #t)
        ('gate
         (unless ($ other 'open?)
           (reverse-move)
diff --git a/modules/game/level.scm b/modules/game/level.scm
index f5cfef0..846c36e 100644
--- a/modules/game/level.scm
+++ b/modules/game/level.scm
@@ -37,7 +37,7 @@
   (actor level-actor)
   (player level-player))
 
-(define (make-level width height background objects spawn-gem?)
+(define (make-level width height background objects collected-gem?)
   (let ((level* (spawn ^level width height))
         (background* (make-vector (* width height))))
     ;; Unpack background tile data.
@@ -70,7 +70,9 @@
                         (8 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
                                  (target-y (bytevector-u8-ref objects (+ i 4))))
                              (spawn ^floor-switch x y target-x target-y)))
-                        (9 (and spawn-gem? (spawn ^gem x y)))
+                        (9 (if collected-gem?
+                               (spawn ^ghost-gem x y)
+                               (spawn ^gem x y)))
                         (10 (spawn ^gate x y))
                         (11 (spawn ^and-gate x y))
                         (12 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
diff --git a/scripts/compile-map.scm b/scripts/compile-map.scm
index b9c0c4e..e670d28 100644
--- a/scripts/compile-map.scm
+++ b/scripts/compile-map.scm
@@ -635,7 +635,7 @@ the default ORIENTATION value of 'orthogonal' is supported."
                `((define-module ,module-name
                    #:use-module (game level)
                    #:export (,proc-name))
-                 (define (,proc-name spawn-gem?)
+                 (define (,proc-name collected-gem?)
                    (make-level ,(tile-map-width tile-map)
                                ,(tile-map-height tile-map)
                                ,(compile-tile-layer tile-map "background")
@@ -643,5 +643,5 @@ the default ORIENTATION value of 'orthogonal' is supported."
                                  (append
                                   (compile-environment-layer tile-map "background")
                                   (compile-object-layer tile-map "objects")))
-                               spawn-gem?))))))
+                               collected-gem?))))))
   (_ (error "file name expected")))