Just for fun: Now both host/join programs are graphical.

6 files changed, 278 insertions, 165 deletions

diff --git a/community-garden/actors.scm b/community-garden/actors.scm
index 5146047..64d4e58 100644
--- a/community-garden/actors.scm
+++ b/community-garden/actors.scm
@@ -43,7 +43,8 @@
       (error "tile already has something planted in it" x y)))
   (methods
    ((get-name) name)
-   ((get-bed) garden-bed)
+   ((get-bed)
+    (serialize-garden-bed garden-bed))
    ((get-approved-plants)
     ($ garden-gate 'get-approved-plants))
    ((plant gardener-name x y sealed-plant)
diff --git a/community-garden/edit.scm b/community-garden/edit.scm
deleted file mode 100644
index 0a7cc3d..0000000
--- a/community-garden/edit.scm
+++ /dev/null
@@ -1,72 +0,0 @@
-(define-module (community-garden edit)
-  #:use-module (community-garden actors)
-  #:use-module (goblins)
-  #:use-module (goblins vrun)
-  #:use-module (goblins ocapn ids)
-  #:use-module (goblins ocapn captp)
-  #:use-module (goblins ocapn netlayer onion)
-  #:use-module (ice-9 match)
-  #:export (edit-garden))
-
-(define (edit-garden name community-address)
-  (define community-sref (string->ocapn-id community-address))
-  (define vat (spawn-vat))
-  (define-vat-run vat-run vat)
-  (define onion-netlayer (vat-run (new-onion-netlayer)))
-  (define mycapn (vat-run (spawn-mycapn onion-netlayer)))
-  (define community-vow (vat-run ($ mycapn 'enliven community-sref)))
-  (define gardener (vat-run (<- community-vow 'register-gardener name)))
-  (define approved-plants-vow (vat-run (<- gardener 'get-approved-plants)))
-  (define running? #t)
-  (define (plant-ref plants name)
-    (let loop ((plants plants))
-      (match plants
-        (() #f)
-        (((k v) . rest)
-         (if (string=? k name)
-             v
-             (loop rest))))))
-  (define (read*)
-    (display "> ")
-    (read))
-  (format #t ">>> Community Garden Command Console <<<
-  Enter (help) for a list of commands.
-
-\"Hope you like cabbage and sunflowers!\" - admin
-
-")
-  (while running?
-    (match (read*)
-      (('quit)
-       (set! running? #f))
-      (('help)
-       (format #t "Available commands:
-(get-garden-name) - display current garden name
-(list-plants) - list available plant names
-(dig-up x y) - dig up plant at tile (x, y)
-(plant x y name) - plant at tile (x, y)
-"))
-      (('get-garden-name)
-       (vat-run (on (<- gardener 'get-garden-name)
-                    (lambda (name)
-                      (format #t "Garden name: ~a\n"
-                              name)))))
-      (('list-plants)
-       (vat-run
-        (on approved-plants-vow
-            (lambda (plants)
-              (for-each (match-lambda
-                          ((name _)
-                           (format #t "~a\n" name)))
-                        plants)))))
-      (('dig-up x y)
-       (format #t "dig up tile (~a, ~a)\n" x y)
-       (vat-run (<- gardener 'dig-up x y)))
-      (('plant x y name)
-       (format #t "plant in tile (~a, ~a)\n" x y)
-       (vat-run
-        (on approved-plants-vow
-            (lambda (plants)
-              (<- gardener 'plant x y (plant-ref plants name))))))
-      (exp
-       (format #t "unrecognized command: ~a\n" exp)))))
diff --git a/community-garden/garden-bed.scm b/community-garden/garden-bed.scm
index 71cf6e6..f6a5dde 100644
--- a/community-garden/garden-bed.scm
+++ b/community-garden/garden-bed.scm
@@ -9,7 +9,8 @@
             garden-bed-height
             garden-bed-tiles
             garden-bed-ref
-            garden-bed-set))
+            garden-bed-set
+            serialize-garden-bed))
 
 (define (list-replace lst i o)
   (let loop ((j 0)
@@ -61,6 +62,16 @@
                     (garden-bed-height garden)
                     (bed-set (garden-bed-tiles garden) x y o)))
 
+(define (serialize-garden-bed garden)
+  (list (garden-bed-width garden)
+        (garden-bed-height garden)
+        (map (lambda (row)
+               (map (lambda (tile)
+                      (and (plant? tile)
+                           (plant-name tile)))
+                    row))
+             (garden-bed-tiles garden))))
+
 (define (display-garden-bed garden)
   (for-each (lambda (row)
               (for-each (lambda (tile)
diff --git a/community-garden/host.scm b/community-garden/host.scm
new file mode 100644
index 0000000..c2bc4a9
--- /dev/null
+++ b/community-garden/host.scm
@@ -0,0 +1,38 @@
+(define-module (community-garden host)
+  #:use-module (community-garden actors)
+  #:use-module (community-garden garden-bed)
+  #:use-module (community-garden plant)
+  #:use-module (community-garden view)
+  #:use-module (goblins)
+  #:use-module (goblins vrun)
+  #:use-module (goblins ocapn ids)
+  #:use-module (goblins ocapn captp)
+  #:use-module (goblins ocapn netlayer onion)
+  #:export (host-garden))
+
+(define (host-garden garden-name user-name)
+  (define garden-vat (spawn-vat))
+  (define user-vat (spawn-vat))
+  (define-vat-run garden-run garden-vat)
+  (define-vat-run user-run user-vat)
+  (define the-botanist (garden-run (spawn ^botanist)))
+  (define the-garden-gate (garden-run (spawn ^garden-gate the-botanist)))
+  (define sunflower/approved
+    (garden-run ($ the-botanist 'approve-plant sunflower)))
+  (define cabbage/approved
+    (garden-run ($ the-botanist 'approve-plant cabbage)))
+  (define our-garden
+    (garden-run
+     (spawn ^garden garden-name (make-garden-bed 8 8) the-garden-gate)))
+  (define our-garden-community
+    (garden-run
+     (spawn ^garden-community our-garden)))
+  (define user
+    (user-run (<- our-garden-community 'register-gardener user-name)))
+  (define onion-netlayer (garden-run (new-onion-netlayer)))
+  (define mycapn (garden-run (spawn-mycapn onion-netlayer)))
+
+  (garden-run
+   (let ((community-sref ($ mycapn 'register our-garden-community 'onion)))
+     (format #t "Connect to: ~a\n" (ocapn-id->string community-sref))))
+  (view-garden user-vat user))
diff --git a/community-garden/join.scm b/community-garden/join.scm
new file mode 100644
index 0000000..8e11aa2
--- /dev/null
+++ b/community-garden/join.scm
@@ -0,0 +1,20 @@
+(define-module (community-garden join)
+  #:use-module (community-garden actors)
+  #:use-module (community-garden view)
+  #:use-module (goblins)
+  #:use-module (goblins vrun)
+  #:use-module (goblins ocapn ids)
+  #:use-module (goblins ocapn captp)
+  #:use-module (goblins ocapn netlayer onion)
+  #:use-module (ice-9 match)
+  #:export (join-garden))
+
+(define (join-garden name community-address)
+  (define community-sref (string->ocapn-id community-address))
+  (define vat (spawn-vat))
+  (define-vat-run vat-run vat)
+  (define onion-netlayer (vat-run (new-onion-netlayer)))
+  (define mycapn (vat-run (spawn-mycapn onion-netlayer)))
+  (define community-vow (vat-run ($ mycapn 'enliven community-sref)))
+  (define gardener (vat-run (<- community-vow 'register-gardener name)))
+  (view-garden vat gardener))
diff --git a/community-garden/view.scm b/community-garden/view.scm
index ad93f45..9d7a2bb 100644
--- a/community-garden/view.scm
+++ b/community-garden/view.scm
@@ -1,10 +1,15 @@
 (define-module (community-garden view)
+  #:use-module (catbird)
   #:use-module (catbird asset)
+  #:use-module (catbird camera)
   #:use-module (catbird input-map)
+  #:use-module (catbird kernel)
   #:use-module (catbird mode)
   #:use-module (catbird node)
   #:use-module (catbird node-2d)
-  #:use-module ((catbird scene) #:select (current-scene))
+  #:use-module (catbird region)
+  #:use-module ((catbird scene)
+                #:select (<scene> current-scene replace-major-mode))
   #:use-module (chickadee config)
   #:use-module (chickadee graphics color)
   #:use-module (chickadee graphics path)
@@ -19,10 +24,7 @@
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:use-module (srfi srfi-43)
-  #:export (%window-width
-            %window-height
-            <garden-view>
-            <garden-mode>))
+  #:export (view-garden))
 
 (define %window-width 1024)
 (define %window-height 768)
@@ -38,6 +40,11 @@
 (define-asset (cabbage-texture (f "assets/images/cabbage.png"))
   (load-image f))
 
+(define-class <button> (<node-2d>)
+  (on-click #:accessor on-click
+            #:init-keyword #:on-click
+            #:init-value (const #t)))
+
 (define-class <garden-tile> (<node-2d>)
   (tile-x #:getter tile-x #:init-keyword #:tile-x)
   (tile-y #:getter tile-y #:init-keyword #:tile-y))
@@ -49,6 +56,7 @@
   (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 #())
+  (current-plant #:accessor current-plant #:init-value "Cabbage")
   (read-only? #:getter read-only? #:init-keyword #:read-only? #:init-value #t))
 
 (define-method (garden-bed (garden <garden-view>))
@@ -61,7 +69,7 @@
   (define title
     (make <label>
       #:name 'name
-      #:text (or (garden-name garden) "Untitled")
+      #:text "Connecting..."
       #:font title-font
       #:position (vec2 32.0 (- %window-height 72.0))))
   (define tile-container
@@ -70,19 +78,69 @@
   (set! (width garden) %window-width)
   (set! (height garden) %window-height)
   (attach-to garden title tile-container)
-  (center-horizontal-in-parent title)
+  (center-horizontal-in-parent (& garden name))
   (refresh-garden garden)
+  ;; Add buttons for selecting what to plant.
+  (let loop ((plants '("Cabbage" "Sunflower"))
+             (prev #f))
+    (match plants
+      (() #t)
+      ((plant . rest)
+       (let ((button (make <button>
+                       #:on-click (lambda ()
+                                    (set! (current-plant garden) plant))))
+             (bg (make <canvas> #:name 'background))
+             (sprite (make <sprite>
+                       #:name 'sprite
+                       #:texture (plant->texture plant)
+                       #:position (vec2 8.0 0.0)))
+             (label (make <label>
+                      #:name 'label
+                      #:text plant
+                      #:font title-font))
+             (pad 8.0))
+         (set! (height button) 64.0)
+         (set! (width button)
+               (+ (* pad 3.0) (width sprite) (width label)))
+         (set! (painter bg)
+               (with-style ((fill-color db32-rope)
+                            (stroke-color db32-oiled-cedar))
+                 (fill-and-stroke
+                  (rounded-rectangle (vec2 0.0 0.0)
+                                     (width button)
+                                     (height button)
+                                     #:radius 2.0))))
+         (attach-to button bg sprite label)
+         (center-vertical-in-parent sprite)
+         (center-vertical-in-parent label)
+         (place-right sprite label #:padding pad)
+         (if prev
+             (begin
+               (place-right prev button #:padding 32.0)
+               (align-bottom prev button))
+             (teleport button 32.0 32.0))
+         (attach-to garden button)
+         (loop rest button)))))
   (run-script garden
     (forever
-     ((vat garden)
-      (lambda ()
-        (on (user garden)
-            (lambda (user)
-              (on (<- user 'inspect-garden)
-                  (lambda (garden-bed)
-                    (atomic-box-set! (garden-bed-box garden) garden-bed)))))))
+     ;; Do not start asking for the garden bed information until the
+     ;; name come across the network.  This is a really hacky way of
+     ;; waiting until we've connected to the remote garden.
+     (when (atomic-box-ref (name-box garden))
+       (refresh-name garden)
+       ((vat garden)
+        (lambda ()
+          (on (user garden)
+              (lambda (user)
+                (on (<- user 'inspect-garden)
+                    (lambda (garden-bed)
+                      (atomic-box-set! (garden-bed-box garden) garden-bed))))))))
      (sleep 0.5))))
 
+(define-method (refresh-name (garden <garden-view>))
+  (set! (text (& garden name)) (garden-name garden))
+  (center-horizontal-in-parent (& garden name)))
+
 (define (for-each-tile proc tiles)
   (vector-for-each
    (lambda (y row)
@@ -98,71 +156,83 @@
 (define-method (rebuild-tiles (garden <garden-view>))
   (let ((g (garden-bed garden))
         (container (& garden tile-container)))
-    (for-each-tile
-     (lambda (x y tile)
-       (detach tile))
-     (tiles garden))
-    (set! (tiles garden)
-          (vector-unfold
-           (lambda (y)
+    (match g
+      ((bed-width bed-height bed-tiles)
+       (for-each-tile
+        (lambda (x y tile)
+          (detach tile))
+        (tiles garden))
+       (set! (tiles garden)
              (vector-unfold
-              (lambda (x)
-                (let* ((painter (with-style ((fill-color db32-rope)
-                                             (stroke-color db32-oiled-cedar))
-                                  (fill-and-stroke
-                                   (rectangle (vec2 0.0 0.0)
-                                              %tile-width
-                                              %tile-height))))
-                       (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
-     (lambda (x y tile)
-       (if (= y 0)
-           (set! (position-y tile) (* %tile-height (- (garden-bed-height g) 1)))
-           (place-below (tile-ref garden x (- y 1)) tile))
-       (unless (= x 0)
-         (place-right (tile-ref garden (- x 1) y) tile)))
-     (tiles garden))
-    (set! (width container) (* (garden-bed-width g) %tile-width))
-    (set! (height container) (* (garden-bed-height g) %tile-height))
-    (center-in-parent container)))
+              (lambda (y)
+                (vector-unfold
+                 (lambda (x)
+                   (let* ((painter (with-style ((fill-color db32-rope)
+                                                (stroke-color db32-oiled-cedar))
+                                     (fill-and-stroke
+                                      (rectangle (vec2 0.0 0.0)
+                                                 %tile-width
+                                                 %tile-height))))
+                          (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))
+                 bed-width))
+              bed-height))
+       (for-each-tile
+        (lambda (x y tile)
+          (if (= y 0)
+              (set! (position-y tile)
+                    (* %tile-height (- bed-height 1)))
+              (place-below (tile-ref garden x (- y 1)) tile))
+          (unless (= x 0)
+            (place-right (tile-ref garden (- x 1) y) tile)))
+        (tiles garden))
+       (set! (width container) (* bed-width %tile-width))
+       (set! (height container) (* bed-height %tile-height))
+       (center-in-parent container)))))
+
+(define (plant->texture plant)
+  (match plant
+    ("Cabbage" cabbage-texture)
+    ("Sunflower" sunflower-texture)
+    (_ null-texture)))
 
 (define-method (refresh-garden (garden <garden-view>))
   (let ((g (garden-bed garden))
         (prev-g (prev-garden garden)))
-    (unless (eq? g prev-g)
-      (unless (and prev-g
-                   (= (garden-bed-width g) (garden-bed-width prev-g))
-                   (= (garden-bed-height g) (garden-bed-height prev-g)))
-        (rebuild-tiles garden))
-      (for-each-tile
-       (lambda (x y tile)
-         (let ((plant (garden-bed-ref g x y))
-               (sprite (& tile sprite)))
-           (set! (texture sprite)
-                 (if plant
-                     (match (plant-name plant)
-                       ("Cabbage" cabbage-texture)
-                       ("Sunflower" sunflower-texture)
-                       (_ null-texture))
-                     null-texture))
-           (center-in-parent sprite)))
-       (tiles garden))
-      (set! (prev-garden garden) g))))
+    (match g
+      ((bed-width bed-height bed-tiles)
+       (unless (match prev-g
+                 ((_ _ prev-tiles)
+                  (equal? prev-tiles bed-tiles))
+                 (_ #f))
+         (unless (match prev-g
+                   ((prev-width prev-height _)
+                    (and prev-width prev-height
+                         (= bed-width prev-width)
+                         (= bed-height prev-height)))
+                   (_ #f))
+           (rebuild-tiles garden))
+         (for-each-tile
+          (lambda (x y tile)
+            (let ((plant (list-ref (list-ref bed-tiles y) x))
+                  (sprite (& tile sprite)))
+              (set! (texture sprite) (plant->texture plant))
+              (center-in-parent sprite)))
+          (tiles garden))
+         (set! (prev-garden garden) g)))
+      (_ #f))))
 
 (define-method (update (garden <garden-view>) dt)
   (refresh-garden garden))
@@ -176,16 +246,17 @@
          (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")))))))))
+  (when (current-plant garden)
+    ((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 (current-plant garden)))))))))))
 
 (define-method (dig-up-tile (garden <garden-view>) (tile <garden-tile>))
   ((vat garden)
@@ -199,19 +270,25 @@
     (cond
      ((not node)
       #f)
-     ((is-a? node <garden-tile>)
+     ((or (is-a? node <garden-tile>)
+          (is-a? node <button>))
       node)
      ((parent node)
-      (find-tile (parent node)))))
+      (find-tile (parent node)))
+     (else #f)))
   (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-method (do-plant-or-select (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 node (garden-pick garden x y))
+  (cond
+   ((is-a? node <button>)
+    ((on-click node)))
+   ((is-a? node <garden-tile>)
+    (unless (read-only? garden)
+      (plant-in-tile garden node)))))
 
 (define-method (do-dig (mode <garden-mode>) x y)
   (define garden (& (current-scene) garden))
@@ -219,5 +296,43 @@
   (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 'left) do-plant-or-select)
 (bind-input <garden-mode> (mouse-press 'right) do-dig)
+
+(define* (view-garden vat user #:key read-only?)
+  (define garden-bed-box (make-atomic-box #f))
+  (define garden-name-box (make-atomic-box #f))
+  (vat
+   (lambda ()
+     (on (<- user 'get-garden-name)
+         (lambda (name)
+           (atomic-box-set! garden-name-box name)))))
+  (run-catbird
+   (lambda ()
+     (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
+               #:height %window-height))
+       (attach-to scene
+                  (make <canvas>
+                    #:name 'background
+                    #:painter
+                    (with-style ((fill-color db32-elf-green))
+                      (fill
+                       (rectangle (vec2 0.0 0.0)
+                                  %window-width
+                                  %window-height))))
+                  (make <garden-view>
+                    #:name 'garden
+                    #:vat vat
+                    #:user user
+                    #:name-box garden-name-box
+                    #:garden-bed-box garden-bed-box
+                    #:read-only? read-only?))))
+   #:title "Community Garden"
+   #:width %window-width
+   #:height %window-height))