diff options
| -rw-r--r-- | community-garden.scm | 12 | ||||
| -rw-r--r-- | community-garden/view.scm | 98 |
2 files changed, 92 insertions, 18 deletions
diff --git a/community-garden.scm b/community-garden.scm index 7cd535a..6d6af5d 100644 --- a/community-garden.scm +++ b/community-garden.scm @@ -6,7 +6,8 @@ (catbird node) (catbird node-2d) (catbird region) - ((catbird scene) #:select (<scene>)) + ((catbird scene) + #:select (<scene> current-scene replace-major-mode)) (chickadee graphics color) (chickadee graphics path) (chickadee math vector) @@ -68,7 +69,7 @@ (alice-plant 6 2 cabbage/approved) (define catbird-visitor - (catbird-run (<- our-garden-community 'register-visitor "Catbird Viewer"))) + (catbird-run (<- our-garden-community 'register-gardener "Catbird Viewer"))) (define catbird-garden-bed (make-atomic-box #f)) (define catbird-garden-name (make-atomic-box #f)) (catbird-run @@ -83,6 +84,7 @@ (let ((region (create-full-region #:name 'main)) (scene (make <scene> #:name 'scratch))) (replace-scene region scene) + (replace-major-mode scene (make <garden-mode>)) (set! (camera region) (make <camera-2d> #:width %window-width @@ -97,10 +99,12 @@ %window-width %window-height)))) (make <garden-view> + #:name 'garden #:vat catbird-vat - #:visitor catbird-visitor + #:user catbird-visitor #:name-box catbird-garden-name - #:garden-bed-box catbird-garden-bed)))) + #:garden-bed-box catbird-garden-bed + #:read-only? #f)))) #:title "Community Garden" #:width %window-width #:height %window-height) diff --git a/community-garden/view.scm b/community-garden/view.scm index 4ec4dda..ad93f45 100644 --- a/community-garden/view.scm +++ b/community-garden/view.scm @@ -1,7 +1,10 @@ (define-module (community-garden view) #:use-module (catbird asset) + #:use-module (catbird input-map) + #:use-module (catbird mode) #:use-module (catbird node) #:use-module (catbird node-2d) + #:use-module ((catbird scene) #:select (current-scene)) #:use-module (chickadee config) #:use-module (chickadee graphics color) #:use-module (chickadee graphics path) @@ -18,7 +21,8 @@ #:use-module (srfi srfi-43) #:export (%window-width %window-height - <garden-view>)) + <garden-view> + <garden-mode>)) (define %window-width 1024) (define %window-height 768) @@ -34,13 +38,18 @@ (define-asset (cabbage-texture (f "assets/images/cabbage.png")) (load-image f)) +(define-class <garden-tile> (<node-2d>) + (tile-x #:getter tile-x #:init-keyword #:tile-x) + (tile-y #:getter tile-y #:init-keyword #:tile-y)) + (define-class <garden-view> (<node-2d>) (vat #:getter vat #:init-keyword #:vat) - (visitor #:getter visitor #:init-keyword #:visitor) + (user #:getter user #:init-keyword #:user) (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 #())) + (tiles #:accessor tiles #:init-value #()) + (read-only? #:getter read-only? #:init-keyword #:read-only? #:init-value #t)) (define-method (garden-bed (garden <garden-view>)) (atomic-box-ref (garden-bed-box garden))) @@ -67,9 +76,9 @@ (forever ((vat garden) (lambda () - (on (visitor garden) - (lambda (visitor) - (on (<- visitor 'inspect-garden) + (on (user garden) + (lambda (user) + (on (<- user 'inspect-garden) (lambda (garden-bed) (atomic-box-set! (garden-bed-box garden) garden-bed))))))) (sleep 0.5)))) @@ -104,14 +113,20 @@ (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)) + (bg (make <canvas> + #:name 'background + #:painter painter)) + (sprite (make <sprite> + #:name 'sprite + #:texture null-texture)) + (tile (make <garden-tile> + #:tile-x x + #:tile-y y))) + (set! (width tile) %tile-width) + (set! (height tile) %tile-height) + (attach-to tile bg sprite) + (attach-to container tile) + tile)) (garden-bed-width g))) (garden-bed-height g))) (for-each-tile @@ -151,3 +166,58 @@ (define-method (update (garden <garden-view>) dt) (refresh-garden garden)) + +(define-method (plant-in-tile (garden <garden-view>) (tile <garden-tile>)) + (define (plant-ref plants name) + (let loop ((plants plants)) + (match plants + (() #f) + (((k v) . rest) + (if (string=? k name) + v + (loop rest)))))) + ((vat garden) + (lambda () + (on (user garden) + (lambda (user) + (on (<- user 'get-approved-plants) + (lambda (plants) + (<- user 'plant + (tile-x tile) + (tile-y tile) + (plant-ref plants "Cabbage"))))))))) + +(define-method (dig-up-tile (garden <garden-view>) (tile <garden-tile>)) + ((vat garden) + (lambda () + (on (user garden) + (lambda (user) + (<- user 'dig-up (tile-x tile) (tile-y tile))))))) + +(define-method (garden-pick (garden <garden-view>) x y) + (define (find-tile node) + (cond + ((not node) + #f) + ((is-a? node <garden-tile>) + node) + ((parent node) + (find-tile (parent node))))) + (find-tile (pick garden (vec2 x y) (lambda _ #t)))) + +(define-class <garden-mode> (<major-mode>)) + +(define-method (do-plant (mode <garden-mode>) x y) + (define garden (& (current-scene) garden)) + (define tile (garden-pick garden x y)) + (when (and tile (not (read-only? garden))) + (plant-in-tile garden tile))) + +(define-method (do-dig (mode <garden-mode>) x y) + (define garden (& (current-scene) garden)) + (define tile (garden-pick garden x y)) + (when (and tile (not (read-only? garden))) + (dig-up-tile garden tile))) + +(bind-input <garden-mode> (mouse-press 'left) do-plant) +(bind-input <garden-mode> (mouse-press 'right) do-dig) |