summaryrefslogtreecommitdiff
path: root/community-garden.scm
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2022-12-15 12:14:43 -0500
committerDavid Thompson <dthompson2@worcester.edu>2023-01-06 16:00:25 -0500
commit03944a1765fcfc26dc11f25e659fbb7a2c1a03fa (patch)
tree1c83d5aa3b57078a384d56d37ca40e58805a4a2e /community-garden.scm
parentd4608e63104b217f5741d057675255efa5b522f9 (diff)
Break into modules.
This will make adding ocapn easier.
Diffstat (limited to 'community-garden.scm')
-rw-r--r--community-garden.scm310
1 files changed, 11 insertions, 299 deletions
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)