summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--community-garden.scm46
-rw-r--r--community-garden/actors.scm73
-rw-r--r--community-garden/edit.scm40
-rw-r--r--community-garden/view.scm12
4 files changed, 104 insertions, 67 deletions
diff --git a/community-garden.scm b/community-garden.scm
index 5c8c383..7cd535a 100644
--- a/community-garden.scm
+++ b/community-garden.scm
@@ -40,35 +40,43 @@
"Spritely Institute Community Garden"
(make-garden-bed 8 8)
the-garden-gate)))
+(define our-garden-community
+ (garden-run
+ (spawn ^garden-community our-garden)))
(define onion-netlayer (garden-run (new-onion-netlayer)))
(define mycapn
(garden-run
(let* ((mycapn (spawn-mycapn onion-netlayer))
- (garden-sref ($ mycapn 'register our-garden 'onion)))
- (format #t "edit-garden Dave ~a\n" (ocapn-id->string garden-sref))
+ (community-sref ($ mycapn 'register our-garden-community 'onion)))
+ (format #t "Connect to: ~a\n" (ocapn-id->string community-sref))
mycapn)))
-(define alice (alice-run (spawn ^gardener "Alice" our-garden)))
-(alice-run ($ alice 'plant 1 1 sunflower/approved))
-(alice-run ($ alice 'plant 2 1 sunflower/approved))
-(alice-run ($ alice 'plant 1 2 sunflower/approved))
-(alice-run ($ alice 'plant 2 2 sunflower/approved))
-(alice-run ($ alice 'plant 5 1 cabbage/approved))
-(alice-run ($ alice 'plant 6 1 cabbage/approved))
-(alice-run ($ alice 'plant 5 2 cabbage/approved))
-(alice-run ($ alice 'plant 6 2 cabbage/approved))
+(define alice
+ (alice-run (<- our-garden-community 'register-gardener "Alice")))
+(define (alice-plant x y plant)
+ (alice-run (on alice
+ (lambda (alice)
+ (<- alice 'plant x y plant)))))
+
+(alice-plant 1 1 sunflower/approved)
+(alice-plant 2 1 sunflower/approved)
+(alice-plant 1 2 sunflower/approved)
+(alice-plant 2 2 sunflower/approved)
+(alice-plant 5 1 cabbage/approved)
+(alice-plant 6 1 cabbage/approved)
+(alice-plant 5 2 cabbage/approved)
+(alice-plant 6 2 cabbage/approved)
-(define catbird-visitor (catbird-run (spawn ^visitor "Catbird UI" our-garden)))
+(define catbird-visitor
+ (catbird-run (<- our-garden-community 'register-visitor "Catbird Viewer")))
(define catbird-garden-bed (make-atomic-box #f))
(define catbird-garden-name (make-atomic-box #f))
(catbird-run
- (on ($ catbird-visitor 'get-garden-name)
- (lambda (name)
- (atomic-box-set! catbird-garden-name name))))
-(catbird-run
- (on ($ catbird-visitor 'inspect-garden)
- (lambda (garden-bed)
- (atomic-box-set! catbird-garden-bed garden-bed))))
+ (on catbird-visitor
+ (lambda (visitor)
+ (on (<- visitor 'get-garden-name)
+ (lambda (name)
+ (atomic-box-set! catbird-garden-name name))))))
(run-catbird
(lambda ()
diff --git a/community-garden/actors.scm b/community-garden/actors.scm
index d98894f..5146047 100644
--- a/community-garden/actors.scm
+++ b/community-garden/actors.scm
@@ -9,7 +9,7 @@
^garden-gate
^garden
^visitor
- ^gardener))
+ ^garden-community))
(define* (^botanist _bcom)
(define registry (spawn ^cell '()))
@@ -18,59 +18,70 @@
(methods
((approve-plant plant)
(let ((sealed-plant ($ seal-plant plant)))
- ($ registry (cons sealed-plant ($ registry)))
+ ($ registry (cons (list (plant-name plant) sealed-plant)
+ ($ registry)))
sealed-plant))
((check-plant plant)
(if ($ approved-plant? plant)
($ unseal-plant plant)
(error "plant is not allowed" plant)))
- ((approved-plants)
+ ((get-approved-plants)
($ registry))))
(define (^garden-gate bcom botanist)
(methods
((check-plant plant)
($ botanist 'check-plant plant))
- ((approved-plants)
- ($ botanist 'approved-plants))))
+ ((get-approved-plants)
+ ($ botanist 'get-approved-plants))))
(define (^garden bcom name garden-bed garden-gate)
- (define (ensure-empty x y)
+ (define (ensure-empty name x y)
(when (garden-bed-ref garden-bed x y)
- (format #t "tried to plant in occupied tile (~a, ~a)\n" x y)
+ (format #t "~a tried to plant in occupied tile (~a, ~a)\n"
+ name x y)
(error "tile already has something planted in it" x y)))
(methods
((get-name) name)
((get-bed) garden-bed)
((get-approved-plants)
- ($ garden-gate 'approved-plants))
- ((plant x y sealed-plant)
- (ensure-empty x y)
+ ($ garden-gate 'get-approved-plants))
+ ((plant gardener-name x y sealed-plant)
+ (ensure-empty gardener-name x y)
(let* ((plant ($ garden-gate 'check-plant sealed-plant))
(new-bed (garden-bed-set garden-bed x y plant)))
- (format #t "planted ~a in tile (~a, ~a)\n" (plant-name plant) x y)
+ (format #t "~a planted ~a in tile (~a, ~a)\n"
+ gardener-name (plant-name plant) x y)
(bcom (^garden bcom name new-bed garden-gate))))
- ((dig-up x y)
+ ((dig-up gardener-name x y)
(let ((new-bed (garden-bed-set garden-bed x y #f)))
- (format #t "dug up tile (~a, ~a)\n" x y)
+ (format #t "~a dug up tile (~a, ~a)\n" gardener-name x y)
(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)
+(define (^garden-community bcom garden)
+ (define garden-name ($ garden 'get-name))
+ (define (^gardener bcom name)
+ (methods
+ ((get-name) name)
+ ((get-garden-name) garden-name)
+ ((get-approved-plants)
+ ($ garden 'get-approved-plants))
+ ((inspect-garden)
+ ($ garden 'get-bed))
+ ((plant x y plant)
+ ($ garden 'plant name x y plant))
+ ((dig-up x y)
+ ($ garden 'dig-up name x y))))
+ (define (^visitor bcom name)
+ (methods
+ ((get-name) name)
+ ((get-garden-name) garden-name)
+ ((inspect-garden)
+ ($ garden 'get-bed))))
(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))))
+ ((register-gardener name)
+ (format #t "~a has joined ~a\n" name garden-name)
+ (spawn ^gardener name))
+ ((register-visitor name)
+ (format #t "~a has come to visit ~a\n" name garden-name)
+ (spawn ^visitor name))))
diff --git a/community-garden/edit.scm b/community-garden/edit.scm
index 3da54ba..01addd6 100644
--- a/community-garden/edit.scm
+++ b/community-garden/edit.scm
@@ -8,16 +8,24 @@
#:use-module (ice-9 match)
#:export (edit-garden))
-(define (edit-garden name garden-address)
- (define garden-sref (string->ocapn-id garden-address))
+(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 garden-vow (vat-run ($ mycapn 'enliven garden-sref)))
- (define approved-plants-vow (vat-run (<- garden-vow 'get-approved-plants)))
- (define gardener (vat-run (spawn ^gardener name garden-vow)))
+ (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))
@@ -26,18 +34,26 @@
(('quit)
(set! running? #f))
(('get-garden-name)
- (vat-run (on ($ gardener 'get-garden-name)
+ (vat-run (on (<- gardener 'get-garden-name)
(lambda (name)
- (format #t "~a\n" 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)
+ (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
- (match-lambda
- ((plant . _)
- ($ gardener 'plant x y plant))))))
+ (lambda (plants)
+ (<- gardener 'plant x y (plant-ref plants name))))))
(exp
(format #t "unrecognized command: ~a\n" exp)))))
diff --git a/community-garden/view.scm b/community-garden/view.scm
index e43617b..429394a 100644
--- a/community-garden/view.scm
+++ b/community-garden/view.scm
@@ -60,7 +60,7 @@
(define title
(make <label>
#:name 'name
- #:text (garden-name garden)
+ #:text (or (garden-name garden) "Untitled")
#:font title-font
#:position (vec2 32.0 (- %window-height 72.0))))
(define tile-container
@@ -73,12 +73,14 @@
(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))))))))
+ (on (visitor garden)
+ (lambda (visitor)
+ (on (<- visitor 'inspect-garden)
+ (lambda (garden-bed)
+ (atomic-box-set! (garden-bed-box garden) garden-bed)))))))
+ (sleep 0.5))))
(define (for-each-tile proc tiles)
(vector-for-each