diff options
| -rw-r--r-- | community-garden.scm | 46 | ||||
| -rw-r--r-- | community-garden/actors.scm | 73 | ||||
| -rw-r--r-- | community-garden/edit.scm | 40 | ||||
| -rw-r--r-- | community-garden/view.scm | 12 |
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 |