blob: 5146047b3be233f2137fcea3cf2b6cc2db75740f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
(define-module (community-garden actors)
#:use-module (community-garden garden-bed)
#:use-module (community-garden plant)
#:use-module (goblins)
#:use-module (goblins actor-lib cell)
#:use-module (goblins actor-lib methods)
#:use-module (goblins actor-lib sealers)
#:export (^botanist
^garden-gate
^garden
^visitor
^garden-community))
(define* (^botanist _bcom)
(define registry (spawn ^cell '()))
(define-values (seal-plant unseal-plant approved-plant?)
(spawn-sealer-triplet))
(methods
((approve-plant plant)
(let ((sealed-plant ($ seal-plant plant)))
($ 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)))
((get-approved-plants)
($ registry))))
(define (^garden-gate bcom botanist)
(methods
((check-plant plant)
($ botanist 'check-plant plant))
((get-approved-plants)
($ botanist 'get-approved-plants))))
(define (^garden bcom name garden-bed garden-gate)
(define (ensure-empty name x y)
(when (garden-bed-ref garden-bed 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 '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 "~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 gardener-name x y)
(let ((new-bed (garden-bed-set garden-bed x y #f)))
(format #t "~a dug up tile (~a, ~a)\n" gardener-name x y)
(bcom (^garden bcom name new-bed garden-gate))))))
(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
((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))))
|
