Add point-and-click editing.

2 files changed, 92 insertions, 18 deletions

diff --git a/community-garden.scm b/community-garden.scm
index 7cd535a..6d6af5d 100644
--- a/community-garden.scm
+++ b/community-garden.scm
@@ -6,7 +6,8 @@
              (catbird node)
              (catbird node-2d)
              (catbird region)
-             ((catbird scene) #:select (<scene>))
+             ((catbird scene)
+              #:select (<scene> current-scene replace-major-mode))
              (chickadee graphics color)
              (chickadee graphics path)
              (chickadee math vector)
@@ -68,7 +69,7 @@
 (alice-plant 6 2 cabbage/approved)
 
 (define catbird-visitor
-  (catbird-run (<- our-garden-community 'register-visitor "Catbird Viewer")))
+  (catbird-run (<- our-garden-community 'register-gardener "Catbird Viewer")))
 (define catbird-garden-bed (make-atomic-box #f))
 (define catbird-garden-name (make-atomic-box #f))
 (catbird-run
@@ -83,6 +84,7 @@
    (let ((region (create-full-region #:name 'main))
          (scene (make <scene> #:name 'scratch)))
      (replace-scene region scene)
+     (replace-major-mode scene (make <garden-mode>))
      (set! (camera region)
            (make <camera-2d>
              #:width %window-width
@@ -97,10 +99,12 @@
                                 %window-width
                                 %window-height))))
                 (make <garden-view>
+                  #:name 'garden
                   #:vat catbird-vat
-                  #:visitor catbird-visitor
+                  #:user catbird-visitor
                   #:name-box catbird-garden-name
-                  #:garden-bed-box catbird-garden-bed))))
+                  #:garden-bed-box catbird-garden-bed
+                  #:read-only? #f))))
  #:title "Community Garden"
  #:width %window-width
  #:height %window-height)
diff --git a/community-garden/view.scm b/community-garden/view.scm
index 4ec4dda..ad93f45 100644
--- a/community-garden/view.scm
+++ b/community-garden/view.scm
@@ -1,7 +1,10 @@
 (define-module (community-garden view)
   #:use-module (catbird asset)
+  #:use-module (catbird input-map)
+  #:use-module (catbird mode)
   #:use-module (catbird node)
   #:use-module (catbird node-2d)
+  #:use-module ((catbird scene) #:select (current-scene))
   #:use-module (chickadee config)
   #:use-module (chickadee graphics color)
   #:use-module (chickadee graphics path)
@@ -18,7 +21,8 @@
   #:use-module (srfi srfi-43)
   #:export (%window-width
             %window-height
-            <garden-view>))
+            <garden-view>
+            <garden-mode>))
 
 (define %window-width 1024)
 (define %window-height 768)
@@ -34,13 +38,18 @@
 (define-asset (cabbage-texture (f "assets/images/cabbage.png"))
   (load-image f))
 
+(define-class <garden-tile> (<node-2d>)
+  (tile-x #:getter tile-x #:init-keyword #:tile-x)
+  (tile-y #:getter tile-y #:init-keyword #:tile-y))
+
 (define-class <garden-view> (<node-2d>)
   (vat #:getter vat #:init-keyword #:vat)
-  (visitor #:getter visitor #:init-keyword #:visitor)
+  (user #:getter user #:init-keyword #:user)
   (name-box #:getter name-box #:init-keyword #:name-box)
   (garden-bed-box #:getter garden-bed-box #:init-keyword #:garden-bed-box)
   (prev-garden #:accessor prev-garden #:init-value #f)
-  (tiles #:accessor tiles #:init-value #()))
+  (tiles #:accessor tiles #:init-value #())
+  (read-only? #:getter read-only? #:init-keyword #:read-only? #:init-value #t))
 
 (define-method (garden-bed (garden <garden-view>))
   (atomic-box-ref (garden-bed-box garden)))
@@ -67,9 +76,9 @@
     (forever
      ((vat garden)
       (lambda ()
-        (on (visitor garden)
-            (lambda (visitor)
-              (on (<- visitor 'inspect-garden)
+        (on (user garden)
+            (lambda (user)
+              (on (<- user 'inspect-garden)
                   (lambda (garden-bed)
                     (atomic-box-set! (garden-bed-box garden) garden-bed)))))))
      (sleep 0.5))))
@@ -104,14 +113,20 @@
                                    (rectangle (vec2 0.0 0.0)
                                               %tile-width
                                               %tile-height))))
-                       (canvas (make <canvas>
-                                 #:painter painter)))
-                  (attach-to container canvas)
-                  (attach-to canvas
-                             (make <sprite>
-                               #:name 'sprite
-                               #:texture null-texture))
-                  canvas))
+                       (bg (make <canvas>
+                             #:name 'background
+                             #:painter painter))
+                       (sprite (make <sprite>
+                                 #:name 'sprite
+                                 #:texture null-texture))
+                       (tile (make <garden-tile>
+                               #:tile-x x
+                               #:tile-y y)))
+                  (set! (width tile) %tile-width)
+                  (set! (height tile) %tile-height)
+                  (attach-to tile bg sprite)
+                  (attach-to container tile)
+                  tile))
               (garden-bed-width g)))
            (garden-bed-height g)))
     (for-each-tile
@@ -151,3 +166,58 @@
 
 (define-method (update (garden <garden-view>) dt)
   (refresh-garden garden))
+
+(define-method (plant-in-tile (garden <garden-view>) (tile <garden-tile>))
+  (define (plant-ref plants name)
+    (let loop ((plants plants))
+      (match plants
+        (() #f)
+        (((k v) . rest)
+         (if (string=? k name)
+             v
+             (loop rest))))))
+  ((vat garden)
+   (lambda ()
+     (on (user garden)
+         (lambda (user)
+           (on (<- user 'get-approved-plants)
+               (lambda (plants)
+                 (<- user 'plant
+                     (tile-x tile)
+                     (tile-y tile)
+                     (plant-ref plants "Cabbage")))))))))
+
+(define-method (dig-up-tile (garden <garden-view>) (tile <garden-tile>))
+  ((vat garden)
+   (lambda ()
+     (on (user garden)
+         (lambda (user)
+           (<- user 'dig-up (tile-x tile) (tile-y tile)))))))
+
+(define-method (garden-pick (garden <garden-view>) x y)
+  (define (find-tile node)
+    (cond
+     ((not node)
+      #f)
+     ((is-a? node <garden-tile>)
+      node)
+     ((parent node)
+      (find-tile (parent node)))))
+  (find-tile (pick garden (vec2 x y) (lambda _ #t))))
+
+(define-class <garden-mode> (<major-mode>))
+
+(define-method (do-plant (mode <garden-mode>) x y)
+  (define garden (& (current-scene) garden))
+  (define tile (garden-pick garden x y))
+  (when (and tile (not (read-only? garden)))
+    (plant-in-tile garden tile)))
+
+(define-method (do-dig (mode <garden-mode>) x y)
+  (define garden (& (current-scene) garden))
+  (define tile (garden-pick garden x y))
+  (when (and tile (not (read-only? garden)))
+    (dig-up-tile garden tile)))
+
+(bind-input <garden-mode> (mouse-press 'left) do-plant)
+(bind-input <garden-mode> (mouse-press 'right) do-dig)