blob: b34d1f8bb3789ea1049611f649c47adfd7dead14 (
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
|
(define-module (community-garden actors)
#:use-module (community-garden garden-bed)
#:use-module (goblins)
#:use-module (goblins actor-lib methods)
#:use-module (goblins utils simple-sealers)
#:export (^botanist
^garden-gate
^garden
^visitor
^gardener))
(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))))
|
