blob: e43617b062f506ec5c558128145ac85a3a8ea3a7 (
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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
(define-module (community-garden view)
#:use-module (catbird asset)
#:use-module (catbird node)
#:use-module (catbird node-2d)
#:use-module (chickadee config)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics path)
#:use-module (chickadee graphics text)
#:use-module (chickadee graphics texture)
#:use-module (chickadee math vector)
#:use-module (chickadee scripting)
#:use-module (community-garden garden-bed)
#:use-module (community-garden plant)
#:use-module (goblins)
#:use-module (ice-9 atomic)
#:use-module (ice-9 match)
#:use-module (oop goops)
#:use-module (srfi srfi-43)
#:export (%window-width
%window-height
<garden-view>))
;; Hack to fix broken version of this in catbird upstream.
(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 %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))
(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-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)
((vat garden)
(lambda ()
(on ($ (visitor garden) 'inspect-garden)
(lambda (garden-bed)
(atomic-box-set! (garden-bed-box garden) 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 (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))
|
