1 files changed, 159 insertions, 0 deletions
diff --git a/community-garden/view.scm b/community-garden/view.scm
new file mode 100644
index 0000000..e43617b
--- /dev/null
+++ b/community-garden/view.scm
@@ -0,0 +1,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))