Break into modules.

This will make adding ocapn easier.

4 files changed, 315 insertions, 0 deletions

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))