From 03944a1765fcfc26dc11f25e659fbb7a2c1a03fa Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Thu, 15 Dec 2022 12:14:43 -0500
Subject: Break into modules.

This will make adding ocapn easier.
---
 community-garden.scm | 310 ++-------------------------------------------------
 1 file changed, 11 insertions(+), 299 deletions(-)

(limited to '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)
-- 
cgit v1.2.3