Break into modules.

This will make adding ocapn easier.

7 files changed, 331 insertions, 299 deletions

diff --git a/.gitignore b/.gitignore
index fe8a487..9148070 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,4 @@
+*.go
 /Makefile
 /Makefile.in
 /aclocal.m4
diff --git a/Makefile.am b/Makefile.am
index a571bce..de95d08 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -22,4 +22,8 @@ moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
 godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
 
 SOURCES = 					\
+  community-garden/plant.scm			\
+  community-garden/garden-bed.scm		\
+  community-garden/actors.scm			\
+  community-garden/view.scm			\
   community-garden.scm
diff --git a/community-garden.scm b/community-garden.scm
index 35d28f9..a121b39 100644
--- a/community-garden.scm
+++ b/community-garden.scm
@@ -1,113 +1,23 @@
 (setenv "CATBIRD_DEV_MODE" "1")
 
 (use-modules (catbird)
-             (catbird asset)
              (catbird camera)
              (catbird kernel)
              (catbird node)
              (catbird node-2d)
              (catbird region)
              ((catbird scene) #:select (<scene>))
-             (chickadee config)
              (chickadee graphics color)
              (chickadee graphics path)
-             (chickadee graphics text)
-             (chickadee graphics texture)
              (chickadee math vector)
-             (chickadee scripting)
+             (community-garden actors)
+             (community-garden garden-bed)
+             (community-garden plant)
+             (community-garden view)
              (goblins)
-             (goblins actor-lib cell)
-             (goblins actor-lib methods)
-             (goblins utils simple-sealers)
              (goblins vrun)
              (ice-9 atomic)
-             (ice-9 match)
-             (oop goops)
-             (srfi srfi-1)
-             (srfi srfi-9)
-             (srfi srfi-43))
-
-
-;;;
-;;; Data types
-;;;
-
-(define-record-type <plant>
-  (make-plant name char)
-  plant?
-  (name plant-name)
-  (char plant-char))
-
-(define sunflower (make-plant "Sunflower" #\S))
-(define cabbage (make-plant "Cabbage" #\C))
-(define winter-squash (make-plant "Winter Squash" #\W))
-
-(define (list-replace lst i o)
-  (let loop ((j 0)
-             (lst lst))
-    (match lst
-      ((head . rest)
-       (if (= i j)
-           (cons o rest)
-           (cons head (loop (+ j 1) rest)))))))
-
-(define (make-empty-row width)
-  (make-list width #f))
-
-(define (make-empty-bed width height)
-  (list-tabulate height
-                 (lambda (_i)
-                   (make-empty-row width))))
-
-(define (bed-ref bed x y)
-  (list-ref (list-ref bed y) x))
-
-(define (bed-set bed x y o)
-  (list-replace bed y (list-replace (list-ref bed y) x o)))
-
-(define-record-type <garden-bed>
-  (%make-garden-bed width height tiles)
-  garden-bed?
-  (width garden-bed-width)
-  (height garden-bed-height)
-  (tiles garden-bed-tiles))
-
-(define (make-garden-bed width height)
-  (%make-garden-bed width height (make-empty-bed width height)))
-
-(define (bounds-check garden x y)
-  (unless (and (>= x 0)
-               (>= y 0)
-               (< x (garden-bed-width garden))
-               (< y (garden-bed-height garden)))
-    (error "garden tile out of bounds" x y)))
-
-(define (garden-bed-ref garden x y)
-  (bounds-check garden x y)
-  (bed-ref (garden-bed-tiles garden) x y))
-
-(define (garden-bed-set garden x y o)
-  (bounds-check garden x y)
-  (%make-garden-bed (garden-bed-width garden)
-                    (garden-bed-height garden)
-                    (bed-set (garden-bed-tiles garden) x y o)))
-
-(define (display-garden-bed garden)
-  (for-each (lambda (row)
-              (for-each (lambda (tile)
-                          (display
-                           (if (plant? tile)
-                               (plant-char tile)
-                               "."))
-                          (display " "))
-                        row)
-              (newline))
-            (garden-bed-tiles garden)))
-
-
-;;;
-;;; Actors
-;;;
+             (oop goops))
 
 (define garden-vat (spawn-vat))
 (define catbird-vat (spawn-vat))
@@ -116,58 +26,6 @@
 (define-vat-run catbird-run catbird-vat)
 (define-vat-run alice-run alice-vat)
 
-(define (^botanist bcom)
-  (define-values (seal-plant unseal-plant approved-plant?)
-    (make-sealer-triplet))
-  (methods
-   ((approve-plant plant)
-    (seal-plant plant))
-   ((check-plant plant)
-    (if (approved-plant? plant)
-        (unseal-plant plant)
-        (error "plant is not allowed" plant)))))
-
-(define (^garden-gate bcom botanist)
-  (methods
-   ((check-plant plant)
-    ($ botanist 'check-plant plant))))
-
-(define (^garden bcom name garden-bed garden-gate)
-  (define (ensure-empty x y)
-    (when (garden-bed-ref garden-bed x y)
-      (error "tile already has something planted in it" x y)))
-  (methods
-   ((get-name) name)
-   ((get-bed) garden-bed)
-   ((plant x y sealed-plant)
-    (ensure-empty x y)
-    (let* ((plant ($ garden-gate 'check-plant sealed-plant))
-           (new-bed (garden-bed-set garden-bed x y plant)))
-      (bcom (^garden bcom name new-bed garden-gate))))
-   ((dig-up x y)
-    (let ((new-bed (garden-bed-set garden-bed x y #f)))
-      (bcom (^garden bcom name new-bed garden-gate))))))
-
-(define (^visitor bcom name garden)
-  (methods
-   ((get-name) name)
-   ((get-garden-name)
-    (<- garden 'get-name))
-   ((inspect-garden)
-    (<- garden 'get-bed))))
-
-(define (^gardener bcom name garden)
-  (methods
-   ((get-name) name)
-   ((get-garden-name)
-    (<- garden 'get-name))
-   ((inspect-garden)
-    (<- garden 'get-bed))
-   ((plant x y plant)
-    (<- garden 'plant x y plant))
-   ((dig-up x y)
-    (<- garden 'dig-up x y))))
-
 (define the-botanist (garden-run (spawn ^botanist)))
 (define the-garden-gate (garden-run (spawn ^garden-gate the-botanist)))
 (define sunflower/approved
@@ -191,7 +49,6 @@
 (alice-run ($ alice 'plant 5 2 cabbage/approved))
 (alice-run ($ alice 'plant 6 2 cabbage/approved))
 
-
 (define catbird-visitor (catbird-run (spawn ^visitor "Catbird UI" our-garden)))
 (define catbird-garden-bed (make-atomic-box #f))
 (define catbird-garden-name (make-atomic-box #f))
@@ -204,155 +61,6 @@
      (lambda (garden-bed)
        (atomic-box-set! catbird-garden-bed garden-bed))))
 
-(define %window-width 1024)
-(define %window-height 768)
-(define %tile-width 64.0)
-(define %tile-height 64.0)
-(define font-file (scope-datadir "fonts/Inconsolata-Regular.otf"))
-(define-asset (title-font (f font-file))
-  (load-font f 24))
-(define-asset (plant-tile-font (f font-file))
-  (load-font f 32))
-(define-asset (sunflower-texture (f "assets/images/sunflower.png"))
-  (load-image f))
-(define-asset (cabbage-texture (f "assets/images/cabbage.png"))
-  (load-image f))
-
-
-;;;
-;;; Catbird visualization
-;;;
-
-(define-class <garden-view> (<node-2d>)
-  (vat #:getter vat #:init-keyword #:vat)
-  (visitor #:getter visitor #:init-keyword #:visitor)
-  (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 #()))
-
-(define (make-garden-view)
-  (make <garden-view>
-    #:rank 1
-    #:vat catbird-vat
-    #:visitor catbird-visitor
-    #:name-box catbird-garden-name
-    #:garden-bed-box catbird-garden-bed))
-
-(define-method (garden-bed (garden <garden-view>))
-  (atomic-box-ref (garden-bed-box garden)))
-
-(define-method (garden-name (garden <garden-view>))
-  (atomic-box-ref (name-box garden)))
-
-(define-method (on-boot (garden <garden-view>))
-  (define title
-    (make <label>
-      #:name 'name
-      #:text (garden-name garden)
-      #:font title-font
-      #:position (vec2 32.0 (- %window-height 72.0))))
-  (define tile-container
-    (make <node-2d>
-      #:name 'tile-container))
-  (set! (width garden) %window-width)
-  (set! (height garden) %window-height)
-  (attach-to garden title tile-container)
-  (center-horizontal-in-parent title)
-  (refresh-garden garden)
-  (run-script garden
-    (forever
-     (sleep 1.0)
-     (catbird-run
-      (on ($ catbird-visitor 'inspect-garden)
-          (lambda (garden-bed)
-            (atomic-box-set! catbird-garden-bed garden-bed)))))))
-
-(define (for-each-tile proc tiles)
-  (vector-for-each
-   (lambda (y row)
-     (vector-for-each
-      (lambda (x tile)
-        (proc x y tile))
-      row))
-   tiles))
-
-(define-method (tile-ref (garden <garden-view>) x y)
-  (vector-ref (vector-ref (tiles garden) y) x))
-
-(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)
-             (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))))
-                       (canvas (make <canvas>
-                                 #:painter painter)))
-                  (attach-to container canvas)
-                  (attach-to canvas
-                             (make <sprite>
-                               #:name 'sprite
-                               #:texture null-texture))
-                  canvas))
-              (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)))
-
-(define-method (on-change (sprite <sprite>) slot-name old new)
-  (case slot-name
-    ((texture)
-     (let ((new (artifact (->asset new))))
-       (set! (width sprite) (texture-width new))
-       (set! (height sprite) (texture-height new))))))
-
-(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))))
-
-(define-method (update (garden <garden-view>) dt)
-  (refresh-garden garden))
-
 (run-catbird
  (lambda ()
    (let ((region (create-full-region #:name 'main))
@@ -370,8 +78,12 @@
                     (fill
                      (rectangle (vec2 0.0 0.0)
                                 %window-width
-                                %window-height)))))
-     (attach-to scene (make-garden-view))))
+                                %window-height))))
+                (make <garden-view>
+                  #:vat catbird-vat
+                  #:visitor catbird-visitor
+                  #:name-box catbird-garden-name
+                  #:garden-bed-box catbird-garden-bed))))
  #:title "Community Garden"
  #:width %window-width
  #:height %window-height)
diff --git a/community-garden/actors.scm b/community-garden/actors.scm
new file mode 100644
index 0000000..b34d1f8
--- /dev/null
+++ b/community-garden/actors.scm
@@ -0,0 +1,62 @@
+(define-module (community-garden actors)
+  #:use-module (community-garden garden-bed)
+  #:use-module (goblins)
+  #:use-module (goblins actor-lib methods)
+  #:use-module (goblins utils simple-sealers)
+  #:export (^botanist
+            ^garden-gate
+            ^garden
+            ^visitor
+            ^gardener))
+
+(define (^botanist bcom)
+  (define-values (seal-plant unseal-plant approved-plant?)
+    (make-sealer-triplet))
+  (methods
+   ((approve-plant plant)
+    (seal-plant plant))
+   ((check-plant plant)
+    (if (approved-plant? plant)
+        (unseal-plant plant)
+        (error "plant is not allowed" plant)))))
+
+(define (^garden-gate bcom botanist)
+  (methods
+   ((check-plant plant)
+    ($ botanist 'check-plant plant))))
+
+(define (^garden bcom name garden-bed garden-gate)
+  (define (ensure-empty x y)
+    (when (garden-bed-ref garden-bed x y)
+      (error "tile already has something planted in it" x y)))
+  (methods
+   ((get-name) name)
+   ((get-bed) garden-bed)
+   ((plant x y sealed-plant)
+    (ensure-empty x y)
+    (let* ((plant ($ garden-gate 'check-plant sealed-plant))
+           (new-bed (garden-bed-set garden-bed x y plant)))
+      (bcom (^garden bcom name new-bed garden-gate))))
+   ((dig-up x y)
+    (let ((new-bed (garden-bed-set garden-bed x y #f)))
+      (bcom (^garden bcom name new-bed garden-gate))))))
+
+(define (^visitor bcom name garden)
+  (methods
+   ((get-name) name)
+   ((get-garden-name)
+    (<- garden 'get-name))
+   ((inspect-garden)
+    (<- garden 'get-bed))))
+
+(define (^gardener bcom name garden)
+  (methods
+   ((get-name) name)
+   ((get-garden-name)
+    (<- garden 'get-name))
+   ((inspect-garden)
+    (<- garden 'get-bed))
+   ((plant x y plant)
+    (<- garden 'plant x y plant))
+   ((dig-up x y)
+    (<- garden 'dig-up x y))))
diff --git a/community-garden/garden-bed.scm b/community-garden/garden-bed.scm
new file mode 100644
index 0000000..71cf6e6
--- /dev/null
+++ b/community-garden/garden-bed.scm
@@ -0,0 +1,74 @@
+(define-module (community-garden garden-bed)
+  #:use-module (community-garden plant)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:export (make-garden-bed
+            garden-bed?
+            garden-bed-width
+            garden-bed-height
+            garden-bed-tiles
+            garden-bed-ref
+            garden-bed-set))
+
+(define (list-replace lst i o)
+  (let loop ((j 0)
+             (lst lst))
+    (match lst
+      ((head . rest)
+       (if (= i j)
+           (cons o rest)
+           (cons head (loop (+ j 1) rest)))))))
+
+(define (make-empty-row width)
+  (make-list width #f))
+
+(define (make-empty-bed width height)
+  (list-tabulate height
+                 (lambda (_i)
+                   (make-empty-row width))))
+
+(define (bed-ref bed x y)
+  (list-ref (list-ref bed y) x))
+
+(define (bed-set bed x y o)
+  (list-replace bed y (list-replace (list-ref bed y) x o)))
+
+(define-record-type <garden-bed>
+  (%make-garden-bed width height tiles)
+  garden-bed?
+  (width garden-bed-width)
+  (height garden-bed-height)
+  (tiles garden-bed-tiles))
+
+(define (make-garden-bed width height)
+  (%make-garden-bed width height (make-empty-bed width height)))
+
+(define (bounds-check garden x y)
+  (unless (and (>= x 0)
+               (>= y 0)
+               (< x (garden-bed-width garden))
+               (< y (garden-bed-height garden)))
+    (error "garden tile out of bounds" x y)))
+
+(define (garden-bed-ref garden x y)
+  (bounds-check garden x y)
+  (bed-ref (garden-bed-tiles garden) x y))
+
+(define (garden-bed-set garden x y o)
+  (bounds-check garden x y)
+  (%make-garden-bed (garden-bed-width garden)
+                    (garden-bed-height garden)
+                    (bed-set (garden-bed-tiles garden) x y o)))
+
+(define (display-garden-bed garden)
+  (for-each (lambda (row)
+              (for-each (lambda (tile)
+                          (display
+                           (if (plant? tile)
+                               (plant-char tile)
+                               "."))
+                          (display " "))
+                        row)
+              (newline))
+            (garden-bed-tiles garden)))
diff --git a/community-garden/plant.scm b/community-garden/plant.scm
new file mode 100644
index 0000000..3f034b8
--- /dev/null
+++ b/community-garden/plant.scm
@@ -0,0 +1,20 @@
+(define-module (community-garden plant)
+  #:use-module (srfi srfi-9)
+  #:export (make-plant
+            plant?
+            plant-name
+            plant-char
+
+            sunflower
+            cabbage
+            winter-squash))
+
+(define-record-type <plant>
+  (make-plant name char)
+  plant?
+  (name plant-name)
+  (char plant-char))
+
+(define sunflower (make-plant "Sunflower" #\S))
+(define cabbage (make-plant "Cabbage" #\C))
+(define winter-squash (make-plant "Winter Squash" #\W))
diff --git a/community-garden/view.scm b/community-garden/view.scm
new file mode 100644
index 0000000..e43617b
--- /dev/null
+++ b/community-garden/view.scm
@@ -0,0 +1,159 @@
+(define-module (community-garden view)
+  #:use-module (catbird asset)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (chickadee config)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics path)
+  #:use-module (chickadee graphics text)
+  #:use-module (chickadee graphics texture)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (community-garden garden-bed)
+  #:use-module (community-garden plant)
+  #:use-module (goblins)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-43)
+  #:export (%window-width
+            %window-height
+            <garden-view>))
+
+;; Hack to fix broken version of this in catbird upstream.
+(define-method (on-change (sprite <sprite>) slot-name old new)
+  (case slot-name
+    ((texture)
+     (let ((new (artifact (->asset new))))
+       (set! (width sprite) (texture-width new))
+       (set! (height sprite) (texture-height new))))))
+
+(define %window-width 1024)
+(define %window-height 768)
+(define %tile-width 64.0)
+(define %tile-height 64.0)
+(define font-file (scope-datadir "fonts/Inconsolata-Regular.otf"))
+(define-asset (title-font (f font-file))
+  (load-font f 24))
+(define-asset (plant-tile-font (f font-file))
+  (load-font f 32))
+(define-asset (sunflower-texture (f "assets/images/sunflower.png"))
+  (load-image f))
+(define-asset (cabbage-texture (f "assets/images/cabbage.png"))
+  (load-image f))
+
+(define-class <garden-view> (<node-2d>)
+  (vat #:getter vat #:init-keyword #:vat)
+  (visitor #:getter visitor #:init-keyword #:visitor)
+  (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 #()))
+
+(define-method (garden-bed (garden <garden-view>))
+  (atomic-box-ref (garden-bed-box garden)))
+
+(define-method (garden-name (garden <garden-view>))
+  (atomic-box-ref (name-box garden)))
+
+(define-method (on-boot (garden <garden-view>))
+  (define title
+    (make <label>
+      #:name 'name
+      #:text (garden-name garden)
+      #:font title-font
+      #:position (vec2 32.0 (- %window-height 72.0))))
+  (define tile-container
+    (make <node-2d>
+      #:name 'tile-container))
+  (set! (width garden) %window-width)
+  (set! (height garden) %window-height)
+  (attach-to garden title tile-container)
+  (center-horizontal-in-parent title)
+  (refresh-garden garden)
+  (run-script garden
+    (forever
+     (sleep 1.0)
+     ((vat garden)
+      (lambda ()
+        (on ($ (visitor garden) 'inspect-garden)
+            (lambda (garden-bed)
+              (atomic-box-set! (garden-bed-box garden) garden-bed))))))))
+
+(define (for-each-tile proc tiles)
+  (vector-for-each
+   (lambda (y row)
+     (vector-for-each
+      (lambda (x tile)
+        (proc x y tile))
+      row))
+   tiles))
+
+(define-method (tile-ref (garden <garden-view>) x y)
+  (vector-ref (vector-ref (tiles garden) y) x))
+
+(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)
+             (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))))
+                       (canvas (make <canvas>
+                                 #:painter painter)))
+                  (attach-to container canvas)
+                  (attach-to canvas
+                             (make <sprite>
+                               #:name 'sprite
+                               #:texture null-texture))
+                  canvas))
+              (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)))
+
+(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))))
+
+(define-method (update (garden <garden-view>) dt)
+  (refresh-garden garden))